[multiple changes]
[gcc.git] / gcc / ada / sem_ch3.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 3 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2017, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Contracts; use Contracts;
30 with Debug; use Debug;
31 with Elists; use Elists;
32 with Einfo; use Einfo;
33 with Errout; use Errout;
34 with Eval_Fat; use Eval_Fat;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Disp; use Exp_Disp;
38 with Exp_Dist; use Exp_Dist;
39 with Exp_Tss; use Exp_Tss;
40 with Exp_Util; use Exp_Util;
41 with Freeze; use Freeze;
42 with Ghost; use Ghost;
43 with Itypes; use Itypes;
44 with Layout; use Layout;
45 with Lib; use Lib;
46 with Lib.Xref; use Lib.Xref;
47 with Namet; use Namet;
48 with Nmake; use Nmake;
49 with Opt; use Opt;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
53 with Sem; use Sem;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Case; use Sem_Case;
56 with Sem_Cat; use Sem_Cat;
57 with Sem_Ch6; use Sem_Ch6;
58 with Sem_Ch7; use Sem_Ch7;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch13; use Sem_Ch13;
61 with Sem_Dim; use Sem_Dim;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Dist; use Sem_Dist;
64 with Sem_Elim; use Sem_Elim;
65 with Sem_Eval; use Sem_Eval;
66 with Sem_Mech; use Sem_Mech;
67 with Sem_Res; use Sem_Res;
68 with Sem_Smem; use Sem_Smem;
69 with Sem_Type; use Sem_Type;
70 with Sem_Util; use Sem_Util;
71 with Sem_Warn; use Sem_Warn;
72 with Stand; use Stand;
73 with Sinfo; use Sinfo;
74 with Sinput; use Sinput;
75 with Snames; use Snames;
76 with Targparm; use Targparm;
77 with Tbuild; use Tbuild;
78 with Ttypes; use Ttypes;
79 with Uintp; use Uintp;
80 with Urealp; use Urealp;
81
82 package body Sem_Ch3 is
83
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
87
88 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id);
89 -- Ada 2005 (AI-251): Add the tag components corresponding to all the
90 -- abstract interface types implemented by a record type or a derived
91 -- record type.
92
93 procedure Build_Derived_Type
94 (N : Node_Id;
95 Parent_Type : Entity_Id;
96 Derived_Type : Entity_Id;
97 Is_Completion : Boolean;
98 Derive_Subps : Boolean := True);
99 -- Create and decorate a Derived_Type given the Parent_Type entity. N is
100 -- the N_Full_Type_Declaration node containing the derived type definition.
101 -- Parent_Type is the entity for the parent type in the derived type
102 -- definition and Derived_Type the actual derived type. Is_Completion must
103 -- be set to False if Derived_Type is the N_Defining_Identifier node in N
104 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the
105 -- completion of a private type declaration. If Is_Completion is set to
106 -- True, N is the completion of a private type declaration and Derived_Type
107 -- is different from the defining identifier inside N (i.e. Derived_Type /=
108 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent
109 -- subprograms should be derived. The only case where this parameter is
110 -- False is when Build_Derived_Type is recursively called to process an
111 -- implicit derived full type for a type derived from a private type (in
112 -- that case the subprograms must only be derived for the private view of
113 -- the type).
114 --
115 -- ??? These flags need a bit of re-examination and re-documentation:
116 -- ??? are they both necessary (both seem related to the recursion)?
117
118 procedure Build_Derived_Access_Type
119 (N : Node_Id;
120 Parent_Type : Entity_Id;
121 Derived_Type : Entity_Id);
122 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
123 -- create an implicit base if the parent type is constrained or if the
124 -- subtype indication has a constraint.
125
126 procedure Build_Derived_Array_Type
127 (N : Node_Id;
128 Parent_Type : Entity_Id;
129 Derived_Type : Entity_Id);
130 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
131 -- create an implicit base if the parent type is constrained or if the
132 -- subtype indication has a constraint.
133
134 procedure Build_Derived_Concurrent_Type
135 (N : Node_Id;
136 Parent_Type : Entity_Id;
137 Derived_Type : Entity_Id);
138 -- Subsidiary procedure to Build_Derived_Type. For a derived task or
139 -- protected type, inherit entries and protected subprograms, check
140 -- legality of discriminant constraints if any.
141
142 procedure Build_Derived_Enumeration_Type
143 (N : Node_Id;
144 Parent_Type : Entity_Id;
145 Derived_Type : Entity_Id);
146 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
147 -- type, we must create a new list of literals. Types derived from
148 -- Character and [Wide_]Wide_Character are special-cased.
149
150 procedure Build_Derived_Numeric_Type
151 (N : Node_Id;
152 Parent_Type : Entity_Id;
153 Derived_Type : Entity_Id);
154 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
155 -- an anonymous base type, and propagate constraint to subtype if needed.
156
157 procedure Build_Derived_Private_Type
158 (N : Node_Id;
159 Parent_Type : Entity_Id;
160 Derived_Type : Entity_Id;
161 Is_Completion : Boolean;
162 Derive_Subps : Boolean := True);
163 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
164 -- because the parent may or may not have a completion, and the derivation
165 -- may itself be a completion.
166
167 procedure Build_Derived_Record_Type
168 (N : Node_Id;
169 Parent_Type : Entity_Id;
170 Derived_Type : Entity_Id;
171 Derive_Subps : Boolean := True);
172 -- Subsidiary procedure used for tagged and untagged record types
173 -- by Build_Derived_Type and Analyze_Private_Extension_Declaration.
174 -- All parameters are as in Build_Derived_Type except that N, in
175 -- addition to being an N_Full_Type_Declaration node, can also be an
176 -- N_Private_Extension_Declaration node. See the definition of this routine
177 -- for much more info. Derive_Subps indicates whether subprograms should be
178 -- derived from the parent type. The only case where Derive_Subps is False
179 -- is for an implicit derived full type for a type derived from a private
180 -- type (see Build_Derived_Type).
181
182 procedure Build_Discriminal (Discrim : Entity_Id);
183 -- Create the discriminal corresponding to discriminant Discrim, that is
184 -- the parameter corresponding to Discrim to be used in initialization
185 -- procedures for the type where Discrim is a discriminant. Discriminals
186 -- are not used during semantic analysis, and are not fully defined
187 -- entities until expansion. Thus they are not given a scope until
188 -- initialization procedures are built.
189
190 function Build_Discriminant_Constraints
191 (T : Entity_Id;
192 Def : Node_Id;
193 Derived_Def : Boolean := False) return Elist_Id;
194 -- Validate discriminant constraints and return the list of the constraints
195 -- in order of discriminant declarations, where T is the discriminated
196 -- unconstrained type. Def is the N_Subtype_Indication node where the
197 -- discriminants constraints for T are specified. Derived_Def is True
198 -- when building the discriminant constraints in a derived type definition
199 -- of the form "type D (...) is new T (xxx)". In this case T is the parent
200 -- type and Def is the constraint "(xxx)" on T and this routine sets the
201 -- Corresponding_Discriminant field of the discriminants in the derived
202 -- type D to point to the corresponding discriminants in the parent type T.
203
204 procedure Build_Discriminated_Subtype
205 (T : Entity_Id;
206 Def_Id : Entity_Id;
207 Elist : Elist_Id;
208 Related_Nod : Node_Id;
209 For_Access : Boolean := False);
210 -- Subsidiary procedure to Constrain_Discriminated_Type and to
211 -- Process_Incomplete_Dependents. Given
212 --
213 -- T (a possibly discriminated base type)
214 -- Def_Id (a very partially built subtype for T),
215 --
216 -- the call completes Def_Id to be the appropriate E_*_Subtype.
217 --
218 -- The Elist is the list of discriminant constraints if any (it is set
219 -- to No_Elist if T is not a discriminated type, and to an empty list if
220 -- T has discriminants but there are no discriminant constraints). The
221 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
222 -- The For_Access says whether or not this subtype is really constraining
223 -- an access type. That is its sole purpose is the designated type of an
224 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
225 -- is built to avoid freezing T when the access subtype is frozen.
226
227 function Build_Scalar_Bound
228 (Bound : Node_Id;
229 Par_T : Entity_Id;
230 Der_T : Entity_Id) return Node_Id;
231 -- The bounds of a derived scalar type are conversions of the bounds of
232 -- the parent type. Optimize the representation if the bounds are literals.
233 -- Needs a more complete spec--what are the parameters exactly, and what
234 -- exactly is the returned value, and how is Bound affected???
235
236 procedure Build_Underlying_Full_View
237 (N : Node_Id;
238 Typ : Entity_Id;
239 Par : Entity_Id);
240 -- If the completion of a private type is itself derived from a private
241 -- type, or if the full view of a private subtype is itself private, the
242 -- back-end has no way to compute the actual size of this type. We build
243 -- an internal subtype declaration of the proper parent type to convey
244 -- this information. This extra mechanism is needed because a full
245 -- view cannot itself have a full view (it would get clobbered during
246 -- view exchanges).
247
248 procedure Check_Access_Discriminant_Requires_Limited
249 (D : Node_Id;
250 Loc : Node_Id);
251 -- Check the restriction that the type to which an access discriminant
252 -- belongs must be a concurrent type or a descendant of a type with
253 -- the reserved word 'limited' in its declaration.
254
255 procedure Check_Anonymous_Access_Components
256 (Typ_Decl : Node_Id;
257 Typ : Entity_Id;
258 Prev : Entity_Id;
259 Comp_List : Node_Id);
260 -- Ada 2005 AI-382: an access component in a record definition can refer to
261 -- the enclosing record, in which case it denotes the type itself, and not
262 -- the current instance of the type. We create an anonymous access type for
263 -- the component, and flag it as an access to a component, so accessibility
264 -- checks are properly performed on it. The declaration of the access type
265 -- is placed ahead of that of the record to prevent order-of-elaboration
266 -- circularity issues in Gigi. We create an incomplete type for the record
267 -- declaration, which is the designated type of the anonymous access.
268
269 procedure Check_Delta_Expression (E : Node_Id);
270 -- Check that the expression represented by E is suitable for use as a
271 -- delta expression, i.e. it is of real type and is static.
272
273 procedure Check_Digits_Expression (E : Node_Id);
274 -- Check that the expression represented by E is suitable for use as a
275 -- digits expression, i.e. it is of integer type, positive and static.
276
277 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
278 -- Validate the initialization of an object declaration. T is the required
279 -- type, and Exp is the initialization expression.
280
281 procedure Check_Interfaces (N : Node_Id; Def : Node_Id);
282 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
283
284 procedure Check_Or_Process_Discriminants
285 (N : Node_Id;
286 T : Entity_Id;
287 Prev : Entity_Id := Empty);
288 -- If N is the full declaration of the completion T of an incomplete or
289 -- private type, check its discriminants (which are already known to be
290 -- conformant with those of the partial view, see Find_Type_Name),
291 -- otherwise process them. Prev is the entity of the partial declaration,
292 -- if any.
293
294 procedure Check_Real_Bound (Bound : Node_Id);
295 -- Check given bound for being of real type and static. If not, post an
296 -- appropriate message, and rewrite the bound with the real literal zero.
297
298 procedure Constant_Redeclaration
299 (Id : Entity_Id;
300 N : Node_Id;
301 T : out Entity_Id);
302 -- Various checks on legality of full declaration of deferred constant.
303 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
304 -- node. The caller has not yet set any attributes of this entity.
305
306 function Contain_Interface
307 (Iface : Entity_Id;
308 Ifaces : Elist_Id) return Boolean;
309 -- Ada 2005: Determine whether Iface is present in the list Ifaces
310
311 procedure Convert_Scalar_Bounds
312 (N : Node_Id;
313 Parent_Type : Entity_Id;
314 Derived_Type : Entity_Id;
315 Loc : Source_Ptr);
316 -- For derived scalar types, convert the bounds in the type definition to
317 -- the derived type, and complete their analysis. Given a constraint of the
318 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with
319 -- T'Base, the parent_type. The bounds of the derived type (the anonymous
320 -- base) are copies of Lo and Hi. Finally, the bounds of the derived
321 -- subtype are conversions of those bounds to the derived_type, so that
322 -- their typing is consistent.
323
324 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
325 -- Copies attributes from array base type T2 to array base type T1. Copies
326 -- only attributes that apply to base types, but not subtypes.
327
328 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
329 -- Copies attributes from array subtype T2 to array subtype T1. Copies
330 -- attributes that apply to both subtypes and base types.
331
332 procedure Create_Constrained_Components
333 (Subt : Entity_Id;
334 Decl_Node : Node_Id;
335 Typ : Entity_Id;
336 Constraints : Elist_Id);
337 -- Build the list of entities for a constrained discriminated record
338 -- subtype. If a component depends on a discriminant, replace its subtype
339 -- using the discriminant values in the discriminant constraint. Subt
340 -- is the defining identifier for the subtype whose list of constrained
341 -- entities we will create. Decl_Node is the type declaration node where
342 -- we will attach all the itypes created. Typ is the base discriminated
343 -- type for the subtype Subt. Constraints is the list of discriminant
344 -- constraints for Typ.
345
346 function Constrain_Component_Type
347 (Comp : Entity_Id;
348 Constrained_Typ : Entity_Id;
349 Related_Node : Node_Id;
350 Typ : Entity_Id;
351 Constraints : Elist_Id) return Entity_Id;
352 -- Given a discriminated base type Typ, a list of discriminant constraints,
353 -- Constraints, for Typ and a component Comp of Typ, create and return the
354 -- type corresponding to Etype (Comp) where all discriminant references
355 -- are replaced with the corresponding constraint. If Etype (Comp) contains
356 -- no discriminant references then it is returned as-is. Constrained_Typ
357 -- is the final constrained subtype to which the constrained component
358 -- belongs. Related_Node is the node where we attach all created itypes.
359
360 procedure Constrain_Access
361 (Def_Id : in out Entity_Id;
362 S : Node_Id;
363 Related_Nod : Node_Id);
364 -- Apply a list of constraints to an access type. If Def_Id is empty, it is
365 -- an anonymous type created for a subtype indication. In that case it is
366 -- created in the procedure and attached to Related_Nod.
367
368 procedure Constrain_Array
369 (Def_Id : in out Entity_Id;
370 SI : Node_Id;
371 Related_Nod : Node_Id;
372 Related_Id : Entity_Id;
373 Suffix : Character);
374 -- Apply a list of index constraints to an unconstrained array type. The
375 -- first parameter is the entity for the resulting subtype. A value of
376 -- Empty for Def_Id indicates that an implicit type must be created, but
377 -- creation is delayed (and must be done by this procedure) because other
378 -- subsidiary implicit types must be created first (which is why Def_Id
379 -- is an in/out parameter). The second parameter is a subtype indication
380 -- node for the constrained array to be created (e.g. something of the
381 -- form string (1 .. 10)). Related_Nod gives the place where this type
382 -- has to be inserted in the tree. The Related_Id and Suffix parameters
383 -- are used to build the associated Implicit type name.
384
385 procedure Constrain_Concurrent
386 (Def_Id : in out Entity_Id;
387 SI : Node_Id;
388 Related_Nod : Node_Id;
389 Related_Id : Entity_Id;
390 Suffix : Character);
391 -- Apply list of discriminant constraints to an unconstrained concurrent
392 -- type.
393 --
394 -- SI is the N_Subtype_Indication node containing the constraint and
395 -- the unconstrained type to constrain.
396 --
397 -- Def_Id is the entity for the resulting constrained subtype. A value
398 -- of Empty for Def_Id indicates that an implicit type must be created,
399 -- but creation is delayed (and must be done by this procedure) because
400 -- other subsidiary implicit types must be created first (which is why
401 -- Def_Id is an in/out parameter).
402 --
403 -- Related_Nod gives the place where this type has to be inserted
404 -- in the tree.
405 --
406 -- The last two arguments are used to create its external name if needed.
407
408 function Constrain_Corresponding_Record
409 (Prot_Subt : Entity_Id;
410 Corr_Rec : Entity_Id;
411 Related_Nod : Node_Id) return Entity_Id;
412 -- When constraining a protected type or task type with discriminants,
413 -- constrain the corresponding record with the same discriminant values.
414
415 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
416 -- Constrain a decimal fixed point type with a digits constraint and/or a
417 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
418
419 procedure Constrain_Discriminated_Type
420 (Def_Id : Entity_Id;
421 S : Node_Id;
422 Related_Nod : Node_Id;
423 For_Access : Boolean := False);
424 -- Process discriminant constraints of composite type. Verify that values
425 -- have been provided for all discriminants, that the original type is
426 -- unconstrained, and that the types of the supplied expressions match
427 -- the discriminant types. The first three parameters are like in routine
428 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
429 -- of For_Access.
430
431 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
432 -- Constrain an enumeration type with a range constraint. This is identical
433 -- to Constrain_Integer, but for the Ekind of the resulting subtype.
434
435 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
436 -- Constrain a floating point type with either a digits constraint
437 -- and/or a range constraint, building a E_Floating_Point_Subtype.
438
439 procedure Constrain_Index
440 (Index : Node_Id;
441 S : Node_Id;
442 Related_Nod : Node_Id;
443 Related_Id : Entity_Id;
444 Suffix : Character;
445 Suffix_Index : Nat);
446 -- Process an index constraint S in a constrained array declaration. The
447 -- constraint can be a subtype name, or a range with or without an explicit
448 -- subtype mark. The index is the corresponding index of the unconstrained
449 -- array. The Related_Id and Suffix parameters are used to build the
450 -- associated Implicit type name.
451
452 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
453 -- Build subtype of a signed or modular integer type
454
455 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
456 -- Constrain an ordinary fixed point type with a range constraint, and
457 -- build an E_Ordinary_Fixed_Point_Subtype entity.
458
459 procedure Copy_And_Swap (Priv, Full : Entity_Id);
460 -- Copy the Priv entity into the entity of its full declaration then swap
461 -- the two entities in such a manner that the former private type is now
462 -- seen as a full type.
463
464 procedure Decimal_Fixed_Point_Type_Declaration
465 (T : Entity_Id;
466 Def : Node_Id);
467 -- Create a new decimal fixed point type, and apply the constraint to
468 -- obtain a subtype of this new type.
469
470 procedure Complete_Private_Subtype
471 (Priv : Entity_Id;
472 Full : Entity_Id;
473 Full_Base : Entity_Id;
474 Related_Nod : Node_Id);
475 -- Complete the implicit full view of a private subtype by setting the
476 -- appropriate semantic fields. If the full view of the parent is a record
477 -- type, build constrained components of subtype.
478
479 procedure Derive_Progenitor_Subprograms
480 (Parent_Type : Entity_Id;
481 Tagged_Type : Entity_Id);
482 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive
483 -- operations of progenitors of Tagged_Type, and replace the subsidiary
484 -- subtypes with Tagged_Type, to build the specs of the inherited interface
485 -- primitives. The derived primitives are aliased to those of the
486 -- interface. This routine takes care also of transferring to the full view
487 -- subprograms associated with the partial view of Tagged_Type that cover
488 -- interface primitives.
489
490 procedure Derived_Standard_Character
491 (N : Node_Id;
492 Parent_Type : Entity_Id;
493 Derived_Type : Entity_Id);
494 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
495 -- derivations from types Standard.Character and Standard.Wide_Character.
496
497 procedure Derived_Type_Declaration
498 (T : Entity_Id;
499 N : Node_Id;
500 Is_Completion : Boolean);
501 -- Process a derived type declaration. Build_Derived_Type is invoked
502 -- to process the actual derived type definition. Parameters N and
503 -- Is_Completion have the same meaning as in Build_Derived_Type.
504 -- T is the N_Defining_Identifier for the entity defined in the
505 -- N_Full_Type_Declaration node N, that is T is the derived type.
506
507 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
508 -- Insert each literal in symbol table, as an overloadable identifier. Each
509 -- enumeration type is mapped into a sequence of integers, and each literal
510 -- is defined as a constant with integer value. If any of the literals are
511 -- character literals, the type is a character type, which means that
512 -- strings are legal aggregates for arrays of components of the type.
513
514 function Expand_To_Stored_Constraint
515 (Typ : Entity_Id;
516 Constraint : Elist_Id) return Elist_Id;
517 -- Given a constraint (i.e. a list of expressions) on the discriminants of
518 -- Typ, expand it into a constraint on the stored discriminants and return
519 -- the new list of expressions constraining the stored discriminants.
520
521 function Find_Type_Of_Object
522 (Obj_Def : Node_Id;
523 Related_Nod : Node_Id) return Entity_Id;
524 -- Get type entity for object referenced by Obj_Def, attaching the implicit
525 -- types generated to Related_Nod.
526
527 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
528 -- Create a new float and apply the constraint to obtain subtype of it
529
530 function Has_Range_Constraint (N : Node_Id) return Boolean;
531 -- Given an N_Subtype_Indication node N, return True if a range constraint
532 -- is present, either directly, or as part of a digits or delta constraint.
533 -- In addition, a digits constraint in the decimal case returns True, since
534 -- it establishes a default range if no explicit range is present.
535
536 function Inherit_Components
537 (N : Node_Id;
538 Parent_Base : Entity_Id;
539 Derived_Base : Entity_Id;
540 Is_Tagged : Boolean;
541 Inherit_Discr : Boolean;
542 Discs : Elist_Id) return Elist_Id;
543 -- Called from Build_Derived_Record_Type to inherit the components of
544 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
545 -- For more information on derived types and component inheritance please
546 -- consult the comment above the body of Build_Derived_Record_Type.
547 --
548 -- N is the original derived type declaration
549 --
550 -- Is_Tagged is set if we are dealing with tagged types
551 --
552 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
553 -- Parent_Base, otherwise no discriminants are inherited.
554 --
555 -- Discs gives the list of constraints that apply to Parent_Base in the
556 -- derived type declaration. If Discs is set to No_Elist, then we have
557 -- the following situation:
558 --
559 -- type Parent (D1..Dn : ..) is [tagged] record ...;
560 -- type Derived is new Parent [with ...];
561 --
562 -- which gets treated as
563 --
564 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
565 --
566 -- For untagged types the returned value is an association list. The list
567 -- starts from the association (Parent_Base => Derived_Base), and then it
568 -- contains a sequence of the associations of the form
569 --
570 -- (Old_Component => New_Component),
571 --
572 -- where Old_Component is the Entity_Id of a component in Parent_Base and
573 -- New_Component is the Entity_Id of the corresponding component in
574 -- Derived_Base. For untagged records, this association list is needed when
575 -- copying the record declaration for the derived base. In the tagged case
576 -- the value returned is irrelevant.
577
578 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
579 -- Propagate static and dynamic predicate flags from a parent to the
580 -- subtype in a subtype declaration with and without constraints.
581
582 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean;
583 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram.
584 -- Determine whether subprogram Subp is a procedure subject to pragma
585 -- Extensions_Visible with value False and has at least one controlling
586 -- parameter of mode OUT.
587
588 function Is_Valid_Constraint_Kind
589 (T_Kind : Type_Kind;
590 Constraint_Kind : Node_Kind) return Boolean;
591 -- Returns True if it is legal to apply the given kind of constraint to the
592 -- given kind of type (index constraint to an array type, for example).
593
594 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
595 -- Create new modular type. Verify that modulus is in bounds
596
597 procedure New_Concatenation_Op (Typ : Entity_Id);
598 -- Create an abbreviated declaration for an operator in order to
599 -- materialize concatenation on array types.
600
601 procedure Ordinary_Fixed_Point_Type_Declaration
602 (T : Entity_Id;
603 Def : Node_Id);
604 -- Create a new ordinary fixed point type, and apply the constraint to
605 -- obtain subtype of it.
606
607 procedure Prepare_Private_Subtype_Completion
608 (Id : Entity_Id;
609 Related_Nod : Node_Id);
610 -- Id is a subtype of some private type. Creates the full declaration
611 -- associated with Id whenever possible, i.e. when the full declaration
612 -- of the base type is already known. Records each subtype into
613 -- Private_Dependents of the base type.
614
615 procedure Process_Incomplete_Dependents
616 (N : Node_Id;
617 Full_T : Entity_Id;
618 Inc_T : Entity_Id);
619 -- Process all entities that depend on an incomplete type. There include
620 -- subtypes, subprogram types that mention the incomplete type in their
621 -- profiles, and subprogram with access parameters that designate the
622 -- incomplete type.
623
624 -- Inc_T is the defining identifier of an incomplete type declaration, its
625 -- Ekind is E_Incomplete_Type.
626 --
627 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
628 --
629 -- Full_T is N's defining identifier.
630 --
631 -- Subtypes of incomplete types with discriminants are completed when the
632 -- parent type is. This is simpler than private subtypes, because they can
633 -- only appear in the same scope, and there is no need to exchange views.
634 -- Similarly, access_to_subprogram types may have a parameter or a return
635 -- type that is an incomplete type, and that must be replaced with the
636 -- full type.
637 --
638 -- If the full type is tagged, subprogram with access parameters that
639 -- designated the incomplete may be primitive operations of the full type,
640 -- and have to be processed accordingly.
641
642 procedure Process_Real_Range_Specification (Def : Node_Id);
643 -- Given the type definition for a real type, this procedure processes and
644 -- checks the real range specification of this type definition if one is
645 -- present. If errors are found, error messages are posted, and the
646 -- Real_Range_Specification of Def is reset to Empty.
647
648 procedure Record_Type_Declaration
649 (T : Entity_Id;
650 N : Node_Id;
651 Prev : Entity_Id);
652 -- Process a record type declaration (for both untagged and tagged
653 -- records). Parameters T and N are exactly like in procedure
654 -- Derived_Type_Declaration, except that no flag Is_Completion is needed
655 -- for this routine. If this is the completion of an incomplete type
656 -- declaration, Prev is the entity of the incomplete declaration, used for
657 -- cross-referencing. Otherwise Prev = T.
658
659 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id);
660 -- This routine is used to process the actual record type definition (both
661 -- for untagged and tagged records). Def is a record type definition node.
662 -- This procedure analyzes the components in this record type definition.
663 -- Prev_T is the entity for the enclosing record type. It is provided so
664 -- that its Has_Task flag can be set if any of the component have Has_Task
665 -- set. If the declaration is the completion of an incomplete type
666 -- declaration, Prev_T is the original incomplete type, whose full view is
667 -- the record type.
668
669 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
670 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
671 -- build a copy of the declaration tree of the parent, and we create
672 -- independently the list of components for the derived type. Semantic
673 -- information uses the component entities, but record representation
674 -- clauses are validated on the declaration tree. This procedure replaces
675 -- discriminants and components in the declaration with those that have
676 -- been created by Inherit_Components.
677
678 procedure Set_Fixed_Range
679 (E : Entity_Id;
680 Loc : Source_Ptr;
681 Lo : Ureal;
682 Hi : Ureal);
683 -- Build a range node with the given bounds and set it as the Scalar_Range
684 -- of the given fixed-point type entity. Loc is the source location used
685 -- for the constructed range. See body for further details.
686
687 procedure Set_Scalar_Range_For_Subtype
688 (Def_Id : Entity_Id;
689 R : Node_Id;
690 Subt : Entity_Id);
691 -- This routine is used to set the scalar range field for a subtype given
692 -- Def_Id, the entity for the subtype, and R, the range expression for the
693 -- scalar range. Subt provides the parent subtype to be used to analyze,
694 -- resolve, and check the given range.
695
696 procedure Set_Default_SSO (T : Entity_Id);
697 -- T is the entity for an array or record being declared. This procedure
698 -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according
699 -- to the setting of Opt.Default_SSO.
700
701 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
702 -- Create a new signed integer entity, and apply the constraint to obtain
703 -- the required first named subtype of this type.
704
705 procedure Set_Stored_Constraint_From_Discriminant_Constraint
706 (E : Entity_Id);
707 -- E is some record type. This routine computes E's Stored_Constraint
708 -- from its Discriminant_Constraint.
709
710 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id);
711 -- Check that an entity in a list of progenitors is an interface,
712 -- emit error otherwise.
713
714 -----------------------
715 -- Access_Definition --
716 -----------------------
717
718 function Access_Definition
719 (Related_Nod : Node_Id;
720 N : Node_Id) return Entity_Id
721 is
722 Anon_Type : Entity_Id;
723 Anon_Scope : Entity_Id;
724 Desig_Type : Entity_Id;
725 Enclosing_Prot_Type : Entity_Id := Empty;
726
727 begin
728 Check_SPARK_05_Restriction ("access type is not allowed", N);
729
730 if Is_Entry (Current_Scope)
731 and then Is_Task_Type (Etype (Scope (Current_Scope)))
732 then
733 Error_Msg_N ("task entries cannot have access parameters", N);
734 return Empty;
735 end if;
736
737 -- Ada 2005: For an object declaration the corresponding anonymous
738 -- type is declared in the current scope.
739
740 -- If the access definition is the return type of another access to
741 -- function, scope is the current one, because it is the one of the
742 -- current type declaration, except for the pathological case below.
743
744 if Nkind_In (Related_Nod, N_Object_Declaration,
745 N_Access_Function_Definition)
746 then
747 Anon_Scope := Current_Scope;
748
749 -- A pathological case: function returning access functions that
750 -- return access functions, etc. Each anonymous access type created
751 -- is in the enclosing scope of the outermost function.
752
753 declare
754 Par : Node_Id;
755
756 begin
757 Par := Related_Nod;
758 while Nkind_In (Par, N_Access_Function_Definition,
759 N_Access_Definition)
760 loop
761 Par := Parent (Par);
762 end loop;
763
764 if Nkind (Par) = N_Function_Specification then
765 Anon_Scope := Scope (Defining_Entity (Par));
766 end if;
767 end;
768
769 -- For the anonymous function result case, retrieve the scope of the
770 -- function specification's associated entity rather than using the
771 -- current scope. The current scope will be the function itself if the
772 -- formal part is currently being analyzed, but will be the parent scope
773 -- in the case of a parameterless function, and we always want to use
774 -- the function's parent scope. Finally, if the function is a child
775 -- unit, we must traverse the tree to retrieve the proper entity.
776
777 elsif Nkind (Related_Nod) = N_Function_Specification
778 and then Nkind (Parent (N)) /= N_Parameter_Specification
779 then
780 -- If the current scope is a protected type, the anonymous access
781 -- is associated with one of the protected operations, and must
782 -- be available in the scope that encloses the protected declaration.
783 -- Otherwise the type is in the scope enclosing the subprogram.
784
785 -- If the function has formals, The return type of a subprogram
786 -- declaration is analyzed in the scope of the subprogram (see
787 -- Process_Formals) and thus the protected type, if present, is
788 -- the scope of the current function scope.
789
790 if Ekind (Current_Scope) = E_Protected_Type then
791 Enclosing_Prot_Type := Current_Scope;
792
793 elsif Ekind (Current_Scope) = E_Function
794 and then Ekind (Scope (Current_Scope)) = E_Protected_Type
795 then
796 Enclosing_Prot_Type := Scope (Current_Scope);
797 end if;
798
799 if Present (Enclosing_Prot_Type) then
800 Anon_Scope := Scope (Enclosing_Prot_Type);
801
802 else
803 Anon_Scope := Scope (Defining_Entity (Related_Nod));
804 end if;
805
806 -- For an access type definition, if the current scope is a child
807 -- unit it is the scope of the type.
808
809 elsif Is_Compilation_Unit (Current_Scope) then
810 Anon_Scope := Current_Scope;
811
812 -- For access formals, access components, and access discriminants, the
813 -- scope is that of the enclosing declaration,
814
815 else
816 Anon_Scope := Scope (Current_Scope);
817 end if;
818
819 Anon_Type :=
820 Create_Itype
821 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope);
822
823 if All_Present (N)
824 and then Ada_Version >= Ada_2005
825 then
826 Error_Msg_N ("ALL is not permitted for anonymous access types", N);
827 end if;
828
829 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call
830 -- the corresponding semantic routine
831
832 if Present (Access_To_Subprogram_Definition (N)) then
833
834 -- Compiler runtime units are compiled in Ada 2005 mode when building
835 -- the runtime library but must also be compilable in Ada 95 mode
836 -- (when bootstrapping the compiler).
837
838 Check_Compiler_Unit ("anonymous access to subprogram", N);
839
840 Access_Subprogram_Declaration
841 (T_Name => Anon_Type,
842 T_Def => Access_To_Subprogram_Definition (N));
843
844 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
845 Set_Ekind
846 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
847 else
848 Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type);
849 end if;
850
851 Set_Can_Use_Internal_Rep
852 (Anon_Type, not Always_Compatible_Rep_On_Target);
853
854 -- If the anonymous access is associated with a protected operation,
855 -- create a reference to it after the enclosing protected definition
856 -- because the itype will be used in the subsequent bodies.
857
858 -- If the anonymous access itself is protected, a full type
859 -- declaratiton will be created for it, so that the equivalent
860 -- record type can be constructed. For further details, see
861 -- Replace_Anonymous_Access_To_Protected-Subprogram.
862
863 if Ekind (Current_Scope) = E_Protected_Type
864 and then not Protected_Present (Access_To_Subprogram_Definition (N))
865 then
866 Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
867 end if;
868
869 return Anon_Type;
870 end if;
871
872 Find_Type (Subtype_Mark (N));
873 Desig_Type := Entity (Subtype_Mark (N));
874
875 Set_Directly_Designated_Type (Anon_Type, Desig_Type);
876 Set_Etype (Anon_Type, Anon_Type);
877
878 -- Make sure the anonymous access type has size and alignment fields
879 -- set, as required by gigi. This is necessary in the case of the
880 -- Task_Body_Procedure.
881
882 if not Has_Private_Component (Desig_Type) then
883 Layout_Type (Anon_Type);
884 end if;
885
886 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
887 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if
888 -- the null value is allowed. In Ada 95 the null value is never allowed.
889
890 if Ada_Version >= Ada_2005 then
891 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
892 else
893 Set_Can_Never_Be_Null (Anon_Type, True);
894 end if;
895
896 -- The anonymous access type is as public as the discriminated type or
897 -- subprogram that defines it. It is imported (for back-end purposes)
898 -- if the designated type is.
899
900 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
901
902 -- Ada 2005 (AI-231): Propagate the access-constant attribute
903
904 Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
905
906 -- The context is either a subprogram declaration, object declaration,
907 -- or an access discriminant, in a private or a full type declaration.
908 -- In the case of a subprogram, if the designated type is incomplete,
909 -- the operation will be a primitive operation of the full type, to be
910 -- updated subsequently. If the type is imported through a limited_with
911 -- clause, the subprogram is not a primitive operation of the type
912 -- (which is declared elsewhere in some other scope).
913
914 if Ekind (Desig_Type) = E_Incomplete_Type
915 and then not From_Limited_With (Desig_Type)
916 and then Is_Overloadable (Current_Scope)
917 then
918 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
919 Set_Has_Delayed_Freeze (Current_Scope);
920 end if;
921
922 -- Ada 2005: If the designated type is an interface that may contain
923 -- tasks, create a Master entity for the declaration. This must be done
924 -- before expansion of the full declaration, because the declaration may
925 -- include an expression that is an allocator, whose expansion needs the
926 -- proper Master for the created tasks.
927
928 if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active
929 then
930 if Is_Interface (Desig_Type) and then Is_Limited_Record (Desig_Type)
931 then
932 Build_Class_Wide_Master (Anon_Type);
933
934 -- Similarly, if the type is an anonymous access that designates
935 -- tasks, create a master entity for it in the current context.
936
937 elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod)
938 then
939 Build_Master_Entity (Defining_Identifier (Related_Nod));
940 Build_Master_Renaming (Anon_Type);
941 end if;
942 end if;
943
944 -- For a private component of a protected type, it is imperative that
945 -- the back-end elaborate the type immediately after the protected
946 -- declaration, because this type will be used in the declarations
947 -- created for the component within each protected body, so we must
948 -- create an itype reference for it now.
949
950 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then
951 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
952
953 -- Similarly, if the access definition is the return result of a
954 -- function, create an itype reference for it because it will be used
955 -- within the function body. For a regular function that is not a
956 -- compilation unit, insert reference after the declaration. For a
957 -- protected operation, insert it after the enclosing protected type
958 -- declaration. In either case, do not create a reference for a type
959 -- obtained through a limited_with clause, because this would introduce
960 -- semantic dependencies.
961
962 -- Similarly, do not create a reference if the designated type is a
963 -- generic formal, because no use of it will reach the backend.
964
965 elsif Nkind (Related_Nod) = N_Function_Specification
966 and then not From_Limited_With (Desig_Type)
967 and then not Is_Generic_Type (Desig_Type)
968 then
969 if Present (Enclosing_Prot_Type) then
970 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
971
972 elsif Is_List_Member (Parent (Related_Nod))
973 and then Nkind (Parent (N)) /= N_Parameter_Specification
974 then
975 Build_Itype_Reference (Anon_Type, Parent (Related_Nod));
976 end if;
977
978 -- Finally, create an itype reference for an object declaration of an
979 -- anonymous access type. This is strictly necessary only for deferred
980 -- constants, but in any case will avoid out-of-scope problems in the
981 -- back-end.
982
983 elsif Nkind (Related_Nod) = N_Object_Declaration then
984 Build_Itype_Reference (Anon_Type, Related_Nod);
985 end if;
986
987 return Anon_Type;
988 end Access_Definition;
989
990 -----------------------------------
991 -- Access_Subprogram_Declaration --
992 -----------------------------------
993
994 procedure Access_Subprogram_Declaration
995 (T_Name : Entity_Id;
996 T_Def : Node_Id)
997 is
998 procedure Check_For_Premature_Usage (Def : Node_Id);
999 -- Check that type T_Name is not used, directly or recursively, as a
1000 -- parameter or a return type in Def. Def is either a subtype, an
1001 -- access_definition, or an access_to_subprogram_definition.
1002
1003 -------------------------------
1004 -- Check_For_Premature_Usage --
1005 -------------------------------
1006
1007 procedure Check_For_Premature_Usage (Def : Node_Id) is
1008 Param : Node_Id;
1009
1010 begin
1011 -- Check for a subtype mark
1012
1013 if Nkind (Def) in N_Has_Etype then
1014 if Etype (Def) = T_Name then
1015 Error_Msg_N
1016 ("type& cannot be used before end of its declaration", Def);
1017 end if;
1018
1019 -- If this is not a subtype, then this is an access_definition
1020
1021 elsif Nkind (Def) = N_Access_Definition then
1022 if Present (Access_To_Subprogram_Definition (Def)) then
1023 Check_For_Premature_Usage
1024 (Access_To_Subprogram_Definition (Def));
1025 else
1026 Check_For_Premature_Usage (Subtype_Mark (Def));
1027 end if;
1028
1029 -- The only cases left are N_Access_Function_Definition and
1030 -- N_Access_Procedure_Definition.
1031
1032 else
1033 if Present (Parameter_Specifications (Def)) then
1034 Param := First (Parameter_Specifications (Def));
1035 while Present (Param) loop
1036 Check_For_Premature_Usage (Parameter_Type (Param));
1037 Param := Next (Param);
1038 end loop;
1039 end if;
1040
1041 if Nkind (Def) = N_Access_Function_Definition then
1042 Check_For_Premature_Usage (Result_Definition (Def));
1043 end if;
1044 end if;
1045 end Check_For_Premature_Usage;
1046
1047 -- Local variables
1048
1049 Formals : constant List_Id := Parameter_Specifications (T_Def);
1050 Formal : Entity_Id;
1051 D_Ityp : Node_Id;
1052 Desig_Type : constant Entity_Id :=
1053 Create_Itype (E_Subprogram_Type, Parent (T_Def));
1054
1055 -- Start of processing for Access_Subprogram_Declaration
1056
1057 begin
1058 Check_SPARK_05_Restriction ("access type is not allowed", T_Def);
1059
1060 -- Associate the Itype node with the inner full-type declaration or
1061 -- subprogram spec or entry body. This is required to handle nested
1062 -- anonymous declarations. For example:
1063
1064 -- procedure P
1065 -- (X : access procedure
1066 -- (Y : access procedure
1067 -- (Z : access T)))
1068
1069 D_Ityp := Associated_Node_For_Itype (Desig_Type);
1070 while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
1071 N_Private_Type_Declaration,
1072 N_Private_Extension_Declaration,
1073 N_Procedure_Specification,
1074 N_Function_Specification,
1075 N_Entry_Body)
1076
1077 or else
1078 Nkind_In (D_Ityp, N_Object_Declaration,
1079 N_Object_Renaming_Declaration,
1080 N_Formal_Object_Declaration,
1081 N_Formal_Type_Declaration,
1082 N_Task_Type_Declaration,
1083 N_Protected_Type_Declaration))
1084 loop
1085 D_Ityp := Parent (D_Ityp);
1086 pragma Assert (D_Ityp /= Empty);
1087 end loop;
1088
1089 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
1090
1091 if Nkind_In (D_Ityp, N_Procedure_Specification,
1092 N_Function_Specification)
1093 then
1094 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
1095
1096 elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
1097 N_Object_Declaration,
1098 N_Object_Renaming_Declaration,
1099 N_Formal_Type_Declaration)
1100 then
1101 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
1102 end if;
1103
1104 if Nkind (T_Def) = N_Access_Function_Definition then
1105 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
1106 declare
1107 Acc : constant Node_Id := Result_Definition (T_Def);
1108
1109 begin
1110 if Present (Access_To_Subprogram_Definition (Acc))
1111 and then
1112 Protected_Present (Access_To_Subprogram_Definition (Acc))
1113 then
1114 Set_Etype
1115 (Desig_Type,
1116 Replace_Anonymous_Access_To_Protected_Subprogram
1117 (T_Def));
1118
1119 else
1120 Set_Etype
1121 (Desig_Type,
1122 Access_Definition (T_Def, Result_Definition (T_Def)));
1123 end if;
1124 end;
1125
1126 else
1127 Analyze (Result_Definition (T_Def));
1128
1129 declare
1130 Typ : constant Entity_Id := Entity (Result_Definition (T_Def));
1131
1132 begin
1133 -- If a null exclusion is imposed on the result type, then
1134 -- create a null-excluding itype (an access subtype) and use
1135 -- it as the function's Etype.
1136
1137 if Is_Access_Type (Typ)
1138 and then Null_Exclusion_In_Return_Present (T_Def)
1139 then
1140 Set_Etype (Desig_Type,
1141 Create_Null_Excluding_Itype
1142 (T => Typ,
1143 Related_Nod => T_Def,
1144 Scope_Id => Current_Scope));
1145
1146 else
1147 if From_Limited_With (Typ) then
1148
1149 -- AI05-151: Incomplete types are allowed in all basic
1150 -- declarations, including access to subprograms.
1151
1152 if Ada_Version >= Ada_2012 then
1153 null;
1154
1155 else
1156 Error_Msg_NE
1157 ("illegal use of incomplete type&",
1158 Result_Definition (T_Def), Typ);
1159 end if;
1160
1161 elsif Ekind (Current_Scope) = E_Package
1162 and then In_Private_Part (Current_Scope)
1163 then
1164 if Ekind (Typ) = E_Incomplete_Type then
1165 Append_Elmt (Desig_Type, Private_Dependents (Typ));
1166
1167 elsif Is_Class_Wide_Type (Typ)
1168 and then Ekind (Etype (Typ)) = E_Incomplete_Type
1169 then
1170 Append_Elmt
1171 (Desig_Type, Private_Dependents (Etype (Typ)));
1172 end if;
1173 end if;
1174
1175 Set_Etype (Desig_Type, Typ);
1176 end if;
1177 end;
1178 end if;
1179
1180 if not (Is_Type (Etype (Desig_Type))) then
1181 Error_Msg_N
1182 ("expect type in function specification",
1183 Result_Definition (T_Def));
1184 end if;
1185
1186 else
1187 Set_Etype (Desig_Type, Standard_Void_Type);
1188 end if;
1189
1190 if Present (Formals) then
1191 Push_Scope (Desig_Type);
1192
1193 -- Some special tests here. These special tests can be removed
1194 -- if and when Itypes always have proper parent pointers to their
1195 -- declarations???
1196
1197 -- Special test 1) Link defining_identifier of formals. Required by
1198 -- First_Formal to provide its functionality.
1199
1200 declare
1201 F : Node_Id;
1202
1203 begin
1204 F := First (Formals);
1205
1206 -- In ASIS mode, the access_to_subprogram may be analyzed twice,
1207 -- when it is part of an unconstrained type and subtype expansion
1208 -- is disabled. To avoid back-end problems with shared profiles,
1209 -- use previous subprogram type as the designated type, and then
1210 -- remove scope added above.
1211
1212 if ASIS_Mode and then Present (Scope (Defining_Identifier (F)))
1213 then
1214 Set_Etype (T_Name, T_Name);
1215 Init_Size_Align (T_Name);
1216 Set_Directly_Designated_Type (T_Name,
1217 Scope (Defining_Identifier (F)));
1218 End_Scope;
1219 return;
1220 end if;
1221
1222 while Present (F) loop
1223 if No (Parent (Defining_Identifier (F))) then
1224 Set_Parent (Defining_Identifier (F), F);
1225 end if;
1226
1227 Next (F);
1228 end loop;
1229 end;
1230
1231 Process_Formals (Formals, Parent (T_Def));
1232
1233 -- Special test 2) End_Scope requires that the parent pointer be set
1234 -- to something reasonable, but Itypes don't have parent pointers. So
1235 -- we set it and then unset it ???
1236
1237 Set_Parent (Desig_Type, T_Name);
1238 End_Scope;
1239 Set_Parent (Desig_Type, Empty);
1240 end if;
1241
1242 -- Check for premature usage of the type being defined
1243
1244 Check_For_Premature_Usage (T_Def);
1245
1246 -- The return type and/or any parameter type may be incomplete. Mark the
1247 -- subprogram_type as depending on the incomplete type, so that it can
1248 -- be updated when the full type declaration is seen. This only applies
1249 -- to incomplete types declared in some enclosing scope, not to limited
1250 -- views from other packages.
1251
1252 -- Prior to Ada 2012, access to functions can only have in_parameters.
1253
1254 if Present (Formals) then
1255 Formal := First_Formal (Desig_Type);
1256 while Present (Formal) loop
1257 if Ekind (Formal) /= E_In_Parameter
1258 and then Nkind (T_Def) = N_Access_Function_Definition
1259 and then Ada_Version < Ada_2012
1260 then
1261 Error_Msg_N ("functions can only have IN parameters", Formal);
1262 end if;
1263
1264 if Ekind (Etype (Formal)) = E_Incomplete_Type
1265 and then In_Open_Scopes (Scope (Etype (Formal)))
1266 then
1267 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
1268 Set_Has_Delayed_Freeze (Desig_Type);
1269 end if;
1270
1271 Next_Formal (Formal);
1272 end loop;
1273 end if;
1274
1275 -- Check whether an indirect call without actuals may be possible. This
1276 -- is used when resolving calls whose result is then indexed.
1277
1278 May_Need_Actuals (Desig_Type);
1279
1280 -- If the return type is incomplete, this is legal as long as the type
1281 -- is declared in the current scope and will be completed in it (rather
1282 -- than being part of limited view).
1283
1284 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
1285 and then not Has_Delayed_Freeze (Desig_Type)
1286 and then In_Open_Scopes (Scope (Etype (Desig_Type)))
1287 then
1288 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
1289 Set_Has_Delayed_Freeze (Desig_Type);
1290 end if;
1291
1292 Check_Delayed_Subprogram (Desig_Type);
1293
1294 if Protected_Present (T_Def) then
1295 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
1296 Set_Convention (Desig_Type, Convention_Protected);
1297 else
1298 Set_Ekind (T_Name, E_Access_Subprogram_Type);
1299 end if;
1300
1301 Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
1302
1303 Set_Etype (T_Name, T_Name);
1304 Init_Size_Align (T_Name);
1305 Set_Directly_Designated_Type (T_Name, Desig_Type);
1306
1307 Generate_Reference_To_Formals (T_Name);
1308
1309 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
1310
1311 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
1312
1313 Check_Restriction (No_Access_Subprograms, T_Def);
1314 end Access_Subprogram_Declaration;
1315
1316 ----------------------------
1317 -- Access_Type_Declaration --
1318 ----------------------------
1319
1320 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
1321 P : constant Node_Id := Parent (Def);
1322 S : constant Node_Id := Subtype_Indication (Def);
1323
1324 Full_Desig : Entity_Id;
1325
1326 begin
1327 Check_SPARK_05_Restriction ("access type is not allowed", Def);
1328
1329 -- Check for permissible use of incomplete type
1330
1331 if Nkind (S) /= N_Subtype_Indication then
1332 Analyze (S);
1333
1334 if Present (Entity (S))
1335 and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
1336 then
1337 Set_Directly_Designated_Type (T, Entity (S));
1338
1339 -- If the designated type is a limited view, we cannot tell if
1340 -- the full view contains tasks, and there is no way to handle
1341 -- that full view in a client. We create a master entity for the
1342 -- scope, which will be used when a client determines that one
1343 -- is needed.
1344
1345 if From_Limited_With (Entity (S))
1346 and then not Is_Class_Wide_Type (Entity (S))
1347 then
1348 Set_Ekind (T, E_Access_Type);
1349 Build_Master_Entity (T);
1350 Build_Master_Renaming (T);
1351 end if;
1352
1353 else
1354 Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P'));
1355 end if;
1356
1357 -- If the access definition is of the form: ACCESS NOT NULL ..
1358 -- the subtype indication must be of an access type. Create
1359 -- a null-excluding subtype of it.
1360
1361 if Null_Excluding_Subtype (Def) then
1362 if not Is_Access_Type (Entity (S)) then
1363 Error_Msg_N ("null exclusion must apply to access type", Def);
1364
1365 else
1366 declare
1367 Loc : constant Source_Ptr := Sloc (S);
1368 Decl : Node_Id;
1369 Nam : constant Entity_Id := Make_Temporary (Loc, 'S');
1370
1371 begin
1372 Decl :=
1373 Make_Subtype_Declaration (Loc,
1374 Defining_Identifier => Nam,
1375 Subtype_Indication =>
1376 New_Occurrence_Of (Entity (S), Loc));
1377 Set_Null_Exclusion_Present (Decl);
1378 Insert_Before (Parent (Def), Decl);
1379 Analyze (Decl);
1380 Set_Entity (S, Nam);
1381 end;
1382 end if;
1383 end if;
1384
1385 else
1386 Set_Directly_Designated_Type (T,
1387 Process_Subtype (S, P, T, 'P'));
1388 end if;
1389
1390 if All_Present (Def) or Constant_Present (Def) then
1391 Set_Ekind (T, E_General_Access_Type);
1392 else
1393 Set_Ekind (T, E_Access_Type);
1394 end if;
1395
1396 Full_Desig := Designated_Type (T);
1397
1398 if Base_Type (Full_Desig) = T then
1399 Error_Msg_N ("access type cannot designate itself", S);
1400
1401 -- In Ada 2005, the type may have a limited view through some unit in
1402 -- its own context, allowing the following circularity that cannot be
1403 -- detected earlier.
1404
1405 elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
1406 then
1407 Error_Msg_N
1408 ("access type cannot designate its own class-wide type", S);
1409
1410 -- Clean up indication of tagged status to prevent cascaded errors
1411
1412 Set_Is_Tagged_Type (T, False);
1413 end if;
1414
1415 Set_Etype (T, T);
1416
1417 -- If the type has appeared already in a with_type clause, it is frozen
1418 -- and the pointer size is already set. Else, initialize.
1419
1420 if not From_Limited_With (T) then
1421 Init_Size_Align (T);
1422 end if;
1423
1424 -- Note that Has_Task is always false, since the access type itself
1425 -- is not a task type. See Einfo for more description on this point.
1426 -- Exactly the same consideration applies to Has_Controlled_Component
1427 -- and to Has_Protected.
1428
1429 Set_Has_Task (T, False);
1430 Set_Has_Protected (T, False);
1431 Set_Has_Timing_Event (T, False);
1432 Set_Has_Controlled_Component (T, False);
1433
1434 -- Initialize field Finalization_Master explicitly to Empty, to avoid
1435 -- problems where an incomplete view of this entity has been previously
1436 -- established by a limited with and an overlaid version of this field
1437 -- (Stored_Constraint) was initialized for the incomplete view.
1438
1439 -- This reset is performed in most cases except where the access type
1440 -- has been created for the purposes of allocating or deallocating a
1441 -- build-in-place object. Such access types have explicitly set pools
1442 -- and finalization masters.
1443
1444 if No (Associated_Storage_Pool (T)) then
1445 Set_Finalization_Master (T, Empty);
1446 end if;
1447
1448 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1449 -- attributes
1450
1451 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def));
1452 Set_Is_Access_Constant (T, Constant_Present (Def));
1453 end Access_Type_Declaration;
1454
1455 ----------------------------------
1456 -- Add_Interface_Tag_Components --
1457 ----------------------------------
1458
1459 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
1460 Loc : constant Source_Ptr := Sloc (N);
1461 L : List_Id;
1462 Last_Tag : Node_Id;
1463
1464 procedure Add_Tag (Iface : Entity_Id);
1465 -- Add tag for one of the progenitor interfaces
1466
1467 -------------
1468 -- Add_Tag --
1469 -------------
1470
1471 procedure Add_Tag (Iface : Entity_Id) is
1472 Decl : Node_Id;
1473 Def : Node_Id;
1474 Tag : Entity_Id;
1475 Offset : Entity_Id;
1476
1477 begin
1478 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface));
1479
1480 -- This is a reasonable place to propagate predicates
1481
1482 if Has_Predicates (Iface) then
1483 Set_Has_Predicates (Typ);
1484 end if;
1485
1486 Def :=
1487 Make_Component_Definition (Loc,
1488 Aliased_Present => True,
1489 Subtype_Indication =>
1490 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc));
1491
1492 Tag := Make_Temporary (Loc, 'V');
1493
1494 Decl :=
1495 Make_Component_Declaration (Loc,
1496 Defining_Identifier => Tag,
1497 Component_Definition => Def);
1498
1499 Analyze_Component_Declaration (Decl);
1500
1501 Set_Analyzed (Decl);
1502 Set_Ekind (Tag, E_Component);
1503 Set_Is_Tag (Tag);
1504 Set_Is_Aliased (Tag);
1505 Set_Related_Type (Tag, Iface);
1506 Init_Component_Location (Tag);
1507
1508 pragma Assert (Is_Frozen (Iface));
1509
1510 Set_DT_Entry_Count (Tag,
1511 DT_Entry_Count (First_Entity (Iface)));
1512
1513 if No (Last_Tag) then
1514 Prepend (Decl, L);
1515 else
1516 Insert_After (Last_Tag, Decl);
1517 end if;
1518
1519 Last_Tag := Decl;
1520
1521 -- If the ancestor has discriminants we need to give special support
1522 -- to store the offset_to_top value of the secondary dispatch tables.
1523 -- For this purpose we add a supplementary component just after the
1524 -- field that contains the tag associated with each secondary DT.
1525
1526 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then
1527 Def :=
1528 Make_Component_Definition (Loc,
1529 Subtype_Indication =>
1530 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1531
1532 Offset := Make_Temporary (Loc, 'V');
1533
1534 Decl :=
1535 Make_Component_Declaration (Loc,
1536 Defining_Identifier => Offset,
1537 Component_Definition => Def);
1538
1539 Analyze_Component_Declaration (Decl);
1540
1541 Set_Analyzed (Decl);
1542 Set_Ekind (Offset, E_Component);
1543 Set_Is_Aliased (Offset);
1544 Set_Related_Type (Offset, Iface);
1545 Init_Component_Location (Offset);
1546 Insert_After (Last_Tag, Decl);
1547 Last_Tag := Decl;
1548 end if;
1549 end Add_Tag;
1550
1551 -- Local variables
1552
1553 Elmt : Elmt_Id;
1554 Ext : Node_Id;
1555 Comp : Node_Id;
1556
1557 -- Start of processing for Add_Interface_Tag_Components
1558
1559 begin
1560 if not RTE_Available (RE_Interface_Tag) then
1561 Error_Msg
1562 ("(Ada 2005) interface types not supported by this run-time!",
1563 Sloc (N));
1564 return;
1565 end if;
1566
1567 if Ekind (Typ) /= E_Record_Type
1568 or else (Is_Concurrent_Record_Type (Typ)
1569 and then Is_Empty_List (Abstract_Interface_List (Typ)))
1570 or else (not Is_Concurrent_Record_Type (Typ)
1571 and then No (Interfaces (Typ))
1572 and then Is_Empty_Elmt_List (Interfaces (Typ)))
1573 then
1574 return;
1575 end if;
1576
1577 -- Find the current last tag
1578
1579 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1580 Ext := Record_Extension_Part (Type_Definition (N));
1581 else
1582 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
1583 Ext := Type_Definition (N);
1584 end if;
1585
1586 Last_Tag := Empty;
1587
1588 if not (Present (Component_List (Ext))) then
1589 Set_Null_Present (Ext, False);
1590 L := New_List;
1591 Set_Component_List (Ext,
1592 Make_Component_List (Loc,
1593 Component_Items => L,
1594 Null_Present => False));
1595 else
1596 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1597 L := Component_Items
1598 (Component_List
1599 (Record_Extension_Part
1600 (Type_Definition (N))));
1601 else
1602 L := Component_Items
1603 (Component_List
1604 (Type_Definition (N)));
1605 end if;
1606
1607 -- Find the last tag component
1608
1609 Comp := First (L);
1610 while Present (Comp) loop
1611 if Nkind (Comp) = N_Component_Declaration
1612 and then Is_Tag (Defining_Identifier (Comp))
1613 then
1614 Last_Tag := Comp;
1615 end if;
1616
1617 Next (Comp);
1618 end loop;
1619 end if;
1620
1621 -- At this point L references the list of components and Last_Tag
1622 -- references the current last tag (if any). Now we add the tag
1623 -- corresponding with all the interfaces that are not implemented
1624 -- by the parent.
1625
1626 if Present (Interfaces (Typ)) then
1627 Elmt := First_Elmt (Interfaces (Typ));
1628 while Present (Elmt) loop
1629 Add_Tag (Node (Elmt));
1630 Next_Elmt (Elmt);
1631 end loop;
1632 end if;
1633 end Add_Interface_Tag_Components;
1634
1635 -------------------------------------
1636 -- Add_Internal_Interface_Entities --
1637 -------------------------------------
1638
1639 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
1640 Elmt : Elmt_Id;
1641 Iface : Entity_Id;
1642 Iface_Elmt : Elmt_Id;
1643 Iface_Prim : Entity_Id;
1644 Ifaces_List : Elist_Id;
1645 New_Subp : Entity_Id := Empty;
1646 Prim : Entity_Id;
1647 Restore_Scope : Boolean := False;
1648
1649 begin
1650 pragma Assert (Ada_Version >= Ada_2005
1651 and then Is_Record_Type (Tagged_Type)
1652 and then Is_Tagged_Type (Tagged_Type)
1653 and then Has_Interfaces (Tagged_Type)
1654 and then not Is_Interface (Tagged_Type));
1655
1656 -- Ensure that the internal entities are added to the scope of the type
1657
1658 if Scope (Tagged_Type) /= Current_Scope then
1659 Push_Scope (Scope (Tagged_Type));
1660 Restore_Scope := True;
1661 end if;
1662
1663 Collect_Interfaces (Tagged_Type, Ifaces_List);
1664
1665 Iface_Elmt := First_Elmt (Ifaces_List);
1666 while Present (Iface_Elmt) loop
1667 Iface := Node (Iface_Elmt);
1668
1669 -- Originally we excluded here from this processing interfaces that
1670 -- are parents of Tagged_Type because their primitives are located
1671 -- in the primary dispatch table (and hence no auxiliary internal
1672 -- entities are required to handle secondary dispatch tables in such
1673 -- case). However, these auxiliary entities are also required to
1674 -- handle derivations of interfaces in formals of generics (see
1675 -- Derive_Subprograms).
1676
1677 Elmt := First_Elmt (Primitive_Operations (Iface));
1678 while Present (Elmt) loop
1679 Iface_Prim := Node (Elmt);
1680
1681 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
1682 Prim :=
1683 Find_Primitive_Covering_Interface
1684 (Tagged_Type => Tagged_Type,
1685 Iface_Prim => Iface_Prim);
1686
1687 if No (Prim) and then Serious_Errors_Detected > 0 then
1688 goto Continue;
1689 end if;
1690
1691 pragma Assert (Present (Prim));
1692
1693 -- Ada 2012 (AI05-0197): If the name of the covering primitive
1694 -- differs from the name of the interface primitive then it is
1695 -- a private primitive inherited from a parent type. In such
1696 -- case, given that Tagged_Type covers the interface, the
1697 -- inherited private primitive becomes visible. For such
1698 -- purpose we add a new entity that renames the inherited
1699 -- private primitive.
1700
1701 if Chars (Prim) /= Chars (Iface_Prim) then
1702 pragma Assert (Has_Suffix (Prim, 'P'));
1703 Derive_Subprogram
1704 (New_Subp => New_Subp,
1705 Parent_Subp => Iface_Prim,
1706 Derived_Type => Tagged_Type,
1707 Parent_Type => Iface);
1708 Set_Alias (New_Subp, Prim);
1709 Set_Is_Abstract_Subprogram
1710 (New_Subp, Is_Abstract_Subprogram (Prim));
1711 end if;
1712
1713 Derive_Subprogram
1714 (New_Subp => New_Subp,
1715 Parent_Subp => Iface_Prim,
1716 Derived_Type => Tagged_Type,
1717 Parent_Type => Iface);
1718
1719 declare
1720 Anc : Entity_Id;
1721 begin
1722 if Is_Inherited_Operation (Prim)
1723 and then Present (Alias (Prim))
1724 then
1725 Anc := Alias (Prim);
1726 else
1727 Anc := Overridden_Operation (Prim);
1728 end if;
1729
1730 -- Apply legality checks in RM 6.1.1 (10-13) concerning
1731 -- nonconforming preconditions in both an ancestor and
1732 -- a progenitor operation.
1733
1734 if Present (Anc)
1735 and then Has_Non_Trivial_Precondition (Anc)
1736 and then Has_Non_Trivial_Precondition (Iface_Prim)
1737 then
1738 if Is_Abstract_Subprogram (Prim)
1739 or else
1740 (Ekind (Prim) = E_Procedure
1741 and then Nkind (Parent (Prim)) =
1742 N_Procedure_Specification
1743 and then Null_Present (Parent (Prim)))
1744 then
1745 null;
1746
1747 -- The inherited operation must be overridden
1748
1749 elsif not Comes_From_Source (Prim) then
1750 Error_Msg_NE
1751 ("&inherits non-conforming preconditions and must "
1752 & "be overridden (RM 6.1.1 (10-16)",
1753 Parent (Tagged_Type), Prim);
1754 end if;
1755 end if;
1756 end;
1757
1758 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
1759 -- associated with interface types. These entities are
1760 -- only registered in the list of primitives of its
1761 -- corresponding tagged type because they are only used
1762 -- to fill the contents of the secondary dispatch tables.
1763 -- Therefore they are removed from the homonym chains.
1764
1765 Set_Is_Hidden (New_Subp);
1766 Set_Is_Internal (New_Subp);
1767 Set_Alias (New_Subp, Prim);
1768 Set_Is_Abstract_Subprogram
1769 (New_Subp, Is_Abstract_Subprogram (Prim));
1770 Set_Interface_Alias (New_Subp, Iface_Prim);
1771
1772 -- If the returned type is an interface then propagate it to
1773 -- the returned type. Needed by the thunk to generate the code
1774 -- which displaces "this" to reference the corresponding
1775 -- secondary dispatch table in the returned object.
1776
1777 if Is_Interface (Etype (Iface_Prim)) then
1778 Set_Etype (New_Subp, Etype (Iface_Prim));
1779 end if;
1780
1781 -- Internal entities associated with interface types are only
1782 -- registered in the list of primitives of the tagged type.
1783 -- They are only used to fill the contents of the secondary
1784 -- dispatch tables. Therefore they are not needed in the
1785 -- homonym chains.
1786
1787 Remove_Homonym (New_Subp);
1788
1789 -- Hidden entities associated with interfaces must have set
1790 -- the Has_Delay_Freeze attribute to ensure that, in case
1791 -- of locally defined tagged types (or compiling with static
1792 -- dispatch tables generation disabled) the corresponding
1793 -- entry of the secondary dispatch table is filled when such
1794 -- an entity is frozen. This is an expansion activity that must
1795 -- be suppressed for ASIS because it leads to gigi elaboration
1796 -- issues in annotate mode.
1797
1798 if not ASIS_Mode then
1799 Set_Has_Delayed_Freeze (New_Subp);
1800 end if;
1801 end if;
1802
1803 <<Continue>>
1804 Next_Elmt (Elmt);
1805 end loop;
1806
1807 Next_Elmt (Iface_Elmt);
1808 end loop;
1809
1810 if Restore_Scope then
1811 Pop_Scope;
1812 end if;
1813 end Add_Internal_Interface_Entities;
1814
1815 -----------------------------------
1816 -- Analyze_Component_Declaration --
1817 -----------------------------------
1818
1819 procedure Analyze_Component_Declaration (N : Node_Id) is
1820 Loc : constant Source_Ptr := Sloc (Component_Definition (N));
1821 Id : constant Entity_Id := Defining_Identifier (N);
1822 E : constant Node_Id := Expression (N);
1823 Typ : constant Node_Id :=
1824 Subtype_Indication (Component_Definition (N));
1825 T : Entity_Id;
1826 P : Entity_Id;
1827
1828 function Contains_POC (Constr : Node_Id) return Boolean;
1829 -- Determines whether a constraint uses the discriminant of a record
1830 -- type thus becoming a per-object constraint (POC).
1831
1832 function Is_Known_Limited (Typ : Entity_Id) return Boolean;
1833 -- Typ is the type of the current component, check whether this type is
1834 -- a limited type. Used to validate declaration against that of
1835 -- enclosing record.
1836
1837 ------------------
1838 -- Contains_POC --
1839 ------------------
1840
1841 function Contains_POC (Constr : Node_Id) return Boolean is
1842 begin
1843 -- Prevent cascaded errors
1844
1845 if Error_Posted (Constr) then
1846 return False;
1847 end if;
1848
1849 case Nkind (Constr) is
1850 when N_Attribute_Reference =>
1851 return Attribute_Name (Constr) = Name_Access
1852 and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
1853
1854 when N_Discriminant_Association =>
1855 return Denotes_Discriminant (Expression (Constr));
1856
1857 when N_Identifier =>
1858 return Denotes_Discriminant (Constr);
1859
1860 when N_Index_Or_Discriminant_Constraint =>
1861 declare
1862 IDC : Node_Id;
1863
1864 begin
1865 IDC := First (Constraints (Constr));
1866 while Present (IDC) loop
1867
1868 -- One per-object constraint is sufficient
1869
1870 if Contains_POC (IDC) then
1871 return True;
1872 end if;
1873
1874 Next (IDC);
1875 end loop;
1876
1877 return False;
1878 end;
1879
1880 when N_Range =>
1881 return Denotes_Discriminant (Low_Bound (Constr))
1882 or else
1883 Denotes_Discriminant (High_Bound (Constr));
1884
1885 when N_Range_Constraint =>
1886 return Denotes_Discriminant (Range_Expression (Constr));
1887
1888 when others =>
1889 return False;
1890 end case;
1891 end Contains_POC;
1892
1893 ----------------------
1894 -- Is_Known_Limited --
1895 ----------------------
1896
1897 function Is_Known_Limited (Typ : Entity_Id) return Boolean is
1898 P : constant Entity_Id := Etype (Typ);
1899 R : constant Entity_Id := Root_Type (Typ);
1900
1901 begin
1902 if Is_Limited_Record (Typ) then
1903 return True;
1904
1905 -- If the root type is limited (and not a limited interface)
1906 -- so is the current type
1907
1908 elsif Is_Limited_Record (R)
1909 and then (not Is_Interface (R) or else not Is_Limited_Interface (R))
1910 then
1911 return True;
1912
1913 -- Else the type may have a limited interface progenitor, but a
1914 -- limited record parent.
1915
1916 elsif R /= P and then Is_Limited_Record (P) then
1917 return True;
1918
1919 else
1920 return False;
1921 end if;
1922 end Is_Known_Limited;
1923
1924 -- Start of processing for Analyze_Component_Declaration
1925
1926 begin
1927 Generate_Definition (Id);
1928 Enter_Name (Id);
1929
1930 if Present (Typ) then
1931 T := Find_Type_Of_Object
1932 (Subtype_Indication (Component_Definition (N)), N);
1933
1934 if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then
1935 Check_SPARK_05_Restriction ("subtype mark required", Typ);
1936 end if;
1937
1938 -- Ada 2005 (AI-230): Access Definition case
1939
1940 else
1941 pragma Assert (Present
1942 (Access_Definition (Component_Definition (N))));
1943
1944 T := Access_Definition
1945 (Related_Nod => N,
1946 N => Access_Definition (Component_Definition (N)));
1947 Set_Is_Local_Anonymous_Access (T);
1948
1949 -- Ada 2005 (AI-254)
1950
1951 if Present (Access_To_Subprogram_Definition
1952 (Access_Definition (Component_Definition (N))))
1953 and then Protected_Present (Access_To_Subprogram_Definition
1954 (Access_Definition
1955 (Component_Definition (N))))
1956 then
1957 T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1958 end if;
1959 end if;
1960
1961 -- If the subtype is a constrained subtype of the enclosing record,
1962 -- (which must have a partial view) the back-end does not properly
1963 -- handle the recursion. Rewrite the component declaration with an
1964 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1965 -- the tree directly because side effects have already been removed from
1966 -- discriminant constraints.
1967
1968 if Ekind (T) = E_Access_Subtype
1969 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
1970 and then Comes_From_Source (T)
1971 and then Nkind (Parent (T)) = N_Subtype_Declaration
1972 and then Etype (Directly_Designated_Type (T)) = Current_Scope
1973 then
1974 Rewrite
1975 (Subtype_Indication (Component_Definition (N)),
1976 New_Copy_Tree (Subtype_Indication (Parent (T))));
1977 T := Find_Type_Of_Object
1978 (Subtype_Indication (Component_Definition (N)), N);
1979 end if;
1980
1981 -- If the component declaration includes a default expression, then we
1982 -- check that the component is not of a limited type (RM 3.7(5)),
1983 -- and do the special preanalysis of the expression (see section on
1984 -- "Handling of Default and Per-Object Expressions" in the spec of
1985 -- package Sem).
1986
1987 if Present (E) then
1988 Check_SPARK_05_Restriction ("default expression is not allowed", E);
1989 Preanalyze_Default_Expression (E, T);
1990 Check_Initialization (T, E);
1991
1992 if Ada_Version >= Ada_2005
1993 and then Ekind (T) = E_Anonymous_Access_Type
1994 and then Etype (E) /= Any_Type
1995 then
1996 -- Check RM 3.9.2(9): "if the expected type for an expression is
1997 -- an anonymous access-to-specific tagged type, then the object
1998 -- designated by the expression shall not be dynamically tagged
1999 -- unless it is a controlling operand in a call on a dispatching
2000 -- operation"
2001
2002 if Is_Tagged_Type (Directly_Designated_Type (T))
2003 and then
2004 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
2005 and then
2006 Ekind (Directly_Designated_Type (Etype (E))) =
2007 E_Class_Wide_Type
2008 then
2009 Error_Msg_N
2010 ("access to specific tagged type required (RM 3.9.2(9))", E);
2011 end if;
2012
2013 -- (Ada 2005: AI-230): Accessibility check for anonymous
2014 -- components
2015
2016 if Type_Access_Level (Etype (E)) >
2017 Deepest_Type_Access_Level (T)
2018 then
2019 Error_Msg_N
2020 ("expression has deeper access level than component " &
2021 "(RM 3.10.2 (12.2))", E);
2022 end if;
2023
2024 -- The initialization expression is a reference to an access
2025 -- discriminant. The type of the discriminant is always deeper
2026 -- than any access type.
2027
2028 if Ekind (Etype (E)) = E_Anonymous_Access_Type
2029 and then Is_Entity_Name (E)
2030 and then Ekind (Entity (E)) = E_In_Parameter
2031 and then Present (Discriminal_Link (Entity (E)))
2032 then
2033 Error_Msg_N
2034 ("discriminant has deeper accessibility level than target",
2035 E);
2036 end if;
2037 end if;
2038 end if;
2039
2040 -- The parent type may be a private view with unknown discriminants,
2041 -- and thus unconstrained. Regular components must be constrained.
2042
2043 if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then
2044 if Is_Class_Wide_Type (T) then
2045 Error_Msg_N
2046 ("class-wide subtype with unknown discriminants" &
2047 " in component declaration",
2048 Subtype_Indication (Component_Definition (N)));
2049 else
2050 Error_Msg_N
2051 ("unconstrained subtype in component declaration",
2052 Subtype_Indication (Component_Definition (N)));
2053 end if;
2054
2055 -- Components cannot be abstract, except for the special case of
2056 -- the _Parent field (case of extending an abstract tagged type)
2057
2058 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then
2059 Error_Msg_N ("type of a component cannot be abstract", N);
2060 end if;
2061
2062 Set_Etype (Id, T);
2063 Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
2064
2065 -- The component declaration may have a per-object constraint, set
2066 -- the appropriate flag in the defining identifier of the subtype.
2067
2068 if Present (Subtype_Indication (Component_Definition (N))) then
2069 declare
2070 Sindic : constant Node_Id :=
2071 Subtype_Indication (Component_Definition (N));
2072 begin
2073 if Nkind (Sindic) = N_Subtype_Indication
2074 and then Present (Constraint (Sindic))
2075 and then Contains_POC (Constraint (Sindic))
2076 then
2077 Set_Has_Per_Object_Constraint (Id);
2078 end if;
2079 end;
2080 end if;
2081
2082 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2083 -- out some static checks.
2084
2085 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
2086 Null_Exclusion_Static_Checks (N);
2087 end if;
2088
2089 -- If this component is private (or depends on a private type), flag the
2090 -- record type to indicate that some operations are not available.
2091
2092 P := Private_Component (T);
2093
2094 if Present (P) then
2095
2096 -- Check for circular definitions
2097
2098 if P = Any_Type then
2099 Set_Etype (Id, Any_Type);
2100
2101 -- There is a gap in the visibility of operations only if the
2102 -- component type is not defined in the scope of the record type.
2103
2104 elsif Scope (P) = Scope (Current_Scope) then
2105 null;
2106
2107 elsif Is_Limited_Type (P) then
2108 Set_Is_Limited_Composite (Current_Scope);
2109
2110 else
2111 Set_Is_Private_Composite (Current_Scope);
2112 end if;
2113 end if;
2114
2115 if P /= Any_Type
2116 and then Is_Limited_Type (T)
2117 and then Chars (Id) /= Name_uParent
2118 and then Is_Tagged_Type (Current_Scope)
2119 then
2120 if Is_Derived_Type (Current_Scope)
2121 and then not Is_Known_Limited (Current_Scope)
2122 then
2123 Error_Msg_N
2124 ("extension of nonlimited type cannot have limited components",
2125 N);
2126
2127 if Is_Interface (Root_Type (Current_Scope)) then
2128 Error_Msg_N
2129 ("\limitedness is not inherited from limited interface", N);
2130 Error_Msg_N ("\add LIMITED to type indication", N);
2131 end if;
2132
2133 Explain_Limited_Type (T, N);
2134 Set_Etype (Id, Any_Type);
2135 Set_Is_Limited_Composite (Current_Scope, False);
2136
2137 elsif not Is_Derived_Type (Current_Scope)
2138 and then not Is_Limited_Record (Current_Scope)
2139 and then not Is_Concurrent_Type (Current_Scope)
2140 then
2141 Error_Msg_N
2142 ("nonlimited tagged type cannot have limited components", N);
2143 Explain_Limited_Type (T, N);
2144 Set_Etype (Id, Any_Type);
2145 Set_Is_Limited_Composite (Current_Scope, False);
2146 end if;
2147 end if;
2148
2149 -- If the component is an unconstrained task or protected type with
2150 -- discriminants, the component and the enclosing record are limited
2151 -- and the component is constrained by its default values. Compute
2152 -- its actual subtype, else it may be allocated the maximum size by
2153 -- the backend, and possibly overflow.
2154
2155 if Is_Concurrent_Type (T)
2156 and then not Is_Constrained (T)
2157 and then Has_Discriminants (T)
2158 and then not Has_Discriminants (Current_Scope)
2159 then
2160 declare
2161 Act_T : constant Entity_Id := Build_Default_Subtype (T, N);
2162
2163 begin
2164 Set_Etype (Id, Act_T);
2165
2166 -- Rewrite component definition to use the constrained subtype
2167
2168 Rewrite (Component_Definition (N),
2169 Make_Component_Definition (Loc,
2170 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)));
2171 end;
2172 end if;
2173
2174 Set_Original_Record_Component (Id, Id);
2175
2176 if Has_Aspects (N) then
2177 Analyze_Aspect_Specifications (N, Id);
2178 end if;
2179
2180 Analyze_Dimension (N);
2181 end Analyze_Component_Declaration;
2182
2183 --------------------------
2184 -- Analyze_Declarations --
2185 --------------------------
2186
2187 procedure Analyze_Declarations (L : List_Id) is
2188 Decl : Node_Id;
2189
2190 procedure Adjust_Decl;
2191 -- Adjust Decl not to include implicit label declarations, since these
2192 -- have strange Sloc values that result in elaboration check problems.
2193 -- (They have the sloc of the label as found in the source, and that
2194 -- is ahead of the current declarative part).
2195
2196 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id);
2197 -- Create the subprogram bodies which verify the run-time semantics of
2198 -- the pragmas listed below for each elibigle type found in declarative
2199 -- list Decls. The pragmas are:
2200 --
2201 -- Default_Initial_Condition
2202 -- Invariant
2203 -- Type_Invariant
2204 --
2205 -- Context denotes the owner of the declarative list.
2206
2207 procedure Check_Entry_Contracts;
2208 -- Perform a pre-analysis of the pre- and postconditions of an entry
2209 -- declaration. This must be done before full resolution and creation
2210 -- of the parameter block, etc. to catch illegal uses within the
2211 -- contract expression. Full analysis of the expression is done when
2212 -- the contract is processed.
2213
2214 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
2215 -- Determine whether Body_Decl denotes the body of a late controlled
2216 -- primitive (either Initialize, Adjust or Finalize). If this is the
2217 -- case, add a proper spec if the body lacks one. The spec is inserted
2218 -- before Body_Decl and immediately analyzed.
2219
2220 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id);
2221 -- Spec_Id is the entity of a package that may define abstract states,
2222 -- and in the case of a child unit, whose ancestors may define abstract
2223 -- states. If the states have partial visible refinement, remove the
2224 -- partial visibility of each constituent at the end of the package
2225 -- spec and body declarations.
2226
2227 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id);
2228 -- Spec_Id is the entity of a package that may define abstract states.
2229 -- If the states have visible refinement, remove the visibility of each
2230 -- constituent at the end of the package body declaration.
2231
2232 procedure Resolve_Aspects;
2233 -- Utility to resolve the expressions of aspects at the end of a list of
2234 -- declarations.
2235
2236 function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
2237 -- Check if an inner package has entities within it that rely on library
2238 -- level private types where the full view has not been seen.
2239
2240 -----------------
2241 -- Adjust_Decl --
2242 -----------------
2243
2244 procedure Adjust_Decl is
2245 begin
2246 while Present (Prev (Decl))
2247 and then Nkind (Decl) = N_Implicit_Label_Declaration
2248 loop
2249 Prev (Decl);
2250 end loop;
2251 end Adjust_Decl;
2252
2253 ----------------------------
2254 -- Build_Assertion_Bodies --
2255 ----------------------------
2256
2257 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is
2258 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id);
2259 -- Create the subprogram bodies which verify the run-time semantics
2260 -- of the pragmas listed below for type Typ. The pragmas are:
2261 --
2262 -- Default_Initial_Condition
2263 -- Invariant
2264 -- Type_Invariant
2265
2266 -------------------------------------
2267 -- Build_Assertion_Bodies_For_Type --
2268 -------------------------------------
2269
2270 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is
2271 begin
2272 -- Preanalyze and resolve the Default_Initial_Condition assertion
2273 -- expression at the end of the declarations to catch any errors.
2274
2275 if Has_DIC (Typ) then
2276 Build_DIC_Procedure_Body (Typ);
2277 end if;
2278
2279 if Nkind (Context) = N_Package_Specification then
2280
2281 -- Preanalyze and resolve the class-wide invariants of an
2282 -- interface at the end of whichever declarative part has the
2283 -- interface type. Note that an interface may be declared in
2284 -- any non-package declarative part, but reaching the end of
2285 -- such a declarative part will always freeze the type and
2286 -- generate the invariant procedure (see Freeze_Type).
2287
2288 if Is_Interface (Typ) then
2289
2290 -- Interfaces are treated as the partial view of a private
2291 -- type, in order to achieve uniformity with the general
2292 -- case. As a result, an interface receives only a "partial"
2293 -- invariant procedure, which is never called.
2294
2295 if Has_Own_Invariants (Typ) then
2296 Build_Invariant_Procedure_Body
2297 (Typ => Typ,
2298 Partial_Invariant => True);
2299 end if;
2300
2301 -- Preanalyze and resolve the invariants of a private type
2302 -- at the end of the visible declarations to catch potential
2303 -- errors. Inherited class-wide invariants are not included
2304 -- because they have already been resolved.
2305
2306 elsif Decls = Visible_Declarations (Context)
2307 and then Ekind_In (Typ, E_Limited_Private_Type,
2308 E_Private_Type,
2309 E_Record_Type_With_Private)
2310 and then Has_Own_Invariants (Typ)
2311 then
2312 Build_Invariant_Procedure_Body
2313 (Typ => Typ,
2314 Partial_Invariant => True);
2315
2316 -- Preanalyze and resolve the invariants of a private type's
2317 -- full view at the end of the private declarations to catch
2318 -- potential errors.
2319
2320 elsif Decls = Private_Declarations (Context)
2321 and then not Is_Private_Type (Typ)
2322 and then Has_Private_Declaration (Typ)
2323 and then Has_Invariants (Typ)
2324 then
2325 Build_Invariant_Procedure_Body (Typ);
2326 end if;
2327 end if;
2328 end Build_Assertion_Bodies_For_Type;
2329
2330 -- Local variables
2331
2332 Decl : Node_Id;
2333 Decl_Id : Entity_Id;
2334
2335 -- Start of processing for Build_Assertion_Bodies
2336
2337 begin
2338 Decl := First (Decls);
2339 while Present (Decl) loop
2340 if Is_Declaration (Decl) then
2341 Decl_Id := Defining_Entity (Decl);
2342
2343 if Is_Type (Decl_Id) then
2344 Build_Assertion_Bodies_For_Type (Decl_Id);
2345 end if;
2346 end if;
2347
2348 Next (Decl);
2349 end loop;
2350 end Build_Assertion_Bodies;
2351
2352 ---------------------------
2353 -- Check_Entry_Contracts --
2354 ---------------------------
2355
2356 procedure Check_Entry_Contracts is
2357 ASN : Node_Id;
2358 Ent : Entity_Id;
2359 Exp : Node_Id;
2360
2361 begin
2362 Ent := First_Entity (Current_Scope);
2363 while Present (Ent) loop
2364
2365 -- This only concerns entries with pre/postconditions
2366
2367 if Ekind (Ent) = E_Entry
2368 and then Present (Contract (Ent))
2369 and then Present (Pre_Post_Conditions (Contract (Ent)))
2370 then
2371 ASN := Pre_Post_Conditions (Contract (Ent));
2372 Push_Scope (Ent);
2373 Install_Formals (Ent);
2374
2375 -- Pre/postconditions are rewritten as Check pragmas. Analysis
2376 -- is performed on a copy of the pragma expression, to prevent
2377 -- modifying the original expression.
2378
2379 while Present (ASN) loop
2380 if Nkind (ASN) = N_Pragma then
2381 Exp :=
2382 New_Copy_Tree
2383 (Expression
2384 (First (Pragma_Argument_Associations (ASN))));
2385 Set_Parent (Exp, ASN);
2386
2387 Preanalyze_Assert_Expression (Exp, Standard_Boolean);
2388 end if;
2389
2390 ASN := Next_Pragma (ASN);
2391 end loop;
2392
2393 End_Scope;
2394 end if;
2395
2396 Next_Entity (Ent);
2397 end loop;
2398 end Check_Entry_Contracts;
2399
2400 --------------------------------------
2401 -- Handle_Late_Controlled_Primitive --
2402 --------------------------------------
2403
2404 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is
2405 Body_Spec : constant Node_Id := Specification (Body_Decl);
2406 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec);
2407 Loc : constant Source_Ptr := Sloc (Body_Id);
2408 Params : constant List_Id :=
2409 Parameter_Specifications (Body_Spec);
2410 Spec : Node_Id;
2411 Spec_Id : Entity_Id;
2412 Typ : Node_Id;
2413
2414 begin
2415 -- Consider only procedure bodies whose name matches one of the three
2416 -- controlled primitives.
2417
2418 if Nkind (Body_Spec) /= N_Procedure_Specification
2419 or else not Nam_In (Chars (Body_Id), Name_Adjust,
2420 Name_Finalize,
2421 Name_Initialize)
2422 then
2423 return;
2424
2425 -- A controlled primitive must have exactly one formal which is not
2426 -- an anonymous access type.
2427
2428 elsif List_Length (Params) /= 1 then
2429 return;
2430 end if;
2431
2432 Typ := Parameter_Type (First (Params));
2433
2434 if Nkind (Typ) = N_Access_Definition then
2435 return;
2436 end if;
2437
2438 Find_Type (Typ);
2439
2440 -- The type of the formal must be derived from [Limited_]Controlled
2441
2442 if not Is_Controlled (Entity (Typ)) then
2443 return;
2444 end if;
2445
2446 -- Check whether a specification exists for this body. We do not
2447 -- analyze the spec of the body in full, because it will be analyzed
2448 -- again when the body is properly analyzed, and we cannot create
2449 -- duplicate entries in the formals chain. We look for an explicit
2450 -- specification because the body may be an overriding operation and
2451 -- an inherited spec may be present.
2452
2453 Spec_Id := Current_Entity (Body_Id);
2454
2455 while Present (Spec_Id) loop
2456 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure)
2457 and then Scope (Spec_Id) = Current_Scope
2458 and then Present (First_Formal (Spec_Id))
2459 and then No (Next_Formal (First_Formal (Spec_Id)))
2460 and then Etype (First_Formal (Spec_Id)) = Entity (Typ)
2461 and then Comes_From_Source (Spec_Id)
2462 then
2463 return;
2464 end if;
2465
2466 Spec_Id := Homonym (Spec_Id);
2467 end loop;
2468
2469 -- At this point the body is known to be a late controlled primitive.
2470 -- Generate a matching spec and insert it before the body. Note the
2471 -- use of Copy_Separate_Tree - we want an entirely separate semantic
2472 -- tree in this case.
2473
2474 Spec := Copy_Separate_Tree (Body_Spec);
2475
2476 -- Ensure that the subprogram declaration does not inherit the null
2477 -- indicator from the body as we now have a proper spec/body pair.
2478
2479 Set_Null_Present (Spec, False);
2480
2481 -- Ensure that the freeze node is inserted after the declaration of
2482 -- the primitive since its expansion will freeze the primitive.
2483
2484 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
2485
2486 Insert_Before_And_Analyze (Body_Decl, Decl);
2487 end Handle_Late_Controlled_Primitive;
2488
2489 ----------------------------------------
2490 -- Remove_Partial_Visible_Refinements --
2491 ----------------------------------------
2492
2493 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is
2494 State_Elmt : Elmt_Id;
2495 begin
2496 if Present (Abstract_States (Spec_Id)) then
2497 State_Elmt := First_Elmt (Abstract_States (Spec_Id));
2498 while Present (State_Elmt) loop
2499 Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False);
2500 Next_Elmt (State_Elmt);
2501 end loop;
2502 end if;
2503
2504 -- For a child unit, also hide the partial state refinement from
2505 -- ancestor packages.
2506
2507 if Is_Child_Unit (Spec_Id) then
2508 Remove_Partial_Visible_Refinements (Scope (Spec_Id));
2509 end if;
2510 end Remove_Partial_Visible_Refinements;
2511
2512 --------------------------------
2513 -- Remove_Visible_Refinements --
2514 --------------------------------
2515
2516 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is
2517 State_Elmt : Elmt_Id;
2518 begin
2519 if Present (Abstract_States (Spec_Id)) then
2520 State_Elmt := First_Elmt (Abstract_States (Spec_Id));
2521 while Present (State_Elmt) loop
2522 Set_Has_Visible_Refinement (Node (State_Elmt), False);
2523 Next_Elmt (State_Elmt);
2524 end loop;
2525 end if;
2526 end Remove_Visible_Refinements;
2527
2528 ---------------------
2529 -- Resolve_Aspects --
2530 ---------------------
2531
2532 procedure Resolve_Aspects is
2533 E : Entity_Id;
2534
2535 begin
2536 E := First_Entity (Current_Scope);
2537 while Present (E) loop
2538 Resolve_Aspect_Expressions (E);
2539 Next_Entity (E);
2540 end loop;
2541 end Resolve_Aspects;
2542
2543 -------------------------------
2544 -- Uses_Unseen_Lib_Unit_Priv --
2545 -------------------------------
2546
2547 function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
2548 Curr : Entity_Id;
2549
2550 begin
2551 -- Avoid looking through scopes that do not meet the precondition of
2552 -- Pkg not being within a library unit spec.
2553
2554 if not Is_Compilation_Unit (Pkg)
2555 and then not Is_Generic_Instance (Pkg)
2556 and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
2557 then
2558 -- Loop through all entities in the current scope to identify
2559 -- an entity that depends on a private type.
2560
2561 Curr := First_Entity (Pkg);
2562 loop
2563 if Nkind (Curr) in N_Entity
2564 and then Depends_On_Private (Curr)
2565 then
2566 return True;
2567 end if;
2568
2569 exit when Last_Entity (Current_Scope) = Curr;
2570 Curr := Next_Entity (Curr);
2571 end loop;
2572 end if;
2573
2574 return False;
2575 end Uses_Unseen_Lib_Unit_Priv;
2576
2577 -- Local variables
2578
2579 Context : Node_Id := Empty;
2580 Freeze_From : Entity_Id := Empty;
2581 Next_Decl : Node_Id;
2582
2583 Body_Seen : Boolean := False;
2584 -- Flag set when the first body [stub] is encountered
2585
2586 -- Start of processing for Analyze_Declarations
2587
2588 begin
2589 if Restriction_Check_Required (SPARK_05) then
2590 Check_Later_Vs_Basic_Declarations (L, During_Parsing => False);
2591 end if;
2592
2593 Decl := First (L);
2594 while Present (Decl) loop
2595
2596 -- Package spec cannot contain a package declaration in SPARK
2597
2598 if Nkind (Decl) = N_Package_Declaration
2599 and then Nkind (Parent (L)) = N_Package_Specification
2600 then
2601 Check_SPARK_05_Restriction
2602 ("package specification cannot contain a package declaration",
2603 Decl);
2604 end if;
2605
2606 -- Complete analysis of declaration
2607
2608 Analyze (Decl);
2609 Next_Decl := Next (Decl);
2610
2611 if No (Freeze_From) then
2612 Freeze_From := First_Entity (Current_Scope);
2613 end if;
2614
2615 -- At the end of a declarative part, freeze remaining entities
2616 -- declared in it. The end of the visible declarations of package
2617 -- specification is not the end of a declarative part if private
2618 -- declarations are present. The end of a package declaration is a
2619 -- freezing point only if it a library package. A task definition or
2620 -- protected type definition is not a freeze point either. Finally,
2621 -- we do not freeze entities in generic scopes, because there is no
2622 -- code generated for them and freeze nodes will be generated for
2623 -- the instance.
2624
2625 -- The end of a package instantiation is not a freeze point, but
2626 -- for now we make it one, because the generic body is inserted
2627 -- (currently) immediately after. Generic instantiations will not
2628 -- be a freeze point once delayed freezing of bodies is implemented.
2629 -- (This is needed in any case for early instantiations ???).
2630
2631 if No (Next_Decl) then
2632 if Nkind (Parent (L)) = N_Component_List then
2633 null;
2634
2635 elsif Nkind_In (Parent (L), N_Protected_Definition,
2636 N_Task_Definition)
2637 then
2638 Check_Entry_Contracts;
2639
2640 elsif Nkind (Parent (L)) /= N_Package_Specification then
2641 if Nkind (Parent (L)) = N_Package_Body then
2642 Freeze_From := First_Entity (Current_Scope);
2643 end if;
2644
2645 -- There may have been several freezing points previously,
2646 -- for example object declarations or subprogram bodies, but
2647 -- at the end of a declarative part we check freezing from
2648 -- the beginning, even though entities may already be frozen,
2649 -- in order to perform visibility checks on delayed aspects.
2650
2651 Adjust_Decl;
2652 Freeze_All (First_Entity (Current_Scope), Decl);
2653 Freeze_From := Last_Entity (Current_Scope);
2654
2655 -- Current scope is a package specification
2656
2657 elsif Scope (Current_Scope) /= Standard_Standard
2658 and then not Is_Child_Unit (Current_Scope)
2659 and then No (Generic_Parent (Parent (L)))
2660 then
2661 -- This is needed in all cases to catch visibility errors in
2662 -- aspect expressions, but several large user tests are now
2663 -- rejected. Pending notification we restrict this call to
2664 -- ASIS mode.
2665
2666 if ASIS_Mode then
2667 Resolve_Aspects;
2668 end if;
2669
2670 elsif L /= Visible_Declarations (Parent (L))
2671 or else No (Private_Declarations (Parent (L)))
2672 or else Is_Empty_List (Private_Declarations (Parent (L)))
2673 then
2674 Adjust_Decl;
2675
2676 -- End of a package declaration
2677
2678 -- In compilation mode the expansion of freeze node takes care
2679 -- of resolving expressions of all aspects in the list. In ASIS
2680 -- mode this must be done explicitly.
2681
2682 if ASIS_Mode
2683 and then Scope (Current_Scope) = Standard_Standard
2684 then
2685 Resolve_Aspects;
2686 end if;
2687
2688 -- This is a freeze point because it is the end of a
2689 -- compilation unit.
2690
2691 Freeze_All (First_Entity (Current_Scope), Decl);
2692 Freeze_From := Last_Entity (Current_Scope);
2693
2694 -- At the end of the visible declarations the expressions in
2695 -- aspects of all entities declared so far must be resolved.
2696 -- The entities themselves might be frozen later, and the
2697 -- generated pragmas and attribute definition clauses analyzed
2698 -- in full at that point, but name resolution must take place
2699 -- now.
2700 -- In addition to being the proper semantics, this is mandatory
2701 -- within generic units, because global name capture requires
2702 -- those expressions to be analyzed, given that the generated
2703 -- pragmas do not appear in the original generic tree.
2704
2705 elsif Serious_Errors_Detected = 0 then
2706 Resolve_Aspects;
2707 end if;
2708
2709 -- If next node is a body then freeze all types before the body.
2710 -- An exception occurs for some expander-generated bodies. If these
2711 -- are generated at places where in general language rules would not
2712 -- allow a freeze point, then we assume that the expander has
2713 -- explicitly checked that all required types are properly frozen,
2714 -- and we do not cause general freezing here. This special circuit
2715 -- is used when the encountered body is marked as having already
2716 -- been analyzed.
2717
2718 -- In all other cases (bodies that come from source, and expander
2719 -- generated bodies that have not been analyzed yet), freeze all
2720 -- types now. Note that in the latter case, the expander must take
2721 -- care to attach the bodies at a proper place in the tree so as to
2722 -- not cause unwanted freezing at that point.
2723
2724 -- It is also necessary to check for a case where both an expression
2725 -- function is used and the current scope depends on an unseen
2726 -- private type from a library unit, otherwise premature freezing of
2727 -- the private type will occur.
2728
2729 elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
2730 and then ((Nkind (Next_Decl) /= N_Subprogram_Body
2731 or else not Was_Expression_Function (Next_Decl))
2732 or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
2733 then
2734 -- When a controlled type is frozen, the expander generates stream
2735 -- and controlled-type support routines. If the freeze is caused
2736 -- by the stand-alone body of Initialize, Adjust, or Finalize, the
2737 -- expander will end up using the wrong version of these routines,
2738 -- as the body has not been processed yet. To remedy this, detect
2739 -- a late controlled primitive and create a proper spec for it.
2740 -- This ensures that the primitive will override its inherited
2741 -- counterpart before the freeze takes place.
2742
2743 -- If the declaration we just processed is a body, do not attempt
2744 -- to examine Next_Decl as the late primitive idiom can only apply
2745 -- to the first encountered body.
2746
2747 -- The spec of the late primitive is not generated in ASIS mode to
2748 -- ensure a consistent list of primitives that indicates the true
2749 -- semantic structure of the program (which is not relevant when
2750 -- generating executable code).
2751
2752 -- ??? A cleaner approach may be possible and/or this solution
2753 -- could be extended to general-purpose late primitives, TBD.
2754
2755 if not ASIS_Mode
2756 and then not Body_Seen
2757 and then not Is_Body (Decl)
2758 then
2759 Body_Seen := True;
2760
2761 if Nkind (Next_Decl) = N_Subprogram_Body then
2762 Handle_Late_Controlled_Primitive (Next_Decl);
2763 end if;
2764 end if;
2765
2766 Adjust_Decl;
2767
2768 -- The generated body of an expression function does not freeze,
2769 -- unless it is a completion, in which case only the expression
2770 -- itself freezes. This is handled when the body itself is
2771 -- analyzed (see Freeze_Expr_Types, sem_ch6.adb).
2772
2773 Freeze_All (Freeze_From, Decl);
2774 Freeze_From := Last_Entity (Current_Scope);
2775 end if;
2776
2777 Decl := Next_Decl;
2778 end loop;
2779
2780 -- Post-freezing actions
2781
2782 if Present (L) then
2783 Context := Parent (L);
2784
2785 -- Analyze the contracts of packages and their bodies
2786
2787 if Nkind (Context) = N_Package_Specification then
2788
2789 -- When a package has private declarations, its contract must be
2790 -- analyzed at the end of the said declarations. This way both the
2791 -- analysis and freeze actions are properly synchronized in case
2792 -- of private type use within the contract.
2793
2794 if L = Private_Declarations (Context) then
2795 Analyze_Package_Contract (Defining_Entity (Context));
2796
2797 -- Otherwise the contract is analyzed at the end of the visible
2798 -- declarations.
2799
2800 elsif L = Visible_Declarations (Context)
2801 and then No (Private_Declarations (Context))
2802 then
2803 Analyze_Package_Contract (Defining_Entity (Context));
2804 end if;
2805
2806 elsif Nkind (Context) = N_Package_Body then
2807 Analyze_Package_Body_Contract (Defining_Entity (Context));
2808 end if;
2809
2810 -- Analyze the contracts of various constructs now due to the delayed
2811 -- visibility needs of their aspects and pragmas.
2812
2813 Analyze_Contracts (L);
2814
2815 if Nkind (Context) = N_Package_Body then
2816
2817 -- Ensure that all abstract states and objects declared in the
2818 -- state space of a package body are utilized as constituents.
2819
2820 Check_Unused_Body_States (Defining_Entity (Context));
2821
2822 -- State refinements are visible up to the end of the package body
2823 -- declarations. Hide the state refinements from visibility to
2824 -- restore the original state conditions.
2825
2826 Remove_Visible_Refinements (Corresponding_Spec (Context));
2827 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
2828
2829 elsif Nkind (Context) = N_Package_Declaration then
2830
2831 -- Partial state refinements are visible up to the end of the
2832 -- package spec declarations. Hide the partial state refinements
2833 -- from visibility to restore the original state conditions.
2834
2835 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
2836 end if;
2837
2838 -- Verify that all abstract states found in any package declared in
2839 -- the input declarative list have proper refinements. The check is
2840 -- performed only when the context denotes a block, entry, package,
2841 -- protected, subprogram, or task body (SPARK RM 7.2.2(3)).
2842
2843 Check_State_Refinements (Context);
2844
2845 -- Create the subprogram bodies which verify the run-time semantics
2846 -- of pragmas Default_Initial_Condition and [Type_]Invariant for all
2847 -- types within the current declarative list. This ensures that all
2848 -- assertion expressions are preanalyzed and resolved at the end of
2849 -- the declarative part. Note that the resolution happens even when
2850 -- freezing does not take place.
2851
2852 Build_Assertion_Bodies (L, Context);
2853 end if;
2854 end Analyze_Declarations;
2855
2856 -----------------------------------
2857 -- Analyze_Full_Type_Declaration --
2858 -----------------------------------
2859
2860 procedure Analyze_Full_Type_Declaration (N : Node_Id) is
2861 Def : constant Node_Id := Type_Definition (N);
2862 Def_Id : constant Entity_Id := Defining_Identifier (N);
2863 T : Entity_Id;
2864 Prev : Entity_Id;
2865
2866 Is_Remote : constant Boolean :=
2867 (Is_Remote_Types (Current_Scope)
2868 or else Is_Remote_Call_Interface (Current_Scope))
2869 and then not (In_Private_Part (Current_Scope)
2870 or else In_Package_Body (Current_Scope));
2871
2872 procedure Check_Nonoverridable_Aspects;
2873 -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot
2874 -- be overridden, and can only be confirmed on derivation.
2875
2876 procedure Check_Ops_From_Incomplete_Type;
2877 -- If there is a tagged incomplete partial view of the type, traverse
2878 -- the primitives of the incomplete view and change the type of any
2879 -- controlling formals and result to indicate the full view. The
2880 -- primitives will be added to the full type's primitive operations
2881 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which
2882 -- is called from Process_Incomplete_Dependents).
2883
2884 ----------------------------------
2885 -- Check_Nonoverridable_Aspects --
2886 ----------------------------------
2887
2888 procedure Check_Nonoverridable_Aspects is
2889 function Get_Aspect_Spec
2890 (Specs : List_Id;
2891 Aspect_Name : Name_Id) return Node_Id;
2892 -- Check whether a list of aspect specifications includes an entry
2893 -- for a specific aspect. The list is either that of a partial or
2894 -- a full view.
2895
2896 ---------------------
2897 -- Get_Aspect_Spec --
2898 ---------------------
2899
2900 function Get_Aspect_Spec
2901 (Specs : List_Id;
2902 Aspect_Name : Name_Id) return Node_Id
2903 is
2904 Spec : Node_Id;
2905
2906 begin
2907 Spec := First (Specs);
2908 while Present (Spec) loop
2909 if Chars (Identifier (Spec)) = Aspect_Name then
2910 return Spec;
2911 end if;
2912 Next (Spec);
2913 end loop;
2914
2915 return Empty;
2916 end Get_Aspect_Spec;
2917
2918 -- Local variables
2919
2920 Prev_Aspects : constant List_Id :=
2921 Aspect_Specifications (Parent (Def_Id));
2922 Par_Type : Entity_Id;
2923 Prev_Aspect : Node_Id;
2924
2925 -- Start of processing for Check_Nonoverridable_Aspects
2926
2927 begin
2928 -- Get parent type of derived type. Note that Prev is the entity in
2929 -- the partial declaration, but its contents are now those of full
2930 -- view, while Def_Id reflects the partial view.
2931
2932 if Is_Private_Type (Def_Id) then
2933 Par_Type := Etype (Full_View (Def_Id));
2934 else
2935 Par_Type := Etype (Def_Id);
2936 end if;
2937
2938 -- If there is an inherited Implicit_Dereference, verify that it is
2939 -- made explicit in the partial view.
2940
2941 if Has_Discriminants (Base_Type (Par_Type))
2942 and then Nkind (Parent (Prev)) = N_Full_Type_Declaration
2943 and then Present (Discriminant_Specifications (Parent (Prev)))
2944 and then Present (Get_Reference_Discriminant (Par_Type))
2945 then
2946 Prev_Aspect :=
2947 Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference);
2948
2949 if No (Prev_Aspect)
2950 and then Present
2951 (Discriminant_Specifications
2952 (Original_Node (Parent (Prev))))
2953 then
2954 Error_Msg_N
2955 ("type does not inherit implicit dereference", Prev);
2956
2957 else
2958 -- If one of the views has the aspect specified, verify that it
2959 -- is consistent with that of the parent.
2960
2961 declare
2962 Par_Discr : constant Entity_Id :=
2963 Get_Reference_Discriminant (Par_Type);
2964 Cur_Discr : constant Entity_Id :=
2965 Get_Reference_Discriminant (Prev);
2966
2967 begin
2968 if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
2969 Error_Msg_N ("aspect incosistent with that of parent", N);
2970 end if;
2971
2972 -- Check that specification in partial view matches the
2973 -- inherited aspect. Compare names directly because aspect
2974 -- expression may not be analyzed.
2975
2976 if Present (Prev_Aspect)
2977 and then Nkind (Expression (Prev_Aspect)) = N_Identifier
2978 and then Chars (Expression (Prev_Aspect)) /=
2979 Chars (Cur_Discr)
2980 then
2981 Error_Msg_N
2982 ("aspect incosistent with that of parent", N);
2983 end if;
2984 end;
2985 end if;
2986 end if;
2987
2988 -- TBD : other nonoverridable aspects.
2989 end Check_Nonoverridable_Aspects;
2990
2991 ------------------------------------
2992 -- Check_Ops_From_Incomplete_Type --
2993 ------------------------------------
2994
2995 procedure Check_Ops_From_Incomplete_Type is
2996 Elmt : Elmt_Id;
2997 Formal : Entity_Id;
2998 Op : Entity_Id;
2999
3000 begin
3001 if Prev /= T
3002 and then Ekind (Prev) = E_Incomplete_Type
3003 and then Is_Tagged_Type (Prev)
3004 and then Is_Tagged_Type (T)
3005 then
3006 Elmt := First_Elmt (Primitive_Operations (Prev));
3007 while Present (Elmt) loop
3008 Op := Node (Elmt);
3009
3010 Formal := First_Formal (Op);
3011 while Present (Formal) loop
3012 if Etype (Formal) = Prev then
3013 Set_Etype (Formal, T);
3014 end if;
3015
3016 Next_Formal (Formal);
3017 end loop;
3018
3019 if Etype (Op) = Prev then
3020 Set_Etype (Op, T);
3021 end if;
3022
3023 Next_Elmt (Elmt);
3024 end loop;
3025 end if;
3026 end Check_Ops_From_Incomplete_Type;
3027
3028 -- Start of processing for Analyze_Full_Type_Declaration
3029
3030 begin
3031 Prev := Find_Type_Name (N);
3032
3033 -- The full view, if present, now points to the current type. If there
3034 -- is an incomplete partial view, set a link to it, to simplify the
3035 -- retrieval of primitive operations of the type.
3036
3037 -- Ada 2005 (AI-50217): If the type was previously decorated when
3038 -- imported through a LIMITED WITH clause, it appears as incomplete
3039 -- but has no full view.
3040
3041 if Ekind (Prev) = E_Incomplete_Type
3042 and then Present (Full_View (Prev))
3043 then
3044 T := Full_View (Prev);
3045 Set_Incomplete_View (N, Parent (Prev));
3046 else
3047 T := Prev;
3048 end if;
3049
3050 Set_Is_Pure (T, Is_Pure (Current_Scope));
3051
3052 -- We set the flag Is_First_Subtype here. It is needed to set the
3053 -- corresponding flag for the Implicit class-wide-type created
3054 -- during tagged types processing.
3055
3056 Set_Is_First_Subtype (T, True);
3057
3058 -- Only composite types other than array types are allowed to have
3059 -- discriminants.
3060
3061 case Nkind (Def) is
3062
3063 -- For derived types, the rule will be checked once we've figured
3064 -- out the parent type.
3065
3066 when N_Derived_Type_Definition =>
3067 null;
3068
3069 -- For record types, discriminants are allowed, unless we are in
3070 -- SPARK.
3071
3072 when N_Record_Definition =>
3073 if Present (Discriminant_Specifications (N)) then
3074 Check_SPARK_05_Restriction
3075 ("discriminant type is not allowed",
3076 Defining_Identifier
3077 (First (Discriminant_Specifications (N))));
3078 end if;
3079
3080 when others =>
3081 if Present (Discriminant_Specifications (N)) then
3082 Error_Msg_N
3083 ("elementary or array type cannot have discriminants",
3084 Defining_Identifier
3085 (First (Discriminant_Specifications (N))));
3086 end if;
3087 end case;
3088
3089 -- Elaborate the type definition according to kind, and generate
3090 -- subsidiary (implicit) subtypes where needed. We skip this if it was
3091 -- already done (this happens during the reanalysis that follows a call
3092 -- to the high level optimizer).
3093
3094 if not Analyzed (T) then
3095 Set_Analyzed (T);
3096
3097 case Nkind (Def) is
3098 when N_Access_To_Subprogram_Definition =>
3099 Access_Subprogram_Declaration (T, Def);
3100
3101 -- If this is a remote access to subprogram, we must create the
3102 -- equivalent fat pointer type, and related subprograms.
3103
3104 if Is_Remote then
3105 Process_Remote_AST_Declaration (N);
3106 end if;
3107
3108 -- Validate categorization rule against access type declaration
3109 -- usually a violation in Pure unit, Shared_Passive unit.
3110
3111 Validate_Access_Type_Declaration (T, N);
3112
3113 when N_Access_To_Object_Definition =>
3114 Access_Type_Declaration (T, Def);
3115
3116 -- Validate categorization rule against access type declaration
3117 -- usually a violation in Pure unit, Shared_Passive unit.
3118
3119 Validate_Access_Type_Declaration (T, N);
3120
3121 -- If we are in a Remote_Call_Interface package and define a
3122 -- RACW, then calling stubs and specific stream attributes
3123 -- must be added.
3124
3125 if Is_Remote
3126 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
3127 then
3128 Add_RACW_Features (Def_Id);
3129 end if;
3130
3131 when N_Array_Type_Definition =>
3132 Array_Type_Declaration (T, Def);
3133
3134 when N_Derived_Type_Definition =>
3135 Derived_Type_Declaration (T, N, T /= Def_Id);
3136
3137 when N_Enumeration_Type_Definition =>
3138 Enumeration_Type_Declaration (T, Def);
3139
3140 when N_Floating_Point_Definition =>
3141 Floating_Point_Type_Declaration (T, Def);
3142
3143 when N_Decimal_Fixed_Point_Definition =>
3144 Decimal_Fixed_Point_Type_Declaration (T, Def);
3145
3146 when N_Ordinary_Fixed_Point_Definition =>
3147 Ordinary_Fixed_Point_Type_Declaration (T, Def);
3148
3149 when N_Signed_Integer_Type_Definition =>
3150 Signed_Integer_Type_Declaration (T, Def);
3151
3152 when N_Modular_Type_Definition =>
3153 Modular_Type_Declaration (T, Def);
3154
3155 when N_Record_Definition =>
3156 Record_Type_Declaration (T, N, Prev);
3157
3158 -- If declaration has a parse error, nothing to elaborate.
3159
3160 when N_Error =>
3161 null;
3162
3163 when others =>
3164 raise Program_Error;
3165 end case;
3166 end if;
3167
3168 if Etype (T) = Any_Type then
3169 return;
3170 end if;
3171
3172 -- Controlled type is not allowed in SPARK
3173
3174 if Is_Visibly_Controlled (T) then
3175 Check_SPARK_05_Restriction ("controlled type is not allowed", N);
3176 end if;
3177
3178 -- Some common processing for all types
3179
3180 Set_Depends_On_Private (T, Has_Private_Component (T));
3181 Check_Ops_From_Incomplete_Type;
3182
3183 -- Both the declared entity, and its anonymous base type if one was
3184 -- created, need freeze nodes allocated.
3185
3186 declare
3187 B : constant Entity_Id := Base_Type (T);
3188
3189 begin
3190 -- In the case where the base type differs from the first subtype, we
3191 -- pre-allocate a freeze node, and set the proper link to the first
3192 -- subtype. Freeze_Entity will use this preallocated freeze node when
3193 -- it freezes the entity.
3194
3195 -- This does not apply if the base type is a generic type, whose
3196 -- declaration is independent of the current derived definition.
3197
3198 if B /= T and then not Is_Generic_Type (B) then
3199 Ensure_Freeze_Node (B);
3200 Set_First_Subtype_Link (Freeze_Node (B), T);
3201 end if;
3202
3203 -- A type that is imported through a limited_with clause cannot
3204 -- generate any code, and thus need not be frozen. However, an access
3205 -- type with an imported designated type needs a finalization list,
3206 -- which may be referenced in some other package that has non-limited
3207 -- visibility on the designated type. Thus we must create the
3208 -- finalization list at the point the access type is frozen, to
3209 -- prevent unsatisfied references at link time.
3210
3211 if not From_Limited_With (T) or else Is_Access_Type (T) then
3212 Set_Has_Delayed_Freeze (T);
3213 end if;
3214 end;
3215
3216 -- Case where T is the full declaration of some private type which has
3217 -- been swapped in Defining_Identifier (N).
3218
3219 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3220 Process_Full_View (N, T, Def_Id);
3221
3222 -- Record the reference. The form of this is a little strange, since
3223 -- the full declaration has been swapped in. So the first parameter
3224 -- here represents the entity to which a reference is made which is
3225 -- the "real" entity, i.e. the one swapped in, and the second
3226 -- parameter provides the reference location.
3227
3228 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here
3229 -- since we don't want a complaint about the full type being an
3230 -- unwanted reference to the private type
3231
3232 declare
3233 B : constant Boolean := Has_Pragma_Unreferenced (T);
3234 begin
3235 Set_Has_Pragma_Unreferenced (T, False);
3236 Generate_Reference (T, T, 'c');
3237 Set_Has_Pragma_Unreferenced (T, B);
3238 end;
3239
3240 Set_Completion_Referenced (Def_Id);
3241
3242 -- For completion of incomplete type, process incomplete dependents
3243 -- and always mark the full type as referenced (it is the incomplete
3244 -- type that we get for any real reference).
3245
3246 elsif Ekind (Prev) = E_Incomplete_Type then
3247 Process_Incomplete_Dependents (N, T, Prev);
3248 Generate_Reference (Prev, Def_Id, 'c');
3249 Set_Completion_Referenced (Def_Id);
3250
3251 -- If not private type or incomplete type completion, this is a real
3252 -- definition of a new entity, so record it.
3253
3254 else
3255 Generate_Definition (Def_Id);
3256 end if;
3257
3258 -- Propagate any pending access types whose finalization masters need to
3259 -- be fully initialized from the partial to the full view. Guard against
3260 -- an illegal full view that remains unanalyzed.
3261
3262 if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then
3263 Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev));
3264 end if;
3265
3266 if Chars (Scope (Def_Id)) = Name_System
3267 and then Chars (Def_Id) = Name_Address
3268 and then In_Predefined_Unit (N)
3269 then
3270 Set_Is_Descendant_Of_Address (Def_Id);
3271 Set_Is_Descendant_Of_Address (Base_Type (Def_Id));
3272 Set_Is_Descendant_Of_Address (Prev);
3273 end if;
3274
3275 Set_Optimize_Alignment_Flags (Def_Id);
3276 Check_Eliminated (Def_Id);
3277
3278 -- If the declaration is a completion and aspects are present, apply
3279 -- them to the entity for the type which is currently the partial
3280 -- view, but which is the one that will be frozen.
3281
3282 if Has_Aspects (N) then
3283
3284 -- In most cases the partial view is a private type, and both views
3285 -- appear in different declarative parts. In the unusual case where
3286 -- the partial view is incomplete, perform the analysis on the
3287 -- full view, to prevent freezing anomalies with the corresponding
3288 -- class-wide type, which otherwise might be frozen before the
3289 -- dispatch table is built.
3290
3291 if Prev /= Def_Id
3292 and then Ekind (Prev) /= E_Incomplete_Type
3293 then
3294 Analyze_Aspect_Specifications (N, Prev);
3295
3296 -- Normal case
3297
3298 else
3299 Analyze_Aspect_Specifications (N, Def_Id);
3300 end if;
3301 end if;
3302
3303 if Is_Derived_Type (Prev)
3304 and then Def_Id /= Prev
3305 then
3306 Check_Nonoverridable_Aspects;
3307 end if;
3308 end Analyze_Full_Type_Declaration;
3309
3310 ----------------------------------
3311 -- Analyze_Incomplete_Type_Decl --
3312 ----------------------------------
3313
3314 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
3315 F : constant Boolean := Is_Pure (Current_Scope);
3316 T : Entity_Id;
3317
3318 begin
3319 Check_SPARK_05_Restriction ("incomplete type is not allowed", N);
3320
3321 Generate_Definition (Defining_Identifier (N));
3322
3323 -- Process an incomplete declaration. The identifier must not have been
3324 -- declared already in the scope. However, an incomplete declaration may
3325 -- appear in the private part of a package, for a private type that has
3326 -- already been declared.
3327
3328 -- In this case, the discriminants (if any) must match
3329
3330 T := Find_Type_Name (N);
3331
3332 Set_Ekind (T, E_Incomplete_Type);
3333 Init_Size_Align (T);
3334 Set_Is_First_Subtype (T, True);
3335 Set_Etype (T, T);
3336
3337 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
3338 -- incomplete types.
3339
3340 if Tagged_Present (N) then
3341 Set_Is_Tagged_Type (T, True);
3342 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
3343 Make_Class_Wide_Type (T);
3344 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3345 end if;
3346
3347 Set_Stored_Constraint (T, No_Elist);
3348
3349 if Present (Discriminant_Specifications (N)) then
3350 Push_Scope (T);
3351 Process_Discriminants (N);
3352 End_Scope;
3353 end if;
3354
3355 -- If the type has discriminants, nontrivial subtypes may be declared
3356 -- before the full view of the type. The full views of those subtypes
3357 -- will be built after the full view of the type.
3358
3359 Set_Private_Dependents (T, New_Elmt_List);
3360 Set_Is_Pure (T, F);
3361 end Analyze_Incomplete_Type_Decl;
3362
3363 -----------------------------------
3364 -- Analyze_Interface_Declaration --
3365 -----------------------------------
3366
3367 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
3368 CW : constant Entity_Id := Class_Wide_Type (T);
3369
3370 begin
3371 Set_Is_Tagged_Type (T);
3372 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
3373
3374 Set_Is_Limited_Record (T, Limited_Present (Def)
3375 or else Task_Present (Def)
3376 or else Protected_Present (Def)
3377 or else Synchronized_Present (Def));
3378
3379 -- Type is abstract if full declaration carries keyword, or if previous
3380 -- partial view did.
3381
3382 Set_Is_Abstract_Type (T);
3383 Set_Is_Interface (T);
3384
3385 -- Type is a limited interface if it includes the keyword limited, task,
3386 -- protected, or synchronized.
3387
3388 Set_Is_Limited_Interface
3389 (T, Limited_Present (Def)
3390 or else Protected_Present (Def)
3391 or else Synchronized_Present (Def)
3392 or else Task_Present (Def));
3393
3394 Set_Interfaces (T, New_Elmt_List);
3395 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3396
3397 -- Complete the decoration of the class-wide entity if it was already
3398 -- built (i.e. during the creation of the limited view)
3399
3400 if Present (CW) then
3401 Set_Is_Interface (CW);
3402 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T));
3403 end if;
3404
3405 -- Check runtime support for synchronized interfaces
3406
3407 if (Is_Task_Interface (T)
3408 or else Is_Protected_Interface (T)
3409 or else Is_Synchronized_Interface (T))
3410 and then not RTE_Available (RE_Select_Specific_Data)
3411 then
3412 Error_Msg_CRT ("synchronized interfaces", T);
3413 end if;
3414 end Analyze_Interface_Declaration;
3415
3416 -----------------------------
3417 -- Analyze_Itype_Reference --
3418 -----------------------------
3419
3420 -- Nothing to do. This node is placed in the tree only for the benefit of
3421 -- back end processing, and has no effect on the semantic processing.
3422
3423 procedure Analyze_Itype_Reference (N : Node_Id) is
3424 begin
3425 pragma Assert (Is_Itype (Itype (N)));
3426 null;
3427 end Analyze_Itype_Reference;
3428
3429 --------------------------------
3430 -- Analyze_Number_Declaration --
3431 --------------------------------
3432
3433 procedure Analyze_Number_Declaration (N : Node_Id) is
3434 E : constant Node_Id := Expression (N);
3435 Id : constant Entity_Id := Defining_Identifier (N);
3436 Index : Interp_Index;
3437 It : Interp;
3438 T : Entity_Id;
3439
3440 begin
3441 Generate_Definition (Id);
3442 Enter_Name (Id);
3443
3444 -- This is an optimization of a common case of an integer literal
3445
3446 if Nkind (E) = N_Integer_Literal then
3447 Set_Is_Static_Expression (E, True);
3448 Set_Etype (E, Universal_Integer);
3449
3450 Set_Etype (Id, Universal_Integer);
3451 Set_Ekind (Id, E_Named_Integer);
3452 Set_Is_Frozen (Id, True);
3453 return;
3454 end if;
3455
3456 Set_Is_Pure (Id, Is_Pure (Current_Scope));
3457
3458 -- Process expression, replacing error by integer zero, to avoid
3459 -- cascaded errors or aborts further along in the processing
3460
3461 -- Replace Error by integer zero, which seems least likely to cause
3462 -- cascaded errors.
3463
3464 if E = Error then
3465 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
3466 Set_Error_Posted (E);
3467 end if;
3468
3469 Analyze (E);
3470
3471 -- Verify that the expression is static and numeric. If
3472 -- the expression is overloaded, we apply the preference
3473 -- rule that favors root numeric types.
3474
3475 if not Is_Overloaded (E) then
3476 T := Etype (E);
3477 if Has_Dynamic_Predicate_Aspect (T) then
3478 Error_Msg_N
3479 ("subtype has dynamic predicate, "
3480 & "not allowed in number declaration", N);
3481 end if;
3482
3483 else
3484 T := Any_Type;
3485
3486 Get_First_Interp (E, Index, It);
3487 while Present (It.Typ) loop
3488 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ))
3489 and then (Scope (Base_Type (It.Typ))) = Standard_Standard
3490 then
3491 if T = Any_Type then
3492 T := It.Typ;
3493
3494 elsif It.Typ = Universal_Real
3495 or else
3496 It.Typ = Universal_Integer
3497 then
3498 -- Choose universal interpretation over any other
3499
3500 T := It.Typ;
3501 exit;
3502 end if;
3503 end if;
3504
3505 Get_Next_Interp (Index, It);
3506 end loop;
3507 end if;
3508
3509 if Is_Integer_Type (T) then
3510 Resolve (E, T);
3511 Set_Etype (Id, Universal_Integer);
3512 Set_Ekind (Id, E_Named_Integer);
3513
3514 elsif Is_Real_Type (T) then
3515
3516 -- Because the real value is converted to universal_real, this is a
3517 -- legal context for a universal fixed expression.
3518
3519 if T = Universal_Fixed then
3520 declare
3521 Loc : constant Source_Ptr := Sloc (N);
3522 Conv : constant Node_Id := Make_Type_Conversion (Loc,
3523 Subtype_Mark =>
3524 New_Occurrence_Of (Universal_Real, Loc),
3525 Expression => Relocate_Node (E));
3526
3527 begin
3528 Rewrite (E, Conv);
3529 Analyze (E);
3530 end;
3531
3532 elsif T = Any_Fixed then
3533 Error_Msg_N ("illegal context for mixed mode operation", E);
3534
3535 -- Expression is of the form : universal_fixed * integer. Try to
3536 -- resolve as universal_real.
3537
3538 T := Universal_Real;
3539 Set_Etype (E, T);
3540 end if;
3541
3542 Resolve (E, T);
3543 Set_Etype (Id, Universal_Real);
3544 Set_Ekind (Id, E_Named_Real);
3545
3546 else
3547 Wrong_Type (E, Any_Numeric);
3548 Resolve (E, T);
3549
3550 Set_Etype (Id, T);
3551 Set_Ekind (Id, E_Constant);
3552 Set_Never_Set_In_Source (Id, True);
3553 Set_Is_True_Constant (Id, True);
3554 return;
3555 end if;
3556
3557 if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
3558 Set_Etype (E, Etype (Id));
3559 end if;
3560
3561 if not Is_OK_Static_Expression (E) then
3562 Flag_Non_Static_Expr
3563 ("non-static expression used in number declaration!", E);
3564 Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
3565 Set_Etype (E, Any_Type);
3566 end if;
3567
3568 Analyze_Dimension (N);
3569 end Analyze_Number_Declaration;
3570
3571 --------------------------------
3572 -- Analyze_Object_Declaration --
3573 --------------------------------
3574
3575 -- WARNING: This routine manages Ghost regions. Return statements must be
3576 -- replaced by gotos which jump to the end of the routine and restore the
3577 -- Ghost mode.
3578
3579 procedure Analyze_Object_Declaration (N : Node_Id) is
3580 Loc : constant Source_Ptr := Sloc (N);
3581 Id : constant Entity_Id := Defining_Identifier (N);
3582 Act_T : Entity_Id;
3583 T : Entity_Id;
3584
3585 E : Node_Id := Expression (N);
3586 -- E is set to Expression (N) throughout this routine. When
3587 -- Expression (N) is modified, E is changed accordingly.
3588
3589 Prev_Entity : Entity_Id := Empty;
3590
3591 procedure Check_For_Null_Excluding_Components
3592 (Obj_Typ : Entity_Id;
3593 Obj_Decl : Node_Id);
3594 -- Recursively verify that each null-excluding component of an object
3595 -- declaration's type has explicit initialization, and generate
3596 -- compile-time warnings for each one that does not.
3597
3598 function Count_Tasks (T : Entity_Id) return Uint;
3599 -- This function is called when a non-generic library level object of a
3600 -- task type is declared. Its function is to count the static number of
3601 -- tasks declared within the type (it is only called if Has_Task is set
3602 -- for T). As a side effect, if an array of tasks with non-static bounds
3603 -- or a variant record type is encountered, Check_Restriction is called
3604 -- indicating the count is unknown.
3605
3606 function Delayed_Aspect_Present return Boolean;
3607 -- If the declaration has an expression that is an aggregate, and it
3608 -- has aspects that require delayed analysis, the resolution of the
3609 -- aggregate must be deferred to the freeze point of the objet. This
3610 -- special processing was created for address clauses, but it must
3611 -- also apply to Alignment. This must be done before the aspect
3612 -- specifications are analyzed because we must handle the aggregate
3613 -- before the analysis of the object declaration is complete.
3614
3615 -- Any other relevant delayed aspects on object declarations ???
3616
3617 -----------------------------------------
3618 -- Check_For_Null_Excluding_Components --
3619 -----------------------------------------
3620
3621 procedure Check_For_Null_Excluding_Components
3622 (Obj_Typ : Entity_Id;
3623 Obj_Decl : Node_Id)
3624 is
3625
3626 procedure Check_Component
3627 (Comp_Typ : Entity_Id;
3628 Comp_Decl : Node_Id := Empty);
3629 -- Perform compile-time null-exclusion checks on a given component
3630 -- and all of its subcomponents, if any.
3631
3632 ---------------------
3633 -- Check_Component --
3634 ---------------------
3635
3636 procedure Check_Component
3637 (Comp_Typ : Entity_Id;
3638 Comp_Decl : Node_Id := Empty)
3639 is
3640 Comp : Entity_Id;
3641 T : Entity_Id;
3642
3643 begin
3644 -- Return without further checking if the component has explicit
3645 -- initialization or does not come from source.
3646
3647 if Present (Comp_Decl) then
3648 if not Comes_From_Source (Comp_Decl)
3649 or else Present (Expression (Comp_Decl))
3650 then
3651 return;
3652 end if;
3653 end if;
3654
3655 if Is_Incomplete_Or_Private_Type (Comp_Typ)
3656 and then Present (Full_View (Comp_Typ))
3657 then
3658 T := Full_View (Comp_Typ);
3659 else
3660 T := Comp_Typ;
3661 end if;
3662
3663 -- Verify a component of a null-excluding access type
3664
3665 if Is_Access_Type (T)
3666 and then Can_Never_Be_Null (T)
3667 then
3668 Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl);
3669
3670 -- Check array type components
3671
3672 elsif Is_Array_Type (T) then
3673 -- There is no suitable component when the object is of an
3674 -- array type. However, a namable component may appear at some
3675 -- point during the recursive inspection, but not at the top
3676 -- level.
3677
3678 if Comp_Decl = Obj_Decl then
3679 Check_Component (Component_Type (T));
3680 else
3681 Check_Component (Component_Type (T), Comp_Decl);
3682 end if;
3683
3684 -- If T allows named components, then iterate through them,
3685 -- recursively verifying all subcomponents.
3686
3687 -- NOTE: Due to the complexities involved with checking components
3688 -- of nontrivial types with discriminants (variant records and
3689 -- the like), no static checking is performed on them. ???
3690
3691 elsif (Is_Concurrent_Type (T)
3692 or else Is_Incomplete_Or_Private_Type (T)
3693 or else Is_Record_Type (T))
3694 and then not Has_Discriminants (T)
3695 then
3696 Comp := First_Component (T);
3697 while Present (Comp) loop
3698 Check_Component (Etype (Comp), Parent (Comp));
3699
3700 Comp := Next_Component (Comp);
3701 end loop;
3702 end if;
3703 end Check_Component;
3704
3705 -- Start processing for Check_For_Null_Excluding_Components
3706
3707 begin
3708 Check_Component (Obj_Typ, Obj_Decl);
3709 end Check_For_Null_Excluding_Components;
3710
3711 -----------------
3712 -- Count_Tasks --
3713 -----------------
3714
3715 function Count_Tasks (T : Entity_Id) return Uint is
3716 C : Entity_Id;
3717 X : Node_Id;
3718 V : Uint;
3719
3720 begin
3721 if Is_Task_Type (T) then
3722 return Uint_1;
3723
3724 elsif Is_Record_Type (T) then
3725 if Has_Discriminants (T) then
3726 Check_Restriction (Max_Tasks, N);
3727 return Uint_0;
3728
3729 else
3730 V := Uint_0;
3731 C := First_Component (T);
3732 while Present (C) loop
3733 V := V + Count_Tasks (Etype (C));
3734 Next_Component (C);
3735 end loop;
3736
3737 return V;
3738 end if;
3739
3740 elsif Is_Array_Type (T) then
3741 X := First_Index (T);
3742 V := Count_Tasks (Component_Type (T));
3743 while Present (X) loop
3744 C := Etype (X);
3745
3746 if not Is_OK_Static_Subtype (C) then
3747 Check_Restriction (Max_Tasks, N);
3748 return Uint_0;
3749 else
3750 V := V * (UI_Max (Uint_0,
3751 Expr_Value (Type_High_Bound (C)) -
3752 Expr_Value (Type_Low_Bound (C)) + Uint_1));
3753 end if;
3754
3755 Next_Index (X);
3756 end loop;
3757
3758 return V;
3759
3760 else
3761 return Uint_0;
3762 end if;
3763 end Count_Tasks;
3764
3765 ----------------------------
3766 -- Delayed_Aspect_Present --
3767 ----------------------------
3768
3769 function Delayed_Aspect_Present return Boolean is
3770 A : Node_Id;
3771 A_Id : Aspect_Id;
3772
3773 begin
3774 if Present (Aspect_Specifications (N)) then
3775 A := First (Aspect_Specifications (N));
3776 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3777 while Present (A) loop
3778 if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then
3779 return True;
3780 end if;
3781
3782 Next (A);
3783 end loop;
3784 end if;
3785
3786 return False;
3787 end Delayed_Aspect_Present;
3788
3789 -- Local variables
3790
3791 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3792 -- Save the Ghost mode to restore on exit
3793
3794 Related_Id : Entity_Id;
3795
3796 -- Start of processing for Analyze_Object_Declaration
3797
3798 begin
3799 -- There are three kinds of implicit types generated by an
3800 -- object declaration:
3801
3802 -- 1. Those generated by the original Object Definition
3803
3804 -- 2. Those generated by the Expression
3805
3806 -- 3. Those used to constrain the Object Definition with the
3807 -- expression constraints when the definition is unconstrained.
3808
3809 -- They must be generated in this order to avoid order of elaboration
3810 -- issues. Thus the first step (after entering the name) is to analyze
3811 -- the object definition.
3812
3813 if Constant_Present (N) then
3814 Prev_Entity := Current_Entity_In_Scope (Id);
3815
3816 if Present (Prev_Entity)
3817 and then
3818 -- If the homograph is an implicit subprogram, it is overridden
3819 -- by the current declaration.
3820
3821 ((Is_Overloadable (Prev_Entity)
3822 and then Is_Inherited_Operation (Prev_Entity))
3823
3824 -- The current object is a discriminal generated for an entry
3825 -- family index. Even though the index is a constant, in this
3826 -- particular context there is no true constant redeclaration.
3827 -- Enter_Name will handle the visibility.
3828
3829 or else
3830 (Is_Discriminal (Id)
3831 and then Ekind (Discriminal_Link (Id)) =
3832 E_Entry_Index_Parameter)
3833
3834 -- The current object is the renaming for a generic declared
3835 -- within the instance.
3836
3837 or else
3838 (Ekind (Prev_Entity) = E_Package
3839 and then Nkind (Parent (Prev_Entity)) =
3840 N_Package_Renaming_Declaration
3841 and then not Comes_From_Source (Prev_Entity)
3842 and then
3843 Is_Generic_Instance (Renamed_Entity (Prev_Entity)))
3844
3845 -- The entity may be a homonym of a private component of the
3846 -- enclosing protected object, for which we create a local
3847 -- renaming declaration. The declaration is legal, even if
3848 -- useless when it just captures that component.
3849
3850 or else
3851 (Ekind (Scope (Current_Scope)) = E_Protected_Type
3852 and then Nkind (Parent (Prev_Entity)) =
3853 N_Object_Renaming_Declaration))
3854 then
3855 Prev_Entity := Empty;
3856 end if;
3857 end if;
3858
3859 if Present (Prev_Entity) then
3860
3861 -- The object declaration is Ghost when it completes a deferred Ghost
3862 -- constant.
3863
3864 Mark_And_Set_Ghost_Completion (N, Prev_Entity);
3865
3866 Constant_Redeclaration (Id, N, T);
3867
3868 Generate_Reference (Prev_Entity, Id, 'c');
3869 Set_Completion_Referenced (Id);
3870
3871 if Error_Posted (N) then
3872
3873 -- Type mismatch or illegal redeclaration; do not analyze
3874 -- expression to avoid cascaded errors.
3875
3876 T := Find_Type_Of_Object (Object_Definition (N), N);
3877 Set_Etype (Id, T);
3878 Set_Ekind (Id, E_Variable);
3879 goto Leave;
3880 end if;
3881
3882 -- In the normal case, enter identifier at the start to catch premature
3883 -- usage in the initialization expression.
3884
3885 else
3886 Generate_Definition (Id);
3887 Enter_Name (Id);
3888
3889 Mark_Coextensions (N, Object_Definition (N));
3890
3891 T := Find_Type_Of_Object (Object_Definition (N), N);
3892
3893 if Nkind (Object_Definition (N)) = N_Access_Definition
3894 and then Present
3895 (Access_To_Subprogram_Definition (Object_Definition (N)))
3896 and then Protected_Present
3897 (Access_To_Subprogram_Definition (Object_Definition (N)))
3898 then
3899 T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
3900 end if;
3901
3902 if Error_Posted (Id) then
3903 Set_Etype (Id, T);
3904 Set_Ekind (Id, E_Variable);
3905 goto Leave;
3906 end if;
3907 end if;
3908
3909 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
3910 -- out some static checks.
3911
3912 if Ada_Version >= Ada_2005 then
3913 -- In case of aggregates we must also take care of the correct
3914 -- initialization of nested aggregates bug this is done at the
3915 -- point of the analysis of the aggregate (see sem_aggr.adb) ???
3916
3917 if Can_Never_Be_Null (T) then
3918
3919 if Present (Expression (N))
3920 and then Nkind (Expression (N)) = N_Aggregate
3921 then
3922 null;
3923
3924 else
3925 declare
3926 Save_Typ : constant Entity_Id := Etype (Id);
3927 begin
3928 Set_Etype (Id, T); -- Temp. decoration for static checks
3929 Null_Exclusion_Static_Checks (N);
3930 Set_Etype (Id, Save_Typ);
3931 end;
3932 end if;
3933
3934 -- We might be dealing with an object of a composite type containing
3935 -- null-excluding components without an aggregate, so we must verify
3936 -- that such components have default initialization.
3937
3938 else
3939 Check_For_Null_Excluding_Components (T, N);
3940 end if;
3941 end if;
3942
3943 -- Object is marked pure if it is in a pure scope
3944
3945 Set_Is_Pure (Id, Is_Pure (Current_Scope));
3946
3947 -- If deferred constant, make sure context is appropriate. We detect
3948 -- a deferred constant as a constant declaration with no expression.
3949 -- A deferred constant can appear in a package body if its completion
3950 -- is by means of an interface pragma.
3951
3952 if Constant_Present (N) and then No (E) then
3953
3954 -- A deferred constant may appear in the declarative part of the
3955 -- following constructs:
3956
3957 -- blocks
3958 -- entry bodies
3959 -- extended return statements
3960 -- package specs
3961 -- package bodies
3962 -- subprogram bodies
3963 -- task bodies
3964
3965 -- When declared inside a package spec, a deferred constant must be
3966 -- completed by a full constant declaration or pragma Import. In all
3967 -- other cases, the only proper completion is pragma Import. Extended
3968 -- return statements are flagged as invalid contexts because they do
3969 -- not have a declarative part and so cannot accommodate the pragma.
3970
3971 if Ekind (Current_Scope) = E_Return_Statement then
3972 Error_Msg_N
3973 ("invalid context for deferred constant declaration (RM 7.4)",
3974 N);
3975 Error_Msg_N
3976 ("\declaration requires an initialization expression",
3977 N);
3978 Set_Constant_Present (N, False);
3979
3980 -- In Ada 83, deferred constant must be of private type
3981
3982 elsif not Is_Private_Type (T) then
3983 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3984 Error_Msg_N
3985 ("(Ada 83) deferred constant must be private type", N);
3986 end if;
3987 end if;
3988
3989 -- If not a deferred constant, then the object declaration freezes
3990 -- its type, unless the object is of an anonymous type and has delayed
3991 -- aspects. In that case the type is frozen when the object itself is.
3992
3993 else
3994 Check_Fully_Declared (T, N);
3995
3996 if Has_Delayed_Aspects (Id)
3997 and then Is_Array_Type (T)
3998 and then Is_Itype (T)
3999 then
4000 Set_Has_Delayed_Freeze (T);
4001 else
4002 Freeze_Before (N, T);
4003 end if;
4004 end if;
4005
4006 -- If the object was created by a constrained array definition, then
4007 -- set the link in both the anonymous base type and anonymous subtype
4008 -- that are built to represent the array type to point to the object.
4009
4010 if Nkind (Object_Definition (Declaration_Node (Id))) =
4011 N_Constrained_Array_Definition
4012 then
4013 Set_Related_Array_Object (T, Id);
4014 Set_Related_Array_Object (Base_Type (T), Id);
4015 end if;
4016
4017 -- Special checks for protected objects not at library level
4018
4019 if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
4020 Check_Restriction (No_Local_Protected_Objects, Id);
4021
4022 -- Protected objects with interrupt handlers must be at library level
4023
4024 -- Ada 2005: This test is not needed (and the corresponding clause
4025 -- in the RM is removed) because accessibility checks are sufficient
4026 -- to make handlers not at the library level illegal.
4027
4028 -- AI05-0303: The AI is in fact a binding interpretation, and thus
4029 -- applies to the '95 version of the language as well.
4030
4031 if Is_Protected_Type (T)
4032 and then Has_Interrupt_Handler (T)
4033 and then Ada_Version < Ada_95
4034 then
4035 Error_Msg_N
4036 ("interrupt object can only be declared at library level", Id);
4037 end if;
4038 end if;
4039
4040 -- Check for violation of No_Local_Timing_Events
4041
4042 if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then
4043 Check_Restriction (No_Local_Timing_Events, Id);
4044 end if;
4045
4046 -- The actual subtype of the object is the nominal subtype, unless
4047 -- the nominal one is unconstrained and obtained from the expression.
4048
4049 Act_T := T;
4050
4051 -- These checks should be performed before the initialization expression
4052 -- is considered, so that the Object_Definition node is still the same
4053 -- as in source code.
4054
4055 -- In SPARK, the nominal subtype is always given by a subtype mark
4056 -- and must not be unconstrained. (The only exception to this is the
4057 -- acceptance of declarations of constants of type String.)
4058
4059 if not Nkind_In (Object_Definition (N), N_Expanded_Name, N_Identifier)
4060 then
4061 Check_SPARK_05_Restriction
4062 ("subtype mark required", Object_Definition (N));
4063
4064 elsif Is_Array_Type (T)
4065 and then not Is_Constrained (T)
4066 and then T /= Standard_String
4067 then
4068 Check_SPARK_05_Restriction
4069 ("subtype mark of constrained type expected",
4070 Object_Definition (N));
4071 end if;
4072
4073 -- There are no aliased objects in SPARK
4074
4075 if Aliased_Present (N) then
4076 Check_SPARK_05_Restriction ("aliased object is not allowed", N);
4077 end if;
4078
4079 -- Process initialization expression if present and not in error
4080
4081 if Present (E) and then E /= Error then
4082
4083 -- Generate an error in case of CPP class-wide object initialization.
4084 -- Required because otherwise the expansion of the class-wide
4085 -- assignment would try to use 'size to initialize the object
4086 -- (primitive that is not available in CPP tagged types).
4087
4088 if Is_Class_Wide_Type (Act_T)
4089 and then
4090 (Is_CPP_Class (Root_Type (Etype (Act_T)))
4091 or else
4092 (Present (Full_View (Root_Type (Etype (Act_T))))
4093 and then
4094 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
4095 then
4096 Error_Msg_N
4097 ("predefined assignment not available for 'C'P'P tagged types",
4098 E);
4099 end if;
4100
4101 Mark_Coextensions (N, E);
4102 Analyze (E);
4103
4104 -- In case of errors detected in the analysis of the expression,
4105 -- decorate it with the expected type to avoid cascaded errors
4106
4107 if No (Etype (E)) then
4108 Set_Etype (E, T);
4109 end if;
4110
4111 -- If an initialization expression is present, then we set the
4112 -- Is_True_Constant flag. It will be reset if this is a variable
4113 -- and it is indeed modified.
4114
4115 Set_Is_True_Constant (Id, True);
4116
4117 -- If we are analyzing a constant declaration, set its completion
4118 -- flag after analyzing and resolving the expression.
4119
4120 if Constant_Present (N) then
4121 Set_Has_Completion (Id);
4122 end if;
4123
4124 -- Set type and resolve (type may be overridden later on). Note:
4125 -- Ekind (Id) must still be E_Void at this point so that incorrect
4126 -- early usage within E is properly diagnosed.
4127
4128 Set_Etype (Id, T);
4129
4130 -- If the expression is an aggregate we must look ahead to detect
4131 -- the possible presence of an address clause, and defer resolution
4132 -- and expansion of the aggregate to the freeze point of the entity.
4133
4134 -- This is not always legal because the aggregate may contain other
4135 -- references that need freezing, e.g. references to other entities
4136 -- with address clauses. In any case, when compiling with -gnatI the
4137 -- presence of the address clause must be ignored.
4138
4139 if Comes_From_Source (N)
4140 and then Expander_Active
4141 and then Nkind (E) = N_Aggregate
4142 and then
4143 ((Present (Following_Address_Clause (N))
4144 and then not Ignore_Rep_Clauses)
4145 or else Delayed_Aspect_Present)
4146 then
4147 Set_Etype (E, T);
4148
4149 else
4150 Resolve (E, T);
4151 end if;
4152
4153 -- No further action needed if E is a call to an inlined function
4154 -- which returns an unconstrained type and it has been expanded into
4155 -- a procedure call. In that case N has been replaced by an object
4156 -- declaration without initializing expression and it has been
4157 -- analyzed (see Expand_Inlined_Call).
4158
4159 if Back_End_Inlining
4160 and then Expander_Active
4161 and then Nkind (E) = N_Function_Call
4162 and then Nkind (Name (E)) in N_Has_Entity
4163 and then Is_Inlined (Entity (Name (E)))
4164 and then not Is_Constrained (Etype (E))
4165 and then Analyzed (N)
4166 and then No (Expression (N))
4167 then
4168 goto Leave;
4169 end if;
4170
4171 -- If E is null and has been replaced by an N_Raise_Constraint_Error
4172 -- node (which was marked already-analyzed), we need to set the type
4173 -- to something other than Any_Access in order to keep gigi happy.
4174
4175 if Etype (E) = Any_Access then
4176 Set_Etype (E, T);
4177 end if;
4178
4179 -- If the object is an access to variable, the initialization
4180 -- expression cannot be an access to constant.
4181
4182 if Is_Access_Type (T)
4183 and then not Is_Access_Constant (T)
4184 and then Is_Access_Type (Etype (E))
4185 and then Is_Access_Constant (Etype (E))
4186 then
4187 Error_Msg_N
4188 ("access to variable cannot be initialized with an "
4189 & "access-to-constant expression", E);
4190 end if;
4191
4192 if not Assignment_OK (N) then
4193 Check_Initialization (T, E);
4194 end if;
4195
4196 Check_Unset_Reference (E);
4197
4198 -- If this is a variable, then set current value. If this is a
4199 -- declared constant of a scalar type with a static expression,
4200 -- indicate that it is always valid.
4201
4202 if not Constant_Present (N) then
4203 if Compile_Time_Known_Value (E) then
4204 Set_Current_Value (Id, E);
4205 end if;
4206
4207 elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then
4208 Set_Is_Known_Valid (Id);
4209 end if;
4210
4211 -- Deal with setting of null flags
4212
4213 if Is_Access_Type (T) then
4214 if Known_Non_Null (E) then
4215 Set_Is_Known_Non_Null (Id, True);
4216 elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then
4217 Set_Is_Known_Null (Id, True);
4218 end if;
4219 end if;
4220
4221 -- Check incorrect use of dynamically tagged expressions
4222
4223 if Is_Tagged_Type (T) then
4224 Check_Dynamically_Tagged_Expression
4225 (Expr => E,
4226 Typ => T,
4227 Related_Nod => N);
4228 end if;
4229
4230 Apply_Scalar_Range_Check (E, T);
4231 Apply_Static_Length_Check (E, T);
4232
4233 if Nkind (Original_Node (N)) = N_Object_Declaration
4234 and then Comes_From_Source (Original_Node (N))
4235
4236 -- Only call test if needed
4237
4238 and then Restriction_Check_Required (SPARK_05)
4239 and then not Is_SPARK_05_Initialization_Expr (Original_Node (E))
4240 then
4241 Check_SPARK_05_Restriction
4242 ("initialization expression is not appropriate", E);
4243 end if;
4244
4245 -- A formal parameter of a specific tagged type whose related
4246 -- subprogram is subject to pragma Extensions_Visible with value
4247 -- "False" cannot be implicitly converted to a class-wide type by
4248 -- means of an initialization expression (SPARK RM 6.1.7(3)). Do
4249 -- not consider internally generated expressions.
4250
4251 if Is_Class_Wide_Type (T)
4252 and then Comes_From_Source (E)
4253 and then Is_EVF_Expression (E)
4254 then
4255 Error_Msg_N
4256 ("formal parameter cannot be implicitly converted to "
4257 & "class-wide type when Extensions_Visible is False", E);
4258 end if;
4259 end if;
4260
4261 -- If the No_Streams restriction is set, check that the type of the
4262 -- object is not, and does not contain, any subtype derived from
4263 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
4264 -- Has_Stream just for efficiency reasons. There is no point in
4265 -- spending time on a Has_Stream check if the restriction is not set.
4266
4267 if Restriction_Check_Required (No_Streams) then
4268 if Has_Stream (T) then
4269 Check_Restriction (No_Streams, N);
4270 end if;
4271 end if;
4272
4273 -- Deal with predicate check before we start to do major rewriting. It
4274 -- is OK to initialize and then check the initialized value, since the
4275 -- object goes out of scope if we get a predicate failure. Note that we
4276 -- do this in the analyzer and not the expander because the analyzer
4277 -- does some substantial rewriting in some cases.
4278
4279 -- We need a predicate check if the type has predicates that are not
4280 -- ignored, and if either there is an initializing expression, or for
4281 -- default initialization when we have at least one case of an explicit
4282 -- default initial value and then this is not an internal declaration
4283 -- whose initialization comes later (as for an aggregate expansion).
4284
4285 if not Suppress_Assignment_Checks (N)
4286 and then Present (Predicate_Function (T))
4287 and then not Predicates_Ignored (T)
4288 and then not No_Initialization (N)
4289 and then
4290 (Present (E)
4291 or else
4292 Is_Partially_Initialized_Type (T, Include_Implicit => False))
4293 then
4294 -- If the type has a static predicate and the expression is known at
4295 -- compile time, see if the expression satisfies the predicate.
4296
4297 if Present (E) then
4298 Check_Expression_Against_Static_Predicate (E, T);
4299 end if;
4300
4301 -- If the type is a null record and there is no explicit initial
4302 -- expression, no predicate check applies.
4303
4304 if No (E) and then Is_Null_Record_Type (T) then
4305 null;
4306
4307 -- Do not generate a predicate check if the initialization expression
4308 -- is a type conversion because the conversion has been subjected to
4309 -- the same check. This is a small optimization which avoid redundant
4310 -- checks.
4311
4312 elsif Present (E) and then Nkind (E) = N_Type_Conversion then
4313 null;
4314
4315 else
4316 Insert_After (N,
4317 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
4318 end if;
4319 end if;
4320
4321 -- Case of unconstrained type
4322
4323 if not Is_Definite_Subtype (T) then
4324
4325 -- In SPARK, a declaration of unconstrained type is allowed
4326 -- only for constants of type string.
4327
4328 if Is_String_Type (T) and then not Constant_Present (N) then
4329 Check_SPARK_05_Restriction
4330 ("declaration of object of unconstrained type not allowed", N);
4331 end if;
4332
4333 -- Nothing to do in deferred constant case
4334
4335 if Constant_Present (N) and then No (E) then
4336 null;
4337
4338 -- Case of no initialization present
4339
4340 elsif No (E) then
4341 if No_Initialization (N) then
4342 null;
4343
4344 elsif Is_Class_Wide_Type (T) then
4345 Error_Msg_N
4346 ("initialization required in class-wide declaration ", N);
4347
4348 else
4349 Error_Msg_N
4350 ("unconstrained subtype not allowed (need initialization)",
4351 Object_Definition (N));
4352
4353 if Is_Record_Type (T) and then Has_Discriminants (T) then
4354 Error_Msg_N
4355 ("\provide initial value or explicit discriminant values",
4356 Object_Definition (N));
4357
4358 Error_Msg_NE
4359 ("\or give default discriminant values for type&",
4360 Object_Definition (N), T);
4361
4362 elsif Is_Array_Type (T) then
4363 Error_Msg_N
4364 ("\provide initial value or explicit array bounds",
4365 Object_Definition (N));
4366 end if;
4367 end if;
4368
4369 -- Case of initialization present but in error. Set initial
4370 -- expression as absent (but do not make above complaints)
4371
4372 elsif E = Error then
4373 Set_Expression (N, Empty);
4374 E := Empty;
4375
4376 -- Case of initialization present
4377
4378 else
4379 -- Check restrictions in Ada 83
4380
4381 if not Constant_Present (N) then
4382
4383 -- Unconstrained variables not allowed in Ada 83 mode
4384
4385 if Ada_Version = Ada_83
4386 and then Comes_From_Source (Object_Definition (N))
4387 then
4388 Error_Msg_N
4389 ("(Ada 83) unconstrained variable not allowed",
4390 Object_Definition (N));
4391 end if;
4392 end if;
4393
4394 -- Now we constrain the variable from the initializing expression
4395
4396 -- If the expression is an aggregate, it has been expanded into
4397 -- individual assignments. Retrieve the actual type from the
4398 -- expanded construct.
4399
4400 if Is_Array_Type (T)
4401 and then No_Initialization (N)
4402 and then Nkind (Original_Node (E)) = N_Aggregate
4403 then
4404 Act_T := Etype (E);
4405
4406 -- In case of class-wide interface object declarations we delay
4407 -- the generation of the equivalent record type declarations until
4408 -- its expansion because there are cases in they are not required.
4409
4410 elsif Is_Interface (T) then
4411 null;
4412
4413 -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus,
4414 -- we should prevent the generation of another Itype with the
4415 -- same name as the one already generated, or we end up with
4416 -- two identical types in GNATprove.
4417
4418 elsif GNATprove_Mode then
4419 null;
4420
4421 -- If the type is an unchecked union, no subtype can be built from
4422 -- the expression. Rewrite declaration as a renaming, which the
4423 -- back-end can handle properly. This is a rather unusual case,
4424 -- because most unchecked_union declarations have default values
4425 -- for discriminants and are thus not indefinite.
4426
4427 elsif Is_Unchecked_Union (T) then
4428 if Constant_Present (N) or else Nkind (E) = N_Function_Call then
4429 Set_Ekind (Id, E_Constant);
4430 else
4431 Set_Ekind (Id, E_Variable);
4432 end if;
4433
4434 Rewrite (N,
4435 Make_Object_Renaming_Declaration (Loc,
4436 Defining_Identifier => Id,
4437 Subtype_Mark => New_Occurrence_Of (T, Loc),
4438 Name => E));
4439
4440 Set_Renamed_Object (Id, E);
4441 Freeze_Before (N, T);
4442 Set_Is_Frozen (Id);
4443 goto Leave;
4444
4445 else
4446 -- Ensure that the generated subtype has a unique external name
4447 -- when the related object is public. This guarantees that the
4448 -- subtype and its bounds will not be affected by switches or
4449 -- pragmas that may offset the internal counter due to extra
4450 -- generated code.
4451
4452 if Is_Public (Id) then
4453 Related_Id := Id;
4454 else
4455 Related_Id := Empty;
4456 end if;
4457
4458 Expand_Subtype_From_Expr
4459 (N => N,
4460 Unc_Type => T,
4461 Subtype_Indic => Object_Definition (N),
4462 Exp => E,
4463 Related_Id => Related_Id);
4464
4465 Act_T := Find_Type_Of_Object (Object_Definition (N), N);
4466 end if;
4467
4468 Set_Is_Constr_Subt_For_U_Nominal (Act_T);
4469
4470 if Aliased_Present (N) then
4471 Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
4472 end if;
4473
4474 Freeze_Before (N, Act_T);
4475 Freeze_Before (N, T);
4476 end if;
4477
4478 elsif Is_Array_Type (T)
4479 and then No_Initialization (N)
4480 and then (Nkind (Original_Node (E)) = N_Aggregate
4481 or else (Nkind (Original_Node (E)) = N_Qualified_Expression
4482 and then Nkind (Original_Node (Expression
4483 (Original_Node (E)))) = N_Aggregate))
4484 then
4485 if not Is_Entity_Name (Object_Definition (N)) then
4486 Act_T := Etype (E);
4487 Check_Compile_Time_Size (Act_T);
4488
4489 if Aliased_Present (N) then
4490 Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
4491 end if;
4492 end if;
4493
4494 -- When the given object definition and the aggregate are specified
4495 -- independently, and their lengths might differ do a length check.
4496 -- This cannot happen if the aggregate is of the form (others =>...)
4497
4498 if not Is_Constrained (T) then
4499 null;
4500
4501 elsif Nkind (E) = N_Raise_Constraint_Error then
4502
4503 -- Aggregate is statically illegal. Place back in declaration
4504
4505 Set_Expression (N, E);
4506 Set_No_Initialization (N, False);
4507
4508 elsif T = Etype (E) then
4509 null;
4510
4511 elsif Nkind (E) = N_Aggregate
4512 and then Present (Component_Associations (E))
4513 and then Present (Choice_List (First (Component_Associations (E))))
4514 and then
4515 Nkind (First (Choice_List (First (Component_Associations (E))))) =
4516 N_Others_Choice
4517 then
4518 null;
4519
4520 else
4521 Apply_Length_Check (E, T);
4522 end if;
4523
4524 -- If the type is limited unconstrained with defaulted discriminants and
4525 -- there is no expression, then the object is constrained by the
4526 -- defaults, so it is worthwhile building the corresponding subtype.
4527
4528 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
4529 and then not Is_Constrained (T)
4530 and then Has_Discriminants (T)
4531 then
4532 if No (E) then
4533 Act_T := Build_Default_Subtype (T, N);
4534 else
4535 -- Ada 2005: A limited object may be initialized by means of an
4536 -- aggregate. If the type has default discriminants it has an
4537 -- unconstrained nominal type, Its actual subtype will be obtained
4538 -- from the aggregate, and not from the default discriminants.
4539
4540 Act_T := Etype (E);
4541 end if;
4542
4543 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
4544
4545 elsif Nkind (E) = N_Function_Call
4546 and then Constant_Present (N)
4547 and then Has_Unconstrained_Elements (Etype (E))
4548 then
4549 -- The back-end has problems with constants of a discriminated type
4550 -- with defaults, if the initial value is a function call. We
4551 -- generate an intermediate temporary that will receive a reference
4552 -- to the result of the call. The initialization expression then
4553 -- becomes a dereference of that temporary.
4554
4555 Remove_Side_Effects (E);
4556
4557 -- If this is a constant declaration of an unconstrained type and
4558 -- the initialization is an aggregate, we can use the subtype of the
4559 -- aggregate for the declared entity because it is immutable.
4560
4561 elsif not Is_Constrained (T)
4562 and then Has_Discriminants (T)
4563 and then Constant_Present (N)
4564 and then not Has_Unchecked_Union (T)
4565 and then Nkind (E) = N_Aggregate
4566 then
4567 Act_T := Etype (E);
4568 end if;
4569
4570 -- Check No_Wide_Characters restriction
4571
4572 Check_Wide_Character_Restriction (T, Object_Definition (N));
4573
4574 -- Indicate this is not set in source. Certainly true for constants, and
4575 -- true for variables so far (will be reset for a variable if and when
4576 -- we encounter a modification in the source).
4577
4578 Set_Never_Set_In_Source (Id);
4579
4580 -- Now establish the proper kind and type of the object
4581
4582 if Constant_Present (N) then
4583 Set_Ekind (Id, E_Constant);
4584 Set_Is_True_Constant (Id);
4585
4586 else
4587 Set_Ekind (Id, E_Variable);
4588
4589 -- A variable is set as shared passive if it appears in a shared
4590 -- passive package, and is at the outer level. This is not done for
4591 -- entities generated during expansion, because those are always
4592 -- manipulated locally.
4593
4594 if Is_Shared_Passive (Current_Scope)
4595 and then Is_Library_Level_Entity (Id)
4596 and then Comes_From_Source (Id)
4597 then
4598 Set_Is_Shared_Passive (Id);
4599 Check_Shared_Var (Id, T, N);
4600 end if;
4601
4602 -- Set Has_Initial_Value if initializing expression present. Note
4603 -- that if there is no initializing expression, we leave the state
4604 -- of this flag unchanged (usually it will be False, but notably in
4605 -- the case of exception choice variables, it will already be true).
4606
4607 if Present (E) then
4608 Set_Has_Initial_Value (Id);
4609 end if;
4610 end if;
4611
4612 -- Initialize alignment and size and capture alignment setting
4613
4614 Init_Alignment (Id);
4615 Init_Esize (Id);
4616 Set_Optimize_Alignment_Flags (Id);
4617
4618 -- Deal with aliased case
4619
4620 if Aliased_Present (N) then
4621 Set_Is_Aliased (Id);
4622
4623 -- If the object is aliased and the type is unconstrained with
4624 -- defaulted discriminants and there is no expression, then the
4625 -- object is constrained by the defaults, so it is worthwhile
4626 -- building the corresponding subtype.
4627
4628 -- Ada 2005 (AI-363): If the aliased object is discriminated and
4629 -- unconstrained, then only establish an actual subtype if the
4630 -- nominal subtype is indefinite. In definite cases the object is
4631 -- unconstrained in Ada 2005.
4632
4633 if No (E)
4634 and then Is_Record_Type (T)
4635 and then not Is_Constrained (T)
4636 and then Has_Discriminants (T)
4637 and then (Ada_Version < Ada_2005
4638 or else not Is_Definite_Subtype (T))
4639 then
4640 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
4641 end if;
4642 end if;
4643
4644 -- Now we can set the type of the object
4645
4646 Set_Etype (Id, Act_T);
4647
4648 -- Non-constant object is marked to be treated as volatile if type is
4649 -- volatile and we clear the Current_Value setting that may have been
4650 -- set above. Doing so for constants isn't required and might interfere
4651 -- with possible uses of the object as a static expression in contexts
4652 -- incompatible with volatility (e.g. as a case-statement alternative).
4653
4654 if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then
4655 Set_Treat_As_Volatile (Id);
4656 Set_Current_Value (Id, Empty);
4657 end if;
4658
4659 -- Deal with controlled types
4660
4661 if Has_Controlled_Component (Etype (Id))
4662 or else Is_Controlled (Etype (Id))
4663 then
4664 if not Is_Library_Level_Entity (Id) then
4665 Check_Restriction (No_Nested_Finalization, N);
4666 else
4667 Validate_Controlled_Object (Id);
4668 end if;
4669 end if;
4670
4671 if Has_Task (Etype (Id)) then
4672 Check_Restriction (No_Tasking, N);
4673
4674 -- Deal with counting max tasks
4675
4676 -- Nothing to do if inside a generic
4677
4678 if Inside_A_Generic then
4679 null;
4680
4681 -- If library level entity, then count tasks
4682
4683 elsif Is_Library_Level_Entity (Id) then
4684 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
4685
4686 -- If not library level entity, then indicate we don't know max
4687 -- tasks and also check task hierarchy restriction and blocking
4688 -- operation (since starting a task is definitely blocking).
4689
4690 else
4691 Check_Restriction (Max_Tasks, N);
4692 Check_Restriction (No_Task_Hierarchy, N);
4693 Check_Potentially_Blocking_Operation (N);
4694 end if;
4695
4696 -- A rather specialized test. If we see two tasks being declared
4697 -- of the same type in the same object declaration, and the task
4698 -- has an entry with an address clause, we know that program error
4699 -- will be raised at run time since we can't have two tasks with
4700 -- entries at the same address.
4701
4702 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
4703 declare
4704 E : Entity_Id;
4705
4706 begin
4707 E := First_Entity (Etype (Id));
4708 while Present (E) loop
4709 if Ekind (E) = E_Entry
4710 and then Present (Get_Attribute_Definition_Clause
4711 (E, Attribute_Address))
4712 then
4713 Error_Msg_Warn := SPARK_Mode /= On;
4714 Error_Msg_N
4715 ("more than one task with same entry address<<", N);
4716 Error_Msg_N ("\Program_Error [<<", N);
4717 Insert_Action (N,
4718 Make_Raise_Program_Error (Loc,
4719 Reason => PE_Duplicated_Entry_Address));
4720 exit;
4721 end if;
4722
4723 Next_Entity (E);
4724 end loop;
4725 end;
4726 end if;
4727 end if;
4728
4729 -- Some simple constant-propagation: if the expression is a constant
4730 -- string initialized with a literal, share the literal. This avoids
4731 -- a run-time copy.
4732
4733 if Present (E)
4734 and then Is_Entity_Name (E)
4735 and then Ekind (Entity (E)) = E_Constant
4736 and then Base_Type (Etype (E)) = Standard_String
4737 then
4738 declare
4739 Val : constant Node_Id := Constant_Value (Entity (E));
4740 begin
4741 if Present (Val) and then Nkind (Val) = N_String_Literal then
4742 Rewrite (E, New_Copy (Val));
4743 end if;
4744 end;
4745 end if;
4746
4747 -- Another optimization: if the nominal subtype is unconstrained and
4748 -- the expression is a function call that returns an unconstrained
4749 -- type, rewrite the declaration as a renaming of the result of the
4750 -- call. The exceptions below are cases where the copy is expected,
4751 -- either by the back end (Aliased case) or by the semantics, as for
4752 -- initializing controlled types or copying tags for class-wide types.
4753
4754 if Present (E)
4755 and then Nkind (E) = N_Explicit_Dereference
4756 and then Nkind (Original_Node (E)) = N_Function_Call
4757 and then not Is_Library_Level_Entity (Id)
4758 and then not Is_Constrained (Underlying_Type (T))
4759 and then not Is_Aliased (Id)
4760 and then not Is_Class_Wide_Type (T)
4761 and then not Is_Controlled_Active (T)
4762 and then not Has_Controlled_Component (Base_Type (T))
4763 and then Expander_Active
4764 then
4765 Rewrite (N,
4766 Make_Object_Renaming_Declaration (Loc,
4767 Defining_Identifier => Id,
4768 Access_Definition => Empty,
4769 Subtype_Mark => New_Occurrence_Of
4770 (Base_Type (Etype (Id)), Loc),
4771 Name => E));
4772
4773 Set_Renamed_Object (Id, E);
4774
4775 -- Force generation of debugging information for the constant and for
4776 -- the renamed function call.
4777
4778 Set_Debug_Info_Needed (Id);
4779 Set_Debug_Info_Needed (Entity (Prefix (E)));
4780 end if;
4781
4782 if Present (Prev_Entity)
4783 and then Is_Frozen (Prev_Entity)
4784 and then not Error_Posted (Id)
4785 then
4786 Error_Msg_N ("full constant declaration appears too late", N);
4787 end if;
4788
4789 Check_Eliminated (Id);
4790
4791 -- Deal with setting In_Private_Part flag if in private part
4792
4793 if Ekind (Scope (Id)) = E_Package
4794 and then In_Private_Part (Scope (Id))
4795 then
4796 Set_In_Private_Part (Id);
4797 end if;
4798
4799 <<Leave>>
4800 -- Initialize the refined state of a variable here because this is a
4801 -- common destination for legal and illegal object declarations.
4802
4803 if Ekind (Id) = E_Variable then
4804 Set_Encapsulating_State (Id, Empty);
4805 end if;
4806
4807 if Has_Aspects (N) then
4808 Analyze_Aspect_Specifications (N, Id);
4809 end if;
4810
4811 Analyze_Dimension (N);
4812
4813 -- Verify whether the object declaration introduces an illegal hidden
4814 -- state within a package subject to a null abstract state.
4815
4816 if Ekind (Id) = E_Variable then
4817 Check_No_Hidden_State (Id);
4818 end if;
4819
4820 Restore_Ghost_Mode (Saved_GM);
4821 end Analyze_Object_Declaration;
4822
4823 ---------------------------
4824 -- Analyze_Others_Choice --
4825 ---------------------------
4826
4827 -- Nothing to do for the others choice node itself, the semantic analysis
4828 -- of the others choice will occur as part of the processing of the parent
4829
4830 procedure Analyze_Others_Choice (N : Node_Id) is
4831 pragma Warnings (Off, N);
4832 begin
4833 null;
4834 end Analyze_Others_Choice;
4835
4836 -------------------------------------------
4837 -- Analyze_Private_Extension_Declaration --
4838 -------------------------------------------
4839
4840 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
4841 Indic : constant Node_Id := Subtype_Indication (N);
4842 T : constant Entity_Id := Defining_Identifier (N);
4843 Iface : Entity_Id;
4844 Iface_Elmt : Elmt_Id;
4845 Parent_Base : Entity_Id;
4846 Parent_Type : Entity_Id;
4847
4848 begin
4849 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
4850
4851 if Is_Non_Empty_List (Interface_List (N)) then
4852 declare
4853 Intf : Node_Id;
4854 T : Entity_Id;
4855
4856 begin
4857 Intf := First (Interface_List (N));
4858 while Present (Intf) loop
4859 T := Find_Type_Of_Subtype_Indic (Intf);
4860
4861 Diagnose_Interface (Intf, T);
4862 Next (Intf);
4863 end loop;
4864 end;
4865 end if;
4866
4867 Generate_Definition (T);
4868
4869 -- For other than Ada 2012, just enter the name in the current scope
4870
4871 if Ada_Version < Ada_2012 then
4872 Enter_Name (T);
4873
4874 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling
4875 -- case of private type that completes an incomplete type.
4876
4877 else
4878 declare
4879 Prev : Entity_Id;
4880
4881 begin
4882 Prev := Find_Type_Name (N);
4883
4884 pragma Assert (Prev = T
4885 or else (Ekind (Prev) = E_Incomplete_Type
4886 and then Present (Full_View (Prev))
4887 and then Full_View (Prev) = T));
4888 end;
4889 end if;
4890
4891 Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
4892 Parent_Base := Base_Type (Parent_Type);
4893
4894 if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then
4895 Set_Ekind (T, Ekind (Parent_Type));
4896 Set_Etype (T, Any_Type);
4897 goto Leave;
4898
4899 elsif not Is_Tagged_Type (Parent_Type) then
4900 Error_Msg_N
4901 ("parent of type extension must be a tagged type ", Indic);
4902 goto Leave;
4903
4904 elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
4905 Error_Msg_N ("premature derivation of incomplete type", Indic);
4906 goto Leave;
4907
4908 elsif Is_Concurrent_Type (Parent_Type) then
4909 Error_Msg_N
4910 ("parent type of a private extension cannot be a synchronized "
4911 & "tagged type (RM 3.9.1 (3/1))", N);
4912
4913 Set_Etype (T, Any_Type);
4914 Set_Ekind (T, E_Limited_Private_Type);
4915 Set_Private_Dependents (T, New_Elmt_List);
4916 Set_Error_Posted (T);
4917 goto Leave;
4918 end if;
4919
4920 -- Perhaps the parent type should be changed to the class-wide type's
4921 -- specific type in this case to prevent cascading errors ???
4922
4923 if Is_Class_Wide_Type (Parent_Type) then
4924 Error_Msg_N
4925 ("parent of type extension must not be a class-wide type", Indic);
4926 goto Leave;
4927 end if;
4928
4929 if (not Is_Package_Or_Generic_Package (Current_Scope)
4930 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
4931 or else In_Private_Part (Current_Scope)
4932 then
4933 Error_Msg_N ("invalid context for private extension", N);
4934 end if;
4935
4936 -- Set common attributes
4937
4938 Set_Is_Pure (T, Is_Pure (Current_Scope));
4939 Set_Scope (T, Current_Scope);
4940 Set_Ekind (T, E_Record_Type_With_Private);
4941 Init_Size_Align (T);
4942 Set_Default_SSO (T);
4943
4944 Set_Etype (T, Parent_Base);
4945 Propagate_Concurrent_Flags (T, Parent_Base);
4946
4947 Set_Convention (T, Convention (Parent_Type));
4948 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
4949 Set_Is_First_Subtype (T);
4950 Make_Class_Wide_Type (T);
4951
4952 if Unknown_Discriminants_Present (N) then
4953 Set_Discriminant_Constraint (T, No_Elist);
4954 end if;
4955
4956 Build_Derived_Record_Type (N, Parent_Type, T);
4957
4958 -- A private extension inherits the Default_Initial_Condition pragma
4959 -- coming from any parent type within the derivation chain.
4960
4961 if Has_DIC (Parent_Type) then
4962 Set_Has_Inherited_DIC (T);
4963 end if;
4964
4965 -- A private extension inherits any class-wide invariants coming from a
4966 -- parent type or an interface. Note that the invariant procedure of the
4967 -- parent type should not be inherited because the private extension may
4968 -- define invariants of its own.
4969
4970 if Has_Inherited_Invariants (Parent_Type)
4971 or else Has_Inheritable_Invariants (Parent_Type)
4972 then
4973 Set_Has_Inherited_Invariants (T);
4974
4975 elsif Present (Interfaces (T)) then
4976 Iface_Elmt := First_Elmt (Interfaces (T));
4977 while Present (Iface_Elmt) loop
4978 Iface := Node (Iface_Elmt);
4979
4980 if Has_Inheritable_Invariants (Iface) then
4981 Set_Has_Inherited_Invariants (T);
4982 exit;
4983 end if;
4984
4985 Next_Elmt (Iface_Elmt);
4986 end loop;
4987 end if;
4988
4989 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten
4990 -- synchronized formal derived type.
4991
4992 if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then
4993 Set_Is_Limited_Record (T);
4994
4995 -- Formal derived type case
4996
4997 if Is_Generic_Type (T) then
4998
4999 -- The parent must be a tagged limited type or a synchronized
5000 -- interface.
5001
5002 if (not Is_Tagged_Type (Parent_Type)
5003 or else not Is_Limited_Type (Parent_Type))
5004 and then
5005 (not Is_Interface (Parent_Type)
5006 or else not Is_Synchronized_Interface (Parent_Type))
5007 then
5008 Error_Msg_NE
5009 ("parent type of & must be tagged limited or synchronized",
5010 N, T);
5011 end if;
5012
5013 -- The progenitors (if any) must be limited or synchronized
5014 -- interfaces.
5015
5016 if Present (Interfaces (T)) then
5017 Iface_Elmt := First_Elmt (Interfaces (T));
5018 while Present (Iface_Elmt) loop
5019 Iface := Node (Iface_Elmt);
5020
5021 if not Is_Limited_Interface (Iface)
5022 and then not Is_Synchronized_Interface (Iface)
5023 then
5024 Error_Msg_NE
5025 ("progenitor & must be limited or synchronized",
5026 N, Iface);
5027 end if;
5028
5029 Next_Elmt (Iface_Elmt);
5030 end loop;
5031 end if;
5032
5033 -- Regular derived extension, the parent must be a limited or
5034 -- synchronized interface.
5035
5036 else
5037 if not Is_Interface (Parent_Type)
5038 or else (not Is_Limited_Interface (Parent_Type)
5039 and then not Is_Synchronized_Interface (Parent_Type))
5040 then
5041 Error_Msg_NE
5042 ("parent type of & must be limited interface", N, T);
5043 end if;
5044 end if;
5045
5046 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
5047 -- extension with a synchronized parent must be explicitly declared
5048 -- synchronized, because the full view will be a synchronized type.
5049 -- This must be checked before the check for limited types below,
5050 -- to ensure that types declared limited are not allowed to extend
5051 -- synchronized interfaces.
5052
5053 elsif Is_Interface (Parent_Type)
5054 and then Is_Synchronized_Interface (Parent_Type)
5055 and then not Synchronized_Present (N)
5056 then
5057 Error_Msg_NE
5058 ("private extension of& must be explicitly synchronized",
5059 N, Parent_Type);
5060
5061 elsif Limited_Present (N) then
5062 Set_Is_Limited_Record (T);
5063
5064 if not Is_Limited_Type (Parent_Type)
5065 and then
5066 (not Is_Interface (Parent_Type)
5067 or else not Is_Limited_Interface (Parent_Type))
5068 then
5069 Error_Msg_NE ("parent type& of limited extension must be limited",
5070 N, Parent_Type);
5071 end if;
5072 end if;
5073
5074 -- Remember that its parent type has a private extension. Used to warn
5075 -- on public primitives of the parent type defined after its private
5076 -- extensions (see Check_Dispatching_Operation).
5077
5078 Set_Has_Private_Extension (Parent_Type);
5079
5080 <<Leave>>
5081 if Has_Aspects (N) then
5082 Analyze_Aspect_Specifications (N, T);
5083 end if;
5084 end Analyze_Private_Extension_Declaration;
5085
5086 ---------------------------------
5087 -- Analyze_Subtype_Declaration --
5088 ---------------------------------
5089
5090 procedure Analyze_Subtype_Declaration
5091 (N : Node_Id;
5092 Skip : Boolean := False)
5093 is
5094 Id : constant Entity_Id := Defining_Identifier (N);
5095 R_Checks : Check_Result;
5096 T : Entity_Id;
5097
5098 begin
5099 Generate_Definition (Id);
5100 Set_Is_Pure (Id, Is_Pure (Current_Scope));
5101 Init_Size_Align (Id);
5102
5103 -- The following guard condition on Enter_Name is to handle cases where
5104 -- the defining identifier has already been entered into the scope but
5105 -- the declaration as a whole needs to be analyzed.
5106
5107 -- This case in particular happens for derived enumeration types. The
5108 -- derived enumeration type is processed as an inserted enumeration type
5109 -- declaration followed by a rewritten subtype declaration. The defining
5110 -- identifier, however, is entered into the name scope very early in the
5111 -- processing of the original type declaration and therefore needs to be
5112 -- avoided here, when the created subtype declaration is analyzed. (See
5113 -- Build_Derived_Types)
5114
5115 -- This also happens when the full view of a private type is derived
5116 -- type with constraints. In this case the entity has been introduced
5117 -- in the private declaration.
5118
5119 -- Finally this happens in some complex cases when validity checks are
5120 -- enabled, where the same subtype declaration may be analyzed twice.
5121 -- This can happen if the subtype is created by the pre-analysis of
5122 -- an attribute tht gives the range of a loop statement, and the loop
5123 -- itself appears within an if_statement that will be rewritten during
5124 -- expansion.
5125
5126 if Skip
5127 or else (Present (Etype (Id))
5128 and then (Is_Private_Type (Etype (Id))
5129 or else Is_Task_Type (Etype (Id))
5130 or else Is_Rewrite_Substitution (N)))
5131 then
5132 null;
5133
5134 elsif Current_Entity (Id) = Id then
5135 null;
5136
5137 else
5138 Enter_Name (Id);
5139 end if;
5140
5141 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
5142
5143 -- Class-wide equivalent types of records with unknown discriminants
5144 -- involve the generation of an itype which serves as the private view
5145 -- of a constrained record subtype. In such cases the base type of the
5146 -- current subtype we are processing is the private itype. Use the full
5147 -- of the private itype when decorating various attributes.
5148
5149 if Is_Itype (T)
5150 and then Is_Private_Type (T)
5151 and then Present (Full_View (T))
5152 then
5153 T := Full_View (T);
5154 end if;
5155
5156 -- Inherit common attributes
5157
5158 Set_Is_Volatile (Id, Is_Volatile (T));
5159 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
5160 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
5161 Set_Convention (Id, Convention (T));
5162
5163 -- If ancestor has predicates then so does the subtype, and in addition
5164 -- we must delay the freeze to properly arrange predicate inheritance.
5165
5166 -- The Ancestor_Type test is really unpleasant, there seem to be cases
5167 -- in which T = ID, so the above tests and assignments do nothing???
5168
5169 if Has_Predicates (T)
5170 or else (Present (Ancestor_Subtype (T))
5171 and then Has_Predicates (Ancestor_Subtype (T)))
5172 then
5173 Set_Has_Predicates (Id);
5174 Set_Has_Delayed_Freeze (Id);
5175
5176 -- Generated subtypes inherit the predicate function from the parent
5177 -- (no aspects to examine on the generated declaration).
5178
5179 if not Comes_From_Source (N) then
5180 Set_Ekind (Id, Ekind (T));
5181
5182 if Present (Predicate_Function (T)) then
5183 Set_Predicate_Function (Id, Predicate_Function (T));
5184
5185 elsif Present (Ancestor_Subtype (T))
5186 and then Has_Predicates (Ancestor_Subtype (T))
5187 and then Present (Predicate_Function (Ancestor_Subtype (T)))
5188 then
5189 Set_Predicate_Function (Id,
5190 Predicate_Function (Ancestor_Subtype (T)));
5191 end if;
5192 end if;
5193 end if;
5194
5195 -- Subtype of Boolean cannot have a constraint in SPARK
5196
5197 if Is_Boolean_Type (T)
5198 and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication
5199 then
5200 Check_SPARK_05_Restriction
5201 ("subtype of Boolean cannot have constraint", N);
5202 end if;
5203
5204 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
5205 declare
5206 Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
5207 One_Cstr : Node_Id;
5208 Low : Node_Id;
5209 High : Node_Id;
5210
5211 begin
5212 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then
5213 One_Cstr := First (Constraints (Cstr));
5214 while Present (One_Cstr) loop
5215
5216 -- Index or discriminant constraint in SPARK must be a
5217 -- subtype mark.
5218
5219 if not
5220 Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name)
5221 then
5222 Check_SPARK_05_Restriction
5223 ("subtype mark required", One_Cstr);
5224
5225 -- String subtype must have a lower bound of 1 in SPARK.
5226 -- Note that we do not need to test for the non-static case
5227 -- here, since that was already taken care of in
5228 -- Process_Range_Expr_In_Decl.
5229
5230 elsif Base_Type (T) = Standard_String then
5231 Get_Index_Bounds (One_Cstr, Low, High);
5232
5233 if Is_OK_Static_Expression (Low)
5234 and then Expr_Value (Low) /= 1
5235 then
5236 Check_SPARK_05_Restriction
5237 ("String subtype must have lower bound of 1", N);
5238 end if;
5239 end if;
5240
5241 Next (One_Cstr);
5242 end loop;
5243 end if;
5244 end;
5245 end if;
5246
5247 -- In the case where there is no constraint given in the subtype
5248 -- indication, Process_Subtype just returns the Subtype_Mark, so its
5249 -- semantic attributes must be established here.
5250
5251 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
5252 Set_Etype (Id, Base_Type (T));
5253
5254 -- Subtype of unconstrained array without constraint is not allowed
5255 -- in SPARK.
5256
5257 if Is_Array_Type (T) and then not Is_Constrained (T) then
5258 Check_SPARK_05_Restriction
5259 ("subtype of unconstrained array must have constraint", N);
5260 end if;
5261
5262 case Ekind (T) is
5263 when Array_Kind =>
5264 Set_Ekind (Id, E_Array_Subtype);
5265 Copy_Array_Subtype_Attributes (Id, T);
5266
5267 when Decimal_Fixed_Point_Kind =>
5268 Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
5269 Set_Digits_Value (Id, Digits_Value (T));
5270 Set_Delta_Value (Id, Delta_Value (T));
5271 Set_Scale_Value (Id, Scale_Value (T));
5272 Set_Small_Value (Id, Small_Value (T));
5273 Set_Scalar_Range (Id, Scalar_Range (T));
5274 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T));
5275 Set_Is_Constrained (Id, Is_Constrained (T));
5276 Set_Is_Known_Valid (Id, Is_Known_Valid (T));
5277 Set_RM_Size (Id, RM_Size (T));
5278
5279 when Enumeration_Kind =>
5280 Set_Ekind (Id, E_Enumeration_Subtype);
5281 Set_First_Literal (Id, First_Literal (Base_Type (T)));
5282 Set_Scalar_Range (Id, Scalar_Range (T));
5283 Set_Is_Character_Type (Id, Is_Character_Type (T));
5284 Set_Is_Constrained (Id, Is_Constrained (T));
5285 Set_Is_Known_Valid (Id, Is_Known_Valid (T));
5286 Set_RM_Size (Id, RM_Size (T));
5287 Inherit_Predicate_Flags (Id, T);
5288
5289 when Ordinary_Fixed_Point_Kind =>
5290 Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
5291 Set_Scalar_Range (Id, Scalar_Range (T));
5292 Set_Small_Value (Id, Small_Value (T));
5293 Set_Delta_Value (Id, Delta_Value (T));
5294 Set_Is_Constrained (Id, Is_Constrained (T));
5295 Set_Is_Known_Valid (Id, Is_Known_Valid (T));
5296 Set_RM_Size (Id, RM_Size (T));
5297
5298 when Float_Kind =>
5299 Set_Ekind (Id, E_Floating_Point_Subtype);
5300 Set_Scalar_Range (Id, Scalar_Range (T));
5301 Set_Digits_Value (Id, Digits_Value (T));
5302 Set_Is_Constrained (Id, Is_Constrained (T));
5303
5304 -- If the floating point type has dimensions, these will be
5305 -- inherited subsequently when Analyze_Dimensions is called.
5306
5307 when Signed_Integer_Kind =>
5308 Set_Ekind (Id, E_Signed_Integer_Subtype);
5309 Set_Scalar_Range (Id, Scalar_Range (T));
5310 Set_Is_Constrained (Id, Is_Constrained (T));
5311 Set_Is_Known_Valid (Id, Is_Known_Valid (T));
5312 Set_RM_Size (Id, RM_Size (T));
5313 Inherit_Predicate_Flags (Id, T);
5314
5315 when Modular_Integer_Kind =>
5316 Set_Ekind (Id, E_Modular_Integer_Subtype);
5317 Set_Scalar_Range (Id, Scalar_Range (T));
5318 Set_Is_Constrained (Id, Is_Constrained (T));
5319 Set_Is_Known_Valid (Id, Is_Known_Valid (T));
5320 Set_RM_Size (Id, RM_Size (T));
5321 Inherit_Predicate_Flags (Id, T);
5322
5323 when Class_Wide_Kind =>
5324 Set_Ekind (Id, E_Class_Wide_Subtype);
5325 Set_Class_Wide_Type (Id, Class_Wide_Type (T));
5326 Set_Cloned_Subtype (Id, T);
5327 Set_Is_Tagged_Type (Id, True);
5328 Set_Has_Unknown_Discriminants
5329 (Id, True);
5330 Set_No_Tagged_Streams_Pragma
5331 (Id, No_Tagged_Streams_Pragma (T));
5332
5333 if Ekind (T) = E_Class_Wide_Subtype then
5334 Set_Equivalent_Type (Id, Equivalent_Type (T));
5335 end if;
5336
5337 when E_Record_Subtype
5338 | E_Record_Type
5339 =>
5340 Set_Ekind (Id, E_Record_Subtype);
5341
5342 if Ekind (T) = E_Record_Subtype
5343 and then Present (Cloned_Subtype (T))
5344 then
5345 Set_Cloned_Subtype (Id, Cloned_Subtype (T));
5346 else
5347 Set_Cloned_Subtype (Id, T);
5348 end if;
5349
5350 Set_First_Entity (Id, First_Entity (T));
5351 Set_Last_Entity (Id, Last_Entity (T));
5352 Set_Has_Discriminants (Id, Has_Discriminants (T));
5353 Set_Is_Constrained (Id, Is_Constrained (T));
5354 Set_Is_Limited_Record (Id, Is_Limited_Record (T));
5355 Set_Has_Implicit_Dereference
5356 (Id, Has_Implicit_Dereference (T));
5357 Set_Has_Unknown_Discriminants
5358 (Id, Has_Unknown_Discriminants (T));
5359
5360 if Has_Discriminants (T) then
5361 Set_Discriminant_Constraint
5362 (Id, Discriminant_Constraint (T));
5363 Set_Stored_Constraint_From_Discriminant_Constraint (Id);
5364
5365 elsif Has_Unknown_Discriminants (Id) then
5366 Set_Discriminant_Constraint (Id, No_Elist);
5367 end if;
5368
5369 if Is_Tagged_Type (T) then
5370 Set_Is_Tagged_Type (Id, True);
5371 Set_No_Tagged_Streams_Pragma
5372 (Id, No_Tagged_Streams_Pragma (T));
5373 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
5374 Set_Direct_Primitive_Operations
5375 (Id, Direct_Primitive_Operations (T));
5376 Set_Class_Wide_Type (Id, Class_Wide_Type (T));
5377
5378 if Is_Interface (T) then
5379 Set_Is_Interface (Id);
5380 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
5381 end if;
5382 end if;
5383
5384 when Private_Kind =>
5385 Set_Ekind (Id, Subtype_Kind (Ekind (T)));
5386 Set_Has_Discriminants (Id, Has_Discriminants (T));
5387 Set_Is_Constrained (Id, Is_Constrained (T));
5388 Set_First_Entity (Id, First_Entity (T));
5389 Set_Last_Entity (Id, Last_Entity (T));
5390 Set_Private_Dependents (Id, New_Elmt_List);
5391 Set_Is_Limited_Record (Id, Is_Limited_Record (T));
5392 Set_Has_Implicit_Dereference
5393 (Id, Has_Implicit_Dereference (T));
5394 Set_Has_Unknown_Discriminants
5395 (Id, Has_Unknown_Discriminants (T));
5396 Set_Known_To_Have_Preelab_Init
5397 (Id, Known_To_Have_Preelab_Init (T));
5398
5399 if Is_Tagged_Type (T) then
5400 Set_Is_Tagged_Type (Id);
5401 Set_No_Tagged_Streams_Pragma (Id,
5402 No_Tagged_Streams_Pragma (T));
5403 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
5404 Set_Class_Wide_Type (Id, Class_Wide_Type (T));
5405 Set_Direct_Primitive_Operations (Id,
5406 Direct_Primitive_Operations (T));
5407 end if;
5408
5409 -- In general the attributes of the subtype of a private type
5410 -- are the attributes of the partial view of parent. However,
5411 -- the full view may be a discriminated type, and the subtype
5412 -- must share the discriminant constraint to generate correct
5413 -- calls to initialization procedures.
5414
5415 if Has_Discriminants (T) then
5416 Set_Discriminant_Constraint
5417 (Id, Discriminant_Constraint (T));
5418 Set_Stored_Constraint_From_Discriminant_Constraint (Id);
5419
5420 elsif Present (Full_View (T))
5421 and then Has_Discriminants (Full_View (T))
5422 then
5423 Set_Discriminant_Constraint
5424 (Id, Discriminant_Constraint (Full_View (T)));
5425 Set_Stored_Constraint_From_Discriminant_Constraint (Id);
5426
5427 -- This would seem semantically correct, but apparently
5428 -- generates spurious errors about missing components ???
5429
5430 -- Set_Has_Discriminants (Id);
5431 end if;
5432
5433 Prepare_Private_Subtype_Completion (Id, N);
5434
5435 -- If this is the subtype of a constrained private type with
5436 -- discriminants that has got a full view and we also have
5437 -- built a completion just above, show that the completion
5438 -- is a clone of the full view to the back-end.
5439
5440 if Has_Discriminants (T)
5441 and then not Has_Unknown_Discriminants (T)
5442 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T))
5443 and then Present (Full_View (T))
5444 and then Present (Full_View (Id))
5445 then
5446 Set_Cloned_Subtype (Full_View (Id), Full_View (T));
5447 end if;
5448
5449 when Access_Kind =>
5450 Set_Ekind (Id, E_Access_Subtype);
5451 Set_Is_Constrained (Id, Is_Constrained (T));
5452 Set_Is_Access_Constant
5453 (Id, Is_Access_Constant (T));
5454 Set_Directly_Designated_Type
5455 (Id, Designated_Type (T));
5456 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T));
5457
5458 -- A Pure library_item must not contain the declaration of a
5459 -- named access type, except within a subprogram, generic
5460 -- subprogram, task unit, or protected unit, or if it has
5461 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
5462
5463 if Comes_From_Source (Id)
5464 and then In_Pure_Unit
5465 and then not In_Subprogram_Task_Protected_Unit
5466 and then not No_Pool_Assigned (Id)
5467 then
5468 Error_Msg_N
5469 ("named access types not allowed in pure unit", N);
5470 end if;
5471
5472 when Concurrent_Kind =>
5473 Set_Ekind (Id, Subtype_Kind (Ekind (T)));
5474 Set_Corresponding_Record_Type (Id,
5475 Corresponding_Record_Type (T));
5476 Set_First_Entity (Id, First_Entity (T));
5477 Set_First_Private_Entity (Id, First_Private_Entity (T));
5478 Set_Has_Discriminants (Id, Has_Discriminants (T));
5479 Set_Is_Constrained (Id, Is_Constrained (T));
5480 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
5481 Set_Last_Entity (Id, Last_Entity (T));
5482
5483 if Is_Tagged_Type (T) then
5484 Set_No_Tagged_Streams_Pragma
5485 (Id, No_Tagged_Streams_Pragma (T));
5486 end if;
5487
5488 if Has_Discriminants (T) then
5489 Set_Discriminant_Constraint
5490 (Id, Discriminant_Constraint (T));
5491 Set_Stored_Constraint_From_Discriminant_Constraint (Id);
5492 end if;
5493
5494 when Incomplete_Kind =>
5495 if Ada_Version >= Ada_2005 then
5496
5497 -- In Ada 2005 an incomplete type can be explicitly tagged:
5498 -- propagate indication. Note that we also have to include
5499 -- subtypes for Ada 2012 extended use of incomplete types.
5500
5501 Set_Ekind (Id, E_Incomplete_Subtype);
5502 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
5503 Set_Private_Dependents (Id, New_Elmt_List);
5504
5505 if Is_Tagged_Type (Id) then
5506 Set_No_Tagged_Streams_Pragma
5507 (Id, No_Tagged_Streams_Pragma (T));
5508 Set_Direct_Primitive_Operations (Id, New_Elmt_List);
5509 end if;
5510
5511 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an
5512 -- incomplete type visible through a limited with clause.
5513
5514 if From_Limited_With (T)
5515 and then Present (Non_Limited_View (T))
5516 then
5517 Set_From_Limited_With (Id);
5518 Set_Non_Limited_View (Id, Non_Limited_View (T));
5519
5520 -- Ada 2005 (AI-412): Add the regular incomplete subtype
5521 -- to the private dependents of the original incomplete
5522 -- type for future transformation.
5523
5524 else
5525 Append_Elmt (Id, Private_Dependents (T));
5526 end if;
5527
5528 -- If the subtype name denotes an incomplete type an error
5529 -- was already reported by Process_Subtype.
5530
5531 else
5532 Set_Etype (Id, Any_Type);
5533 end if;
5534
5535 when others =>
5536 raise Program_Error;
5537 end case;
5538 end if;
5539
5540 if Etype (Id) = Any_Type then
5541 goto Leave;
5542 end if;
5543
5544 -- Some common processing on all types
5545
5546 Set_Size_Info (Id, T);
5547 Set_First_Rep_Item (Id, First_Rep_Item (T));
5548
5549 -- If the parent type is a generic actual, so is the subtype. This may
5550 -- happen in a nested instance. Why Comes_From_Source test???
5551
5552 if not Comes_From_Source (N) then
5553 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T));
5554 end if;
5555
5556 -- If this is a subtype declaration for an actual in an instance,
5557 -- inherit static and dynamic predicates if any.
5558
5559 -- If declaration has no aspect specifications, inherit predicate
5560 -- info as well. Unclear how to handle the case of both specified
5561 -- and inherited predicates ??? Other inherited aspects, such as
5562 -- invariants, should be OK, but the combination with later pragmas
5563 -- may also require special merging.
5564
5565 if Has_Predicates (T)
5566 and then Present (Predicate_Function (T))
5567 and then
5568 ((In_Instance and then not Comes_From_Source (N))
5569 or else No (Aspect_Specifications (N)))
5570 then
5571 Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
5572
5573 if Has_Static_Predicate (T) then
5574 Set_Has_Static_Predicate (Id);
5575 Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T));
5576 end if;
5577 end if;
5578
5579 -- Remaining processing depends on characteristics of base type
5580
5581 T := Etype (Id);
5582
5583 Set_Is_Immediately_Visible (Id, True);
5584 Set_Depends_On_Private (Id, Has_Private_Component (T));
5585 Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T));
5586
5587 if Is_Interface (T) then
5588 Set_Is_Interface (Id);
5589 end if;
5590
5591 if Present (Generic_Parent_Type (N))
5592 and then
5593 (Nkind (Parent (Generic_Parent_Type (N))) /=
5594 N_Formal_Type_Declaration
5595 or else Nkind (Formal_Type_Definition
5596 (Parent (Generic_Parent_Type (N)))) /=
5597 N_Formal_Private_Type_Definition)
5598 then
5599 if Is_Tagged_Type (Id) then
5600
5601 -- If this is a generic actual subtype for a synchronized type,
5602 -- the primitive operations are those of the corresponding record
5603 -- for which there is a separate subtype declaration.
5604
5605 if Is_Concurrent_Type (Id) then
5606 null;
5607 elsif Is_Class_Wide_Type (Id) then
5608 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
5609 else
5610 Derive_Subprograms (Generic_Parent_Type (N), Id, T);
5611 end if;
5612
5613 elsif Scope (Etype (Id)) /= Standard_Standard then
5614 Derive_Subprograms (Generic_Parent_Type (N), Id);
5615 end if;
5616 end if;
5617
5618 if Is_Private_Type (T) and then Present (Full_View (T)) then
5619 Conditional_Delay (Id, Full_View (T));
5620
5621 -- The subtypes of components or subcomponents of protected types
5622 -- do not need freeze nodes, which would otherwise appear in the
5623 -- wrong scope (before the freeze node for the protected type). The
5624 -- proper subtypes are those of the subcomponents of the corresponding
5625 -- record.
5626
5627 elsif Ekind (Scope (Id)) /= E_Protected_Type
5628 and then Present (Scope (Scope (Id))) -- error defense
5629 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
5630 then
5631 Conditional_Delay (Id, T);
5632 end if;
5633
5634 -- Check that Constraint_Error is raised for a scalar subtype indication
5635 -- when the lower or upper bound of a non-null range lies outside the
5636 -- range of the type mark.
5637
5638 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
5639 if Is_Scalar_Type (Etype (Id))
5640 and then Scalar_Range (Id) /=
5641 Scalar_Range
5642 (Etype (Subtype_Mark (Subtype_Indication (N))))
5643 then
5644 Apply_Range_Check
5645 (Scalar_Range (Id),
5646 Etype (Subtype_Mark (Subtype_Indication (N))));
5647
5648 -- In the array case, check compatibility for each index
5649
5650 elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id))
5651 then
5652 -- This really should be a subprogram that finds the indications
5653 -- to check???
5654
5655 declare
5656 Subt_Index : Node_Id := First_Index (Id);
5657 Target_Index : Node_Id :=
5658 First_Index (Etype
5659 (Subtype_Mark (Subtype_Indication (N))));
5660 Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N);
5661
5662 begin
5663 while Present (Subt_Index) loop
5664 if ((Nkind (Subt_Index) = N_Identifier
5665 and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
5666 or else Nkind (Subt_Index) = N_Subtype_Indication)
5667 and then
5668 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
5669 then
5670 declare
5671 Target_Typ : constant Entity_Id :=
5672 Etype (Target_Index);
5673 begin
5674 R_Checks :=
5675 Get_Range_Checks
5676 (Scalar_Range (Etype (Subt_Index)),
5677 Target_Typ,
5678 Etype (Subt_Index),
5679 Defining_Identifier (N));
5680
5681 -- Reset Has_Dynamic_Range_Check on the subtype to
5682 -- prevent elision of the index check due to a dynamic
5683 -- check generated for a preceding index (needed since
5684 -- Insert_Range_Checks tries to avoid generating
5685 -- redundant checks on a given declaration).
5686
5687 Set_Has_Dynamic_Range_Check (N, False);
5688
5689 Insert_Range_Checks
5690 (R_Checks,
5691 N,
5692 Target_Typ,
5693 Sloc (Defining_Identifier (N)));
5694
5695 -- Record whether this index involved a dynamic check
5696
5697 Has_Dyn_Chk :=
5698 Has_Dyn_Chk or else Has_Dynamic_Range_Check (N);
5699 end;
5700 end if;
5701
5702 Next_Index (Subt_Index);
5703 Next_Index (Target_Index);
5704 end loop;
5705
5706 -- Finally, mark whether the subtype involves dynamic checks
5707
5708 Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk);
5709 end;
5710 end if;
5711 end if;
5712
5713 Set_Optimize_Alignment_Flags (Id);
5714 Check_Eliminated (Id);
5715
5716 <<Leave>>
5717 if Has_Aspects (N) then
5718 Analyze_Aspect_Specifications (N, Id);
5719 end if;
5720
5721 Analyze_Dimension (N);
5722
5723 -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype
5724 -- indications on composite types where the constraints are dynamic.
5725 -- Note that object declarations and aggregates generate implicit
5726 -- subtype declarations, which this covers. One special case is that the
5727 -- implicitly generated "=" for discriminated types includes an
5728 -- offending subtype declaration, which is harmless, so we ignore it
5729 -- here.
5730
5731 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
5732 declare
5733 Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
5734 begin
5735 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint
5736 and then not (Is_Internal (Id)
5737 and then Is_TSS (Scope (Id),
5738 TSS_Composite_Equality))
5739 and then not Within_Init_Proc
5740 and then not All_Composite_Constraints_Static (Cstr)
5741 then
5742 Check_Restriction (No_Dynamic_Sized_Objects, Cstr);
5743 end if;
5744 end;
5745 end if;
5746 end Analyze_Subtype_Declaration;
5747
5748 --------------------------------
5749 -- Analyze_Subtype_Indication --
5750 --------------------------------
5751
5752 procedure Analyze_Subtype_Indication (N : Node_Id) is
5753 T : constant Entity_Id := Subtype_Mark (N);
5754 R : constant Node_Id := Range_Expression (Constraint (N));
5755
5756 begin
5757 Analyze (T);
5758
5759 if R /= Error then
5760 Analyze (R);
5761 Set_Etype (N, Etype (R));
5762 Resolve (R, Entity (T));
5763 else
5764 Set_Error_Posted (R);
5765 Set_Error_Posted (T);
5766 end if;
5767 end Analyze_Subtype_Indication;
5768
5769 --------------------------
5770 -- Analyze_Variant_Part --
5771 --------------------------
5772
5773 procedure Analyze_Variant_Part (N : Node_Id) is
5774 Discr_Name : Node_Id;
5775 Discr_Type : Entity_Id;
5776
5777 procedure Process_Variant (A : Node_Id);
5778 -- Analyze declarations for a single variant
5779
5780 package Analyze_Variant_Choices is
5781 new Generic_Analyze_Choices (Process_Variant);
5782 use Analyze_Variant_Choices;
5783
5784 ---------------------
5785 -- Process_Variant --
5786 ---------------------
5787
5788 procedure Process_Variant (A : Node_Id) is
5789 CL : constant Node_Id := Component_List (A);
5790 begin
5791 if not Null_Present (CL) then
5792 Analyze_Declarations (Component_Items (CL));
5793
5794 if Present (Variant_Part (CL)) then
5795 Analyze (Variant_Part (CL));
5796 end if;
5797 end if;
5798 end Process_Variant;
5799
5800 -- Start of processing for Analyze_Variant_Part
5801
5802 begin
5803 Discr_Name := Name (N);
5804 Analyze (Discr_Name);
5805
5806 -- If Discr_Name bad, get out (prevent cascaded errors)
5807
5808 if Etype (Discr_Name) = Any_Type then
5809 return;
5810 end if;
5811
5812 -- Check invalid discriminant in variant part
5813
5814 if Ekind (Entity (Discr_Name)) /= E_Discriminant then
5815 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
5816 end if;
5817
5818 Discr_Type := Etype (Entity (Discr_Name));
5819
5820 if not Is_Discrete_Type (Discr_Type) then
5821 Error_Msg_N
5822 ("discriminant in a variant part must be of a discrete type",
5823 Name (N));
5824 return;
5825 end if;
5826
5827 -- Now analyze the choices, which also analyzes the declarations that
5828 -- are associated with each choice.
5829
5830 Analyze_Choices (Variants (N), Discr_Type);
5831
5832 -- Note: we used to instantiate and call Check_Choices here to check
5833 -- that the choices covered the discriminant, but it's too early to do
5834 -- that because of statically predicated subtypes, whose analysis may
5835 -- be deferred to their freeze point which may be as late as the freeze
5836 -- point of the containing record. So this call is now to be found in
5837 -- Freeze_Record_Declaration.
5838
5839 end Analyze_Variant_Part;
5840
5841 ----------------------------
5842 -- Array_Type_Declaration --
5843 ----------------------------
5844
5845 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
5846 Component_Def : constant Node_Id := Component_Definition (Def);
5847 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def);
5848 P : constant Node_Id := Parent (Def);
5849 Element_Type : Entity_Id;
5850 Implicit_Base : Entity_Id;
5851 Index : Node_Id;
5852 Nb_Index : Nat;
5853 Priv : Entity_Id;
5854 Related_Id : Entity_Id := Empty;
5855
5856 begin
5857 if Nkind (Def) = N_Constrained_Array_Definition then
5858 Index := First (Discrete_Subtype_Definitions (Def));
5859 else
5860 Index := First (Subtype_Marks (Def));
5861 end if;
5862
5863 -- Find proper names for the implicit types which may be public. In case
5864 -- of anonymous arrays we use the name of the first object of that type
5865 -- as prefix.
5866
5867 if No (T) then
5868 Related_Id := Defining_Identifier (P);
5869 else
5870 Related_Id := T;
5871 end if;
5872
5873 Nb_Index := 1;
5874 while Present (Index) loop
5875 Analyze (Index);
5876
5877 -- Test for odd case of trying to index a type by the type itself
5878
5879 if Is_Entity_Name (Index) and then Entity (Index) = T then
5880 Error_Msg_N ("type& cannot be indexed by itself", Index);
5881 Set_Entity (Index, Standard_Boolean);
5882 Set_Etype (Index, Standard_Boolean);
5883 end if;
5884
5885 -- Check SPARK restriction requiring a subtype mark
5886
5887 if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then
5888 Check_SPARK_05_Restriction ("subtype mark required", Index);
5889 end if;
5890
5891 -- Add a subtype declaration for each index of private array type
5892 -- declaration whose etype is also private. For example:
5893
5894 -- package Pkg is
5895 -- type Index is private;
5896 -- private
5897 -- type Table is array (Index) of ...
5898 -- end;
5899
5900 -- This is currently required by the expander for the internally
5901 -- generated equality subprogram of records with variant parts in
5902 -- which the etype of some component is such private type.
5903
5904 if Ekind (Current_Scope) = E_Package
5905 and then In_Private_Part (Current_Scope)
5906 and then Has_Private_Declaration (Etype (Index))
5907 then
5908 declare
5909 Loc : constant Source_Ptr := Sloc (Def);
5910 Decl : Entity_Id;
5911 New_E : Entity_Id;
5912
5913 begin
5914 New_E := Make_Temporary (Loc, 'T');
5915 Set_Is_Internal (New_E);
5916
5917 Decl :=
5918 Make_Subtype_Declaration (Loc,
5919 Defining_Identifier => New_E,
5920 Subtype_Indication =>
5921 New_Occurrence_Of (Etype (Index), Loc));
5922
5923 Insert_Before (Parent (Def), Decl);
5924 Analyze (Decl);
5925 Set_Etype (Index, New_E);
5926
5927 -- If the index is a range the Entity attribute is not
5928 -- available. Example:
5929
5930 -- package Pkg is
5931 -- type T is private;
5932 -- private
5933 -- type T is new Natural;
5934 -- Table : array (T(1) .. T(10)) of Boolean;
5935 -- end Pkg;
5936
5937 if Nkind (Index) /= N_Range then
5938 Set_Entity (Index, New_E);
5939 end if;
5940 end;
5941 end if;
5942
5943 Make_Index (Index, P, Related_Id, Nb_Index);
5944
5945 -- Check error of subtype with predicate for index type
5946
5947 Bad_Predicated_Subtype_Use
5948 ("subtype& has predicate, not allowed as index subtype",
5949 Index, Etype (Index));
5950
5951 -- Move to next index
5952
5953 Next_Index (Index);
5954 Nb_Index := Nb_Index + 1;
5955 end loop;
5956
5957 -- Process subtype indication if one is present
5958
5959 if Present (Component_Typ) then
5960 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
5961
5962 Set_Etype (Component_Typ, Element_Type);
5963
5964 if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then
5965 Check_SPARK_05_Restriction
5966 ("subtype mark required", Component_Typ);
5967 end if;
5968
5969 -- Ada 2005 (AI-230): Access Definition case
5970
5971 else pragma Assert (Present (Access_Definition (Component_Def)));
5972
5973 -- Indicate that the anonymous access type is created by the
5974 -- array type declaration.
5975
5976 Element_Type := Access_Definition
5977 (Related_Nod => P,
5978 N => Access_Definition (Component_Def));
5979 Set_Is_Local_Anonymous_Access (Element_Type);
5980
5981 -- Propagate the parent. This field is needed if we have to generate
5982 -- the master_id associated with an anonymous access to task type
5983 -- component (see Expand_N_Full_Type_Declaration.Build_Master)
5984
5985 Set_Parent (Element_Type, Parent (T));
5986
5987 -- Ada 2005 (AI-230): In case of components that are anonymous access
5988 -- types the level of accessibility depends on the enclosing type
5989 -- declaration
5990
5991 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
5992
5993 -- Ada 2005 (AI-254)
5994
5995 declare
5996 CD : constant Node_Id :=
5997 Access_To_Subprogram_Definition
5998 (Access_Definition (Component_Def));
5999 begin
6000 if Present (CD) and then Protected_Present (CD) then
6001 Element_Type :=
6002 Replace_Anonymous_Access_To_Protected_Subprogram (Def);
6003 end if;
6004 end;
6005 end if;
6006
6007 -- Constrained array case
6008
6009 if No (T) then
6010 T := Create_Itype (E_Void, P, Related_Id, 'T');
6011 end if;
6012
6013 if Nkind (Def) = N_Constrained_Array_Definition then
6014
6015 -- Establish Implicit_Base as unconstrained base type
6016
6017 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
6018
6019 Set_Etype (Implicit_Base, Implicit_Base);
6020 Set_Scope (Implicit_Base, Current_Scope);
6021 Set_Has_Delayed_Freeze (Implicit_Base);
6022 Set_Default_SSO (Implicit_Base);
6023
6024 -- The constrained array type is a subtype of the unconstrained one
6025
6026 Set_Ekind (T, E_Array_Subtype);
6027 Init_Size_Align (T);
6028 Set_Etype (T, Implicit_Base);
6029 Set_Scope (T, Current_Scope);
6030 Set_Is_Constrained (T);
6031 Set_First_Index (T,
6032 First (Discrete_Subtype_Definitions (Def)));
6033 Set_Has_Delayed_Freeze (T);
6034
6035 -- Complete setup of implicit base type
6036
6037 Set_Component_Size (Implicit_Base, Uint_0);
6038 Set_Component_Type (Implicit_Base, Element_Type);
6039 Set_Finalize_Storage_Only
6040 (Implicit_Base,
6041 Finalize_Storage_Only (Element_Type));
6042 Set_First_Index (Implicit_Base, First_Index (T));
6043 Set_Has_Controlled_Component
6044 (Implicit_Base,
6045 Has_Controlled_Component (Element_Type)
6046 or else Is_Controlled_Active (Element_Type));
6047 Set_Packed_Array_Impl_Type
6048 (Implicit_Base, Empty);
6049
6050 Propagate_Concurrent_Flags (Implicit_Base, Element_Type);
6051
6052 -- Unconstrained array case
6053
6054 else
6055 Set_Ekind (T, E_Array_Type);
6056 Init_Size_Align (T);
6057 Set_Etype (T, T);
6058 Set_Scope (T, Current_Scope);
6059 Set_Component_Size (T, Uint_0);
6060 Set_Is_Constrained (T, False);
6061 Set_First_Index (T, First (Subtype_Marks (Def)));
6062 Set_Has_Delayed_Freeze (T, True);
6063 Propagate_Concurrent_Flags (T, Element_Type);
6064 Set_Has_Controlled_Component (T, Has_Controlled_Component
6065 (Element_Type)
6066 or else
6067 Is_Controlled_Active (Element_Type));
6068 Set_Finalize_Storage_Only (T, Finalize_Storage_Only
6069 (Element_Type));
6070 Set_Default_SSO (T);
6071 end if;
6072
6073 -- Common attributes for both cases
6074
6075 Set_Component_Type (Base_Type (T), Element_Type);
6076 Set_Packed_Array_Impl_Type (T, Empty);
6077
6078 if Aliased_Present (Component_Definition (Def)) then
6079 Check_SPARK_05_Restriction
6080 ("aliased is not allowed", Component_Definition (Def));
6081 Set_Has_Aliased_Components (Etype (T));
6082 end if;
6083
6084 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
6085 -- array type to ensure that objects of this type are initialized.
6086
6087 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then
6088 Set_Can_Never_Be_Null (T);
6089
6090 if Null_Exclusion_Present (Component_Definition (Def))
6091
6092 -- No need to check itypes because in their case this check was
6093 -- done at their point of creation
6094
6095 and then not Is_Itype (Element_Type)
6096 then
6097 Error_Msg_N
6098 ("`NOT NULL` not allowed (null already excluded)",
6099 Subtype_Indication (Component_Definition (Def)));
6100 end if;
6101 end if;
6102
6103 Priv := Private_Component (Element_Type);
6104
6105 if Present (Priv) then
6106
6107 -- Check for circular definitions
6108
6109 if Priv = Any_Type then
6110 Set_Component_Type (Etype (T), Any_Type);
6111
6112 -- There is a gap in the visibility of operations on the composite
6113 -- type only if the component type is defined in a different scope.
6114
6115 elsif Scope (Priv) = Current_Scope then
6116 null;
6117
6118 elsif Is_Limited_Type (Priv) then
6119 Set_Is_Limited_Composite (Etype (T));
6120 Set_Is_Limited_Composite (T);
6121 else
6122 Set_Is_Private_Composite (Etype (T));
6123 Set_Is_Private_Composite (T);
6124 end if;
6125 end if;
6126
6127 -- A syntax error in the declaration itself may lead to an empty index
6128 -- list, in which case do a minimal patch.
6129
6130 if No (First_Index (T)) then
6131 Error_Msg_N ("missing index definition in array type declaration", T);
6132
6133 declare
6134 Indexes : constant List_Id :=
6135 New_List (New_Occurrence_Of (Any_Id, Sloc (T)));
6136 begin
6137 Set_Discrete_Subtype_Definitions (Def, Indexes);
6138 Set_First_Index (T, First (Indexes));
6139 return;
6140 end;
6141 end if;
6142
6143 -- Create a concatenation operator for the new type. Internal array
6144 -- types created for packed entities do not need such, they are
6145 -- compatible with the user-defined type.
6146
6147 if Number_Dimensions (T) = 1
6148 and then not Is_Packed_Array_Impl_Type (T)
6149 then
6150 New_Concatenation_Op (T);
6151 end if;
6152
6153 -- In the case of an unconstrained array the parser has already verified
6154 -- that all the indexes are unconstrained but we still need to make sure
6155 -- that the element type is constrained.
6156
6157 if not Is_Definite_Subtype (Element_Type) then
6158 Error_Msg_N
6159 ("unconstrained element type in array declaration",
6160 Subtype_Indication (Component_Def));
6161
6162 elsif Is_Abstract_Type (Element_Type) then
6163 Error_Msg_N
6164 ("the type of a component cannot be abstract",
6165 Subtype_Indication (Component_Def));
6166 end if;
6167
6168 -- There may be an invariant declared for the component type, but
6169 -- the construction of the component invariant checking procedure
6170 -- takes place during expansion.
6171 end Array_Type_Declaration;
6172
6173 ------------------------------------------------------
6174 -- Replace_Anonymous_Access_To_Protected_Subprogram --
6175 ------------------------------------------------------
6176
6177 function Replace_Anonymous_Access_To_Protected_Subprogram
6178 (N : Node_Id) return Entity_Id
6179 is
6180 Loc : constant Source_Ptr := Sloc (N);
6181
6182 Curr_Scope : constant Scope_Stack_Entry :=
6183 Scope_Stack.Table (Scope_Stack.Last);
6184
6185 Anon : constant Entity_Id := Make_Temporary (Loc, 'S');
6186
6187 Acc : Node_Id;
6188 -- Access definition in declaration
6189
6190 Comp : Node_Id;
6191 -- Object definition or formal definition with an access definition
6192
6193 Decl : Node_Id;
6194 -- Declaration of anonymous access to subprogram type
6195
6196 Spec : Node_Id;
6197 -- Original specification in access to subprogram
6198
6199 P : Node_Id;
6200
6201 begin
6202 Set_Is_Internal (Anon);
6203
6204 case Nkind (N) is
6205 when N_Constrained_Array_Definition
6206 | N_Component_Declaration
6207 | N_Unconstrained_Array_Definition
6208 =>
6209 Comp := Component_Definition (N);
6210 Acc := Access_Definition (Comp);
6211
6212 when N_Discriminant_Specification =>
6213 Comp := Discriminant_Type (N);
6214 Acc := Comp;
6215
6216 when N_Parameter_Specification =>
6217 Comp := Parameter_Type (N);
6218 Acc := Comp;
6219
6220 when N_Access_Function_Definition =>
6221 Comp := Result_Definition (N);
6222 Acc := Comp;
6223
6224 when N_Object_Declaration =>
6225 Comp := Object_Definition (N);
6226 Acc := Comp;
6227
6228 when N_Function_Specification =>
6229 Comp := Result_Definition (N);
6230 Acc := Comp;
6231
6232 when others =>
6233 raise Program_Error;
6234 end case;
6235
6236 Spec := Access_To_Subprogram_Definition (Acc);
6237
6238 Decl :=
6239 Make_Full_Type_Declaration (Loc,
6240 Defining_Identifier => Anon,
6241 Type_Definition => Copy_Separate_Tree (Spec));
6242
6243 Mark_Rewrite_Insertion (Decl);
6244
6245 -- In ASIS mode, analyze the profile on the original node, because
6246 -- the separate copy does not provide enough links to recover the
6247 -- original tree. Analysis is limited to type annotations, within
6248 -- a temporary scope that serves as an anonymous subprogram to collect
6249 -- otherwise useless temporaries and itypes.
6250
6251 if ASIS_Mode then
6252 declare
6253 Typ : constant Entity_Id := Make_Temporary (Loc, 'S');
6254
6255 begin
6256 if Nkind (Spec) = N_Access_Function_Definition then
6257 Set_Ekind (Typ, E_Function);
6258 else
6259 Set_Ekind (Typ, E_Procedure);
6260 end if;
6261
6262 Set_Parent (Typ, N);
6263 Set_Scope (Typ, Current_Scope);
6264 Push_Scope (Typ);
6265
6266 -- Nothing to do if procedure is parameterless
6267
6268 if Present (Parameter_Specifications (Spec)) then
6269 Process_Formals (Parameter_Specifications (Spec), Spec);
6270 end if;
6271
6272 if Nkind (Spec) = N_Access_Function_Definition then
6273 declare
6274 Def : constant Node_Id := Result_Definition (Spec);
6275
6276 begin
6277 -- The result might itself be an anonymous access type, so
6278 -- have to recurse.
6279
6280 if Nkind (Def) = N_Access_Definition then
6281 if Present (Access_To_Subprogram_Definition (Def)) then
6282 Set_Etype
6283 (Def,
6284 Replace_Anonymous_Access_To_Protected_Subprogram
6285 (Spec));
6286 else
6287 Find_Type (Subtype_Mark (Def));
6288 end if;
6289
6290 else
6291 Find_Type (Def);
6292 end if;
6293 end;
6294 end if;
6295
6296 End_Scope;
6297 end;
6298 end if;
6299
6300 -- Insert the new declaration in the nearest enclosing scope. If the
6301 -- parent is a body and N is its return type, the declaration belongs
6302 -- in the enclosing scope. Likewise if N is the type of a parameter.
6303
6304 P := Parent (N);
6305
6306 if Nkind (N) = N_Function_Specification
6307 and then Nkind (P) = N_Subprogram_Body
6308 then
6309 P := Parent (P);
6310 elsif Nkind (N) = N_Parameter_Specification
6311 and then Nkind (P) in N_Subprogram_Specification
6312 and then Nkind (Parent (P)) = N_Subprogram_Body
6313 then
6314 P := Parent (Parent (P));
6315 end if;
6316
6317 while Present (P) and then not Has_Declarations (P) loop
6318 P := Parent (P);
6319 end loop;
6320
6321 pragma Assert (Present (P));
6322
6323 if Nkind (P) = N_Package_Specification then
6324 Prepend (Decl, Visible_Declarations (P));
6325 else
6326 Prepend (Decl, Declarations (P));
6327 end if;
6328
6329 -- Replace the anonymous type with an occurrence of the new declaration.
6330 -- In all cases the rewritten node does not have the null-exclusion
6331 -- attribute because (if present) it was already inherited by the
6332 -- anonymous entity (Anon). Thus, in case of components we do not
6333 -- inherit this attribute.
6334
6335 if Nkind (N) = N_Parameter_Specification then
6336 Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
6337 Set_Etype (Defining_Identifier (N), Anon);
6338 Set_Null_Exclusion_Present (N, False);
6339
6340 elsif Nkind (N) = N_Object_Declaration then
6341 Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
6342 Set_Etype (Defining_Identifier (N), Anon);
6343
6344 elsif Nkind (N) = N_Access_Function_Definition then
6345 Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
6346
6347 elsif Nkind (N) = N_Function_Specification then
6348 Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
6349 Set_Etype (Defining_Unit_Name (N), Anon);
6350
6351 else
6352 Rewrite (Comp,
6353 Make_Component_Definition (Loc,
6354 Subtype_Indication => New_Occurrence_Of (Anon, Loc)));
6355 end if;
6356
6357 Mark_Rewrite_Insertion (Comp);
6358
6359 if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition)
6360 or else (Nkind (Parent (N)) = N_Full_Type_Declaration
6361 and then not Is_Type (Current_Scope))
6362 then
6363
6364 -- Declaration can be analyzed in the current scope.
6365
6366 Analyze (Decl);
6367
6368 else
6369 -- Temporarily remove the current scope (record or subprogram) from
6370 -- the stack to add the new declarations to the enclosing scope.
6371 -- The anonymous entity is an Itype with the proper attributes.
6372
6373 Scope_Stack.Decrement_Last;
6374 Analyze (Decl);
6375 Set_Is_Itype (Anon);
6376 Set_Associated_Node_For_Itype (Anon, N);
6377 Scope_Stack.Append (Curr_Scope);
6378 end if;
6379
6380 Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
6381 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
6382 return Anon;
6383 end Replace_Anonymous_Access_To_Protected_Subprogram;
6384
6385 -------------------------------
6386 -- Build_Derived_Access_Type --
6387 -------------------------------
6388
6389 procedure Build_Derived_Access_Type
6390 (N : Node_Id;
6391 Parent_Type : Entity_Id;
6392 Derived_Type : Entity_Id)
6393 is
6394 S : constant Node_Id := Subtype_Indication (Type_Definition (N));
6395
6396 Desig_Type : Entity_Id;
6397 Discr : Entity_Id;
6398 Discr_Con_Elist : Elist_Id;
6399 Discr_Con_El : Elmt_Id;
6400 Subt : Entity_Id;
6401
6402 begin
6403 -- Set the designated type so it is available in case this is an access
6404 -- to a self-referential type, e.g. a standard list type with a next
6405 -- pointer. Will be reset after subtype is built.
6406
6407 Set_Directly_Designated_Type
6408 (Derived_Type, Designated_Type (Parent_Type));
6409
6410 Subt := Process_Subtype (S, N);
6411
6412 if Nkind (S) /= N_Subtype_Indication
6413 and then Subt /= Base_Type (Subt)
6414 then
6415 Set_Ekind (Derived_Type, E_Access_Subtype);
6416 end if;
6417
6418 if Ekind (Derived_Type) = E_Access_Subtype then
6419 declare
6420 Pbase : constant Entity_Id := Base_Type (Parent_Type);
6421 Ibase : constant Entity_Id :=
6422 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
6423 Svg_Chars : constant Name_Id := Chars (Ibase);
6424 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
6425
6426 begin
6427 Copy_Node (Pbase, Ibase);
6428
6429 -- Restore Itype status after Copy_Node
6430
6431 Set_Is_Itype (Ibase);
6432 Set_Associated_Node_For_Itype (Ibase, N);
6433
6434 Set_Chars (Ibase, Svg_Chars);
6435 Set_Next_Entity (Ibase, Svg_Next_E);
6436 Set_Sloc (Ibase, Sloc (Derived_Type));
6437 Set_Scope (Ibase, Scope (Derived_Type));
6438 Set_Freeze_Node (Ibase, Empty);
6439 Set_Is_Frozen (Ibase, False);
6440 Set_Comes_From_Source (Ibase, False);
6441 Set_Is_First_Subtype (Ibase, False);
6442
6443 Set_Etype (Ibase, Pbase);
6444 Set_Etype (Derived_Type, Ibase);
6445 end;
6446 end if;
6447
6448 Set_Directly_Designated_Type
6449 (Derived_Type, Designated_Type (Subt));
6450
6451 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt));
6452 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
6453 Set_Size_Info (Derived_Type, Parent_Type);
6454 Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
6455 Set_Depends_On_Private (Derived_Type,
6456 Has_Private_Component (Derived_Type));
6457 Conditional_Delay (Derived_Type, Subt);
6458
6459 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify
6460 -- that it is not redundant.
6461
6462 if Null_Exclusion_Present (Type_Definition (N)) then
6463 Set_Can_Never_Be_Null (Derived_Type);
6464
6465 elsif Can_Never_Be_Null (Parent_Type) then
6466 Set_Can_Never_Be_Null (Derived_Type);
6467 end if;
6468
6469 -- Note: we do not copy the Storage_Size_Variable, since we always go to
6470 -- the root type for this information.
6471
6472 -- Apply range checks to discriminants for derived record case
6473 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
6474
6475 Desig_Type := Designated_Type (Derived_Type);
6476
6477 if Is_Composite_Type (Desig_Type)
6478 and then (not Is_Array_Type (Desig_Type))
6479 and then Has_Discriminants (Desig_Type)
6480 and then Base_Type (Desig_Type) /= Desig_Type
6481 then
6482 Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
6483 Discr_Con_El := First_Elmt (Discr_Con_Elist);
6484
6485 Discr := First_Discriminant (Base_Type (Desig_Type));
6486 while Present (Discr_Con_El) loop
6487 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
6488 Next_Elmt (Discr_Con_El);
6489 Next_Discriminant (Discr);
6490 end loop;
6491 end if;
6492 end Build_Derived_Access_Type;
6493
6494 ------------------------------
6495 -- Build_Derived_Array_Type --
6496 ------------------------------
6497
6498 procedure Build_Derived_Array_Type
6499 (N : Node_Id;
6500 Parent_Type : Entity_Id;
6501 Derived_Type : Entity_Id)
6502 is
6503 Loc : constant Source_Ptr := Sloc (N);
6504 Tdef : constant Node_Id := Type_Definition (N);
6505 Indic : constant Node_Id := Subtype_Indication (Tdef);
6506 Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
6507 Implicit_Base : Entity_Id;
6508 New_Indic : Node_Id;
6509
6510 procedure Make_Implicit_Base;
6511 -- If the parent subtype is constrained, the derived type is a subtype
6512 -- of an implicit base type derived from the parent base.
6513
6514 ------------------------
6515 -- Make_Implicit_Base --
6516 ------------------------
6517
6518 procedure Make_Implicit_Base is
6519 begin
6520 Implicit_Base :=
6521 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
6522
6523 Set_Ekind (Implicit_Base, Ekind (Parent_Base));
6524 Set_Etype (Implicit_Base, Parent_Base);
6525
6526 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base);
6527 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
6528
6529 Set_Has_Delayed_Freeze (Implicit_Base, True);
6530 end Make_Implicit_Base;
6531
6532 -- Start of processing for Build_Derived_Array_Type
6533
6534 begin
6535 if not Is_Constrained (Parent_Type) then
6536 if Nkind (Indic) /= N_Subtype_Indication then
6537 Set_Ekind (Derived_Type, E_Array_Type);
6538
6539 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
6540 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
6541
6542 Set_Has_Delayed_Freeze (Derived_Type, True);
6543
6544 else
6545 Make_Implicit_Base;
6546 Set_Etype (Derived_Type, Implicit_Base);
6547
6548 New_Indic :=
6549 Make_Subtype_Declaration (Loc,
6550 Defining_Identifier => Derived_Type,
6551 Subtype_Indication =>
6552 Make_Subtype_Indication (Loc,
6553 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
6554 Constraint => Constraint (Indic)));
6555
6556 Rewrite (N, New_Indic);
6557 Analyze (N);
6558 end if;
6559
6560 else
6561 if Nkind (Indic) /= N_Subtype_Indication then
6562 Make_Implicit_Base;
6563
6564 Set_Ekind (Derived_Type, Ekind (Parent_Type));
6565 Set_Etype (Derived_Type, Implicit_Base);
6566 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
6567
6568 else
6569 Error_Msg_N ("illegal constraint on constrained type", Indic);
6570 end if;
6571 end if;
6572
6573 -- If parent type is not a derived type itself, and is declared in
6574 -- closed scope (e.g. a subprogram), then we must explicitly introduce
6575 -- the new type's concatenation operator since Derive_Subprograms
6576 -- will not inherit the parent's operator. If the parent type is
6577 -- unconstrained, the operator is of the unconstrained base type.
6578
6579 if Number_Dimensions (Parent_Type) = 1
6580 and then not Is_Limited_Type (Parent_Type)
6581 and then not Is_Derived_Type (Parent_Type)
6582 and then not Is_Package_Or_Generic_Package
6583 (Scope (Base_Type (Parent_Type)))
6584 then
6585 if not Is_Constrained (Parent_Type)
6586 and then Is_Constrained (Derived_Type)
6587 then
6588 New_Concatenation_Op (Implicit_Base);
6589 else
6590 New_Concatenation_Op (Derived_Type);
6591 end if;
6592 end if;
6593 end Build_Derived_Array_Type;
6594
6595 -----------------------------------
6596 -- Build_Derived_Concurrent_Type --
6597 -----------------------------------
6598
6599 procedure Build_Derived_Concurrent_Type
6600 (N : Node_Id;
6601 Parent_Type : Entity_Id;
6602 Derived_Type : Entity_Id)
6603 is
6604 Loc : constant Source_Ptr := Sloc (N);
6605
6606 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C');
6607 Corr_Decl : Node_Id;
6608 Corr_Decl_Needed : Boolean;
6609 -- If the derived type has fewer discriminants than its parent, the
6610 -- corresponding record is also a derived type, in order to account for
6611 -- the bound discriminants. We create a full type declaration for it in
6612 -- this case.
6613
6614 Constraint_Present : constant Boolean :=
6615 Nkind (Subtype_Indication (Type_Definition (N))) =
6616 N_Subtype_Indication;
6617
6618 D_Constraint : Node_Id;
6619 New_Constraint : Elist_Id;
6620 Old_Disc : Entity_Id;
6621 New_Disc : Entity_Id;
6622 New_N : Node_Id;
6623
6624 begin
6625 Set_Stored_Constraint (Derived_Type, No_Elist);
6626 Corr_Decl_Needed := False;
6627 Old_Disc := Empty;
6628
6629 if Present (Discriminant_Specifications (N))
6630 and then Constraint_Present
6631 then
6632 Old_Disc := First_Discriminant (Parent_Type);
6633 New_Disc := First (Discriminant_Specifications (N));
6634 while Present (New_Disc) and then Present (Old_Disc) loop
6635 Next_Discriminant (Old_Disc);
6636 Next (New_Disc);
6637 end loop;
6638 end if;
6639
6640 if Present (Old_Disc) and then Expander_Active then
6641
6642 -- The new type has fewer discriminants, so we need to create a new
6643 -- corresponding record, which is derived from the corresponding
6644 -- record of the parent, and has a stored constraint that captures
6645 -- the values of the discriminant constraints. The corresponding
6646 -- record is needed only if expander is active and code generation is
6647 -- enabled.
6648
6649 -- The type declaration for the derived corresponding record has the
6650 -- same discriminant part and constraints as the current declaration.
6651 -- Copy the unanalyzed tree to build declaration.
6652
6653 Corr_Decl_Needed := True;
6654 New_N := Copy_Separate_Tree (N);
6655
6656 Corr_Decl :=
6657 Make_Full_Type_Declaration (Loc,
6658 Defining_Identifier => Corr_Record,
6659 Discriminant_Specifications =>
6660 Discriminant_Specifications (New_N),
6661 Type_Definition =>
6662 Make_Derived_Type_Definition (Loc,
6663 Subtype_Indication =>
6664 Make_Subtype_Indication (Loc,
6665 Subtype_Mark =>
6666 New_Occurrence_Of
6667 (Corresponding_Record_Type (Parent_Type), Loc),
6668 Constraint =>
6669 Constraint
6670 (Subtype_Indication (Type_Definition (New_N))))));
6671 end if;
6672
6673 -- Copy Storage_Size and Relative_Deadline variables if task case
6674
6675 if Is_Task_Type (Parent_Type) then
6676 Set_Storage_Size_Variable (Derived_Type,
6677 Storage_Size_Variable (Parent_Type));
6678 Set_Relative_Deadline_Variable (Derived_Type,
6679 Relative_Deadline_Variable (Parent_Type));
6680 end if;
6681
6682 if Present (Discriminant_Specifications (N)) then
6683 Push_Scope (Derived_Type);
6684 Check_Or_Process_Discriminants (N, Derived_Type);
6685
6686 if Constraint_Present then
6687 New_Constraint :=
6688 Expand_To_Stored_Constraint
6689 (Parent_Type,
6690 Build_Discriminant_Constraints
6691 (Parent_Type,
6692 Subtype_Indication (Type_Definition (N)), True));
6693 end if;
6694
6695 End_Scope;
6696
6697 elsif Constraint_Present then
6698
6699 -- Build constrained subtype, copying the constraint, and derive
6700 -- from it to create a derived constrained type.
6701
6702 declare
6703 Loc : constant Source_Ptr := Sloc (N);
6704 Anon : constant Entity_Id :=
6705 Make_Defining_Identifier (Loc,
6706 Chars => New_External_Name (Chars (Derived_Type), 'T'));
6707 Decl : Node_Id;
6708
6709 begin
6710 Decl :=
6711 Make_Subtype_Declaration (Loc,
6712 Defining_Identifier => Anon,
6713 Subtype_Indication =>
6714 New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
6715 Insert_Before (N, Decl);
6716 Analyze (Decl);
6717
6718 Rewrite (Subtype_Indication (Type_Definition (N)),
6719 New_Occurrence_Of (Anon, Loc));
6720 Set_Analyzed (Derived_Type, False);
6721 Analyze (N);
6722 return;
6723 end;
6724 end if;
6725
6726 -- By default, operations and private data are inherited from parent.
6727 -- However, in the presence of bound discriminants, a new corresponding
6728 -- record will be created, see below.
6729
6730 Set_Has_Discriminants
6731 (Derived_Type, Has_Discriminants (Parent_Type));
6732 Set_Corresponding_Record_Type
6733 (Derived_Type, Corresponding_Record_Type (Parent_Type));
6734
6735 -- Is_Constrained is set according the parent subtype, but is set to
6736 -- False if the derived type is declared with new discriminants.
6737
6738 Set_Is_Constrained
6739 (Derived_Type,
6740 (Is_Constrained (Parent_Type) or else Constraint_Present)
6741 and then not Present (Discriminant_Specifications (N)));
6742
6743 if Constraint_Present then
6744 if not Has_Discriminants (Parent_Type) then
6745 Error_Msg_N ("untagged parent must have discriminants", N);
6746
6747 elsif Present (Discriminant_Specifications (N)) then
6748
6749 -- Verify that new discriminants are used to constrain old ones
6750
6751 D_Constraint :=
6752 First
6753 (Constraints
6754 (Constraint (Subtype_Indication (Type_Definition (N)))));
6755
6756 Old_Disc := First_Discriminant (Parent_Type);
6757
6758 while Present (D_Constraint) loop
6759 if Nkind (D_Constraint) /= N_Discriminant_Association then
6760
6761 -- Positional constraint. If it is a reference to a new
6762 -- discriminant, it constrains the corresponding old one.
6763
6764 if Nkind (D_Constraint) = N_Identifier then
6765 New_Disc := First_Discriminant (Derived_Type);
6766 while Present (New_Disc) loop
6767 exit when Chars (New_Disc) = Chars (D_Constraint);
6768 Next_Discriminant (New_Disc);
6769 end loop;
6770
6771 if Present (New_Disc) then
6772 Set_Corresponding_Discriminant (New_Disc, Old_Disc);
6773 end if;
6774 end if;
6775
6776 Next_Discriminant (Old_Disc);
6777
6778 -- if this is a named constraint, search by name for the old
6779 -- discriminants constrained by the new one.
6780
6781 elsif Nkind (Expression (D_Constraint)) = N_Identifier then
6782
6783 -- Find new discriminant with that name
6784
6785 New_Disc := First_Discriminant (Derived_Type);
6786 while Present (New_Disc) loop
6787 exit when
6788 Chars (New_Disc) = Chars (Expression (D_Constraint));
6789 Next_Discriminant (New_Disc);
6790 end loop;
6791
6792 if Present (New_Disc) then
6793
6794 -- Verify that new discriminant renames some discriminant
6795 -- of the parent type, and associate the new discriminant
6796 -- with one or more old ones that it renames.
6797
6798 declare
6799 Selector : Node_Id;
6800
6801 begin
6802 Selector := First (Selector_Names (D_Constraint));
6803 while Present (Selector) loop
6804 Old_Disc := First_Discriminant (Parent_Type);
6805 while Present (Old_Disc) loop
6806 exit when Chars (Old_Disc) = Chars (Selector);
6807 Next_Discriminant (Old_Disc);
6808 end loop;
6809
6810 if Present (Old_Disc) then
6811 Set_Corresponding_Discriminant
6812 (New_Disc, Old_Disc);
6813 end if;
6814
6815 Next (Selector);
6816 end loop;
6817 end;
6818 end if;
6819 end if;
6820
6821 Next (D_Constraint);
6822 end loop;
6823
6824 New_Disc := First_Discriminant (Derived_Type);
6825 while Present (New_Disc) loop
6826 if No (Corresponding_Discriminant (New_Disc)) then
6827 Error_Msg_NE
6828 ("new discriminant& must constrain old one", N, New_Disc);
6829
6830 elsif not
6831 Subtypes_Statically_Compatible
6832 (Etype (New_Disc),
6833 Etype (Corresponding_Discriminant (New_Disc)))
6834 then
6835 Error_Msg_NE
6836 ("& not statically compatible with parent discriminant",
6837 N, New_Disc);
6838 end if;
6839
6840 Next_Discriminant (New_Disc);
6841 end loop;
6842 end if;
6843
6844 elsif Present (Discriminant_Specifications (N)) then
6845 Error_Msg_N
6846 ("missing discriminant constraint in untagged derivation", N);
6847 end if;
6848
6849 -- The entity chain of the derived type includes the new discriminants
6850 -- but shares operations with the parent.
6851
6852 if Present (Discriminant_Specifications (N)) then
6853 Old_Disc := First_Discriminant (Parent_Type);
6854 while Present (Old_Disc) loop
6855 if No (Next_Entity (Old_Disc))
6856 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
6857 then
6858 Set_Next_Entity
6859 (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
6860 exit;
6861 end if;
6862
6863 Next_Discriminant (Old_Disc);
6864 end loop;
6865
6866 else
6867 Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
6868 if Has_Discriminants (Parent_Type) then
6869 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
6870 Set_Discriminant_Constraint (
6871 Derived_Type, Discriminant_Constraint (Parent_Type));
6872 end if;
6873 end if;
6874
6875 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
6876
6877 Set_Has_Completion (Derived_Type);
6878
6879 if Corr_Decl_Needed then
6880 Set_Stored_Constraint (Derived_Type, New_Constraint);
6881 Insert_After (N, Corr_Decl);
6882 Analyze (Corr_Decl);
6883 Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
6884 end if;
6885 end Build_Derived_Concurrent_Type;
6886
6887 ------------------------------------
6888 -- Build_Derived_Enumeration_Type --
6889 ------------------------------------
6890
6891 procedure Build_Derived_Enumeration_Type
6892 (N : Node_Id;
6893 Parent_Type : Entity_Id;
6894 Derived_Type : Entity_Id)
6895 is
6896 Loc : constant Source_Ptr := Sloc (N);
6897 Def : constant Node_Id := Type_Definition (N);
6898 Indic : constant Node_Id := Subtype_Indication (Def);
6899 Implicit_Base : Entity_Id;
6900 Literal : Entity_Id;
6901 New_Lit : Entity_Id;
6902 Literals_List : List_Id;
6903 Type_Decl : Node_Id;
6904 Hi, Lo : Node_Id;
6905 Rang_Expr : Node_Id;
6906
6907 begin
6908 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do
6909 -- not have explicit literals lists we need to process types derived
6910 -- from them specially. This is handled by Derived_Standard_Character.
6911 -- If the parent type is a generic type, there are no literals either,
6912 -- and we construct the same skeletal representation as for the generic
6913 -- parent type.
6914
6915 if Is_Standard_Character_Type (Parent_Type) then
6916 Derived_Standard_Character (N, Parent_Type, Derived_Type);
6917
6918 elsif Is_Generic_Type (Root_Type (Parent_Type)) then
6919 declare
6920 Lo : Node_Id;
6921 Hi : Node_Id;
6922
6923 begin
6924 if Nkind (Indic) /= N_Subtype_Indication then
6925 Lo :=
6926 Make_Attribute_Reference (Loc,
6927 Attribute_Name => Name_First,
6928 Prefix => New_Occurrence_Of (Derived_Type, Loc));
6929 Set_Etype (Lo, Derived_Type);
6930
6931 Hi :=
6932 Make_Attribute_Reference (Loc,
6933 Attribute_Name => Name_Last,
6934 Prefix => New_Occurrence_Of (Derived_Type, Loc));
6935 Set_Etype (Hi, Derived_Type);
6936
6937 Set_Scalar_Range (Derived_Type,
6938 Make_Range (Loc,
6939 Low_Bound => Lo,
6940 High_Bound => Hi));
6941 else
6942
6943 -- Analyze subtype indication and verify compatibility
6944 -- with parent type.
6945
6946 if Base_Type (Process_Subtype (Indic, N)) /=
6947 Base_Type (Parent_Type)
6948 then
6949 Error_Msg_N
6950 ("illegal constraint for formal discrete type", N);
6951 end if;
6952 end if;
6953 end;
6954
6955 else
6956 -- If a constraint is present, analyze the bounds to catch
6957 -- premature usage of the derived literals.
6958
6959 if Nkind (Indic) = N_Subtype_Indication
6960 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
6961 then
6962 Analyze (Low_Bound (Range_Expression (Constraint (Indic))));
6963 Analyze (High_Bound (Range_Expression (Constraint (Indic))));
6964 end if;
6965
6966 -- Introduce an implicit base type for the derived type even if there
6967 -- is no constraint attached to it, since this seems closer to the
6968 -- Ada semantics. Build a full type declaration tree for the derived
6969 -- type using the implicit base type as the defining identifier. The
6970 -- build a subtype declaration tree which applies the constraint (if
6971 -- any) have it replace the derived type declaration.
6972
6973 Literal := First_Literal (Parent_Type);
6974 Literals_List := New_List;
6975 while Present (Literal)
6976 and then Ekind (Literal) = E_Enumeration_Literal
6977 loop
6978 -- Literals of the derived type have the same representation as
6979 -- those of the parent type, but this representation can be
6980 -- overridden by an explicit representation clause. Indicate
6981 -- that there is no explicit representation given yet. These
6982 -- derived literals are implicit operations of the new type,
6983 -- and can be overridden by explicit ones.
6984
6985 if Nkind (Literal) = N_Defining_Character_Literal then
6986 New_Lit :=
6987 Make_Defining_Character_Literal (Loc, Chars (Literal));
6988 else
6989 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
6990 end if;
6991
6992 Set_Ekind (New_Lit, E_Enumeration_Literal);
6993 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal));
6994 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal));
6995 Set_Enumeration_Rep_Expr (New_Lit, Empty);
6996 Set_Alias (New_Lit, Literal);
6997 Set_Is_Known_Valid (New_Lit, True);
6998
6999 Append (New_Lit, Literals_List);
7000 Next_Literal (Literal);
7001 end loop;
7002
7003 Implicit_Base :=
7004 Make_Defining_Identifier (Sloc (Derived_Type),
7005 Chars => New_External_Name (Chars (Derived_Type), 'B'));
7006
7007 -- Indicate the proper nature of the derived type. This must be done
7008 -- before analysis of the literals, to recognize cases when a literal
7009 -- may be hidden by a previous explicit function definition (cf.
7010 -- c83031a).
7011
7012 Set_Ekind (Derived_Type, E_Enumeration_Subtype);
7013 Set_Etype (Derived_Type, Implicit_Base);
7014
7015 Type_Decl :=
7016 Make_Full_Type_Declaration (Loc,
7017 Defining_Identifier => Implicit_Base,
7018 Discriminant_Specifications => No_List,
7019 Type_Definition =>
7020 Make_Enumeration_Type_Definition (Loc, Literals_List));
7021
7022 Mark_Rewrite_Insertion (Type_Decl);
7023 Insert_Before (N, Type_Decl);
7024 Analyze (Type_Decl);
7025
7026 -- The anonymous base now has a full declaration, but this base
7027 -- is not a first subtype.
7028
7029 Set_Is_First_Subtype (Implicit_Base, False);
7030
7031 -- After the implicit base is analyzed its Etype needs to be changed
7032 -- to reflect the fact that it is derived from the parent type which
7033 -- was ignored during analysis. We also set the size at this point.
7034
7035 Set_Etype (Implicit_Base, Parent_Type);
7036
7037 Set_Size_Info (Implicit_Base, Parent_Type);
7038 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type));
7039 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
7040
7041 -- Copy other flags from parent type
7042
7043 Set_Has_Non_Standard_Rep
7044 (Implicit_Base, Has_Non_Standard_Rep
7045 (Parent_Type));
7046 Set_Has_Pragma_Ordered
7047 (Implicit_Base, Has_Pragma_Ordered
7048 (Parent_Type));
7049 Set_Has_Delayed_Freeze (Implicit_Base);
7050
7051 -- Process the subtype indication including a validation check on the
7052 -- constraint, if any. If a constraint is given, its bounds must be
7053 -- implicitly converted to the new type.
7054
7055 if Nkind (Indic) = N_Subtype_Indication then
7056 declare
7057 R : constant Node_Id :=
7058 Range_Expression (Constraint (Indic));
7059
7060 begin
7061 if Nkind (R) = N_Range then
7062 Hi := Build_Scalar_Bound
7063 (High_Bound (R), Parent_Type, Implicit_Base);
7064 Lo := Build_Scalar_Bound
7065 (Low_Bound (R), Parent_Type, Implicit_Base);
7066
7067 else
7068 -- Constraint is a Range attribute. Replace with explicit
7069 -- mention of the bounds of the prefix, which must be a
7070 -- subtype.
7071
7072 Analyze (Prefix (R));
7073 Hi :=
7074 Convert_To (Implicit_Base,
7075 Make_Attribute_Reference (Loc,
7076 Attribute_Name => Name_Last,
7077 Prefix =>
7078 New_Occurrence_Of (Entity (Prefix (R)), Loc)));
7079
7080 Lo :=
7081 Convert_To (Implicit_Base,
7082 Make_Attribute_Reference (Loc,
7083 Attribute_Name => Name_First,
7084 Prefix =>
7085 New_Occurrence_Of (Entity (Prefix (R)), Loc)));
7086 end if;
7087 end;
7088
7089 else
7090 Hi :=
7091 Build_Scalar_Bound
7092 (Type_High_Bound (Parent_Type),
7093 Parent_Type, Implicit_Base);
7094 Lo :=
7095 Build_Scalar_Bound
7096 (Type_Low_Bound (Parent_Type),
7097 Parent_Type, Implicit_Base);
7098 end if;
7099
7100 Rang_Expr :=
7101 Make_Range (Loc,
7102 Low_Bound => Lo,
7103 High_Bound => Hi);
7104
7105 -- If we constructed a default range for the case where no range
7106 -- was given, then the expressions in the range must not freeze
7107 -- since they do not correspond to expressions in the source.
7108 -- However, if the type inherits predicates the expressions will
7109 -- be elaborated earlier and must freeze.
7110
7111 if Nkind (Indic) /= N_Subtype_Indication
7112 and then not Has_Predicates (Derived_Type)
7113 then
7114 Set_Must_Not_Freeze (Lo);
7115 Set_Must_Not_Freeze (Hi);
7116 Set_Must_Not_Freeze (Rang_Expr);
7117 end if;
7118
7119 Rewrite (N,
7120 Make_Subtype_Declaration (Loc,
7121 Defining_Identifier => Derived_Type,
7122 Subtype_Indication =>
7123 Make_Subtype_Indication (Loc,
7124 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
7125 Constraint =>
7126 Make_Range_Constraint (Loc,
7127 Range_Expression => Rang_Expr))));
7128
7129 Analyze (N);
7130
7131 -- Propagate the aspects from the original type declaration to the
7132 -- declaration of the implicit base.
7133
7134 Move_Aspects (From => Original_Node (N), To => Type_Decl);
7135
7136 -- Apply a range check. Since this range expression doesn't have an
7137 -- Etype, we have to specifically pass the Source_Typ parameter. Is
7138 -- this right???
7139
7140 if Nkind (Indic) = N_Subtype_Indication then
7141 Apply_Range_Check
7142 (Range_Expression (Constraint (Indic)), Parent_Type,
7143 Source_Typ => Entity (Subtype_Mark (Indic)));
7144 end if;
7145 end if;
7146 end Build_Derived_Enumeration_Type;
7147
7148 --------------------------------
7149 -- Build_Derived_Numeric_Type --
7150 --------------------------------
7151
7152 procedure Build_Derived_Numeric_Type
7153 (N : Node_Id;
7154 Parent_Type : Entity_Id;
7155 Derived_Type : Entity_Id)
7156 is
7157 Loc : constant Source_Ptr := Sloc (N);
7158 Tdef : constant Node_Id := Type_Definition (N);
7159 Indic : constant Node_Id := Subtype_Indication (Tdef);
7160 Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
7161 No_Constraint : constant Boolean := Nkind (Indic) /=
7162 N_Subtype_Indication;
7163 Implicit_Base : Entity_Id;
7164
7165 Lo : Node_Id;
7166 Hi : Node_Id;
7167
7168 begin
7169 -- Process the subtype indication including a validation check on
7170 -- the constraint if any.
7171
7172 Discard_Node (Process_Subtype (Indic, N));
7173
7174 -- Introduce an implicit base type for the derived type even if there
7175 -- is no constraint attached to it, since this seems closer to the Ada
7176 -- semantics.
7177
7178 Implicit_Base :=
7179 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
7180
7181 Set_Etype (Implicit_Base, Parent_Base);
7182 Set_Ekind (Implicit_Base, Ekind (Parent_Base));
7183 Set_Size_Info (Implicit_Base, Parent_Base);
7184 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
7185 Set_Parent (Implicit_Base, Parent (Derived_Type));
7186 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base));
7187
7188 -- Set RM Size for discrete type or decimal fixed-point type
7189 -- Ordinary fixed-point is excluded, why???
7190
7191 if Is_Discrete_Type (Parent_Base)
7192 or else Is_Decimal_Fixed_Point_Type (Parent_Base)
7193 then
7194 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
7195 end if;
7196
7197 Set_Has_Delayed_Freeze (Implicit_Base);
7198
7199 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
7200 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
7201
7202 Set_Scalar_Range (Implicit_Base,
7203 Make_Range (Loc,
7204 Low_Bound => Lo,
7205 High_Bound => Hi));
7206
7207 if Has_Infinities (Parent_Base) then
7208 Set_Includes_Infinities (Scalar_Range (Implicit_Base));
7209 end if;
7210
7211 -- The Derived_Type, which is the entity of the declaration, is a
7212 -- subtype of the implicit base. Its Ekind is a subtype, even in the
7213 -- absence of an explicit constraint.
7214
7215 Set_Etype (Derived_Type, Implicit_Base);
7216
7217 -- If we did not have a constraint, then the Ekind is set from the
7218 -- parent type (otherwise Process_Subtype has set the bounds)
7219
7220 if No_Constraint then
7221 Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
7222 end if;
7223
7224 -- If we did not have a range constraint, then set the range from the
7225 -- parent type. Otherwise, the Process_Subtype call has set the bounds.
7226
7227 if No_Constraint or else not Has_Range_Constraint (Indic) then
7228 Set_Scalar_Range (Derived_Type,
7229 Make_Range (Loc,
7230 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)),
7231 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
7232 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
7233
7234 if Has_Infinities (Parent_Type) then
7235 Set_Includes_Infinities (Scalar_Range (Derived_Type));
7236 end if;
7237
7238 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
7239 end if;
7240
7241 Set_Is_Descendant_Of_Address (Derived_Type,
7242 Is_Descendant_Of_Address (Parent_Type));
7243 Set_Is_Descendant_Of_Address (Implicit_Base,
7244 Is_Descendant_Of_Address (Parent_Type));
7245
7246 -- Set remaining type-specific fields, depending on numeric type
7247
7248 if Is_Modular_Integer_Type (Parent_Type) then
7249 Set_Modulus (Implicit_Base, Modulus (Parent_Base));
7250
7251 Set_Non_Binary_Modulus
7252 (Implicit_Base, Non_Binary_Modulus (Parent_Base));
7253
7254 Set_Is_Known_Valid
7255 (Implicit_Base, Is_Known_Valid (Parent_Base));
7256
7257 elsif Is_Floating_Point_Type (Parent_Type) then
7258
7259 -- Digits of base type is always copied from the digits value of
7260 -- the parent base type, but the digits of the derived type will
7261 -- already have been set if there was a constraint present.
7262
7263 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
7264 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base));
7265
7266 if No_Constraint then
7267 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
7268 end if;
7269
7270 elsif Is_Fixed_Point_Type (Parent_Type) then
7271
7272 -- Small of base type and derived type are always copied from the
7273 -- parent base type, since smalls never change. The delta of the
7274 -- base type is also copied from the parent base type. However the
7275 -- delta of the derived type will have been set already if a
7276 -- constraint was present.
7277
7278 Set_Small_Value (Derived_Type, Small_Value (Parent_Base));
7279 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
7280 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
7281
7282 if No_Constraint then
7283 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type));
7284 end if;
7285
7286 -- The scale and machine radix in the decimal case are always
7287 -- copied from the parent base type.
7288
7289 if Is_Decimal_Fixed_Point_Type (Parent_Type) then
7290 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base));
7291 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
7292
7293 Set_Machine_Radix_10
7294 (Derived_Type, Machine_Radix_10 (Parent_Base));
7295 Set_Machine_Radix_10
7296 (Implicit_Base, Machine_Radix_10 (Parent_Base));
7297
7298 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
7299
7300 if No_Constraint then
7301 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
7302
7303 else
7304 -- the analysis of the subtype_indication sets the
7305 -- digits value of the derived type.
7306
7307 null;
7308 end if;
7309 end if;
7310 end if;
7311
7312 if Is_Integer_Type (Parent_Type) then
7313 Set_Has_Shift_Operator
7314 (Implicit_Base, Has_Shift_Operator (Parent_Type));
7315 end if;
7316
7317 -- The type of the bounds is that of the parent type, and they
7318 -- must be converted to the derived type.
7319
7320 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
7321
7322 -- The implicit_base should be frozen when the derived type is frozen,
7323 -- but note that it is used in the conversions of the bounds. For fixed
7324 -- types we delay the determination of the bounds until the proper
7325 -- freezing point. For other numeric types this is rejected by GCC, for
7326 -- reasons that are currently unclear (???), so we choose to freeze the
7327 -- implicit base now. In the case of integers and floating point types
7328 -- this is harmless because subsequent representation clauses cannot
7329 -- affect anything, but it is still baffling that we cannot use the
7330 -- same mechanism for all derived numeric types.
7331
7332 -- There is a further complication: actually some representation
7333 -- clauses can affect the implicit base type. For example, attribute
7334 -- definition clauses for stream-oriented attributes need to set the
7335 -- corresponding TSS entries on the base type, and this normally
7336 -- cannot be done after the base type is frozen, so the circuitry in
7337 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility
7338 -- and not use Set_TSS in this case.
7339
7340 -- There are also consequences for the case of delayed representation
7341 -- aspects for some cases. For example, a Size aspect is delayed and
7342 -- should not be evaluated to the freeze point. This early freezing
7343 -- means that the size attribute evaluation happens too early???
7344
7345 if Is_Fixed_Point_Type (Parent_Type) then
7346 Conditional_Delay (Implicit_Base, Parent_Type);
7347 else
7348 Freeze_Before (N, Implicit_Base);
7349 end if;
7350 end Build_Derived_Numeric_Type;
7351
7352 --------------------------------
7353 -- Build_Derived_Private_Type --
7354 --------------------------------
7355
7356 procedure Build_Derived_Private_Type
7357 (N : Node_Id;
7358 Parent_Type : Entity_Id;
7359 Derived_Type : Entity_Id;
7360 Is_Completion : Boolean;
7361 Derive_Subps : Boolean := True)
7362 is
7363 Loc : constant Source_Ptr := Sloc (N);
7364 Par_Base : constant Entity_Id := Base_Type (Parent_Type);
7365 Par_Scope : constant Entity_Id := Scope (Par_Base);
7366 Full_N : constant Node_Id := New_Copy_Tree (N);
7367 Full_Der : Entity_Id := New_Copy (Derived_Type);
7368 Full_P : Entity_Id;
7369
7370 procedure Build_Full_Derivation;
7371 -- Build full derivation, i.e. derive from the full view
7372
7373 procedure Copy_And_Build;
7374 -- Copy derived type declaration, replace parent with its full view,
7375 -- and build derivation
7376
7377 ---------------------------
7378 -- Build_Full_Derivation --
7379 ---------------------------
7380
7381 procedure Build_Full_Derivation is
7382 begin
7383 -- If parent scope is not open, install the declarations
7384
7385 if not In_Open_Scopes (Par_Scope) then
7386 Install_Private_Declarations (Par_Scope);
7387 Install_Visible_Declarations (Par_Scope);
7388 Copy_And_Build;
7389 Uninstall_Declarations (Par_Scope);
7390
7391 -- If parent scope is open and in another unit, and parent has a
7392 -- completion, then the derivation is taking place in the visible
7393 -- part of a child unit. In that case retrieve the full view of
7394 -- the parent momentarily.
7395
7396 elsif not In_Same_Source_Unit (N, Parent_Type) then
7397 Full_P := Full_View (Parent_Type);
7398 Exchange_Declarations (Parent_Type);
7399 Copy_And_Build;
7400 Exchange_Declarations (Full_P);
7401
7402 -- Otherwise it is a local derivation
7403
7404 else
7405 Copy_And_Build;
7406 end if;
7407 end Build_Full_Derivation;
7408
7409 --------------------
7410 -- Copy_And_Build --
7411 --------------------
7412
7413 procedure Copy_And_Build is
7414 Full_Parent : Entity_Id := Parent_Type;
7415
7416 begin
7417 -- If the parent is itself derived from another private type,
7418 -- installing the private declarations has not affected its
7419 -- privacy status, so use its own full view explicitly.
7420
7421 if Is_Private_Type (Full_Parent)
7422 and then Present (Full_View (Full_Parent))
7423 then
7424 Full_Parent := Full_View (Full_Parent);
7425 end if;
7426
7427 -- And its underlying full view if necessary
7428
7429 if Is_Private_Type (Full_Parent)
7430 and then Present (Underlying_Full_View (Full_Parent))
7431 then
7432 Full_Parent := Underlying_Full_View (Full_Parent);
7433 end if;
7434
7435 -- For record, access and most enumeration types, derivation from
7436 -- the full view requires a fully-fledged declaration. In the other
7437 -- cases, just use an itype.
7438
7439 if Ekind (Full_Parent) in Record_Kind
7440 or else Ekind (Full_Parent) in Access_Kind
7441 or else
7442 (Ekind (Full_Parent) in Enumeration_Kind
7443 and then not Is_Standard_Character_Type (Full_Parent)
7444 and then not Is_Generic_Type (Root_Type (Full_Parent)))
7445 then
7446 -- Copy and adjust declaration to provide a completion for what
7447 -- is originally a private declaration. Indicate that full view
7448 -- is internally generated.
7449
7450 Set_Comes_From_Source (Full_N, False);
7451 Set_Comes_From_Source (Full_Der, False);
7452 Set_Parent (Full_Der, Full_N);
7453 Set_Defining_Identifier (Full_N, Full_Der);
7454
7455 -- If there are no constraints, adjust the subtype mark
7456
7457 if Nkind (Subtype_Indication (Type_Definition (Full_N))) /=
7458 N_Subtype_Indication
7459 then
7460 Set_Subtype_Indication
7461 (Type_Definition (Full_N),
7462 New_Occurrence_Of (Full_Parent, Sloc (Full_N)));
7463 end if;
7464
7465 Insert_After (N, Full_N);
7466
7467 -- Build full view of derived type from full view of parent which
7468 -- is now installed. Subprograms have been derived on the partial
7469 -- view, the completion does not derive them anew.
7470
7471 if Ekind (Full_Parent) in Record_Kind then
7472
7473 -- If parent type is tagged, the completion inherits the proper
7474 -- primitive operations.
7475
7476 if Is_Tagged_Type (Parent_Type) then
7477 Build_Derived_Record_Type
7478 (Full_N, Full_Parent, Full_Der, Derive_Subps);
7479 else
7480 Build_Derived_Record_Type
7481 (Full_N, Full_Parent, Full_Der, Derive_Subps => False);
7482 end if;
7483
7484 else
7485 Build_Derived_Type
7486 (Full_N, Full_Parent, Full_Der,
7487 Is_Completion => False, Derive_Subps => False);
7488 end if;
7489
7490 -- The full declaration has been introduced into the tree and
7491 -- processed in the step above. It should not be analyzed again
7492 -- (when encountered later in the current list of declarations)
7493 -- to prevent spurious name conflicts. The full entity remains
7494 -- invisible.
7495
7496 Set_Analyzed (Full_N);
7497
7498 else
7499 Full_Der :=
7500 Make_Defining_Identifier (Sloc (Derived_Type),
7501 Chars => Chars (Derived_Type));
7502 Set_Is_Itype (Full_Der);
7503 Set_Associated_Node_For_Itype (Full_Der, N);
7504 Set_Parent (Full_Der, N);
7505 Build_Derived_Type
7506 (N, Full_Parent, Full_Der,
7507 Is_Completion => False, Derive_Subps => False);
7508 end if;
7509
7510 Set_Has_Private_Declaration (Full_Der);
7511 Set_Has_Private_Declaration (Derived_Type);
7512
7513 Set_Scope (Full_Der, Scope (Derived_Type));
7514 Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type));
7515 Set_Has_Size_Clause (Full_Der, False);
7516 Set_Has_Alignment_Clause (Full_Der, False);
7517 Set_Has_Delayed_Freeze (Full_Der);
7518 Set_Is_Frozen (Full_Der, False);
7519 Set_Freeze_Node (Full_Der, Empty);
7520 Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der));
7521 Set_Is_Public (Full_Der, Is_Public (Derived_Type));
7522
7523 -- The convention on the base type may be set in the private part
7524 -- and not propagated to the subtype until later, so we obtain the
7525 -- convention from the base type of the parent.
7526
7527 Set_Convention (Full_Der, Convention (Base_Type (Full_Parent)));
7528 end Copy_And_Build;
7529
7530 -- Start of processing for Build_Derived_Private_Type
7531
7532 begin
7533 if Is_Tagged_Type (Parent_Type) then
7534 Full_P := Full_View (Parent_Type);
7535
7536 -- A type extension of a type with unknown discriminants is an
7537 -- indefinite type that the back-end cannot handle directly.
7538 -- We treat it as a private type, and build a completion that is
7539 -- derived from the full view of the parent, and hopefully has
7540 -- known discriminants.
7541
7542 -- If the full view of the parent type has an underlying record view,
7543 -- use it to generate the underlying record view of this derived type
7544 -- (required for chains of derivations with unknown discriminants).
7545
7546 -- Minor optimization: we avoid the generation of useless underlying
7547 -- record view entities if the private type declaration has unknown
7548 -- discriminants but its corresponding full view has no
7549 -- discriminants.
7550
7551 if Has_Unknown_Discriminants (Parent_Type)
7552 and then Present (Full_P)
7553 and then (Has_Discriminants (Full_P)
7554 or else Present (Underlying_Record_View (Full_P)))
7555 and then not In_Open_Scopes (Par_Scope)
7556 and then Expander_Active
7557 then
7558 declare
7559 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T');
7560 New_Ext : constant Node_Id :=
7561 Copy_Separate_Tree
7562 (Record_Extension_Part (Type_Definition (N)));
7563 Decl : Node_Id;
7564
7565 begin
7566 Build_Derived_Record_Type
7567 (N, Parent_Type, Derived_Type, Derive_Subps);
7568
7569 -- Build anonymous completion, as a derivation from the full
7570 -- view of the parent. This is not a completion in the usual
7571 -- sense, because the current type is not private.
7572
7573 Decl :=
7574 Make_Full_Type_Declaration (Loc,
7575 Defining_Identifier => Full_Der,
7576 Type_Definition =>
7577 Make_Derived_Type_Definition (Loc,
7578 Subtype_Indication =>
7579 New_Copy_Tree
7580 (Subtype_Indication (Type_Definition (N))),
7581 Record_Extension_Part => New_Ext));
7582
7583 -- If the parent type has an underlying record view, use it
7584 -- here to build the new underlying record view.
7585
7586 if Present (Underlying_Record_View (Full_P)) then
7587 pragma Assert
7588 (Nkind (Subtype_Indication (Type_Definition (Decl)))
7589 = N_Identifier);
7590 Set_Entity (Subtype_Indication (Type_Definition (Decl)),
7591 Underlying_Record_View (Full_P));
7592 end if;
7593
7594 Install_Private_Declarations (Par_Scope);
7595 Install_Visible_Declarations (Par_Scope);
7596 Insert_Before (N, Decl);
7597
7598 -- Mark entity as an underlying record view before analysis,
7599 -- to avoid generating the list of its primitive operations
7600 -- (which is not really required for this entity) and thus
7601 -- prevent spurious errors associated with missing overriding
7602 -- of abstract primitives (overridden only for Derived_Type).
7603
7604 Set_Ekind (Full_Der, E_Record_Type);
7605 Set_Is_Underlying_Record_View (Full_Der);
7606 Set_Default_SSO (Full_Der);
7607
7608 Analyze (Decl);
7609
7610 pragma Assert (Has_Discriminants (Full_Der)
7611 and then not Has_Unknown_Discriminants (Full_Der));
7612
7613 Uninstall_Declarations (Par_Scope);
7614
7615 -- Freeze the underlying record view, to prevent generation of
7616 -- useless dispatching information, which is simply shared with
7617 -- the real derived type.
7618
7619 Set_Is_Frozen (Full_Der);
7620
7621 -- If the derived type has access discriminants, create
7622 -- references to their anonymous types now, to prevent
7623 -- back-end problems when their first use is in generated
7624 -- bodies of primitives.
7625
7626 declare
7627 E : Entity_Id;
7628
7629 begin
7630 E := First_Entity (Full_Der);
7631
7632 while Present (E) loop
7633 if Ekind (E) = E_Discriminant
7634 and then Ekind (Etype (E)) = E_Anonymous_Access_Type
7635 then
7636 Build_Itype_Reference (Etype (E), Decl);
7637 end if;
7638
7639 Next_Entity (E);
7640 end loop;
7641 end;
7642
7643 -- Set up links between real entity and underlying record view
7644
7645 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
7646 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
7647 end;
7648
7649 -- If discriminants are known, build derived record
7650
7651 else
7652 Build_Derived_Record_Type
7653 (N, Parent_Type, Derived_Type, Derive_Subps);
7654 end if;
7655
7656 return;
7657
7658 elsif Has_Discriminants (Parent_Type) then
7659
7660 -- Build partial view of derived type from partial view of parent.
7661 -- This must be done before building the full derivation because the
7662 -- second derivation will modify the discriminants of the first and
7663 -- the discriminants are chained with the rest of the components in
7664 -- the full derivation.
7665
7666 Build_Derived_Record_Type
7667 (N, Parent_Type, Derived_Type, Derive_Subps);
7668
7669 -- Build the full derivation if this is not the anonymous derived
7670 -- base type created by Build_Derived_Record_Type in the constrained
7671 -- case (see point 5. of its head comment) since we build it for the
7672 -- derived subtype. And skip it for protected types altogether, as
7673 -- gigi does not use these types directly.
7674
7675 if Present (Full_View (Parent_Type))
7676 and then not Is_Itype (Derived_Type)
7677 and then not (Ekind (Full_View (Parent_Type)) in Protected_Kind)
7678 then
7679 declare
7680 Der_Base : constant Entity_Id := Base_Type (Derived_Type);
7681 Discr : Entity_Id;
7682 Last_Discr : Entity_Id;
7683
7684 begin
7685 -- If this is not a completion, construct the implicit full
7686 -- view by deriving from the full view of the parent type.
7687 -- But if this is a completion, the derived private type
7688 -- being built is a full view and the full derivation can
7689 -- only be its underlying full view.
7690
7691 Build_Full_Derivation;
7692
7693 if not Is_Completion then
7694 Set_Full_View (Derived_Type, Full_Der);
7695 else
7696 Set_Underlying_Full_View (Derived_Type, Full_Der);
7697 Set_Is_Underlying_Full_View (Full_Der);
7698 end if;
7699
7700 if not Is_Base_Type (Derived_Type) then
7701 Set_Full_View (Der_Base, Base_Type (Full_Der));
7702 end if;
7703
7704 -- Copy the discriminant list from full view to the partial
7705 -- view (base type and its subtype). Gigi requires that the
7706 -- partial and full views have the same discriminants.
7707
7708 -- Note that since the partial view points to discriminants
7709 -- in the full view, their scope will be that of the full
7710 -- view. This might cause some front end problems and need
7711 -- adjustment???
7712
7713 Discr := First_Discriminant (Base_Type (Full_Der));
7714 Set_First_Entity (Der_Base, Discr);
7715
7716 loop
7717 Last_Discr := Discr;
7718 Next_Discriminant (Discr);
7719 exit when No (Discr);
7720 end loop;
7721
7722 Set_Last_Entity (Der_Base, Last_Discr);
7723 Set_First_Entity (Derived_Type, First_Entity (Der_Base));
7724 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
7725
7726 Set_Stored_Constraint
7727 (Full_Der, Stored_Constraint (Derived_Type));
7728 end;
7729 end if;
7730
7731 elsif Present (Full_View (Parent_Type))
7732 and then Has_Discriminants (Full_View (Parent_Type))
7733 then
7734 if Has_Unknown_Discriminants (Parent_Type)
7735 and then Nkind (Subtype_Indication (Type_Definition (N))) =
7736 N_Subtype_Indication
7737 then
7738 Error_Msg_N
7739 ("cannot constrain type with unknown discriminants",
7740 Subtype_Indication (Type_Definition (N)));
7741 return;
7742 end if;
7743
7744 -- If this is not a completion, construct the implicit full view by
7745 -- deriving from the full view of the parent type. But if this is a
7746 -- completion, the derived private type being built is a full view
7747 -- and the full derivation can only be its underlying full view.
7748
7749 Build_Full_Derivation;
7750
7751 if not Is_Completion then
7752 Set_Full_View (Derived_Type, Full_Der);
7753 else
7754 Set_Underlying_Full_View (Derived_Type, Full_Der);
7755 Set_Is_Underlying_Full_View (Full_Der);
7756 end if;
7757
7758 -- In any case, the primitive operations are inherited from the
7759 -- parent type, not from the internal full view.
7760
7761 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
7762
7763 if Derive_Subps then
7764 Derive_Subprograms (Parent_Type, Derived_Type);
7765 end if;
7766
7767 Set_Stored_Constraint (Derived_Type, No_Elist);
7768 Set_Is_Constrained
7769 (Derived_Type, Is_Constrained (Full_View (Parent_Type)));
7770
7771 else
7772 -- Untagged type, No discriminants on either view
7773
7774 if Nkind (Subtype_Indication (Type_Definition (N))) =
7775 N_Subtype_Indication
7776 then
7777 Error_Msg_N
7778 ("illegal constraint on type without discriminants", N);
7779 end if;
7780
7781 if Present (Discriminant_Specifications (N))
7782 and then Present (Full_View (Parent_Type))
7783 and then not Is_Tagged_Type (Full_View (Parent_Type))
7784 then
7785 Error_Msg_N ("cannot add discriminants to untagged type", N);
7786 end if;
7787
7788 Set_Stored_Constraint (Derived_Type, No_Elist);
7789 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
7790 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
7791 Set_Disable_Controlled (Derived_Type, Disable_Controlled
7792 (Parent_Type));
7793 Set_Has_Controlled_Component
7794 (Derived_Type, Has_Controlled_Component
7795 (Parent_Type));
7796
7797 -- Direct controlled types do not inherit Finalize_Storage_Only flag
7798
7799 if not Is_Controlled_Active (Parent_Type) then
7800 Set_Finalize_Storage_Only
7801 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
7802 end if;
7803
7804 -- If this is not a completion, construct the implicit full view by
7805 -- deriving from the full view of the parent type.
7806
7807 -- ??? If the parent is untagged private and its completion is
7808 -- tagged, this mechanism will not work because we cannot derive from
7809 -- the tagged full view unless we have an extension.
7810
7811 if Present (Full_View (Parent_Type))
7812 and then not Is_Tagged_Type (Full_View (Parent_Type))
7813 and then not Is_Completion
7814 then
7815 Build_Full_Derivation;
7816 Set_Full_View (Derived_Type, Full_Der);
7817 end if;
7818 end if;
7819
7820 Set_Has_Unknown_Discriminants (Derived_Type,
7821 Has_Unknown_Discriminants (Parent_Type));
7822
7823 if Is_Private_Type (Derived_Type) then
7824 Set_Private_Dependents (Derived_Type, New_Elmt_List);
7825 end if;
7826
7827 -- If the parent base type is in scope, add the derived type to its
7828 -- list of private dependents, because its full view may become
7829 -- visible subsequently (in a nested private part, a body, or in a
7830 -- further child unit).
7831
7832 if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then
7833 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
7834
7835 -- Check for unusual case where a type completed by a private
7836 -- derivation occurs within a package nested in a child unit, and
7837 -- the parent is declared in an ancestor.
7838
7839 if Is_Child_Unit (Scope (Current_Scope))
7840 and then Is_Completion
7841 and then In_Private_Part (Current_Scope)
7842 and then Scope (Parent_Type) /= Current_Scope
7843
7844 -- Note that if the parent has a completion in the private part,
7845 -- (which is itself a derivation from some other private type)
7846 -- it is that completion that is visible, there is no full view
7847 -- available, and no special processing is needed.
7848
7849 and then Present (Full_View (Parent_Type))
7850 then
7851 -- In this case, the full view of the parent type will become
7852 -- visible in the body of the enclosing child, and only then will
7853 -- the current type be possibly non-private. Build an underlying
7854 -- full view that will be installed when the enclosing child body
7855 -- is compiled.
7856
7857 if Present (Underlying_Full_View (Derived_Type)) then
7858 Full_Der := Underlying_Full_View (Derived_Type);
7859 else
7860 Build_Full_Derivation;
7861 Set_Underlying_Full_View (Derived_Type, Full_Der);
7862 Set_Is_Underlying_Full_View (Full_Der);
7863 end if;
7864
7865 -- The full view will be used to swap entities on entry/exit to
7866 -- the body, and must appear in the entity list for the package.
7867
7868 Append_Entity (Full_Der, Scope (Derived_Type));
7869 end if;
7870 end if;
7871 end Build_Derived_Private_Type;
7872
7873 -------------------------------
7874 -- Build_Derived_Record_Type --
7875 -------------------------------
7876
7877 -- 1. INTRODUCTION
7878
7879 -- Ideally we would like to use the same model of type derivation for
7880 -- tagged and untagged record types. Unfortunately this is not quite
7881 -- possible because the semantics of representation clauses is different
7882 -- for tagged and untagged records under inheritance. Consider the
7883 -- following:
7884
7885 -- type R (...) is [tagged] record ... end record;
7886 -- type T (...) is new R (...) [with ...];
7887
7888 -- The representation clauses for T can specify a completely different
7889 -- record layout from R's. Hence the same component can be placed in two
7890 -- very different positions in objects of type T and R. If R and T are
7891 -- tagged types, representation clauses for T can only specify the layout
7892 -- of non inherited components, thus components that are common in R and T
7893 -- have the same position in objects of type R and T.
7894
7895 -- This has two implications. The first is that the entire tree for R's
7896 -- declaration needs to be copied for T in the untagged case, so that T
7897 -- can be viewed as a record type of its own with its own representation
7898 -- clauses. The second implication is the way we handle discriminants.
7899 -- Specifically, in the untagged case we need a way to communicate to Gigi
7900 -- what are the real discriminants in the record, while for the semantics
7901 -- we need to consider those introduced by the user to rename the
7902 -- discriminants in the parent type. This is handled by introducing the
7903 -- notion of stored discriminants. See below for more.
7904
7905 -- Fortunately the way regular components are inherited can be handled in
7906 -- the same way in tagged and untagged types.
7907
7908 -- To complicate things a bit more the private view of a private extension
7909 -- cannot be handled in the same way as the full view (for one thing the
7910 -- semantic rules are somewhat different). We will explain what differs
7911 -- below.
7912
7913 -- 2. DISCRIMINANTS UNDER INHERITANCE
7914
7915 -- The semantic rules governing the discriminants of derived types are
7916 -- quite subtle.
7917
7918 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
7919 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
7920
7921 -- If parent type has discriminants, then the discriminants that are
7922 -- declared in the derived type are [3.4 (11)]:
7923
7924 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
7925 -- there is one;
7926
7927 -- o Otherwise, each discriminant of the parent type (implicitly declared
7928 -- in the same order with the same specifications). In this case, the
7929 -- discriminants are said to be "inherited", or if unknown in the parent
7930 -- are also unknown in the derived type.
7931
7932 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
7933
7934 -- o The parent subtype must be constrained;
7935
7936 -- o If the parent type is not a tagged type, then each discriminant of
7937 -- the derived type must be used in the constraint defining a parent
7938 -- subtype. [Implementation note: This ensures that the new discriminant
7939 -- can share storage with an existing discriminant.]
7940
7941 -- For the derived type each discriminant of the parent type is either
7942 -- inherited, constrained to equal some new discriminant of the derived
7943 -- type, or constrained to the value of an expression.
7944
7945 -- When inherited or constrained to equal some new discriminant, the
7946 -- parent discriminant and the discriminant of the derived type are said
7947 -- to "correspond".
7948
7949 -- If a discriminant of the parent type is constrained to a specific value
7950 -- in the derived type definition, then the discriminant is said to be
7951 -- "specified" by that derived type definition.
7952
7953 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
7954
7955 -- We have spoken about stored discriminants in point 1 (introduction)
7956 -- above. There are two sort of stored discriminants: implicit and
7957 -- explicit. As long as the derived type inherits the same discriminants as
7958 -- the root record type, stored discriminants are the same as regular
7959 -- discriminants, and are said to be implicit. However, if any discriminant
7960 -- in the root type was renamed in the derived type, then the derived
7961 -- type will contain explicit stored discriminants. Explicit stored
7962 -- discriminants are discriminants in addition to the semantically visible
7963 -- discriminants defined for the derived type. Stored discriminants are
7964 -- used by Gigi to figure out what are the physical discriminants in
7965 -- objects of the derived type (see precise definition in einfo.ads).
7966 -- As an example, consider the following:
7967
7968 -- type R (D1, D2, D3 : Int) is record ... end record;
7969 -- type T1 is new R;
7970 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
7971 -- type T3 is new T2;
7972 -- type T4 (Y : Int) is new T3 (Y, 99);
7973
7974 -- The following table summarizes the discriminants and stored
7975 -- discriminants in R and T1 through T4.
7976
7977 -- Type Discrim Stored Discrim Comment
7978 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
7979 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
7980 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
7981 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
7982 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
7983
7984 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
7985 -- find the corresponding discriminant in the parent type, while
7986 -- Original_Record_Component (abbreviated ORC below), the actual physical
7987 -- component that is renamed. Finally the field Is_Completely_Hidden
7988 -- (abbreviated ICH below) is set for all explicit stored discriminants
7989 -- (see einfo.ads for more info). For the above example this gives:
7990
7991 -- Discrim CD ORC ICH
7992 -- ^^^^^^^ ^^ ^^^ ^^^
7993 -- D1 in R empty itself no
7994 -- D2 in R empty itself no
7995 -- D3 in R empty itself no
7996
7997 -- D1 in T1 D1 in R itself no
7998 -- D2 in T1 D2 in R itself no
7999 -- D3 in T1 D3 in R itself no
8000
8001 -- X1 in T2 D3 in T1 D3 in T2 no
8002 -- X2 in T2 D1 in T1 D1 in T2 no
8003 -- D1 in T2 empty itself yes
8004 -- D2 in T2 empty itself yes
8005 -- D3 in T2 empty itself yes
8006
8007 -- X1 in T3 X1 in T2 D3 in T3 no
8008 -- X2 in T3 X2 in T2 D1 in T3 no
8009 -- D1 in T3 empty itself yes
8010 -- D2 in T3 empty itself yes
8011 -- D3 in T3 empty itself yes
8012
8013 -- Y in T4 X1 in T3 D3 in T3 no
8014 -- D1 in T3 empty itself yes
8015 -- D2 in T3 empty itself yes
8016 -- D3 in T3 empty itself yes
8017
8018 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
8019
8020 -- Type derivation for tagged types is fairly straightforward. If no
8021 -- discriminants are specified by the derived type, these are inherited
8022 -- from the parent. No explicit stored discriminants are ever necessary.
8023 -- The only manipulation that is done to the tree is that of adding a
8024 -- _parent field with parent type and constrained to the same constraint
8025 -- specified for the parent in the derived type definition. For instance:
8026
8027 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
8028 -- type T1 is new R with null record;
8029 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
8030
8031 -- are changed into:
8032
8033 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
8034 -- _parent : R (D1, D2, D3);
8035 -- end record;
8036
8037 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
8038 -- _parent : T1 (X2, 88, X1);
8039 -- end record;
8040
8041 -- The discriminants actually present in R, T1 and T2 as well as their CD,
8042 -- ORC and ICH fields are:
8043
8044 -- Discrim CD ORC ICH
8045 -- ^^^^^^^ ^^ ^^^ ^^^
8046 -- D1 in R empty itself no
8047 -- D2 in R empty itself no
8048 -- D3 in R empty itself no
8049
8050 -- D1 in T1 D1 in R D1 in R no
8051 -- D2 in T1 D2 in R D2 in R no
8052 -- D3 in T1 D3 in R D3 in R no
8053
8054 -- X1 in T2 D3 in T1 D3 in R no
8055 -- X2 in T2 D1 in T1 D1 in R no
8056
8057 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
8058 --
8059 -- Regardless of whether we dealing with a tagged or untagged type
8060 -- we will transform all derived type declarations of the form
8061 --
8062 -- type T is new R (...) [with ...];
8063 -- or
8064 -- subtype S is R (...);
8065 -- type T is new S [with ...];
8066 -- into
8067 -- type BT is new R [with ...];
8068 -- subtype T is BT (...);
8069 --
8070 -- That is, the base derived type is constrained only if it has no
8071 -- discriminants. The reason for doing this is that GNAT's semantic model
8072 -- assumes that a base type with discriminants is unconstrained.
8073 --
8074 -- Note that, strictly speaking, the above transformation is not always
8075 -- correct. Consider for instance the following excerpt from ACVC b34011a:
8076 --
8077 -- procedure B34011A is
8078 -- type REC (D : integer := 0) is record
8079 -- I : Integer;
8080 -- end record;
8081
8082 -- package P is
8083 -- type T6 is new Rec;
8084 -- function F return T6;
8085 -- end P;
8086
8087 -- use P;
8088 -- package Q6 is
8089 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
8090 -- end Q6;
8091 --
8092 -- The definition of Q6.U is illegal. However transforming Q6.U into
8093
8094 -- type BaseU is new T6;
8095 -- subtype U is BaseU (Q6.F.I)
8096
8097 -- turns U into a legal subtype, which is incorrect. To avoid this problem
8098 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
8099 -- the transformation described above.
8100
8101 -- There is another instance where the above transformation is incorrect.
8102 -- Consider:
8103
8104 -- package Pack is
8105 -- type Base (D : Integer) is tagged null record;
8106 -- procedure P (X : Base);
8107
8108 -- type Der is new Base (2) with null record;
8109 -- procedure P (X : Der);
8110 -- end Pack;
8111
8112 -- Then the above transformation turns this into
8113
8114 -- type Der_Base is new Base with null record;
8115 -- -- procedure P (X : Base) is implicitly inherited here
8116 -- -- as procedure P (X : Der_Base).
8117
8118 -- subtype Der is Der_Base (2);
8119 -- procedure P (X : Der);
8120 -- -- The overriding of P (X : Der_Base) is illegal since we
8121 -- -- have a parameter conformance problem.
8122
8123 -- To get around this problem, after having semantically processed Der_Base
8124 -- and the rewritten subtype declaration for Der, we copy Der_Base field
8125 -- Discriminant_Constraint from Der so that when parameter conformance is
8126 -- checked when P is overridden, no semantic errors are flagged.
8127
8128 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
8129
8130 -- Regardless of whether we are dealing with a tagged or untagged type
8131 -- we will transform all derived type declarations of the form
8132
8133 -- type R (D1, .., Dn : ...) is [tagged] record ...;
8134 -- type T is new R [with ...];
8135 -- into
8136 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
8137
8138 -- The reason for such transformation is that it allows us to implement a
8139 -- very clean form of component inheritance as explained below.
8140
8141 -- Note that this transformation is not achieved by direct tree rewriting
8142 -- and manipulation, but rather by redoing the semantic actions that the
8143 -- above transformation will entail. This is done directly in routine
8144 -- Inherit_Components.
8145
8146 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
8147
8148 -- In both tagged and untagged derived types, regular non discriminant
8149 -- components are inherited in the derived type from the parent type. In
8150 -- the absence of discriminants component, inheritance is straightforward
8151 -- as components can simply be copied from the parent.
8152
8153 -- If the parent has discriminants, inheriting components constrained with
8154 -- these discriminants requires caution. Consider the following example:
8155
8156 -- type R (D1, D2 : Positive) is [tagged] record
8157 -- S : String (D1 .. D2);
8158 -- end record;
8159
8160 -- type T1 is new R [with null record];
8161 -- type T2 (X : positive) is new R (1, X) [with null record];
8162
8163 -- As explained in 6. above, T1 is rewritten as
8164 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
8165 -- which makes the treatment for T1 and T2 identical.
8166
8167 -- What we want when inheriting S, is that references to D1 and D2 in R are
8168 -- replaced with references to their correct constraints, i.e. D1 and D2 in
8169 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
8170 -- with either discriminant references in the derived type or expressions.
8171 -- This replacement is achieved as follows: before inheriting R's
8172 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
8173 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
8174 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
8175 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
8176 -- by String (1 .. X).
8177
8178 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
8179
8180 -- We explain here the rules governing private type extensions relevant to
8181 -- type derivation. These rules are explained on the following example:
8182
8183 -- type D [(...)] is new A [(...)] with private; <-- partial view
8184 -- type D [(...)] is new P [(...)] with null record; <-- full view
8185
8186 -- Type A is called the ancestor subtype of the private extension.
8187 -- Type P is the parent type of the full view of the private extension. It
8188 -- must be A or a type derived from A.
8189
8190 -- The rules concerning the discriminants of private type extensions are
8191 -- [7.3(10-13)]:
8192
8193 -- o If a private extension inherits known discriminants from the ancestor
8194 -- subtype, then the full view must also inherit its discriminants from
8195 -- the ancestor subtype and the parent subtype of the full view must be
8196 -- constrained if and only if the ancestor subtype is constrained.
8197
8198 -- o If a partial view has unknown discriminants, then the full view may
8199 -- define a definite or an indefinite subtype, with or without
8200 -- discriminants.
8201
8202 -- o If a partial view has neither known nor unknown discriminants, then
8203 -- the full view must define a definite subtype.
8204
8205 -- o If the ancestor subtype of a private extension has constrained
8206 -- discriminants, then the parent subtype of the full view must impose a
8207 -- statically matching constraint on those discriminants.
8208
8209 -- This means that only the following forms of private extensions are
8210 -- allowed:
8211
8212 -- type D is new A with private; <-- partial view
8213 -- type D is new P with null record; <-- full view
8214
8215 -- If A has no discriminants than P has no discriminants, otherwise P must
8216 -- inherit A's discriminants.
8217
8218 -- type D is new A (...) with private; <-- partial view
8219 -- type D is new P (:::) with null record; <-- full view
8220
8221 -- P must inherit A's discriminants and (...) and (:::) must statically
8222 -- match.
8223
8224 -- subtype A is R (...);
8225 -- type D is new A with private; <-- partial view
8226 -- type D is new P with null record; <-- full view
8227
8228 -- P must have inherited R's discriminants and must be derived from A or
8229 -- any of its subtypes.
8230
8231 -- type D (..) is new A with private; <-- partial view
8232 -- type D (..) is new P [(:::)] with null record; <-- full view
8233
8234 -- No specific constraints on P's discriminants or constraint (:::).
8235 -- Note that A can be unconstrained, but the parent subtype P must either
8236 -- be constrained or (:::) must be present.
8237
8238 -- type D (..) is new A [(...)] with private; <-- partial view
8239 -- type D (..) is new P [(:::)] with null record; <-- full view
8240
8241 -- P's constraints on A's discriminants must statically match those
8242 -- imposed by (...).
8243
8244 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
8245
8246 -- The full view of a private extension is handled exactly as described
8247 -- above. The model chose for the private view of a private extension is
8248 -- the same for what concerns discriminants (i.e. they receive the same
8249 -- treatment as in the tagged case). However, the private view of the
8250 -- private extension always inherits the components of the parent base,
8251 -- without replacing any discriminant reference. Strictly speaking this is
8252 -- incorrect. However, Gigi never uses this view to generate code so this
8253 -- is a purely semantic issue. In theory, a set of transformations similar
8254 -- to those given in 5. and 6. above could be applied to private views of
8255 -- private extensions to have the same model of component inheritance as
8256 -- for non private extensions. However, this is not done because it would
8257 -- further complicate private type processing. Semantically speaking, this
8258 -- leaves us in an uncomfortable situation. As an example consider:
8259
8260 -- package Pack is
8261 -- type R (D : integer) is tagged record
8262 -- S : String (1 .. D);
8263 -- end record;
8264 -- procedure P (X : R);
8265 -- type T is new R (1) with private;
8266 -- private
8267 -- type T is new R (1) with null record;
8268 -- end;
8269
8270 -- This is transformed into:
8271
8272 -- package Pack is
8273 -- type R (D : integer) is tagged record
8274 -- S : String (1 .. D);
8275 -- end record;
8276 -- procedure P (X : R);
8277 -- type T is new R (1) with private;
8278 -- private
8279 -- type BaseT is new R with null record;
8280 -- subtype T is BaseT (1);
8281 -- end;
8282
8283 -- (strictly speaking the above is incorrect Ada)
8284
8285 -- From the semantic standpoint the private view of private extension T
8286 -- should be flagged as constrained since one can clearly have
8287 --
8288 -- Obj : T;
8289 --
8290 -- in a unit withing Pack. However, when deriving subprograms for the
8291 -- private view of private extension T, T must be seen as unconstrained
8292 -- since T has discriminants (this is a constraint of the current
8293 -- subprogram derivation model). Thus, when processing the private view of
8294 -- a private extension such as T, we first mark T as unconstrained, we
8295 -- process it, we perform program derivation and just before returning from
8296 -- Build_Derived_Record_Type we mark T as constrained.
8297
8298 -- ??? Are there are other uncomfortable cases that we will have to
8299 -- deal with.
8300
8301 -- 10. RECORD_TYPE_WITH_PRIVATE complications
8302
8303 -- Types that are derived from a visible record type and have a private
8304 -- extension present other peculiarities. They behave mostly like private
8305 -- types, but if they have primitive operations defined, these will not
8306 -- have the proper signatures for further inheritance, because other
8307 -- primitive operations will use the implicit base that we define for
8308 -- private derivations below. This affect subprogram inheritance (see
8309 -- Derive_Subprograms for details). We also derive the implicit base from
8310 -- the base type of the full view, so that the implicit base is a record
8311 -- type and not another private type, This avoids infinite loops.
8312
8313 procedure Build_Derived_Record_Type
8314 (N : Node_Id;
8315 Parent_Type : Entity_Id;
8316 Derived_Type : Entity_Id;
8317 Derive_Subps : Boolean := True)
8318 is
8319 Discriminant_Specs : constant Boolean :=
8320 Present (Discriminant_Specifications (N));
8321 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type);
8322 Loc : constant Source_Ptr := Sloc (N);
8323 Private_Extension : constant Boolean :=
8324 Nkind (N) = N_Private_Extension_Declaration;
8325 Assoc_List : Elist_Id;
8326 Constraint_Present : Boolean;
8327 Constrs : Elist_Id;
8328 Discrim : Entity_Id;
8329 Indic : Node_Id;
8330 Inherit_Discrims : Boolean := False;
8331 Last_Discrim : Entity_Id;
8332 New_Base : Entity_Id;
8333 New_Decl : Node_Id;
8334 New_Discrs : Elist_Id;
8335 New_Indic : Node_Id;
8336 Parent_Base : Entity_Id;
8337 Save_Etype : Entity_Id;
8338 Save_Discr_Constr : Elist_Id;
8339 Save_Next_Entity : Entity_Id;
8340 Type_Def : Node_Id;
8341
8342 Discs : Elist_Id := New_Elmt_List;
8343 -- An empty Discs list means that there were no constraints in the
8344 -- subtype indication or that there was an error processing it.
8345
8346 begin
8347 if Ekind (Parent_Type) = E_Record_Type_With_Private
8348 and then Present (Full_View (Parent_Type))
8349 and then Has_Discriminants (Parent_Type)
8350 then
8351 Parent_Base := Base_Type (Full_View (Parent_Type));
8352 else
8353 Parent_Base := Base_Type (Parent_Type);
8354 end if;
8355
8356 -- AI05-0115 : if this is a derivation from a private type in some
8357 -- other scope that may lead to invisible components for the derived
8358 -- type, mark it accordingly.
8359
8360 if Is_Private_Type (Parent_Type) then
8361 if Scope (Parent_Type) = Scope (Derived_Type) then
8362 null;
8363
8364 elsif In_Open_Scopes (Scope (Parent_Type))
8365 and then In_Private_Part (Scope (Parent_Type))
8366 then
8367 null;
8368
8369 else
8370 Set_Has_Private_Ancestor (Derived_Type);
8371 end if;
8372
8373 else
8374 Set_Has_Private_Ancestor
8375 (Derived_Type, Has_Private_Ancestor (Parent_Type));
8376 end if;
8377
8378 -- Before we start the previously documented transformations, here is
8379 -- little fix for size and alignment of tagged types. Normally when we
8380 -- derive type D from type P, we copy the size and alignment of P as the
8381 -- default for D, and in the absence of explicit representation clauses
8382 -- for D, the size and alignment are indeed the same as the parent.
8383
8384 -- But this is wrong for tagged types, since fields may be added, and
8385 -- the default size may need to be larger, and the default alignment may
8386 -- need to be larger.
8387
8388 -- We therefore reset the size and alignment fields in the tagged case.
8389 -- Note that the size and alignment will in any case be at least as
8390 -- large as the parent type (since the derived type has a copy of the
8391 -- parent type in the _parent field)
8392
8393 -- The type is also marked as being tagged here, which is needed when
8394 -- processing components with a self-referential anonymous access type
8395 -- in the call to Check_Anonymous_Access_Components below. Note that
8396 -- this flag is also set later on for completeness.
8397
8398 if Is_Tagged then
8399 Set_Is_Tagged_Type (Derived_Type);
8400 Init_Size_Align (Derived_Type);
8401 end if;
8402
8403 -- STEP 0a: figure out what kind of derived type declaration we have
8404
8405 if Private_Extension then
8406 Type_Def := N;
8407 Set_Ekind (Derived_Type, E_Record_Type_With_Private);
8408 Set_Default_SSO (Derived_Type);
8409
8410 else
8411 Type_Def := Type_Definition (N);
8412
8413 -- Ekind (Parent_Base) is not necessarily E_Record_Type since
8414 -- Parent_Base can be a private type or private extension. However,
8415 -- for tagged types with an extension the newly added fields are
8416 -- visible and hence the Derived_Type is always an E_Record_Type.
8417 -- (except that the parent may have its own private fields).
8418 -- For untagged types we preserve the Ekind of the Parent_Base.
8419
8420 if Present (Record_Extension_Part (Type_Def)) then
8421 Set_Ekind (Derived_Type, E_Record_Type);
8422 Set_Default_SSO (Derived_Type);
8423
8424 -- Create internal access types for components with anonymous
8425 -- access types.
8426
8427 if Ada_Version >= Ada_2005 then
8428 Check_Anonymous_Access_Components
8429 (N, Derived_Type, Derived_Type,
8430 Component_List (Record_Extension_Part (Type_Def)));
8431 end if;
8432
8433 else
8434 Set_Ekind (Derived_Type, Ekind (Parent_Base));
8435 end if;
8436 end if;
8437
8438 -- Indic can either be an N_Identifier if the subtype indication
8439 -- contains no constraint or an N_Subtype_Indication if the subtype
8440 -- indication has a constraint.
8441
8442 Indic := Subtype_Indication (Type_Def);
8443 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
8444
8445 -- Check that the type has visible discriminants. The type may be
8446 -- a private type with unknown discriminants whose full view has
8447 -- discriminants which are invisible.
8448
8449 if Constraint_Present then
8450 if not Has_Discriminants (Parent_Base)
8451 or else
8452 (Has_Unknown_Discriminants (Parent_Base)
8453 and then Is_Private_Type (Parent_Base))
8454 then
8455 Error_Msg_N
8456 ("invalid constraint: type has no discriminant",
8457 Constraint (Indic));
8458
8459 Constraint_Present := False;
8460 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
8461
8462 elsif Is_Constrained (Parent_Type) then
8463 Error_Msg_N
8464 ("invalid constraint: parent type is already constrained",
8465 Constraint (Indic));
8466
8467 Constraint_Present := False;
8468 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
8469 end if;
8470 end if;
8471
8472 -- STEP 0b: If needed, apply transformation given in point 5. above
8473
8474 if not Private_Extension
8475 and then Has_Discriminants (Parent_Type)
8476 and then not Discriminant_Specs
8477 and then (Is_Constrained (Parent_Type) or else Constraint_Present)
8478 then
8479 -- First, we must analyze the constraint (see comment in point 5.)
8480 -- The constraint may come from the subtype indication of the full
8481 -- declaration.
8482
8483 if Constraint_Present then
8484 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
8485
8486 -- If there is no explicit constraint, there might be one that is
8487 -- inherited from a constrained parent type. In that case verify that
8488 -- it conforms to the constraint in the partial view. In perverse
8489 -- cases the parent subtypes of the partial and full view can have
8490 -- different constraints.
8491
8492 elsif Present (Stored_Constraint (Parent_Type)) then
8493 New_Discrs := Stored_Constraint (Parent_Type);
8494
8495 else
8496 New_Discrs := No_Elist;
8497 end if;
8498
8499 if Has_Discriminants (Derived_Type)
8500 and then Has_Private_Declaration (Derived_Type)
8501 and then Present (Discriminant_Constraint (Derived_Type))
8502 and then Present (New_Discrs)
8503 then
8504 -- Verify that constraints of the full view statically match
8505 -- those given in the partial view.
8506
8507 declare
8508 C1, C2 : Elmt_Id;
8509
8510 begin
8511 C1 := First_Elmt (New_Discrs);
8512 C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
8513 while Present (C1) and then Present (C2) loop
8514 if Fully_Conformant_Expressions (Node (C1), Node (C2))
8515 or else
8516 (Is_OK_Static_Expression (Node (C1))
8517 and then Is_OK_Static_Expression (Node (C2))
8518 and then
8519 Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
8520 then
8521 null;
8522
8523 else
8524 if Constraint_Present then
8525 Error_Msg_N
8526 ("constraint not conformant to previous declaration",
8527 Node (C1));
8528 else
8529 Error_Msg_N
8530 ("constraint of full view is incompatible "
8531 & "with partial view", N);
8532 end if;
8533 end if;
8534
8535 Next_Elmt (C1);
8536 Next_Elmt (C2);
8537 end loop;
8538 end;
8539 end if;
8540
8541 -- Insert and analyze the declaration for the unconstrained base type
8542
8543 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
8544
8545 New_Decl :=
8546 Make_Full_Type_Declaration (Loc,
8547 Defining_Identifier => New_Base,
8548 Type_Definition =>
8549 Make_Derived_Type_Definition (Loc,
8550 Abstract_Present => Abstract_Present (Type_Def),
8551 Limited_Present => Limited_Present (Type_Def),
8552 Subtype_Indication =>
8553 New_Occurrence_Of (Parent_Base, Loc),
8554 Record_Extension_Part =>
8555 Relocate_Node (Record_Extension_Part (Type_Def)),
8556 Interface_List => Interface_List (Type_Def)));
8557
8558 Set_Parent (New_Decl, Parent (N));
8559 Mark_Rewrite_Insertion (New_Decl);
8560 Insert_Before (N, New_Decl);
8561
8562 -- In the extension case, make sure ancestor is frozen appropriately
8563 -- (see also non-discriminated case below).
8564
8565 if Present (Record_Extension_Part (Type_Def))
8566 or else Is_Interface (Parent_Base)
8567 then
8568 Freeze_Before (New_Decl, Parent_Type);
8569 end if;
8570
8571 -- Note that this call passes False for the Derive_Subps parameter
8572 -- because subprogram derivation is deferred until after creating
8573 -- the subtype (see below).
8574
8575 Build_Derived_Type
8576 (New_Decl, Parent_Base, New_Base,
8577 Is_Completion => False, Derive_Subps => False);
8578
8579 -- ??? This needs re-examination to determine whether the
8580 -- above call can simply be replaced by a call to Analyze.
8581
8582 Set_Analyzed (New_Decl);
8583
8584 -- Insert and analyze the declaration for the constrained subtype
8585
8586 if Constraint_Present then
8587 New_Indic :=
8588 Make_Subtype_Indication (Loc,
8589 Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
8590 Constraint => Relocate_Node (Constraint (Indic)));
8591
8592 else
8593 declare
8594 Constr_List : constant List_Id := New_List;
8595 C : Elmt_Id;
8596 Expr : Node_Id;
8597
8598 begin
8599 C := First_Elmt (Discriminant_Constraint (Parent_Type));
8600 while Present (C) loop
8601 Expr := Node (C);
8602
8603 -- It is safe here to call New_Copy_Tree since we called
8604 -- Force_Evaluation on each constraint previously
8605 -- in Build_Discriminant_Constraints.
8606
8607 Append (New_Copy_Tree (Expr), To => Constr_List);
8608
8609 Next_Elmt (C);
8610 end loop;
8611
8612 New_Indic :=
8613 Make_Subtype_Indication (Loc,
8614 Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
8615 Constraint =>
8616 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
8617 end;
8618 end if;
8619
8620 Rewrite (N,
8621 Make_Subtype_Declaration (Loc,
8622 Defining_Identifier => Derived_Type,
8623 Subtype_Indication => New_Indic));
8624
8625 Analyze (N);
8626
8627 -- Derivation of subprograms must be delayed until the full subtype
8628 -- has been established, to ensure proper overriding of subprograms
8629 -- inherited by full types. If the derivations occurred as part of
8630 -- the call to Build_Derived_Type above, then the check for type
8631 -- conformance would fail because earlier primitive subprograms
8632 -- could still refer to the full type prior the change to the new
8633 -- subtype and hence would not match the new base type created here.
8634 -- Subprograms are not derived, however, when Derive_Subps is False
8635 -- (since otherwise there could be redundant derivations).
8636
8637 if Derive_Subps then
8638 Derive_Subprograms (Parent_Type, Derived_Type);
8639 end if;
8640
8641 -- For tagged types the Discriminant_Constraint of the new base itype
8642 -- is inherited from the first subtype so that no subtype conformance
8643 -- problem arise when the first subtype overrides primitive
8644 -- operations inherited by the implicit base type.
8645
8646 if Is_Tagged then
8647 Set_Discriminant_Constraint
8648 (New_Base, Discriminant_Constraint (Derived_Type));
8649 end if;
8650
8651 return;
8652 end if;
8653
8654 -- If we get here Derived_Type will have no discriminants or it will be
8655 -- a discriminated unconstrained base type.
8656
8657 -- STEP 1a: perform preliminary actions/checks for derived tagged types
8658
8659 if Is_Tagged then
8660
8661 -- The parent type is frozen for non-private extensions (RM 13.14(7))
8662 -- The declaration of a specific descendant of an interface type
8663 -- freezes the interface type (RM 13.14).
8664
8665 if not Private_Extension or else Is_Interface (Parent_Base) then
8666 Freeze_Before (N, Parent_Type);
8667 end if;
8668
8669 -- In Ada 2005 (AI-344), the restriction that a derived tagged type
8670 -- cannot be declared at a deeper level than its parent type is
8671 -- removed. The check on derivation within a generic body is also
8672 -- relaxed, but there's a restriction that a derived tagged type
8673 -- cannot be declared in a generic body if it's derived directly
8674 -- or indirectly from a formal type of that generic.
8675
8676 if Ada_Version >= Ada_2005 then
8677 if Present (Enclosing_Generic_Body (Derived_Type)) then
8678 declare
8679 Ancestor_Type : Entity_Id;
8680
8681 begin
8682 -- Check to see if any ancestor of the derived type is a
8683 -- formal type.
8684
8685 Ancestor_Type := Parent_Type;
8686 while not Is_Generic_Type (Ancestor_Type)
8687 and then Etype (Ancestor_Type) /= Ancestor_Type
8688 loop
8689 Ancestor_Type := Etype (Ancestor_Type);
8690 end loop;
8691
8692 -- If the derived type does have a formal type as an
8693 -- ancestor, then it's an error if the derived type is
8694 -- declared within the body of the generic unit that
8695 -- declares the formal type in its generic formal part. It's
8696 -- sufficient to check whether the ancestor type is declared
8697 -- inside the same generic body as the derived type (such as
8698 -- within a nested generic spec), in which case the
8699 -- derivation is legal. If the formal type is declared
8700 -- outside of that generic body, then it's guaranteed that
8701 -- the derived type is declared within the generic body of
8702 -- the generic unit declaring the formal type.
8703
8704 if Is_Generic_Type (Ancestor_Type)
8705 and then Enclosing_Generic_Body (Ancestor_Type) /=
8706 Enclosing_Generic_Body (Derived_Type)
8707 then
8708 Error_Msg_NE
8709 ("parent type of& must not be descendant of formal type"
8710 & " of an enclosing generic body",
8711 Indic, Derived_Type);
8712 end if;
8713 end;
8714 end if;
8715
8716 elsif Type_Access_Level (Derived_Type) /=
8717 Type_Access_Level (Parent_Type)
8718 and then not Is_Generic_Type (Derived_Type)
8719 then
8720 if Is_Controlled (Parent_Type) then
8721 Error_Msg_N
8722 ("controlled type must be declared at the library level",
8723 Indic);
8724 else
8725 Error_Msg_N
8726 ("type extension at deeper accessibility level than parent",
8727 Indic);
8728 end if;
8729
8730 else
8731 declare
8732 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
8733 begin
8734 if Present (GB)
8735 and then GB /= Enclosing_Generic_Body (Parent_Base)
8736 then
8737 Error_Msg_NE
8738 ("parent type of& must not be outside generic body"
8739 & " (RM 3.9.1(4))",
8740 Indic, Derived_Type);
8741 end if;
8742 end;
8743 end if;
8744 end if;
8745
8746 -- Ada 2005 (AI-251)
8747
8748 if Ada_Version >= Ada_2005 and then Is_Tagged then
8749
8750 -- "The declaration of a specific descendant of an interface type
8751 -- freezes the interface type" (RM 13.14).
8752
8753 declare
8754 Iface : Node_Id;
8755 begin
8756 if Is_Non_Empty_List (Interface_List (Type_Def)) then
8757 Iface := First (Interface_List (Type_Def));
8758 while Present (Iface) loop
8759 Freeze_Before (N, Etype (Iface));
8760 Next (Iface);
8761 end loop;
8762 end if;
8763 end;
8764 end if;
8765
8766 -- STEP 1b : preliminary cleanup of the full view of private types
8767
8768 -- If the type is already marked as having discriminants, then it's the
8769 -- completion of a private type or private extension and we need to
8770 -- retain the discriminants from the partial view if the current
8771 -- declaration has Discriminant_Specifications so that we can verify
8772 -- conformance. However, we must remove any existing components that
8773 -- were inherited from the parent (and attached in Copy_And_Swap)
8774 -- because the full type inherits all appropriate components anyway, and
8775 -- we do not want the partial view's components interfering.
8776
8777 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
8778 Discrim := First_Discriminant (Derived_Type);
8779 loop
8780 Last_Discrim := Discrim;
8781 Next_Discriminant (Discrim);
8782 exit when No (Discrim);
8783 end loop;
8784
8785 Set_Last_Entity (Derived_Type, Last_Discrim);
8786
8787 -- In all other cases wipe out the list of inherited components (even
8788 -- inherited discriminants), it will be properly rebuilt here.
8789
8790 else
8791 Set_First_Entity (Derived_Type, Empty);
8792 Set_Last_Entity (Derived_Type, Empty);
8793 end if;
8794
8795 -- STEP 1c: Initialize some flags for the Derived_Type
8796
8797 -- The following flags must be initialized here so that
8798 -- Process_Discriminants can check that discriminants of tagged types do
8799 -- not have a default initial value and that access discriminants are
8800 -- only specified for limited records. For completeness, these flags are
8801 -- also initialized along with all the other flags below.
8802
8803 -- AI-419: Limitedness is not inherited from an interface parent, so to
8804 -- be limited in that case the type must be explicitly declared as
8805 -- limited. However, task and protected interfaces are always limited.
8806
8807 if Limited_Present (Type_Def) then
8808 Set_Is_Limited_Record (Derived_Type);
8809
8810 elsif Is_Limited_Record (Parent_Type)
8811 or else (Present (Full_View (Parent_Type))
8812 and then Is_Limited_Record (Full_View (Parent_Type)))
8813 then
8814 if not Is_Interface (Parent_Type)
8815 or else Is_Synchronized_Interface (Parent_Type)
8816 or else Is_Protected_Interface (Parent_Type)
8817 or else Is_Task_Interface (Parent_Type)
8818 then
8819 Set_Is_Limited_Record (Derived_Type);
8820 end if;
8821 end if;
8822
8823 -- STEP 2a: process discriminants of derived type if any
8824
8825 Push_Scope (Derived_Type);
8826
8827 if Discriminant_Specs then
8828 Set_Has_Unknown_Discriminants (Derived_Type, False);
8829
8830 -- The following call initializes fields Has_Discriminants and
8831 -- Discriminant_Constraint, unless we are processing the completion
8832 -- of a private type declaration.
8833
8834 Check_Or_Process_Discriminants (N, Derived_Type);
8835
8836 -- For untagged types, the constraint on the Parent_Type must be
8837 -- present and is used to rename the discriminants.
8838
8839 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
8840 Error_Msg_N ("untagged parent must have discriminants", Indic);
8841
8842 elsif not Is_Tagged and then not Constraint_Present then
8843 Error_Msg_N
8844 ("discriminant constraint needed for derived untagged records",
8845 Indic);
8846
8847 -- Otherwise the parent subtype must be constrained unless we have a
8848 -- private extension.
8849
8850 elsif not Constraint_Present
8851 and then not Private_Extension
8852 and then not Is_Constrained (Parent_Type)
8853 then
8854 Error_Msg_N
8855 ("unconstrained type not allowed in this context", Indic);
8856
8857 elsif Constraint_Present then
8858 -- The following call sets the field Corresponding_Discriminant
8859 -- for the discriminants in the Derived_Type.
8860
8861 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
8862
8863 -- For untagged types all new discriminants must rename
8864 -- discriminants in the parent. For private extensions new
8865 -- discriminants cannot rename old ones (implied by [7.3(13)]).
8866
8867 Discrim := First_Discriminant (Derived_Type);
8868 while Present (Discrim) loop
8869 if not Is_Tagged
8870 and then No (Corresponding_Discriminant (Discrim))
8871 then
8872 Error_Msg_N
8873 ("new discriminants must constrain old ones", Discrim);
8874
8875 elsif Private_Extension
8876 and then Present (Corresponding_Discriminant (Discrim))
8877 then
8878 Error_Msg_N
8879 ("only static constraints allowed for parent"
8880 & " discriminants in the partial view", Indic);
8881 exit;
8882 end if;
8883
8884 -- If a new discriminant is used in the constraint, then its
8885 -- subtype must be statically compatible with the parent
8886 -- discriminant's subtype (3.7(15)).
8887
8888 -- However, if the record contains an array constrained by
8889 -- the discriminant but with some different bound, the compiler
8890 -- tries to create a smaller range for the discriminant type.
8891 -- (See exp_ch3.Adjust_Discriminants). In this case, where
8892 -- the discriminant type is a scalar type, the check must use
8893 -- the original discriminant type in the parent declaration.
8894
8895 declare
8896 Corr_Disc : constant Entity_Id :=
8897 Corresponding_Discriminant (Discrim);
8898 Disc_Type : constant Entity_Id := Etype (Discrim);
8899 Corr_Type : Entity_Id;
8900
8901 begin
8902 if Present (Corr_Disc) then
8903 if Is_Scalar_Type (Disc_Type) then
8904 Corr_Type :=
8905 Entity (Discriminant_Type (Parent (Corr_Disc)));
8906 else
8907 Corr_Type := Etype (Corr_Disc);
8908 end if;
8909
8910 if not
8911 Subtypes_Statically_Compatible (Disc_Type, Corr_Type)
8912 then
8913 Error_Msg_N
8914 ("subtype must be compatible "
8915 & "with parent discriminant",
8916 Discrim);
8917 end if;
8918 end if;
8919 end;
8920
8921 Next_Discriminant (Discrim);
8922 end loop;
8923
8924 -- Check whether the constraints of the full view statically
8925 -- match those imposed by the parent subtype [7.3(13)].
8926
8927 if Present (Stored_Constraint (Derived_Type)) then
8928 declare
8929 C1, C2 : Elmt_Id;
8930
8931 begin
8932 C1 := First_Elmt (Discs);
8933 C2 := First_Elmt (Stored_Constraint (Derived_Type));
8934 while Present (C1) and then Present (C2) loop
8935 if not
8936 Fully_Conformant_Expressions (Node (C1), Node (C2))
8937 then
8938 Error_Msg_N
8939 ("not conformant with previous declaration",
8940 Node (C1));
8941 end if;
8942
8943 Next_Elmt (C1);
8944 Next_Elmt (C2);
8945 end loop;
8946 end;
8947 end if;
8948 end if;
8949
8950 -- STEP 2b: No new discriminants, inherit discriminants if any
8951
8952 else
8953 if Private_Extension then
8954 Set_Has_Unknown_Discriminants
8955 (Derived_Type,
8956 Has_Unknown_Discriminants (Parent_Type)
8957 or else Unknown_Discriminants_Present (N));
8958
8959 -- The partial view of the parent may have unknown discriminants,
8960 -- but if the full view has discriminants and the parent type is
8961 -- in scope they must be inherited.
8962
8963 elsif Has_Unknown_Discriminants (Parent_Type)
8964 and then
8965 (not Has_Discriminants (Parent_Type)
8966 or else not In_Open_Scopes (Scope (Parent_Type)))
8967 then
8968 Set_Has_Unknown_Discriminants (Derived_Type);
8969 end if;
8970
8971 if not Has_Unknown_Discriminants (Derived_Type)
8972 and then not Has_Unknown_Discriminants (Parent_Base)
8973 and then Has_Discriminants (Parent_Type)
8974 then
8975 Inherit_Discrims := True;
8976 Set_Has_Discriminants
8977 (Derived_Type, True);
8978 Set_Discriminant_Constraint
8979 (Derived_Type, Discriminant_Constraint (Parent_Base));
8980 end if;
8981
8982 -- The following test is true for private types (remember
8983 -- transformation 5. is not applied to those) and in an error
8984 -- situation.
8985
8986 if Constraint_Present then
8987 Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
8988 end if;
8989
8990 -- For now mark a new derived type as constrained only if it has no
8991 -- discriminants. At the end of Build_Derived_Record_Type we properly
8992 -- set this flag in the case of private extensions. See comments in
8993 -- point 9. just before body of Build_Derived_Record_Type.
8994
8995 Set_Is_Constrained
8996 (Derived_Type,
8997 not (Inherit_Discrims
8998 or else Has_Unknown_Discriminants (Derived_Type)));
8999 end if;
9000
9001 -- STEP 3: initialize fields of derived type
9002
9003 Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
9004 Set_Stored_Constraint (Derived_Type, No_Elist);
9005
9006 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
9007 -- but cannot be interfaces
9008
9009 if not Private_Extension
9010 and then Ekind (Derived_Type) /= E_Private_Type
9011 and then Ekind (Derived_Type) /= E_Limited_Private_Type
9012 then
9013 if Interface_Present (Type_Def) then
9014 Analyze_Interface_Declaration (Derived_Type, Type_Def);
9015 end if;
9016
9017 Set_Interfaces (Derived_Type, No_Elist);
9018 end if;
9019
9020 -- Fields inherited from the Parent_Type
9021
9022 Set_Has_Specified_Layout
9023 (Derived_Type, Has_Specified_Layout (Parent_Type));
9024 Set_Is_Limited_Composite
9025 (Derived_Type, Is_Limited_Composite (Parent_Type));
9026 Set_Is_Private_Composite
9027 (Derived_Type, Is_Private_Composite (Parent_Type));
9028
9029 if Is_Tagged_Type (Parent_Type) then
9030 Set_No_Tagged_Streams_Pragma
9031 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
9032 end if;
9033
9034 -- Fields inherited from the Parent_Base
9035
9036 Set_Has_Controlled_Component
9037 (Derived_Type, Has_Controlled_Component (Parent_Base));
9038 Set_Has_Non_Standard_Rep
9039 (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
9040 Set_Has_Primitive_Operations
9041 (Derived_Type, Has_Primitive_Operations (Parent_Base));
9042
9043 -- Fields inherited from the Parent_Base in the non-private case
9044
9045 if Ekind (Derived_Type) = E_Record_Type then
9046 Set_Has_Complex_Representation
9047 (Derived_Type, Has_Complex_Representation (Parent_Base));
9048 end if;
9049
9050 -- Fields inherited from the Parent_Base for record types
9051
9052 if Is_Record_Type (Derived_Type) then
9053 declare
9054 Parent_Full : Entity_Id;
9055
9056 begin
9057 -- Ekind (Parent_Base) is not necessarily E_Record_Type since
9058 -- Parent_Base can be a private type or private extension. Go
9059 -- to the full view here to get the E_Record_Type specific flags.
9060
9061 if Present (Full_View (Parent_Base)) then
9062 Parent_Full := Full_View (Parent_Base);
9063 else
9064 Parent_Full := Parent_Base;
9065 end if;
9066
9067 Set_OK_To_Reorder_Components
9068 (Derived_Type, OK_To_Reorder_Components (Parent_Full));
9069 end;
9070 end if;
9071
9072 -- Set fields for private derived types
9073
9074 if Is_Private_Type (Derived_Type) then
9075 Set_Depends_On_Private (Derived_Type, True);
9076 Set_Private_Dependents (Derived_Type, New_Elmt_List);
9077
9078 -- Inherit fields from non private record types. If this is the
9079 -- completion of a derivation from a private type, the parent itself
9080 -- is private, and the attributes come from its full view, which must
9081 -- be present.
9082
9083 else
9084 if Is_Private_Type (Parent_Base)
9085 and then not Is_Record_Type (Parent_Base)
9086 then
9087 Set_Component_Alignment
9088 (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
9089 Set_C_Pass_By_Copy
9090 (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base)));
9091 else
9092 Set_Component_Alignment
9093 (Derived_Type, Component_Alignment (Parent_Base));
9094 Set_C_Pass_By_Copy
9095 (Derived_Type, C_Pass_By_Copy (Parent_Base));
9096 end if;
9097 end if;
9098
9099 -- Set fields for tagged types
9100
9101 if Is_Tagged then
9102 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
9103
9104 -- All tagged types defined in Ada.Finalization are controlled
9105
9106 if Chars (Scope (Derived_Type)) = Name_Finalization
9107 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
9108 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
9109 then
9110 Set_Is_Controlled (Derived_Type);
9111 else
9112 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
9113 end if;
9114
9115 -- Minor optimization: there is no need to generate the class-wide
9116 -- entity associated with an underlying record view.
9117
9118 if not Is_Underlying_Record_View (Derived_Type) then
9119 Make_Class_Wide_Type (Derived_Type);
9120 end if;
9121
9122 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
9123
9124 if Has_Discriminants (Derived_Type)
9125 and then Constraint_Present
9126 then
9127 Set_Stored_Constraint
9128 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
9129 end if;
9130
9131 if Ada_Version >= Ada_2005 then
9132 declare
9133 Ifaces_List : Elist_Id;
9134
9135 begin
9136 -- Checks rules 3.9.4 (13/2 and 14/2)
9137
9138 if Comes_From_Source (Derived_Type)
9139 and then not Is_Private_Type (Derived_Type)
9140 and then Is_Interface (Parent_Type)
9141 and then not Is_Interface (Derived_Type)
9142 then
9143 if Is_Task_Interface (Parent_Type) then
9144 Error_Msg_N
9145 ("(Ada 2005) task type required (RM 3.9.4 (13.2))",
9146 Derived_Type);
9147
9148 elsif Is_Protected_Interface (Parent_Type) then
9149 Error_Msg_N
9150 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))",
9151 Derived_Type);
9152 end if;
9153 end if;
9154
9155 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
9156
9157 Check_Interfaces (N, Type_Def);
9158
9159 -- Ada 2005 (AI-251): Collect the list of progenitors that are
9160 -- not already in the parents.
9161
9162 Collect_Interfaces
9163 (T => Derived_Type,
9164 Ifaces_List => Ifaces_List,
9165 Exclude_Parents => True);
9166
9167 Set_Interfaces (Derived_Type, Ifaces_List);
9168
9169 -- If the derived type is the anonymous type created for
9170 -- a declaration whose parent has a constraint, propagate
9171 -- the interface list to the source type. This must be done
9172 -- prior to the completion of the analysis of the source type
9173 -- because the components in the extension may contain current
9174 -- instances whose legality depends on some ancestor.
9175
9176 if Is_Itype (Derived_Type) then
9177 declare
9178 Def : constant Node_Id :=
9179 Associated_Node_For_Itype (Derived_Type);
9180 begin
9181 if Present (Def)
9182 and then Nkind (Def) = N_Full_Type_Declaration
9183 then
9184 Set_Interfaces
9185 (Defining_Identifier (Def), Ifaces_List);
9186 end if;
9187 end;
9188 end if;
9189
9190 -- A type extension is automatically Ghost when one of its
9191 -- progenitors is Ghost (SPARK RM 6.9(9)). This property is
9192 -- also inherited when the parent type is Ghost, but this is
9193 -- done in Build_Derived_Type as the mechanism also handles
9194 -- untagged derivations.
9195
9196 if Implements_Ghost_Interface (Derived_Type) then
9197 Set_Is_Ghost_Entity (Derived_Type);
9198 end if;
9199 end;
9200 end if;
9201
9202 else
9203 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
9204 Set_Has_Non_Standard_Rep
9205 (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
9206 end if;
9207
9208 -- STEP 4: Inherit components from the parent base and constrain them.
9209 -- Apply the second transformation described in point 6. above.
9210
9211 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
9212 or else not Has_Discriminants (Parent_Type)
9213 or else not Is_Constrained (Parent_Type)
9214 then
9215 Constrs := Discs;
9216 else
9217 Constrs := Discriminant_Constraint (Parent_Type);
9218 end if;
9219
9220 Assoc_List :=
9221 Inherit_Components
9222 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
9223
9224 -- STEP 5a: Copy the parent record declaration for untagged types
9225
9226 Set_Has_Implicit_Dereference
9227 (Derived_Type, Has_Implicit_Dereference (Parent_Type));
9228
9229 if not Is_Tagged then
9230
9231 -- Discriminant_Constraint (Derived_Type) has been properly
9232 -- constructed. Save it and temporarily set it to Empty because we
9233 -- do not want the call to New_Copy_Tree below to mess this list.
9234
9235 if Has_Discriminants (Derived_Type) then
9236 Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
9237 Set_Discriminant_Constraint (Derived_Type, No_Elist);
9238 else
9239 Save_Discr_Constr := No_Elist;
9240 end if;
9241
9242 -- Save the Etype field of Derived_Type. It is correctly set now,
9243 -- but the call to New_Copy tree may remap it to point to itself,
9244 -- which is not what we want. Ditto for the Next_Entity field.
9245
9246 Save_Etype := Etype (Derived_Type);
9247 Save_Next_Entity := Next_Entity (Derived_Type);
9248
9249 -- Assoc_List maps all stored discriminants in the Parent_Base to
9250 -- stored discriminants in the Derived_Type. It is fundamental that
9251 -- no types or itypes with discriminants other than the stored
9252 -- discriminants appear in the entities declared inside
9253 -- Derived_Type, since the back end cannot deal with it.
9254
9255 New_Decl :=
9256 New_Copy_Tree
9257 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
9258
9259 -- Restore the fields saved prior to the New_Copy_Tree call
9260 -- and compute the stored constraint.
9261
9262 Set_Etype (Derived_Type, Save_Etype);
9263 Set_Next_Entity (Derived_Type, Save_Next_Entity);
9264
9265 if Has_Discriminants (Derived_Type) then
9266 Set_Discriminant_Constraint
9267 (Derived_Type, Save_Discr_Constr);
9268 Set_Stored_Constraint
9269 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
9270 Replace_Components (Derived_Type, New_Decl);
9271 end if;
9272
9273 -- Insert the new derived type declaration
9274
9275 Rewrite (N, New_Decl);
9276
9277 -- STEP 5b: Complete the processing for record extensions in generics
9278
9279 -- There is no completion for record extensions declared in the
9280 -- parameter part of a generic, so we need to complete processing for
9281 -- these generic record extensions here. The Record_Type_Definition call
9282 -- will change the Ekind of the components from E_Void to E_Component.
9283
9284 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
9285 Record_Type_Definition (Empty, Derived_Type);
9286
9287 -- STEP 5c: Process the record extension for non private tagged types
9288
9289 elsif not Private_Extension then
9290 Expand_Record_Extension (Derived_Type, Type_Def);
9291
9292 -- Note : previously in ASIS mode we set the Parent_Subtype of the
9293 -- derived type to propagate some semantic information. This led
9294 -- to other ASIS failures and has been removed.
9295
9296 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
9297 -- implemented interfaces if we are in expansion mode
9298
9299 if Expander_Active
9300 and then Has_Interfaces (Derived_Type)
9301 then
9302 Add_Interface_Tag_Components (N, Derived_Type);
9303 end if;
9304
9305 -- Analyze the record extension
9306
9307 Record_Type_Definition
9308 (Record_Extension_Part (Type_Def), Derived_Type);
9309 end if;
9310
9311 End_Scope;
9312
9313 -- Nothing else to do if there is an error in the derivation.
9314 -- An unusual case: the full view may be derived from a type in an
9315 -- instance, when the partial view was used illegally as an actual
9316 -- in that instance, leading to a circular definition.
9317
9318 if Etype (Derived_Type) = Any_Type
9319 or else Etype (Parent_Type) = Derived_Type
9320 then
9321 return;
9322 end if;
9323
9324 -- Set delayed freeze and then derive subprograms, we need to do
9325 -- this in this order so that derived subprograms inherit the
9326 -- derived freeze if necessary.
9327
9328 Set_Has_Delayed_Freeze (Derived_Type);
9329
9330 if Derive_Subps then
9331 Derive_Subprograms (Parent_Type, Derived_Type);
9332 end if;
9333
9334 -- If we have a private extension which defines a constrained derived
9335 -- type mark as constrained here after we have derived subprograms. See
9336 -- comment on point 9. just above the body of Build_Derived_Record_Type.
9337
9338 if Private_Extension and then Inherit_Discrims then
9339 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
9340 Set_Is_Constrained (Derived_Type, True);
9341 Set_Discriminant_Constraint (Derived_Type, Discs);
9342
9343 elsif Is_Constrained (Parent_Type) then
9344 Set_Is_Constrained
9345 (Derived_Type, True);
9346 Set_Discriminant_Constraint
9347 (Derived_Type, Discriminant_Constraint (Parent_Type));
9348 end if;
9349 end if;
9350
9351 -- Update the class-wide type, which shares the now-completed entity
9352 -- list with its specific type. In case of underlying record views,
9353 -- we do not generate the corresponding class wide entity.
9354
9355 if Is_Tagged
9356 and then not Is_Underlying_Record_View (Derived_Type)
9357 then
9358 Set_First_Entity
9359 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
9360 Set_Last_Entity
9361 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
9362 end if;
9363
9364 Check_Function_Writable_Actuals (N);
9365 end Build_Derived_Record_Type;
9366
9367 ------------------------
9368 -- Build_Derived_Type --
9369 ------------------------
9370
9371 procedure Build_Derived_Type
9372 (N : Node_Id;
9373 Parent_Type : Entity_Id;
9374 Derived_Type : Entity_Id;
9375 Is_Completion : Boolean;
9376 Derive_Subps : Boolean := True)
9377 is
9378 Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
9379
9380 begin
9381 -- Set common attributes
9382
9383 Set_Scope (Derived_Type, Current_Scope);
9384
9385 Set_Etype (Derived_Type, Parent_Base);
9386 Set_Ekind (Derived_Type, Ekind (Parent_Base));
9387 Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
9388
9389 Set_Size_Info (Derived_Type, Parent_Type);
9390 Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
9391 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
9392 Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
9393
9394 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
9395 Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
9396
9397 if Is_Tagged_Type (Derived_Type) then
9398 Set_No_Tagged_Streams_Pragma
9399 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
9400 end if;
9401
9402 -- If the parent has primitive routines, set the derived type link
9403
9404 if Has_Primitive_Operations (Parent_Type) then
9405 Set_Derived_Type_Link (Parent_Base, Derived_Type);
9406 end if;
9407
9408 -- If the parent type is a private subtype, the convention on the base
9409 -- type may be set in the private part, and not propagated to the
9410 -- subtype until later, so we obtain the convention from the base type.
9411
9412 Set_Convention (Derived_Type, Convention (Parent_Base));
9413
9414 -- Set SSO default for record or array type
9415
9416 if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type))
9417 and then Is_Base_Type (Derived_Type)
9418 then
9419 Set_Default_SSO (Derived_Type);
9420 end if;
9421
9422 -- A derived type inherits the Default_Initial_Condition pragma coming
9423 -- from any parent type within the derivation chain.
9424
9425 if Has_DIC (Parent_Type) then
9426 Set_Has_Inherited_DIC (Derived_Type);
9427 end if;
9428
9429 -- A derived type inherits any class-wide invariants coming from a
9430 -- parent type or an interface. Note that the invariant procedure of
9431 -- the parent type should not be inherited because the derived type may
9432 -- define invariants of its own.
9433
9434 if not Is_Interface (Derived_Type) then
9435 if Has_Inherited_Invariants (Parent_Type)
9436 or else Has_Inheritable_Invariants (Parent_Type)
9437 then
9438 Set_Has_Inherited_Invariants (Derived_Type);
9439
9440 elsif Is_Concurrent_Type (Derived_Type)
9441 or else Is_Tagged_Type (Derived_Type)
9442 then
9443 declare
9444 Iface : Entity_Id;
9445 Ifaces : Elist_Id;
9446 Iface_Elmt : Elmt_Id;
9447
9448 begin
9449 Collect_Interfaces
9450 (T => Derived_Type,
9451 Ifaces_List => Ifaces,
9452 Exclude_Parents => True);
9453
9454 if Present (Ifaces) then
9455 Iface_Elmt := First_Elmt (Ifaces);
9456 while Present (Iface_Elmt) loop
9457 Iface := Node (Iface_Elmt);
9458
9459 if Has_Inheritable_Invariants (Iface) then
9460 Set_Has_Inherited_Invariants (Derived_Type);
9461 exit;
9462 end if;
9463
9464 Next_Elmt (Iface_Elmt);
9465 end loop;
9466 end if;
9467 end;
9468 end if;
9469 end if;
9470
9471 -- We similarly inherit predicates. Note that for scalar derived types
9472 -- the predicate is inherited from the first subtype, and not from its
9473 -- (anonymous) base type.
9474
9475 if Has_Predicates (Parent_Type)
9476 or else Has_Predicates (First_Subtype (Parent_Type))
9477 then
9478 Set_Has_Predicates (Derived_Type);
9479 end if;
9480
9481 -- The derived type inherits the representation clauses of the parent
9482
9483 Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
9484
9485 -- If the parent type has delayed rep aspects, then mark the derived
9486 -- type as possibly inheriting a delayed rep aspect.
9487
9488 if Has_Delayed_Rep_Aspects (Parent_Type) then
9489 Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type);
9490 end if;
9491
9492 -- A derived type becomes Ghost when its parent type is also Ghost
9493 -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not
9494 -- directly inherited because the Ghost policy in effect may differ.
9495
9496 if Is_Ghost_Entity (Parent_Type) then
9497 Set_Is_Ghost_Entity (Derived_Type);
9498 end if;
9499
9500 -- Type dependent processing
9501
9502 case Ekind (Parent_Type) is
9503 when Numeric_Kind =>
9504 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
9505
9506 when Array_Kind =>
9507 Build_Derived_Array_Type (N, Parent_Type, Derived_Type);
9508
9509 when Class_Wide_Kind
9510 | E_Record_Subtype
9511 | E_Record_Type
9512 =>
9513 Build_Derived_Record_Type
9514 (N, Parent_Type, Derived_Type, Derive_Subps);
9515 return;
9516
9517 when Enumeration_Kind =>
9518 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
9519
9520 when Access_Kind =>
9521 Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
9522
9523 when Incomplete_Or_Private_Kind =>
9524 Build_Derived_Private_Type
9525 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
9526
9527 -- For discriminated types, the derivation includes deriving
9528 -- primitive operations. For others it is done below.
9529
9530 if Is_Tagged_Type (Parent_Type)
9531 or else Has_Discriminants (Parent_Type)
9532 or else (Present (Full_View (Parent_Type))
9533 and then Has_Discriminants (Full_View (Parent_Type)))
9534 then
9535 return;
9536 end if;
9537
9538 when Concurrent_Kind =>
9539 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
9540
9541 when others =>
9542 raise Program_Error;
9543 end case;
9544
9545 -- Nothing more to do if some error occurred
9546
9547 if Etype (Derived_Type) = Any_Type then
9548 return;
9549 end if;
9550
9551 -- Set delayed freeze and then derive subprograms, we need to do this
9552 -- in this order so that derived subprograms inherit the derived freeze
9553 -- if necessary.
9554
9555 Set_Has_Delayed_Freeze (Derived_Type);
9556
9557 if Derive_Subps then
9558 Derive_Subprograms (Parent_Type, Derived_Type);
9559 end if;
9560
9561 Set_Has_Primitive_Operations
9562 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
9563 end Build_Derived_Type;
9564
9565 -----------------------
9566 -- Build_Discriminal --
9567 -----------------------
9568
9569 procedure Build_Discriminal (Discrim : Entity_Id) is
9570 D_Minal : Entity_Id;
9571 CR_Disc : Entity_Id;
9572
9573 begin
9574 -- A discriminal has the same name as the discriminant
9575
9576 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
9577
9578 Set_Ekind (D_Minal, E_In_Parameter);
9579 Set_Mechanism (D_Minal, Default_Mechanism);
9580 Set_Etype (D_Minal, Etype (Discrim));
9581 Set_Scope (D_Minal, Current_Scope);
9582 Set_Parent (D_Minal, Parent (Discrim));
9583
9584 Set_Discriminal (Discrim, D_Minal);
9585 Set_Discriminal_Link (D_Minal, Discrim);
9586
9587 -- For task types, build at once the discriminants of the corresponding
9588 -- record, which are needed if discriminants are used in entry defaults
9589 -- and in family bounds.
9590
9591 if Is_Concurrent_Type (Current_Scope)
9592 or else
9593 Is_Limited_Type (Current_Scope)
9594 then
9595 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
9596
9597 Set_Ekind (CR_Disc, E_In_Parameter);
9598 Set_Mechanism (CR_Disc, Default_Mechanism);
9599 Set_Etype (CR_Disc, Etype (Discrim));
9600 Set_Scope (CR_Disc, Current_Scope);
9601 Set_Discriminal_Link (CR_Disc, Discrim);
9602 Set_CR_Discriminant (Discrim, CR_Disc);
9603 end if;
9604 end Build_Discriminal;
9605
9606 ------------------------------------
9607 -- Build_Discriminant_Constraints --
9608 ------------------------------------
9609
9610 function Build_Discriminant_Constraints
9611 (T : Entity_Id;
9612 Def : Node_Id;
9613 Derived_Def : Boolean := False) return Elist_Id
9614 is
9615 C : constant Node_Id := Constraint (Def);
9616 Nb_Discr : constant Nat := Number_Discriminants (T);
9617
9618 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
9619 -- Saves the expression corresponding to a given discriminant in T
9620
9621 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
9622 -- Return the Position number within array Discr_Expr of a discriminant
9623 -- D within the discriminant list of the discriminated type T.
9624
9625 procedure Process_Discriminant_Expression
9626 (Expr : Node_Id;
9627 D : Entity_Id);
9628 -- If this is a discriminant constraint on a partial view, do not
9629 -- generate an overflow check on the discriminant expression. The check
9630 -- will be generated when constraining the full view. Otherwise the
9631 -- backend creates duplicate symbols for the temporaries corresponding
9632 -- to the expressions to be checked, causing spurious assembler errors.
9633
9634 ------------------
9635 -- Pos_Of_Discr --
9636 ------------------
9637
9638 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
9639 Disc : Entity_Id;
9640
9641 begin
9642 Disc := First_Discriminant (T);
9643 for J in Discr_Expr'Range loop
9644 if Disc = D then
9645 return J;
9646 end if;
9647
9648 Next_Discriminant (Disc);
9649 end loop;
9650
9651 -- Note: Since this function is called on discriminants that are
9652 -- known to belong to the discriminated type, falling through the
9653 -- loop with no match signals an internal compiler error.
9654
9655 raise Program_Error;
9656 end Pos_Of_Discr;
9657
9658 -------------------------------------
9659 -- Process_Discriminant_Expression --
9660 -------------------------------------
9661
9662 procedure Process_Discriminant_Expression
9663 (Expr : Node_Id;
9664 D : Entity_Id)
9665 is
9666 BDT : constant Entity_Id := Base_Type (Etype (D));
9667
9668 begin
9669 -- If this is a discriminant constraint on a partial view, do
9670 -- not generate an overflow on the discriminant expression. The
9671 -- check will be generated when constraining the full view.
9672
9673 if Is_Private_Type (T)
9674 and then Present (Full_View (T))
9675 then
9676 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check);
9677 else
9678 Analyze_And_Resolve (Expr, BDT);
9679 end if;
9680 end Process_Discriminant_Expression;
9681
9682 -- Declarations local to Build_Discriminant_Constraints
9683
9684 Discr : Entity_Id;
9685 E : Entity_Id;
9686 Elist : constant Elist_Id := New_Elmt_List;
9687
9688 Constr : Node_Id;
9689 Expr : Node_Id;
9690 Id : Node_Id;
9691 Position : Nat;
9692 Found : Boolean;
9693
9694 Discrim_Present : Boolean := False;
9695
9696 -- Start of processing for Build_Discriminant_Constraints
9697
9698 begin
9699 -- The following loop will process positional associations only.
9700 -- For a positional association, the (single) discriminant is
9701 -- implicitly specified by position, in textual order (RM 3.7.2).
9702
9703 Discr := First_Discriminant (T);
9704 Constr := First (Constraints (C));
9705 for D in Discr_Expr'Range loop
9706 exit when Nkind (Constr) = N_Discriminant_Association;
9707
9708 if No (Constr) then
9709 Error_Msg_N ("too few discriminants given in constraint", C);
9710 return New_Elmt_List;
9711
9712 elsif Nkind (Constr) = N_Range
9713 or else (Nkind (Constr) = N_Attribute_Reference
9714 and then Attribute_Name (Constr) = Name_Range)
9715 then
9716 Error_Msg_N
9717 ("a range is not a valid discriminant constraint", Constr);
9718 Discr_Expr (D) := Error;
9719
9720 else
9721 Process_Discriminant_Expression (Constr, Discr);
9722 Discr_Expr (D) := Constr;
9723 end if;
9724
9725 Next_Discriminant (Discr);
9726 Next (Constr);
9727 end loop;
9728
9729 if No (Discr) and then Present (Constr) then
9730 Error_Msg_N ("too many discriminants given in constraint", Constr);
9731 return New_Elmt_List;
9732 end if;
9733
9734 -- Named associations can be given in any order, but if both positional
9735 -- and named associations are used in the same discriminant constraint,
9736 -- then positional associations must occur first, at their normal
9737 -- position. Hence once a named association is used, the rest of the
9738 -- discriminant constraint must use only named associations.
9739
9740 while Present (Constr) loop
9741
9742 -- Positional association forbidden after a named association
9743
9744 if Nkind (Constr) /= N_Discriminant_Association then
9745 Error_Msg_N ("positional association follows named one", Constr);
9746 return New_Elmt_List;
9747
9748 -- Otherwise it is a named association
9749
9750 else
9751 -- E records the type of the discriminants in the named
9752 -- association. All the discriminants specified in the same name
9753 -- association must have the same type.
9754
9755 E := Empty;
9756
9757 -- Search the list of discriminants in T to see if the simple name
9758 -- given in the constraint matches any of them.
9759
9760 Id := First (Selector_Names (Constr));
9761 while Present (Id) loop
9762 Found := False;
9763
9764 -- If Original_Discriminant is present, we are processing a
9765 -- generic instantiation and this is an instance node. We need
9766 -- to find the name of the corresponding discriminant in the
9767 -- actual record type T and not the name of the discriminant in
9768 -- the generic formal. Example:
9769
9770 -- generic
9771 -- type G (D : int) is private;
9772 -- package P is
9773 -- subtype W is G (D => 1);
9774 -- end package;
9775 -- type Rec (X : int) is record ... end record;
9776 -- package Q is new P (G => Rec);
9777
9778 -- At the point of the instantiation, formal type G is Rec
9779 -- and therefore when reanalyzing "subtype W is G (D => 1);"
9780 -- which really looks like "subtype W is Rec (D => 1);" at
9781 -- the point of instantiation, we want to find the discriminant
9782 -- that corresponds to D in Rec, i.e. X.
9783
9784 if Present (Original_Discriminant (Id))
9785 and then In_Instance
9786 then
9787 Discr := Find_Corresponding_Discriminant (Id, T);
9788 Found := True;
9789
9790 else
9791 Discr := First_Discriminant (T);
9792 while Present (Discr) loop
9793 if Chars (Discr) = Chars (Id) then
9794 Found := True;
9795 exit;
9796 end if;
9797
9798 Next_Discriminant (Discr);
9799 end loop;
9800
9801 if not Found then
9802 Error_Msg_N ("& does not match any discriminant", Id);
9803 return New_Elmt_List;
9804
9805 -- If the parent type is a generic formal, preserve the
9806 -- name of the discriminant for subsequent instances.
9807 -- see comment at the beginning of this if statement.
9808
9809 elsif Is_Generic_Type (Root_Type (T)) then
9810 Set_Original_Discriminant (Id, Discr);
9811 end if;
9812 end if;
9813
9814 Position := Pos_Of_Discr (T, Discr);
9815
9816 if Present (Discr_Expr (Position)) then
9817 Error_Msg_N ("duplicate constraint for discriminant&", Id);
9818
9819 else
9820 -- Each discriminant specified in the same named association
9821 -- must be associated with a separate copy of the
9822 -- corresponding expression.
9823
9824 if Present (Next (Id)) then
9825 Expr := New_Copy_Tree (Expression (Constr));
9826 Set_Parent (Expr, Parent (Expression (Constr)));
9827 else
9828 Expr := Expression (Constr);
9829 end if;
9830
9831 Discr_Expr (Position) := Expr;
9832 Process_Discriminant_Expression (Expr, Discr);
9833 end if;
9834
9835 -- A discriminant association with more than one discriminant
9836 -- name is only allowed if the named discriminants are all of
9837 -- the same type (RM 3.7.1(8)).
9838
9839 if E = Empty then
9840 E := Base_Type (Etype (Discr));
9841
9842 elsif Base_Type (Etype (Discr)) /= E then
9843 Error_Msg_N
9844 ("all discriminants in an association " &
9845 "must have the same type", Id);
9846 end if;
9847
9848 Next (Id);
9849 end loop;
9850 end if;
9851
9852 Next (Constr);
9853 end loop;
9854
9855 -- A discriminant constraint must provide exactly one value for each
9856 -- discriminant of the type (RM 3.7.1(8)).
9857
9858 for J in Discr_Expr'Range loop
9859 if No (Discr_Expr (J)) then
9860 Error_Msg_N ("too few discriminants given in constraint", C);
9861 return New_Elmt_List;
9862 end if;
9863 end loop;
9864
9865 -- Determine if there are discriminant expressions in the constraint
9866
9867 for J in Discr_Expr'Range loop
9868 if Denotes_Discriminant
9869 (Discr_Expr (J), Check_Concurrent => True)
9870 then
9871 Discrim_Present := True;
9872 end if;
9873 end loop;
9874
9875 -- Build an element list consisting of the expressions given in the
9876 -- discriminant constraint and apply the appropriate checks. The list
9877 -- is constructed after resolving any named discriminant associations
9878 -- and therefore the expressions appear in the textual order of the
9879 -- discriminants.
9880
9881 Discr := First_Discriminant (T);
9882 for J in Discr_Expr'Range loop
9883 if Discr_Expr (J) /= Error then
9884 Append_Elmt (Discr_Expr (J), Elist);
9885
9886 -- If any of the discriminant constraints is given by a
9887 -- discriminant and we are in a derived type declaration we
9888 -- have a discriminant renaming. Establish link between new
9889 -- and old discriminant. The new discriminant has an implicit
9890 -- dereference if the old one does.
9891
9892 if Denotes_Discriminant (Discr_Expr (J)) then
9893 if Derived_Def then
9894 declare
9895 New_Discr : constant Entity_Id := Entity (Discr_Expr (J));
9896
9897 begin
9898 Set_Corresponding_Discriminant (New_Discr, Discr);
9899 Set_Has_Implicit_Dereference (New_Discr,
9900 Has_Implicit_Dereference (Discr));
9901 end;
9902 end if;
9903
9904 -- Force the evaluation of non-discriminant expressions.
9905 -- If we have found a discriminant in the constraint 3.4(26)
9906 -- and 3.8(18) demand that no range checks are performed are
9907 -- after evaluation. If the constraint is for a component
9908 -- definition that has a per-object constraint, expressions are
9909 -- evaluated but not checked either. In all other cases perform
9910 -- a range check.
9911
9912 else
9913 if Discrim_Present then
9914 null;
9915
9916 elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
9917 and then Has_Per_Object_Constraint
9918 (Defining_Identifier (Parent (Parent (Def))))
9919 then
9920 null;
9921
9922 elsif Is_Access_Type (Etype (Discr)) then
9923 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr));
9924
9925 else
9926 Apply_Range_Check (Discr_Expr (J), Etype (Discr));
9927 end if;
9928
9929 Force_Evaluation (Discr_Expr (J));
9930 end if;
9931
9932 -- Check that the designated type of an access discriminant's
9933 -- expression is not a class-wide type unless the discriminant's
9934 -- designated type is also class-wide.
9935
9936 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
9937 and then not Is_Class_Wide_Type
9938 (Designated_Type (Etype (Discr)))
9939 and then Etype (Discr_Expr (J)) /= Any_Type
9940 and then Is_Class_Wide_Type
9941 (Designated_Type (Etype (Discr_Expr (J))))
9942 then
9943 Wrong_Type (Discr_Expr (J), Etype (Discr));
9944
9945 elsif Is_Access_Type (Etype (Discr))
9946 and then not Is_Access_Constant (Etype (Discr))
9947 and then Is_Access_Type (Etype (Discr_Expr (J)))
9948 and then Is_Access_Constant (Etype (Discr_Expr (J)))
9949 then
9950 Error_Msg_NE
9951 ("constraint for discriminant& must be access to variable",
9952 Def, Discr);
9953 end if;
9954 end if;
9955
9956 Next_Discriminant (Discr);
9957 end loop;
9958
9959 return Elist;
9960 end Build_Discriminant_Constraints;
9961
9962 ---------------------------------
9963 -- Build_Discriminated_Subtype --
9964 ---------------------------------
9965
9966 procedure Build_Discriminated_Subtype
9967 (T : Entity_Id;
9968 Def_Id : Entity_Id;
9969 Elist : Elist_Id;
9970 Related_Nod : Node_Id;
9971 For_Access : Boolean := False)
9972 is
9973 Has_Discrs : constant Boolean := Has_Discriminants (T);
9974 Constrained : constant Boolean :=
9975 (Has_Discrs
9976 and then not Is_Empty_Elmt_List (Elist)
9977 and then not Is_Class_Wide_Type (T))
9978 or else Is_Constrained (T);
9979
9980 begin
9981 if Ekind (T) = E_Record_Type then
9982 if For_Access then
9983 Set_Ekind (Def_Id, E_Private_Subtype);
9984 Set_Is_For_Access_Subtype (Def_Id, True);
9985 else
9986 Set_Ekind (Def_Id, E_Record_Subtype);
9987 end if;
9988
9989 -- Inherit preelaboration flag from base, for types for which it
9990 -- may have been set: records, private types, protected types.
9991
9992 Set_Known_To_Have_Preelab_Init
9993 (Def_Id, Known_To_Have_Preelab_Init (T));
9994
9995 elsif Ekind (T) = E_Task_Type then
9996 Set_Ekind (Def_Id, E_Task_Subtype);
9997
9998 elsif Ekind (T) = E_Protected_Type then
9999 Set_Ekind (Def_Id, E_Protected_Subtype);
10000 Set_Known_To_Have_Preelab_Init
10001 (Def_Id, Known_To_Have_Preelab_Init (T));
10002
10003 elsif Is_Private_Type (T) then
10004 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
10005 Set_Known_To_Have_Preelab_Init
10006 (Def_Id, Known_To_Have_Preelab_Init (T));
10007
10008 -- Private subtypes may have private dependents
10009
10010 Set_Private_Dependents (Def_Id, New_Elmt_List);
10011
10012 elsif Is_Class_Wide_Type (T) then
10013 Set_Ekind (Def_Id, E_Class_Wide_Subtype);
10014
10015 else
10016 -- Incomplete type. Attach subtype to list of dependents, to be
10017 -- completed with full view of parent type, unless is it the
10018 -- designated subtype of a record component within an init_proc.
10019 -- This last case arises for a component of an access type whose
10020 -- designated type is incomplete (e.g. a Taft Amendment type).
10021 -- The designated subtype is within an inner scope, and needs no
10022 -- elaboration, because only the access type is needed in the
10023 -- initialization procedure.
10024
10025 Set_Ekind (Def_Id, Ekind (T));
10026
10027 if For_Access and then Within_Init_Proc then
10028 null;
10029 else
10030 Append_Elmt (Def_Id, Private_Dependents (T));
10031 end if;
10032 end if;
10033
10034 Set_Etype (Def_Id, T);
10035 Init_Size_Align (Def_Id);
10036 Set_Has_Discriminants (Def_Id, Has_Discrs);
10037 Set_Is_Constrained (Def_Id, Constrained);
10038
10039 Set_First_Entity (Def_Id, First_Entity (T));
10040 Set_Last_Entity (Def_Id, Last_Entity (T));
10041 Set_Has_Implicit_Dereference
10042 (Def_Id, Has_Implicit_Dereference (T));
10043 Set_Has_Pragma_Unreferenced_Objects
10044 (Def_Id, Has_Pragma_Unreferenced_Objects (T));
10045
10046 -- If the subtype is the completion of a private declaration, there may
10047 -- have been representation clauses for the partial view, and they must
10048 -- be preserved. Build_Derived_Type chains the inherited clauses with
10049 -- the ones appearing on the extension. If this comes from a subtype
10050 -- declaration, all clauses are inherited.
10051
10052 if No (First_Rep_Item (Def_Id)) then
10053 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
10054 end if;
10055
10056 if Is_Tagged_Type (T) then
10057 Set_Is_Tagged_Type (Def_Id);
10058 Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T));
10059 Make_Class_Wide_Type (Def_Id);
10060 end if;
10061
10062 Set_Stored_Constraint (Def_Id, No_Elist);
10063
10064 if Has_Discrs then
10065 Set_Discriminant_Constraint (Def_Id, Elist);
10066 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id);
10067 end if;
10068
10069 if Is_Tagged_Type (T) then
10070
10071 -- Ada 2005 (AI-251): In case of concurrent types we inherit the
10072 -- concurrent record type (which has the list of primitive
10073 -- operations).
10074
10075 if Ada_Version >= Ada_2005
10076 and then Is_Concurrent_Type (T)
10077 then
10078 Set_Corresponding_Record_Type (Def_Id,
10079 Corresponding_Record_Type (T));
10080 else
10081 Set_Direct_Primitive_Operations (Def_Id,
10082 Direct_Primitive_Operations (T));
10083 end if;
10084
10085 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
10086 end if;
10087
10088 -- Subtypes introduced by component declarations do not need to be
10089 -- marked as delayed, and do not get freeze nodes, because the semantics
10090 -- verifies that the parents of the subtypes are frozen before the
10091 -- enclosing record is frozen.
10092
10093 if not Is_Type (Scope (Def_Id)) then
10094 Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
10095
10096 if Is_Private_Type (T)
10097 and then Present (Full_View (T))
10098 then
10099 Conditional_Delay (Def_Id, Full_View (T));
10100 else
10101 Conditional_Delay (Def_Id, T);
10102 end if;
10103 end if;
10104
10105 if Is_Record_Type (T) then
10106 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
10107
10108 if Has_Discrs
10109 and then not Is_Empty_Elmt_List (Elist)
10110 and then not For_Access
10111 then
10112 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
10113 elsif not For_Access then
10114 Set_Cloned_Subtype (Def_Id, T);
10115 end if;
10116 end if;
10117 end Build_Discriminated_Subtype;
10118
10119 ---------------------------
10120 -- Build_Itype_Reference --
10121 ---------------------------
10122
10123 procedure Build_Itype_Reference
10124 (Ityp : Entity_Id;
10125 Nod : Node_Id)
10126 is
10127 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod));
10128 begin
10129
10130 -- Itype references are only created for use by the back-end
10131
10132 if Inside_A_Generic then
10133 return;
10134 else
10135 Set_Itype (IR, Ityp);
10136 Insert_After (Nod, IR);
10137 end if;
10138 end Build_Itype_Reference;
10139
10140 ------------------------
10141 -- Build_Scalar_Bound --
10142 ------------------------
10143
10144 function Build_Scalar_Bound
10145 (Bound : Node_Id;
10146 Par_T : Entity_Id;
10147 Der_T : Entity_Id) return Node_Id
10148 is
10149 New_Bound : Entity_Id;
10150
10151 begin
10152 -- Note: not clear why this is needed, how can the original bound
10153 -- be unanalyzed at this point? and if it is, what business do we
10154 -- have messing around with it? and why is the base type of the
10155 -- parent type the right type for the resolution. It probably is
10156 -- not. It is OK for the new bound we are creating, but not for
10157 -- the old one??? Still if it never happens, no problem.
10158
10159 Analyze_And_Resolve (Bound, Base_Type (Par_T));
10160
10161 if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
10162 New_Bound := New_Copy (Bound);
10163 Set_Etype (New_Bound, Der_T);
10164 Set_Analyzed (New_Bound);
10165
10166 elsif Is_Entity_Name (Bound) then
10167 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
10168
10169 -- The following is almost certainly wrong. What business do we have
10170 -- relocating a node (Bound) that is presumably still attached to
10171 -- the tree elsewhere???
10172
10173 else
10174 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
10175 end if;
10176
10177 Set_Etype (New_Bound, Der_T);
10178 return New_Bound;
10179 end Build_Scalar_Bound;
10180
10181 --------------------------------
10182 -- Build_Underlying_Full_View --
10183 --------------------------------
10184
10185 procedure Build_Underlying_Full_View
10186 (N : Node_Id;
10187 Typ : Entity_Id;
10188 Par : Entity_Id)
10189 is
10190 Loc : constant Source_Ptr := Sloc (N);
10191 Subt : constant Entity_Id :=
10192 Make_Defining_Identifier
10193 (Loc, New_External_Name (Chars (Typ), 'S'));
10194
10195 Constr : Node_Id;
10196 Indic : Node_Id;
10197 C : Node_Id;
10198 Id : Node_Id;
10199
10200 procedure Set_Discriminant_Name (Id : Node_Id);
10201 -- If the derived type has discriminants, they may rename discriminants
10202 -- of the parent. When building the full view of the parent, we need to
10203 -- recover the names of the original discriminants if the constraint is
10204 -- given by named associations.
10205
10206 ---------------------------
10207 -- Set_Discriminant_Name --
10208 ---------------------------
10209
10210 procedure Set_Discriminant_Name (Id : Node_Id) is
10211 Disc : Entity_Id;
10212
10213 begin
10214 Set_Original_Discriminant (Id, Empty);
10215
10216 if Has_Discriminants (Typ) then
10217 Disc := First_Discriminant (Typ);
10218 while Present (Disc) loop
10219 if Chars (Disc) = Chars (Id)
10220 and then Present (Corresponding_Discriminant (Disc))
10221 then
10222 Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
10223 end if;
10224 Next_Discriminant (Disc);
10225 end loop;
10226 end if;
10227 end Set_Discriminant_Name;
10228
10229 -- Start of processing for Build_Underlying_Full_View
10230
10231 begin
10232 if Nkind (N) = N_Full_Type_Declaration then
10233 Constr := Constraint (Subtype_Indication (Type_Definition (N)));
10234
10235 elsif Nkind (N) = N_Subtype_Declaration then
10236 Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
10237
10238 elsif Nkind (N) = N_Component_Declaration then
10239 Constr :=
10240 New_Copy_Tree
10241 (Constraint (Subtype_Indication (Component_Definition (N))));
10242
10243 else
10244 raise Program_Error;
10245 end if;
10246
10247 C := First (Constraints (Constr));
10248 while Present (C) loop
10249 if Nkind (C) = N_Discriminant_Association then
10250 Id := First (Selector_Names (C));
10251 while Present (Id) loop
10252 Set_Discriminant_Name (Id);
10253 Next (Id);
10254 end loop;
10255 end if;
10256
10257 Next (C);
10258 end loop;
10259
10260 Indic :=
10261 Make_Subtype_Declaration (Loc,
10262 Defining_Identifier => Subt,
10263 Subtype_Indication =>
10264 Make_Subtype_Indication (Loc,
10265 Subtype_Mark => New_Occurrence_Of (Par, Loc),
10266 Constraint => New_Copy_Tree (Constr)));
10267
10268 -- If this is a component subtype for an outer itype, it is not
10269 -- a list member, so simply set the parent link for analysis: if
10270 -- the enclosing type does not need to be in a declarative list,
10271 -- neither do the components.
10272
10273 if Is_List_Member (N)
10274 and then Nkind (N) /= N_Component_Declaration
10275 then
10276 Insert_Before (N, Indic);
10277 else
10278 Set_Parent (Indic, Parent (N));
10279 end if;
10280
10281 Analyze (Indic);
10282 Set_Underlying_Full_View (Typ, Full_View (Subt));
10283 Set_Is_Underlying_Full_View (Full_View (Subt));
10284 end Build_Underlying_Full_View;
10285
10286 -------------------------------
10287 -- Check_Abstract_Overriding --
10288 -------------------------------
10289
10290 procedure Check_Abstract_Overriding (T : Entity_Id) is
10291 Alias_Subp : Entity_Id;
10292 Elmt : Elmt_Id;
10293 Op_List : Elist_Id;
10294 Subp : Entity_Id;
10295 Type_Def : Node_Id;
10296
10297 procedure Check_Pragma_Implemented (Subp : Entity_Id);
10298 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine
10299 -- which has pragma Implemented already set. Check whether Subp's entity
10300 -- kind conforms to the implementation kind of the overridden routine.
10301
10302 procedure Check_Pragma_Implemented
10303 (Subp : Entity_Id;
10304 Iface_Subp : Entity_Id);
10305 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine
10306 -- Iface_Subp and both entities have pragma Implemented already set on
10307 -- them. Check whether the two implementation kinds are conforming.
10308
10309 procedure Inherit_Pragma_Implemented
10310 (Subp : Entity_Id;
10311 Iface_Subp : Entity_Id);
10312 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface
10313 -- subprogram Iface_Subp which has been marked by pragma Implemented.
10314 -- Propagate the implementation kind of Iface_Subp to Subp.
10315
10316 ------------------------------
10317 -- Check_Pragma_Implemented --
10318 ------------------------------
10319
10320 procedure Check_Pragma_Implemented (Subp : Entity_Id) is
10321 Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
10322 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
10323 Subp_Alias : constant Entity_Id := Alias (Subp);
10324 Contr_Typ : Entity_Id;
10325 Impl_Subp : Entity_Id;
10326
10327 begin
10328 -- Subp must have an alias since it is a hidden entity used to link
10329 -- an interface subprogram to its overriding counterpart.
10330
10331 pragma Assert (Present (Subp_Alias));
10332
10333 -- Handle aliases to synchronized wrappers
10334
10335 Impl_Subp := Subp_Alias;
10336
10337 if Is_Primitive_Wrapper (Impl_Subp) then
10338 Impl_Subp := Wrapped_Entity (Impl_Subp);
10339 end if;
10340
10341 -- Extract the type of the controlling formal
10342
10343 Contr_Typ := Etype (First_Formal (Subp_Alias));
10344
10345 if Is_Concurrent_Record_Type (Contr_Typ) then
10346 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
10347 end if;
10348
10349 -- An interface subprogram whose implementation kind is By_Entry must
10350 -- be implemented by an entry.
10351
10352 if Impl_Kind = Name_By_Entry
10353 and then Ekind (Impl_Subp) /= E_Entry
10354 then
10355 Error_Msg_Node_2 := Iface_Alias;
10356 Error_Msg_NE
10357 ("type & must implement abstract subprogram & with an entry",
10358 Subp_Alias, Contr_Typ);
10359
10360 elsif Impl_Kind = Name_By_Protected_Procedure then
10361
10362 -- An interface subprogram whose implementation kind is By_
10363 -- Protected_Procedure cannot be implemented by a primitive
10364 -- procedure of a task type.
10365
10366 if Ekind (Contr_Typ) /= E_Protected_Type then
10367 Error_Msg_Node_2 := Contr_Typ;
10368 Error_Msg_NE
10369 ("interface subprogram & cannot be implemented by a " &
10370 "primitive procedure of task type &", Subp_Alias,
10371 Iface_Alias);
10372
10373 -- An interface subprogram whose implementation kind is By_
10374 -- Protected_Procedure must be implemented by a procedure.
10375
10376 elsif Ekind (Impl_Subp) /= E_Procedure then
10377 Error_Msg_Node_2 := Iface_Alias;
10378 Error_Msg_NE
10379 ("type & must implement abstract subprogram & with a " &
10380 "procedure", Subp_Alias, Contr_Typ);
10381
10382 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
10383 and then Implementation_Kind (Impl_Subp) /= Impl_Kind
10384 then
10385 Error_Msg_Name_1 := Impl_Kind;
10386 Error_Msg_N
10387 ("overriding operation& must have synchronization%",
10388 Subp_Alias);
10389 end if;
10390
10391 -- If primitive has Optional synchronization, overriding operation
10392 -- must match if it has an explicit synchronization..
10393
10394 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
10395 and then Implementation_Kind (Impl_Subp) /= Impl_Kind
10396 then
10397 Error_Msg_Name_1 := Impl_Kind;
10398 Error_Msg_N
10399 ("overriding operation& must have syncrhonization%",
10400 Subp_Alias);
10401 end if;
10402 end Check_Pragma_Implemented;
10403
10404 ------------------------------
10405 -- Check_Pragma_Implemented --
10406 ------------------------------
10407
10408 procedure Check_Pragma_Implemented
10409 (Subp : Entity_Id;
10410 Iface_Subp : Entity_Id)
10411 is
10412 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
10413 Subp_Kind : constant Name_Id := Implementation_Kind (Subp);
10414
10415 begin
10416 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden
10417 -- and overriding subprogram are different. In general this is an
10418 -- error except when the implementation kind of the overridden
10419 -- subprograms is By_Any or Optional.
10420
10421 if Iface_Kind /= Subp_Kind
10422 and then Iface_Kind /= Name_By_Any
10423 and then Iface_Kind /= Name_Optional
10424 then
10425 if Iface_Kind = Name_By_Entry then
10426 Error_Msg_N
10427 ("incompatible implementation kind, overridden subprogram " &
10428 "is marked By_Entry", Subp);
10429 else
10430 Error_Msg_N
10431 ("incompatible implementation kind, overridden subprogram " &
10432 "is marked By_Protected_Procedure", Subp);
10433 end if;
10434 end if;
10435 end Check_Pragma_Implemented;
10436
10437 --------------------------------
10438 -- Inherit_Pragma_Implemented --
10439 --------------------------------
10440
10441 procedure Inherit_Pragma_Implemented
10442 (Subp : Entity_Id;
10443 Iface_Subp : Entity_Id)
10444 is
10445 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
10446 Loc : constant Source_Ptr := Sloc (Subp);
10447 Impl_Prag : Node_Id;
10448
10449 begin
10450 -- Since the implementation kind is stored as a representation item
10451 -- rather than a flag, create a pragma node.
10452
10453 Impl_Prag :=
10454 Make_Pragma (Loc,
10455 Chars => Name_Implemented,
10456 Pragma_Argument_Associations => New_List (
10457 Make_Pragma_Argument_Association (Loc,
10458 Expression => New_Occurrence_Of (Subp, Loc)),
10459
10460 Make_Pragma_Argument_Association (Loc,
10461 Expression => Make_Identifier (Loc, Iface_Kind))));
10462
10463 -- The pragma doesn't need to be analyzed because it is internally
10464 -- built. It is safe to directly register it as a rep item since we
10465 -- are only interested in the characters of the implementation kind.
10466
10467 Record_Rep_Item (Subp, Impl_Prag);
10468 end Inherit_Pragma_Implemented;
10469
10470 -- Start of processing for Check_Abstract_Overriding
10471
10472 begin
10473 Op_List := Primitive_Operations (T);
10474
10475 -- Loop to check primitive operations
10476
10477 Elmt := First_Elmt (Op_List);
10478 while Present (Elmt) loop
10479 Subp := Node (Elmt);
10480 Alias_Subp := Alias (Subp);
10481
10482 -- Inherited subprograms are identified by the fact that they do not
10483 -- come from source, and the associated source location is the
10484 -- location of the first subtype of the derived type.
10485
10486 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for
10487 -- subprograms that "require overriding".
10488
10489 -- Special exception, do not complain about failure to override the
10490 -- stream routines _Input and _Output, as well as the primitive
10491 -- operations used in dispatching selects since we always provide
10492 -- automatic overridings for these subprograms.
10493
10494 -- The partial view of T may have been a private extension, for
10495 -- which inherited functions dispatching on result are abstract.
10496 -- If the full view is a null extension, there is no need for
10497 -- overriding in Ada 2005, but wrappers need to be built for them
10498 -- (see exp_ch3, Build_Controlling_Function_Wrappers).
10499
10500 if Is_Null_Extension (T)
10501 and then Has_Controlling_Result (Subp)
10502 and then Ada_Version >= Ada_2005
10503 and then Present (Alias_Subp)
10504 and then not Comes_From_Source (Subp)
10505 and then not Is_Abstract_Subprogram (Alias_Subp)
10506 and then not Is_Access_Type (Etype (Subp))
10507 then
10508 null;
10509
10510 -- Ada 2005 (AI-251): Internal entities of interfaces need no
10511 -- processing because this check is done with the aliased
10512 -- entity
10513
10514 elsif Present (Interface_Alias (Subp)) then
10515 null;
10516
10517 elsif (Is_Abstract_Subprogram (Subp)
10518 or else Requires_Overriding (Subp)
10519 or else
10520 (Has_Controlling_Result (Subp)
10521 and then Present (Alias_Subp)
10522 and then not Comes_From_Source (Subp)
10523 and then Sloc (Subp) = Sloc (First_Subtype (T))))
10524 and then not Is_TSS (Subp, TSS_Stream_Input)
10525 and then not Is_TSS (Subp, TSS_Stream_Output)
10526 and then not Is_Abstract_Type (T)
10527 and then not Is_Predefined_Interface_Primitive (Subp)
10528
10529 -- Ada 2005 (AI-251): Do not consider hidden entities associated
10530 -- with abstract interface types because the check will be done
10531 -- with the aliased entity (otherwise we generate a duplicated
10532 -- error message).
10533
10534 and then not Present (Interface_Alias (Subp))
10535 then
10536 if Present (Alias_Subp) then
10537
10538 -- Only perform the check for a derived subprogram when the
10539 -- type has an explicit record extension. This avoids incorrect
10540 -- flagging of abstract subprograms for the case of a type
10541 -- without an extension that is derived from a formal type
10542 -- with a tagged actual (can occur within a private part).
10543
10544 -- Ada 2005 (AI-391): In the case of an inherited function with
10545 -- a controlling result of the type, the rule does not apply if
10546 -- the type is a null extension (unless the parent function
10547 -- itself is abstract, in which case the function must still be
10548 -- be overridden). The expander will generate an overriding
10549 -- wrapper function calling the parent subprogram (see
10550 -- Exp_Ch3.Make_Controlling_Wrapper_Functions).
10551
10552 Type_Def := Type_Definition (Parent (T));
10553
10554 if Nkind (Type_Def) = N_Derived_Type_Definition
10555 and then Present (Record_Extension_Part (Type_Def))
10556 and then
10557 (Ada_Version < Ada_2005
10558 or else not Is_Null_Extension (T)
10559 or else Ekind (Subp) = E_Procedure
10560 or else not Has_Controlling_Result (Subp)
10561 or else Is_Abstract_Subprogram (Alias_Subp)
10562 or else Requires_Overriding (Subp)
10563 or else Is_Access_Type (Etype (Subp)))
10564 then
10565 -- Avoid reporting error in case of abstract predefined
10566 -- primitive inherited from interface type because the
10567 -- body of internally generated predefined primitives
10568 -- of tagged types are generated later by Freeze_Type
10569
10570 if Is_Interface (Root_Type (T))
10571 and then Is_Abstract_Subprogram (Subp)
10572 and then Is_Predefined_Dispatching_Operation (Subp)
10573 and then not Comes_From_Source (Ultimate_Alias (Subp))
10574 then
10575 null;
10576
10577 -- A null extension is not obliged to override an inherited
10578 -- procedure subject to pragma Extensions_Visible with value
10579 -- False and at least one controlling OUT parameter
10580 -- (SPARK RM 6.1.7(6)).
10581
10582 elsif Is_Null_Extension (T)
10583 and then Is_EVF_Procedure (Subp)
10584 then
10585 null;
10586
10587 else
10588 Error_Msg_NE
10589 ("type must be declared abstract or & overridden",
10590 T, Subp);
10591
10592 -- Traverse the whole chain of aliased subprograms to
10593 -- complete the error notification. This is especially
10594 -- useful for traceability of the chain of entities when
10595 -- the subprogram corresponds with an interface
10596 -- subprogram (which may be defined in another package).
10597
10598 if Present (Alias_Subp) then
10599 declare
10600 E : Entity_Id;
10601
10602 begin
10603 E := Subp;
10604 while Present (Alias (E)) loop
10605
10606 -- Avoid reporting redundant errors on entities
10607 -- inherited from interfaces
10608
10609 if Sloc (E) /= Sloc (T) then
10610 Error_Msg_Sloc := Sloc (E);
10611 Error_Msg_NE
10612 ("\& has been inherited #", T, Subp);
10613 end if;
10614
10615 E := Alias (E);
10616 end loop;
10617
10618 Error_Msg_Sloc := Sloc (E);
10619
10620 -- AI05-0068: report if there is an overriding
10621 -- non-abstract subprogram that is invisible.
10622
10623 if Is_Hidden (E)
10624 and then not Is_Abstract_Subprogram (E)
10625 then
10626 Error_Msg_NE
10627 ("\& subprogram# is not visible",
10628 T, Subp);
10629
10630 -- Clarify the case where a non-null extension must
10631 -- override inherited procedure subject to pragma
10632 -- Extensions_Visible with value False and at least
10633 -- one controlling OUT param.
10634
10635 elsif Is_EVF_Procedure (E) then
10636 Error_Msg_NE
10637 ("\& # is subject to Extensions_Visible False",
10638 T, Subp);
10639
10640 else
10641 Error_Msg_NE
10642 ("\& has been inherited from subprogram #",
10643 T, Subp);
10644 end if;
10645 end;
10646 end if;
10647 end if;
10648
10649 -- Ada 2005 (AI-345): Protected or task type implementing
10650 -- abstract interfaces.
10651
10652 elsif Is_Concurrent_Record_Type (T)
10653 and then Present (Interfaces (T))
10654 then
10655 -- There is no need to check here RM 9.4(11.9/3) since we
10656 -- are processing the corresponding record type and the
10657 -- mode of the overriding subprograms was verified by
10658 -- Check_Conformance when the corresponding concurrent
10659 -- type declaration was analyzed.
10660
10661 Error_Msg_NE
10662 ("interface subprogram & must be overridden", T, Subp);
10663
10664 -- Examine primitive operations of synchronized type to find
10665 -- homonyms that have the wrong profile.
10666
10667 declare
10668 Prim : Entity_Id;
10669
10670 begin
10671 Prim := First_Entity (Corresponding_Concurrent_Type (T));
10672 while Present (Prim) loop
10673 if Chars (Prim) = Chars (Subp) then
10674 Error_Msg_NE
10675 ("profile is not type conformant with prefixed "
10676 & "view profile of inherited operation&",
10677 Prim, Subp);
10678 end if;
10679
10680 Next_Entity (Prim);
10681 end loop;
10682 end;
10683 end if;
10684
10685 else
10686 Error_Msg_Node_2 := T;
10687 Error_Msg_N
10688 ("abstract subprogram& not allowed for type&", Subp);
10689
10690 -- Also post unconditional warning on the type (unconditional
10691 -- so that if there are more than one of these cases, we get
10692 -- them all, and not just the first one).
10693
10694 Error_Msg_Node_2 := Subp;
10695 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T);
10696 end if;
10697
10698 -- A subprogram subject to pragma Extensions_Visible with value
10699 -- "True" cannot override a subprogram subject to the same pragma
10700 -- with value "False" (SPARK RM 6.1.7(5)).
10701
10702 elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True
10703 and then Present (Overridden_Operation (Subp))
10704 and then Extensions_Visible_Status (Overridden_Operation (Subp)) =
10705 Extensions_Visible_False
10706 then
10707 Error_Msg_Sloc := Sloc (Overridden_Operation (Subp));
10708 Error_Msg_N
10709 ("subprogram & with Extensions_Visible True cannot override "
10710 & "subprogram # with Extensions_Visible False", Subp);
10711 end if;
10712
10713 -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented
10714
10715 -- Subp is an expander-generated procedure which maps an interface
10716 -- alias to a protected wrapper. The interface alias is flagged by
10717 -- pragma Implemented. Ensure that Subp is a procedure when the
10718 -- implementation kind is By_Protected_Procedure or an entry when
10719 -- By_Entry.
10720
10721 if Ada_Version >= Ada_2012
10722 and then Is_Hidden (Subp)
10723 and then Present (Interface_Alias (Subp))
10724 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented)
10725 then
10726 Check_Pragma_Implemented (Subp);
10727 end if;
10728
10729 -- Subp is an interface primitive which overrides another interface
10730 -- primitive marked with pragma Implemented.
10731
10732 if Ada_Version >= Ada_2012
10733 and then Present (Overridden_Operation (Subp))
10734 and then Has_Rep_Pragma
10735 (Overridden_Operation (Subp), Name_Implemented)
10736 then
10737 -- If the overriding routine is also marked by Implemented, check
10738 -- that the two implementation kinds are conforming.
10739
10740 if Has_Rep_Pragma (Subp, Name_Implemented) then
10741 Check_Pragma_Implemented
10742 (Subp => Subp,
10743 Iface_Subp => Overridden_Operation (Subp));
10744
10745 -- Otherwise the overriding routine inherits the implementation
10746 -- kind from the overridden subprogram.
10747
10748 else
10749 Inherit_Pragma_Implemented
10750 (Subp => Subp,
10751 Iface_Subp => Overridden_Operation (Subp));
10752 end if;
10753 end if;
10754
10755 -- If the operation is a wrapper for a synchronized primitive, it
10756 -- may be called indirectly through a dispatching select. We assume
10757 -- that it will be referenced elsewhere indirectly, and suppress
10758 -- warnings about an unused entity.
10759
10760 if Is_Primitive_Wrapper (Subp)
10761 and then Present (Wrapped_Entity (Subp))
10762 then
10763 Set_Referenced (Wrapped_Entity (Subp));
10764 end if;
10765
10766 Next_Elmt (Elmt);
10767 end loop;
10768 end Check_Abstract_Overriding;
10769
10770 ------------------------------------------------
10771 -- Check_Access_Discriminant_Requires_Limited --
10772 ------------------------------------------------
10773
10774 procedure Check_Access_Discriminant_Requires_Limited
10775 (D : Node_Id;
10776 Loc : Node_Id)
10777 is
10778 begin
10779 -- A discriminant_specification for an access discriminant shall appear
10780 -- only in the declaration for a task or protected type, or for a type
10781 -- with the reserved word 'limited' in its definition or in one of its
10782 -- ancestors (RM 3.7(10)).
10783
10784 -- AI-0063: The proper condition is that type must be immutably limited,
10785 -- or else be a partial view.
10786
10787 if Nkind (Discriminant_Type (D)) = N_Access_Definition then
10788 if Is_Limited_View (Current_Scope)
10789 or else
10790 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration
10791 and then Limited_Present (Parent (Current_Scope)))
10792 then
10793 null;
10794
10795 else
10796 Error_Msg_N
10797 ("access discriminants allowed only for limited types", Loc);
10798 end if;
10799 end if;
10800 end Check_Access_Discriminant_Requires_Limited;
10801
10802 -----------------------------------
10803 -- Check_Aliased_Component_Types --
10804 -----------------------------------
10805
10806 procedure Check_Aliased_Component_Types (T : Entity_Id) is
10807 C : Entity_Id;
10808
10809 begin
10810 -- ??? Also need to check components of record extensions, but not
10811 -- components of protected types (which are always limited).
10812
10813 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
10814 -- types to be unconstrained. This is safe because it is illegal to
10815 -- create access subtypes to such types with explicit discriminant
10816 -- constraints.
10817
10818 if not Is_Limited_Type (T) then
10819 if Ekind (T) = E_Record_Type then
10820 C := First_Component (T);
10821 while Present (C) loop
10822 if Is_Aliased (C)
10823 and then Has_Discriminants (Etype (C))
10824 and then not Is_Constrained (Etype (C))
10825 and then not In_Instance_Body
10826 and then Ada_Version < Ada_2005
10827 then
10828 Error_Msg_N
10829 ("aliased component must be constrained (RM 3.6(11))",
10830 C);
10831 end if;
10832
10833 Next_Component (C);
10834 end loop;
10835
10836 elsif Ekind (T) = E_Array_Type then
10837 if Has_Aliased_Components (T)
10838 and then Has_Discriminants (Component_Type (T))
10839 and then not Is_Constrained (Component_Type (T))
10840 and then not In_Instance_Body
10841 and then Ada_Version < Ada_2005
10842 then
10843 Error_Msg_N
10844 ("aliased component type must be constrained (RM 3.6(11))",
10845 T);
10846 end if;
10847 end if;
10848 end if;
10849 end Check_Aliased_Component_Types;
10850
10851 ---------------------------------------
10852 -- Check_Anonymous_Access_Components --
10853 ---------------------------------------
10854
10855 procedure Check_Anonymous_Access_Components
10856 (Typ_Decl : Node_Id;
10857 Typ : Entity_Id;
10858 Prev : Entity_Id;
10859 Comp_List : Node_Id)
10860 is
10861 Loc : constant Source_Ptr := Sloc (Typ_Decl);
10862 Anon_Access : Entity_Id;
10863 Acc_Def : Node_Id;
10864 Comp : Node_Id;
10865 Comp_Def : Node_Id;
10866 Decl : Node_Id;
10867 Type_Def : Node_Id;
10868
10869 procedure Build_Incomplete_Type_Declaration;
10870 -- If the record type contains components that include an access to the
10871 -- current record, then create an incomplete type declaration for the
10872 -- record, to be used as the designated type of the anonymous access.
10873 -- This is done only once, and only if there is no previous partial
10874 -- view of the type.
10875
10876 function Designates_T (Subt : Node_Id) return Boolean;
10877 -- Check whether a node designates the enclosing record type, or 'Class
10878 -- of that type
10879
10880 function Mentions_T (Acc_Def : Node_Id) return Boolean;
10881 -- Check whether an access definition includes a reference to
10882 -- the enclosing record type. The reference can be a subtype mark
10883 -- in the access definition itself, a 'Class attribute reference, or
10884 -- recursively a reference appearing in a parameter specification
10885 -- or result definition of an access_to_subprogram definition.
10886
10887 --------------------------------------
10888 -- Build_Incomplete_Type_Declaration --
10889 --------------------------------------
10890
10891 procedure Build_Incomplete_Type_Declaration is
10892 Decl : Node_Id;
10893 Inc_T : Entity_Id;
10894 H : Entity_Id;
10895
10896 -- Is_Tagged indicates whether the type is tagged. It is tagged if
10897 -- it's "is new ... with record" or else "is tagged record ...".
10898
10899 Is_Tagged : constant Boolean :=
10900 (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
10901 and then
10902 Present (Record_Extension_Part (Type_Definition (Typ_Decl))))
10903 or else
10904 (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
10905 and then Tagged_Present (Type_Definition (Typ_Decl)));
10906
10907 begin
10908 -- If there is a previous partial view, no need to create a new one
10909 -- If the partial view, given by Prev, is incomplete, If Prev is
10910 -- a private declaration, full declaration is flagged accordingly.
10911
10912 if Prev /= Typ then
10913 if Is_Tagged then
10914 Make_Class_Wide_Type (Prev);
10915 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
10916 Set_Etype (Class_Wide_Type (Typ), Typ);
10917 end if;
10918
10919 return;
10920
10921 elsif Has_Private_Declaration (Typ) then
10922
10923 -- If we refer to T'Class inside T, and T is the completion of a
10924 -- private type, then make sure the class-wide type exists.
10925
10926 if Is_Tagged then
10927 Make_Class_Wide_Type (Typ);
10928 end if;
10929
10930 return;
10931
10932 -- If there was a previous anonymous access type, the incomplete
10933 -- type declaration will have been created already.
10934
10935 elsif Present (Current_Entity (Typ))
10936 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
10937 and then Full_View (Current_Entity (Typ)) = Typ
10938 then
10939 if Is_Tagged
10940 and then Comes_From_Source (Current_Entity (Typ))
10941 and then not Is_Tagged_Type (Current_Entity (Typ))
10942 then
10943 Make_Class_Wide_Type (Typ);
10944 Error_Msg_N
10945 ("incomplete view of tagged type should be declared tagged??",
10946 Parent (Current_Entity (Typ)));
10947 end if;
10948 return;
10949
10950 else
10951 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
10952 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
10953
10954 -- Type has already been inserted into the current scope. Remove
10955 -- it, and add incomplete declaration for type, so that subsequent
10956 -- anonymous access types can use it. The entity is unchained from
10957 -- the homonym list and from immediate visibility. After analysis,
10958 -- the entity in the incomplete declaration becomes immediately
10959 -- visible in the record declaration that follows.
10960
10961 H := Current_Entity (Typ);
10962
10963 if H = Typ then
10964 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
10965 else
10966 while Present (H)
10967 and then Homonym (H) /= Typ
10968 loop
10969 H := Homonym (Typ);
10970 end loop;
10971
10972 Set_Homonym (H, Homonym (Typ));
10973 end if;
10974
10975 Insert_Before (Typ_Decl, Decl);
10976 Analyze (Decl);
10977 Set_Full_View (Inc_T, Typ);
10978
10979 if Is_Tagged then
10980
10981 -- Create a common class-wide type for both views, and set the
10982 -- Etype of the class-wide type to the full view.
10983
10984 Make_Class_Wide_Type (Inc_T);
10985 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
10986 Set_Etype (Class_Wide_Type (Typ), Typ);
10987 end if;
10988 end if;
10989 end Build_Incomplete_Type_Declaration;
10990
10991 ------------------
10992 -- Designates_T --
10993 ------------------
10994
10995 function Designates_T (Subt : Node_Id) return Boolean is
10996 Type_Id : constant Name_Id := Chars (Typ);
10997
10998 function Names_T (Nam : Node_Id) return Boolean;
10999 -- The record type has not been introduced in the current scope
11000 -- yet, so we must examine the name of the type itself, either
11001 -- an identifier T, or an expanded name of the form P.T, where
11002 -- P denotes the current scope.
11003
11004 -------------
11005 -- Names_T --
11006 -------------
11007
11008 function Names_T (Nam : Node_Id) return Boolean is
11009 begin
11010 if Nkind (Nam) = N_Identifier then
11011 return Chars (Nam) = Type_Id;
11012
11013 elsif Nkind (Nam) = N_Selected_Component then
11014 if Chars (Selector_Name (Nam)) = Type_Id then
11015 if Nkind (Prefix (Nam)) = N_Identifier then
11016 return Chars (Prefix (Nam)) = Chars (Current_Scope);
11017
11018 elsif Nkind (Prefix (Nam)) = N_Selected_Component then
11019 return Chars (Selector_Name (Prefix (Nam))) =
11020 Chars (Current_Scope);
11021 else
11022 return False;
11023 end if;
11024
11025 else
11026 return False;
11027 end if;
11028
11029 else
11030 return False;
11031 end if;
11032 end Names_T;
11033
11034 -- Start of processing for Designates_T
11035
11036 begin
11037 if Nkind (Subt) = N_Identifier then
11038 return Chars (Subt) = Type_Id;
11039
11040 -- Reference can be through an expanded name which has not been
11041 -- analyzed yet, and which designates enclosing scopes.
11042
11043 elsif Nkind (Subt) = N_Selected_Component then
11044 if Names_T (Subt) then
11045 return True;
11046
11047 -- Otherwise it must denote an entity that is already visible.
11048 -- The access definition may name a subtype of the enclosing
11049 -- type, if there is a previous incomplete declaration for it.
11050
11051 else
11052 Find_Selected_Component (Subt);
11053 return
11054 Is_Entity_Name (Subt)
11055 and then Scope (Entity (Subt)) = Current_Scope
11056 and then
11057 (Chars (Base_Type (Entity (Subt))) = Type_Id
11058 or else
11059 (Is_Class_Wide_Type (Entity (Subt))
11060 and then
11061 Chars (Etype (Base_Type (Entity (Subt)))) =
11062 Type_Id));
11063 end if;
11064
11065 -- A reference to the current type may appear as the prefix of
11066 -- a 'Class attribute.
11067
11068 elsif Nkind (Subt) = N_Attribute_Reference
11069 and then Attribute_Name (Subt) = Name_Class
11070 then
11071 return Names_T (Prefix (Subt));
11072
11073 else
11074 return False;
11075 end if;
11076 end Designates_T;
11077
11078 ----------------
11079 -- Mentions_T --
11080 ----------------
11081
11082 function Mentions_T (Acc_Def : Node_Id) return Boolean is
11083 Param_Spec : Node_Id;
11084
11085 Acc_Subprg : constant Node_Id :=
11086 Access_To_Subprogram_Definition (Acc_Def);
11087
11088 begin
11089 if No (Acc_Subprg) then
11090 return Designates_T (Subtype_Mark (Acc_Def));
11091 end if;
11092
11093 -- Component is an access_to_subprogram: examine its formals,
11094 -- and result definition in the case of an access_to_function.
11095
11096 Param_Spec := First (Parameter_Specifications (Acc_Subprg));
11097 while Present (Param_Spec) loop
11098 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
11099 and then Mentions_T (Parameter_Type (Param_Spec))
11100 then
11101 return True;
11102
11103 elsif Designates_T (Parameter_Type (Param_Spec)) then
11104 return True;
11105 end if;
11106
11107 Next (Param_Spec);
11108 end loop;
11109
11110 if Nkind (Acc_Subprg) = N_Access_Function_Definition then
11111 if Nkind (Result_Definition (Acc_Subprg)) =
11112 N_Access_Definition
11113 then
11114 return Mentions_T (Result_Definition (Acc_Subprg));
11115 else
11116 return Designates_T (Result_Definition (Acc_Subprg));
11117 end if;
11118 end if;
11119
11120 return False;
11121 end Mentions_T;
11122
11123 -- Start of processing for Check_Anonymous_Access_Components
11124
11125 begin
11126 if No (Comp_List) then
11127 return;
11128 end if;
11129
11130 Comp := First (Component_Items (Comp_List));
11131 while Present (Comp) loop
11132 if Nkind (Comp) = N_Component_Declaration
11133 and then Present
11134 (Access_Definition (Component_Definition (Comp)))
11135 and then
11136 Mentions_T (Access_Definition (Component_Definition (Comp)))
11137 then
11138 Comp_Def := Component_Definition (Comp);
11139 Acc_Def :=
11140 Access_To_Subprogram_Definition (Access_Definition (Comp_Def));
11141
11142 Build_Incomplete_Type_Declaration;
11143 Anon_Access := Make_Temporary (Loc, 'S');
11144
11145 -- Create a declaration for the anonymous access type: either
11146 -- an access_to_object or an access_to_subprogram.
11147
11148 if Present (Acc_Def) then
11149 if Nkind (Acc_Def) = N_Access_Function_Definition then
11150 Type_Def :=
11151 Make_Access_Function_Definition (Loc,
11152 Parameter_Specifications =>
11153 Parameter_Specifications (Acc_Def),
11154 Result_Definition => Result_Definition (Acc_Def));
11155 else
11156 Type_Def :=
11157 Make_Access_Procedure_Definition (Loc,
11158 Parameter_Specifications =>
11159 Parameter_Specifications (Acc_Def));
11160 end if;
11161
11162 else
11163 Type_Def :=
11164 Make_Access_To_Object_Definition (Loc,
11165 Subtype_Indication =>
11166 Relocate_Node
11167 (Subtype_Mark (Access_Definition (Comp_Def))));
11168
11169 Set_Constant_Present
11170 (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
11171 Set_All_Present
11172 (Type_Def, All_Present (Access_Definition (Comp_Def)));
11173 end if;
11174
11175 Set_Null_Exclusion_Present
11176 (Type_Def,
11177 Null_Exclusion_Present (Access_Definition (Comp_Def)));
11178
11179 Decl :=
11180 Make_Full_Type_Declaration (Loc,
11181 Defining_Identifier => Anon_Access,
11182 Type_Definition => Type_Def);
11183
11184 Insert_Before (Typ_Decl, Decl);
11185 Analyze (Decl);
11186
11187 -- If an access to subprogram, create the extra formals
11188
11189 if Present (Acc_Def) then
11190 Create_Extra_Formals (Designated_Type (Anon_Access));
11191
11192 -- If an access to object, preserve entity of designated type,
11193 -- for ASIS use, before rewriting the component definition.
11194
11195 else
11196 declare
11197 Desig : Entity_Id;
11198
11199 begin
11200 Desig := Entity (Subtype_Indication (Type_Def));
11201
11202 -- If the access definition is to the current record,
11203 -- the visible entity at this point is an incomplete
11204 -- type. Retrieve the full view to simplify ASIS queries
11205
11206 if Ekind (Desig) = E_Incomplete_Type then
11207 Desig := Full_View (Desig);
11208 end if;
11209
11210 Set_Entity
11211 (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
11212 end;
11213 end if;
11214
11215 Rewrite (Comp_Def,
11216 Make_Component_Definition (Loc,
11217 Subtype_Indication =>
11218 New_Occurrence_Of (Anon_Access, Loc)));
11219
11220 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
11221 Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
11222 else
11223 Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
11224 end if;
11225
11226 Set_Is_Local_Anonymous_Access (Anon_Access);
11227 end if;
11228
11229 Next (Comp);
11230 end loop;
11231
11232 if Present (Variant_Part (Comp_List)) then
11233 declare
11234 V : Node_Id;
11235 begin
11236 V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
11237 while Present (V) loop
11238 Check_Anonymous_Access_Components
11239 (Typ_Decl, Typ, Prev, Component_List (V));
11240 Next_Non_Pragma (V);
11241 end loop;
11242 end;
11243 end if;
11244 end Check_Anonymous_Access_Components;
11245
11246 ----------------------
11247 -- Check_Completion --
11248 ----------------------
11249
11250 procedure Check_Completion (Body_Id : Node_Id := Empty) is
11251 E : Entity_Id;
11252
11253 procedure Post_Error;
11254 -- Post error message for lack of completion for entity E
11255
11256 ----------------
11257 -- Post_Error --
11258 ----------------
11259
11260 procedure Post_Error is
11261 procedure Missing_Body;
11262 -- Output missing body message
11263
11264 ------------------
11265 -- Missing_Body --
11266 ------------------
11267
11268 procedure Missing_Body is
11269 begin
11270 -- Spec is in same unit, so we can post on spec
11271
11272 if In_Same_Source_Unit (Body_Id, E) then
11273 Error_Msg_N ("missing body for &", E);
11274
11275 -- Spec is in a separate unit, so we have to post on the body
11276
11277 else
11278 Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
11279 end if;
11280 end Missing_Body;
11281
11282 -- Start of processing for Post_Error
11283
11284 begin
11285 if not Comes_From_Source (E) then
11286 if Ekind_In (E, E_Task_Type, E_Protected_Type) then
11287
11288 -- It may be an anonymous protected type created for a
11289 -- single variable. Post error on variable, if present.
11290
11291 declare
11292 Var : Entity_Id;
11293
11294 begin
11295 Var := First_Entity (Current_Scope);
11296 while Present (Var) loop
11297 exit when Etype (Var) = E
11298 and then Comes_From_Source (Var);
11299
11300 Next_Entity (Var);
11301 end loop;
11302
11303 if Present (Var) then
11304 E := Var;
11305 end if;
11306 end;
11307 end if;
11308 end if;
11309
11310 -- If a generated entity has no completion, then either previous
11311 -- semantic errors have disabled the expansion phase, or else we had
11312 -- missing subunits, or else we are compiling without expansion,
11313 -- or else something is very wrong.
11314
11315 if not Comes_From_Source (E) then
11316 pragma Assert
11317 (Serious_Errors_Detected > 0
11318 or else Configurable_Run_Time_Violations > 0
11319 or else Subunits_Missing
11320 or else not Expander_Active);
11321 return;
11322
11323 -- Here for source entity
11324
11325 else
11326 -- Here if no body to post the error message, so we post the error
11327 -- on the declaration that has no completion. This is not really
11328 -- the right place to post it, think about this later ???
11329
11330 if No (Body_Id) then
11331 if Is_Type (E) then
11332 Error_Msg_NE
11333 ("missing full declaration for }", Parent (E), E);
11334 else
11335 Error_Msg_NE ("missing body for &", Parent (E), E);
11336 end if;
11337
11338 -- Package body has no completion for a declaration that appears
11339 -- in the corresponding spec. Post error on the body, with a
11340 -- reference to the non-completed declaration.
11341
11342 else
11343 Error_Msg_Sloc := Sloc (E);
11344
11345 if Is_Type (E) then
11346 Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
11347
11348 elsif Is_Overloadable (E)
11349 and then Current_Entity_In_Scope (E) /= E
11350 then
11351 -- It may be that the completion is mistyped and appears as
11352 -- a distinct overloading of the entity.
11353
11354 declare
11355 Candidate : constant Entity_Id :=
11356 Current_Entity_In_Scope (E);
11357 Decl : constant Node_Id :=
11358 Unit_Declaration_Node (Candidate);
11359
11360 begin
11361 if Is_Overloadable (Candidate)
11362 and then Ekind (Candidate) = Ekind (E)
11363 and then Nkind (Decl) = N_Subprogram_Body
11364 and then Acts_As_Spec (Decl)
11365 then
11366 Check_Type_Conformant (Candidate, E);
11367
11368 else
11369 Missing_Body;
11370 end if;
11371 end;
11372
11373 else
11374 Missing_Body;
11375 end if;
11376 end if;
11377 end if;
11378 end Post_Error;
11379
11380 -- Local variables
11381
11382 Pack_Id : constant Entity_Id := Current_Scope;
11383
11384 -- Start of processing for Check_Completion
11385
11386 begin
11387 E := First_Entity (Pack_Id);
11388 while Present (E) loop
11389 if Is_Intrinsic_Subprogram (E) then
11390 null;
11391
11392 -- The following situation requires special handling: a child unit
11393 -- that appears in the context clause of the body of its parent:
11394
11395 -- procedure Parent.Child (...);
11396
11397 -- with Parent.Child;
11398 -- package body Parent is
11399
11400 -- Here Parent.Child appears as a local entity, but should not be
11401 -- flagged as requiring completion, because it is a compilation
11402 -- unit.
11403
11404 -- Ignore missing completion for a subprogram that does not come from
11405 -- source (including the _Call primitive operation of RAS types,
11406 -- which has to have the flag Comes_From_Source for other purposes):
11407 -- we assume that the expander will provide the missing completion.
11408 -- In case of previous errors, other expansion actions that provide
11409 -- bodies for null procedures with not be invoked, so inhibit message
11410 -- in those cases.
11411
11412 -- Note that E_Operator is not in the list that follows, because
11413 -- this kind is reserved for predefined operators, that are
11414 -- intrinsic and do not need completion.
11415
11416 elsif Ekind_In (E, E_Function,
11417 E_Procedure,
11418 E_Generic_Function,
11419 E_Generic_Procedure)
11420 then
11421 if Has_Completion (E) then
11422 null;
11423
11424 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
11425 null;
11426
11427 elsif Is_Subprogram (E)
11428 and then (not Comes_From_Source (E)
11429 or else Chars (E) = Name_uCall)
11430 then
11431 null;
11432
11433 elsif
11434 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
11435 then
11436 null;
11437
11438 elsif Nkind (Parent (E)) = N_Procedure_Specification
11439 and then Null_Present (Parent (E))
11440 and then Serious_Errors_Detected > 0
11441 then
11442 null;
11443
11444 else
11445 Post_Error;
11446 end if;
11447
11448 elsif Is_Entry (E) then
11449 if not Has_Completion (E) and then
11450 (Ekind (Scope (E)) = E_Protected_Object
11451 or else Ekind (Scope (E)) = E_Protected_Type)
11452 then
11453 Post_Error;
11454 end if;
11455
11456 elsif Is_Package_Or_Generic_Package (E) then
11457 if Unit_Requires_Body (E) then
11458 if not Has_Completion (E)
11459 and then Nkind (Parent (Unit_Declaration_Node (E))) /=
11460 N_Compilation_Unit
11461 then
11462 Post_Error;
11463 end if;
11464
11465 elsif not Is_Child_Unit (E) then
11466 May_Need_Implicit_Body (E);
11467 end if;
11468
11469 -- A formal incomplete type (Ada 2012) does not require a completion;
11470 -- other incomplete type declarations do.
11471
11472 elsif Ekind (E) = E_Incomplete_Type
11473 and then No (Underlying_Type (E))
11474 and then not Is_Generic_Type (E)
11475 then
11476 Post_Error;
11477
11478 elsif Ekind_In (E, E_Task_Type, E_Protected_Type)
11479 and then not Has_Completion (E)
11480 then
11481 Post_Error;
11482
11483 -- A single task declared in the current scope is a constant, verify
11484 -- that the body of its anonymous type is in the same scope. If the
11485 -- task is defined elsewhere, this may be a renaming declaration for
11486 -- which no completion is needed.
11487
11488 elsif Ekind (E) = E_Constant
11489 and then Ekind (Etype (E)) = E_Task_Type
11490 and then not Has_Completion (Etype (E))
11491 and then Scope (Etype (E)) = Current_Scope
11492 then
11493 Post_Error;
11494
11495 elsif Ekind (E) = E_Protected_Object
11496 and then not Has_Completion (Etype (E))
11497 then
11498 Post_Error;
11499
11500 elsif Ekind (E) = E_Record_Type then
11501 if Is_Tagged_Type (E) then
11502 Check_Abstract_Overriding (E);
11503 Check_Conventions (E);
11504 end if;
11505
11506 Check_Aliased_Component_Types (E);
11507
11508 elsif Ekind (E) = E_Array_Type then
11509 Check_Aliased_Component_Types (E);
11510
11511 end if;
11512
11513 Next_Entity (E);
11514 end loop;
11515 end Check_Completion;
11516
11517 ------------------------------------
11518 -- Check_CPP_Type_Has_No_Defaults --
11519 ------------------------------------
11520
11521 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
11522 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
11523 Clist : Node_Id;
11524 Comp : Node_Id;
11525
11526 begin
11527 -- Obtain the component list
11528
11529 if Nkind (Tdef) = N_Record_Definition then
11530 Clist := Component_List (Tdef);
11531 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
11532 Clist := Component_List (Record_Extension_Part (Tdef));
11533 end if;
11534
11535 -- Check all components to ensure no default expressions
11536
11537 if Present (Clist) then
11538 Comp := First (Component_Items (Clist));
11539 while Present (Comp) loop
11540 if Present (Expression (Comp)) then
11541 Error_Msg_N
11542 ("component of imported 'C'P'P type cannot have "
11543 & "default expression", Expression (Comp));
11544 end if;
11545
11546 Next (Comp);
11547 end loop;
11548 end if;
11549 end Check_CPP_Type_Has_No_Defaults;
11550
11551 ----------------------------
11552 -- Check_Delta_Expression --
11553 ----------------------------
11554
11555 procedure Check_Delta_Expression (E : Node_Id) is
11556 begin
11557 if not (Is_Real_Type (Etype (E))) then
11558 Wrong_Type (E, Any_Real);
11559
11560 elsif not Is_OK_Static_Expression (E) then
11561 Flag_Non_Static_Expr
11562 ("non-static expression used for delta value!", E);
11563
11564 elsif not UR_Is_Positive (Expr_Value_R (E)) then
11565 Error_Msg_N ("delta expression must be positive", E);
11566
11567 else
11568 return;
11569 end if;
11570
11571 -- If any of above errors occurred, then replace the incorrect
11572 -- expression by the real 0.1, which should prevent further errors.
11573
11574 Rewrite (E,
11575 Make_Real_Literal (Sloc (E), Ureal_Tenth));
11576 Analyze_And_Resolve (E, Standard_Float);
11577 end Check_Delta_Expression;
11578
11579 -----------------------------
11580 -- Check_Digits_Expression --
11581 -----------------------------
11582
11583 procedure Check_Digits_Expression (E : Node_Id) is
11584 begin
11585 if not (Is_Integer_Type (Etype (E))) then
11586 Wrong_Type (E, Any_Integer);
11587
11588 elsif not Is_OK_Static_Expression (E) then
11589 Flag_Non_Static_Expr
11590 ("non-static expression used for digits value!", E);
11591
11592 elsif Expr_Value (E) <= 0 then
11593 Error_Msg_N ("digits value must be greater than zero", E);
11594
11595 else
11596 return;
11597 end if;
11598
11599 -- If any of above errors occurred, then replace the incorrect
11600 -- expression by the integer 1, which should prevent further errors.
11601
11602 Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
11603 Analyze_And_Resolve (E, Standard_Integer);
11604
11605 end Check_Digits_Expression;
11606
11607 --------------------------
11608 -- Check_Initialization --
11609 --------------------------
11610
11611 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
11612 begin
11613 -- Special processing for limited types
11614
11615 if Is_Limited_Type (T)
11616 and then not In_Instance
11617 and then not In_Inlined_Body
11618 then
11619 if not OK_For_Limited_Init (T, Exp) then
11620
11621 -- In GNAT mode, this is just a warning, to allow it to be evilly
11622 -- turned off. Otherwise it is a real error.
11623
11624 if GNAT_Mode then
11625 Error_Msg_N
11626 ("??cannot initialize entities of limited type!", Exp);
11627
11628 elsif Ada_Version < Ada_2005 then
11629
11630 -- The side effect removal machinery may generate illegal Ada
11631 -- code to avoid the usage of access types and 'reference in
11632 -- SPARK mode. Since this is legal code with respect to theorem
11633 -- proving, do not emit the error.
11634
11635 if GNATprove_Mode
11636 and then Nkind (Exp) = N_Function_Call
11637 and then Nkind (Parent (Exp)) = N_Object_Declaration
11638 and then not Comes_From_Source
11639 (Defining_Identifier (Parent (Exp)))
11640 then
11641 null;
11642
11643 else
11644 Error_Msg_N
11645 ("cannot initialize entities of limited type", Exp);
11646 Explain_Limited_Type (T, Exp);
11647 end if;
11648
11649 else
11650 -- Specialize error message according to kind of illegal
11651 -- initial expression.
11652
11653 if Nkind (Exp) = N_Type_Conversion
11654 and then Nkind (Expression (Exp)) = N_Function_Call
11655 then
11656 Error_Msg_N
11657 ("illegal context for call"
11658 & " to function with limited result", Exp);
11659
11660 else
11661 Error_Msg_N
11662 ("initialization of limited object requires aggregate "
11663 & "or function call", Exp);
11664 end if;
11665 end if;
11666 end if;
11667 end if;
11668
11669 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets
11670 -- set unless we can be sure that no range check is required.
11671
11672 if (GNATprove_Mode or not Expander_Active)
11673 and then Is_Scalar_Type (T)
11674 and then not Is_In_Range (Exp, T, Assume_Valid => True)
11675 then
11676 Set_Do_Range_Check (Exp);
11677 end if;
11678 end Check_Initialization;
11679
11680 ----------------------
11681 -- Check_Interfaces --
11682 ----------------------
11683
11684 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
11685 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
11686
11687 Iface : Node_Id;
11688 Iface_Def : Node_Id;
11689 Iface_Typ : Entity_Id;
11690 Parent_Node : Node_Id;
11691
11692 Is_Task : Boolean := False;
11693 -- Set True if parent type or any progenitor is a task interface
11694
11695 Is_Protected : Boolean := False;
11696 -- Set True if parent type or any progenitor is a protected interface
11697
11698 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
11699 -- Check that a progenitor is compatible with declaration. If an error
11700 -- message is output, it is posted on Error_Node.
11701
11702 ------------------
11703 -- Check_Ifaces --
11704 ------------------
11705
11706 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
11707 Iface_Id : constant Entity_Id :=
11708 Defining_Identifier (Parent (Iface_Def));
11709 Type_Def : Node_Id;
11710
11711 begin
11712 if Nkind (N) = N_Private_Extension_Declaration then
11713 Type_Def := N;
11714 else
11715 Type_Def := Type_Definition (N);
11716 end if;
11717
11718 if Is_Task_Interface (Iface_Id) then
11719 Is_Task := True;
11720
11721 elsif Is_Protected_Interface (Iface_Id) then
11722 Is_Protected := True;
11723 end if;
11724
11725 if Is_Synchronized_Interface (Iface_Id) then
11726
11727 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
11728 -- extension derived from a synchronized interface must explicitly
11729 -- be declared synchronized, because the full view will be a
11730 -- synchronized type.
11731
11732 if Nkind (N) = N_Private_Extension_Declaration then
11733 if not Synchronized_Present (N) then
11734 Error_Msg_NE
11735 ("private extension of& must be explicitly synchronized",
11736 N, Iface_Id);
11737 end if;
11738
11739 -- However, by 3.9.4(16/2), a full type that is a record extension
11740 -- is never allowed to derive from a synchronized interface (note
11741 -- that interfaces must be excluded from this check, because those
11742 -- are represented by derived type definitions in some cases).
11743
11744 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
11745 and then not Interface_Present (Type_Definition (N))
11746 then
11747 Error_Msg_N ("record extension cannot derive from synchronized "
11748 & "interface", Error_Node);
11749 end if;
11750 end if;
11751
11752 -- Check that the characteristics of the progenitor are compatible
11753 -- with the explicit qualifier in the declaration.
11754 -- The check only applies to qualifiers that come from source.
11755 -- Limited_Present also appears in the declaration of corresponding
11756 -- records, and the check does not apply to them.
11757
11758 if Limited_Present (Type_Def)
11759 and then not
11760 Is_Concurrent_Record_Type (Defining_Identifier (N))
11761 then
11762 if Is_Limited_Interface (Parent_Type)
11763 and then not Is_Limited_Interface (Iface_Id)
11764 then
11765 Error_Msg_NE
11766 ("progenitor & must be limited interface",
11767 Error_Node, Iface_Id);
11768
11769 elsif
11770 (Task_Present (Iface_Def)
11771 or else Protected_Present (Iface_Def)
11772 or else Synchronized_Present (Iface_Def))
11773 and then Nkind (N) /= N_Private_Extension_Declaration
11774 and then not Error_Posted (N)
11775 then
11776 Error_Msg_NE
11777 ("progenitor & must be limited interface",
11778 Error_Node, Iface_Id);
11779 end if;
11780
11781 -- Protected interfaces can only inherit from limited, synchronized
11782 -- or protected interfaces.
11783
11784 elsif Nkind (N) = N_Full_Type_Declaration
11785 and then Protected_Present (Type_Def)
11786 then
11787 if Limited_Present (Iface_Def)
11788 or else Synchronized_Present (Iface_Def)
11789 or else Protected_Present (Iface_Def)
11790 then
11791 null;
11792
11793 elsif Task_Present (Iface_Def) then
11794 Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
11795 & "from task interface", Error_Node);
11796
11797 else
11798 Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
11799 & "from non-limited interface", Error_Node);
11800 end if;
11801
11802 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
11803 -- limited and synchronized.
11804
11805 elsif Synchronized_Present (Type_Def) then
11806 if Limited_Present (Iface_Def)
11807 or else Synchronized_Present (Iface_Def)
11808 then
11809 null;
11810
11811 elsif Protected_Present (Iface_Def)
11812 and then Nkind (N) /= N_Private_Extension_Declaration
11813 then
11814 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
11815 & "from protected interface", Error_Node);
11816
11817 elsif Task_Present (Iface_Def)
11818 and then Nkind (N) /= N_Private_Extension_Declaration
11819 then
11820 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
11821 & "from task interface", Error_Node);
11822
11823 elsif not Is_Limited_Interface (Iface_Id) then
11824 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
11825 & "from non-limited interface", Error_Node);
11826 end if;
11827
11828 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
11829 -- synchronized or task interfaces.
11830
11831 elsif Nkind (N) = N_Full_Type_Declaration
11832 and then Task_Present (Type_Def)
11833 then
11834 if Limited_Present (Iface_Def)
11835 or else Synchronized_Present (Iface_Def)
11836 or else Task_Present (Iface_Def)
11837 then
11838 null;
11839
11840 elsif Protected_Present (Iface_Def) then
11841 Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
11842 & "protected interface", Error_Node);
11843
11844 else
11845 Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
11846 & "non-limited interface", Error_Node);
11847 end if;
11848 end if;
11849 end Check_Ifaces;
11850
11851 -- Start of processing for Check_Interfaces
11852
11853 begin
11854 if Is_Interface (Parent_Type) then
11855 if Is_Task_Interface (Parent_Type) then
11856 Is_Task := True;
11857
11858 elsif Is_Protected_Interface (Parent_Type) then
11859 Is_Protected := True;
11860 end if;
11861 end if;
11862
11863 if Nkind (N) = N_Private_Extension_Declaration then
11864
11865 -- Check that progenitors are compatible with declaration
11866
11867 Iface := First (Interface_List (Def));
11868 while Present (Iface) loop
11869 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
11870
11871 Parent_Node := Parent (Base_Type (Iface_Typ));
11872 Iface_Def := Type_Definition (Parent_Node);
11873
11874 if not Is_Interface (Iface_Typ) then
11875 Diagnose_Interface (Iface, Iface_Typ);
11876 else
11877 Check_Ifaces (Iface_Def, Iface);
11878 end if;
11879
11880 Next (Iface);
11881 end loop;
11882
11883 if Is_Task and Is_Protected then
11884 Error_Msg_N
11885 ("type cannot derive from task and protected interface", N);
11886 end if;
11887
11888 return;
11889 end if;
11890
11891 -- Full type declaration of derived type.
11892 -- Check compatibility with parent if it is interface type
11893
11894 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
11895 and then Is_Interface (Parent_Type)
11896 then
11897 Parent_Node := Parent (Parent_Type);
11898
11899 -- More detailed checks for interface varieties
11900
11901 Check_Ifaces
11902 (Iface_Def => Type_Definition (Parent_Node),
11903 Error_Node => Subtype_Indication (Type_Definition (N)));
11904 end if;
11905
11906 Iface := First (Interface_List (Def));
11907 while Present (Iface) loop
11908 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
11909
11910 Parent_Node := Parent (Base_Type (Iface_Typ));
11911 Iface_Def := Type_Definition (Parent_Node);
11912
11913 if not Is_Interface (Iface_Typ) then
11914 Diagnose_Interface (Iface, Iface_Typ);
11915
11916 else
11917 -- "The declaration of a specific descendant of an interface
11918 -- type freezes the interface type" RM 13.14
11919
11920 Freeze_Before (N, Iface_Typ);
11921 Check_Ifaces (Iface_Def, Error_Node => Iface);
11922 end if;
11923
11924 Next (Iface);
11925 end loop;
11926
11927 if Is_Task and Is_Protected then
11928 Error_Msg_N
11929 ("type cannot derive from task and protected interface", N);
11930 end if;
11931 end Check_Interfaces;
11932
11933 ------------------------------------
11934 -- Check_Or_Process_Discriminants --
11935 ------------------------------------
11936
11937 -- If an incomplete or private type declaration was already given for the
11938 -- type, the discriminants may have already been processed if they were
11939 -- present on the incomplete declaration. In this case a full conformance
11940 -- check has been performed in Find_Type_Name, and we then recheck here
11941 -- some properties that can't be checked on the partial view alone.
11942 -- Otherwise we call Process_Discriminants.
11943
11944 procedure Check_Or_Process_Discriminants
11945 (N : Node_Id;
11946 T : Entity_Id;
11947 Prev : Entity_Id := Empty)
11948 is
11949 begin
11950 if Has_Discriminants (T) then
11951
11952 -- Discriminants are already set on T if they were already present
11953 -- on the partial view. Make them visible to component declarations.
11954
11955 declare
11956 D : Entity_Id;
11957 -- Discriminant on T (full view) referencing expr on partial view
11958
11959 Prev_D : Entity_Id;
11960 -- Entity of corresponding discriminant on partial view
11961
11962 New_D : Node_Id;
11963 -- Discriminant specification for full view, expression is
11964 -- the syntactic copy on full view (which has been checked for
11965 -- conformance with partial view), only used here to post error
11966 -- message.
11967
11968 begin
11969 D := First_Discriminant (T);
11970 New_D := First (Discriminant_Specifications (N));
11971 while Present (D) loop
11972 Prev_D := Current_Entity (D);
11973 Set_Current_Entity (D);
11974 Set_Is_Immediately_Visible (D);
11975 Set_Homonym (D, Prev_D);
11976
11977 -- Handle the case where there is an untagged partial view and
11978 -- the full view is tagged: must disallow discriminants with
11979 -- defaults, unless compiling for Ada 2012, which allows a
11980 -- limited tagged type to have defaulted discriminants (see
11981 -- AI05-0214). However, suppress error here if it was already
11982 -- reported on the default expression of the partial view.
11983
11984 if Is_Tagged_Type (T)
11985 and then Present (Expression (Parent (D)))
11986 and then (not Is_Limited_Type (Current_Scope)
11987 or else Ada_Version < Ada_2012)
11988 and then not Error_Posted (Expression (Parent (D)))
11989 then
11990 if Ada_Version >= Ada_2012 then
11991 Error_Msg_N
11992 ("discriminants of nonlimited tagged type cannot have "
11993 & "defaults",
11994 Expression (New_D));
11995 else
11996 Error_Msg_N
11997 ("discriminants of tagged type cannot have defaults",
11998 Expression (New_D));
11999 end if;
12000 end if;
12001
12002 -- Ada 2005 (AI-230): Access discriminant allowed in
12003 -- non-limited record types.
12004
12005 if Ada_Version < Ada_2005 then
12006
12007 -- This restriction gets applied to the full type here. It
12008 -- has already been applied earlier to the partial view.
12009
12010 Check_Access_Discriminant_Requires_Limited (Parent (D), N);
12011 end if;
12012
12013 Next_Discriminant (D);
12014 Next (New_D);
12015 end loop;
12016 end;
12017
12018 elsif Present (Discriminant_Specifications (N)) then
12019 Process_Discriminants (N, Prev);
12020 end if;
12021 end Check_Or_Process_Discriminants;
12022
12023 ----------------------
12024 -- Check_Real_Bound --
12025 ----------------------
12026
12027 procedure Check_Real_Bound (Bound : Node_Id) is
12028 begin
12029 if not Is_Real_Type (Etype (Bound)) then
12030 Error_Msg_N
12031 ("bound in real type definition must be of real type", Bound);
12032
12033 elsif not Is_OK_Static_Expression (Bound) then
12034 Flag_Non_Static_Expr
12035 ("non-static expression used for real type bound!", Bound);
12036
12037 else
12038 return;
12039 end if;
12040
12041 Rewrite
12042 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
12043 Analyze (Bound);
12044 Resolve (Bound, Standard_Float);
12045 end Check_Real_Bound;
12046
12047 ------------------------------
12048 -- Complete_Private_Subtype --
12049 ------------------------------
12050
12051 procedure Complete_Private_Subtype
12052 (Priv : Entity_Id;
12053 Full : Entity_Id;
12054 Full_Base : Entity_Id;
12055 Related_Nod : Node_Id)
12056 is
12057 Save_Next_Entity : Entity_Id;
12058 Save_Homonym : Entity_Id;
12059
12060 begin
12061 -- Set semantic attributes for (implicit) private subtype completion.
12062 -- If the full type has no discriminants, then it is a copy of the
12063 -- full view of the base. Otherwise, it is a subtype of the base with
12064 -- a possible discriminant constraint. Save and restore the original
12065 -- Next_Entity field of full to ensure that the calls to Copy_Node do
12066 -- not corrupt the entity chain.
12067
12068 -- Note that the type of the full view is the same entity as the type
12069 -- of the partial view. In this fashion, the subtype has access to the
12070 -- correct view of the parent.
12071
12072 Save_Next_Entity := Next_Entity (Full);
12073 Save_Homonym := Homonym (Priv);
12074
12075 case Ekind (Full_Base) is
12076 when Class_Wide_Kind
12077 | Private_Kind
12078 | Protected_Kind
12079 | Task_Kind
12080 | E_Record_Subtype
12081 | E_Record_Type
12082 =>
12083 Copy_Node (Priv, Full);
12084
12085 Set_Has_Discriminants
12086 (Full, Has_Discriminants (Full_Base));
12087 Set_Has_Unknown_Discriminants
12088 (Full, Has_Unknown_Discriminants (Full_Base));
12089 Set_First_Entity (Full, First_Entity (Full_Base));
12090 Set_Last_Entity (Full, Last_Entity (Full_Base));
12091
12092 -- If the underlying base type is constrained, we know that the
12093 -- full view of the subtype is constrained as well (the converse
12094 -- is not necessarily true).
12095
12096 if Is_Constrained (Full_Base) then
12097 Set_Is_Constrained (Full);
12098 end if;
12099
12100 when others =>
12101 Copy_Node (Full_Base, Full);
12102
12103 Set_Chars (Full, Chars (Priv));
12104 Conditional_Delay (Full, Priv);
12105 Set_Sloc (Full, Sloc (Priv));
12106 end case;
12107
12108 Set_Next_Entity (Full, Save_Next_Entity);
12109 Set_Homonym (Full, Save_Homonym);
12110 Set_Associated_Node_For_Itype (Full, Related_Nod);
12111
12112 -- Set common attributes for all subtypes: kind, convention, etc.
12113
12114 Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
12115 Set_Convention (Full, Convention (Full_Base));
12116
12117 -- The Etype of the full view is inconsistent. Gigi needs to see the
12118 -- structural full view, which is what the current scheme gives: the
12119 -- Etype of the full view is the etype of the full base. However, if the
12120 -- full base is a derived type, the full view then looks like a subtype
12121 -- of the parent, not a subtype of the full base. If instead we write:
12122
12123 -- Set_Etype (Full, Full_Base);
12124
12125 -- then we get inconsistencies in the front-end (confusion between
12126 -- views). Several outstanding bugs are related to this ???
12127
12128 Set_Is_First_Subtype (Full, False);
12129 Set_Scope (Full, Scope (Priv));
12130 Set_Size_Info (Full, Full_Base);
12131 Set_RM_Size (Full, RM_Size (Full_Base));
12132 Set_Is_Itype (Full);
12133
12134 -- A subtype of a private-type-without-discriminants, whose full-view
12135 -- has discriminants with default expressions, is not constrained.
12136
12137 if not Has_Discriminants (Priv) then
12138 Set_Is_Constrained (Full, Is_Constrained (Full_Base));
12139
12140 if Has_Discriminants (Full_Base) then
12141 Set_Discriminant_Constraint
12142 (Full, Discriminant_Constraint (Full_Base));
12143
12144 -- The partial view may have been indefinite, the full view
12145 -- might not be.
12146
12147 Set_Has_Unknown_Discriminants
12148 (Full, Has_Unknown_Discriminants (Full_Base));
12149 end if;
12150 end if;
12151
12152 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
12153 Set_Depends_On_Private (Full, Has_Private_Component (Full));
12154
12155 -- Freeze the private subtype entity if its parent is delayed, and not
12156 -- already frozen. We skip this processing if the type is an anonymous
12157 -- subtype of a record component, or is the corresponding record of a
12158 -- protected type, since these are processed when the enclosing type
12159 -- is frozen. If the parent type is declared in a nested package then
12160 -- the freezing of the private and full views also happens later.
12161
12162 if not Is_Type (Scope (Full)) then
12163 if Is_Itype (Priv)
12164 and then In_Same_Source_Unit (Full, Full_Base)
12165 and then Scope (Full_Base) /= Scope (Full)
12166 then
12167 Set_Has_Delayed_Freeze (Full);
12168 Set_Has_Delayed_Freeze (Priv);
12169
12170 else
12171 Set_Has_Delayed_Freeze (Full,
12172 Has_Delayed_Freeze (Full_Base)
12173 and then not Is_Frozen (Full_Base));
12174 end if;
12175 end if;
12176
12177 Set_Freeze_Node (Full, Empty);
12178 Set_Is_Frozen (Full, False);
12179 Set_Full_View (Priv, Full);
12180
12181 if Has_Discriminants (Full) then
12182 Set_Stored_Constraint_From_Discriminant_Constraint (Full);
12183 Set_Stored_Constraint (Priv, Stored_Constraint (Full));
12184
12185 if Has_Unknown_Discriminants (Full) then
12186 Set_Discriminant_Constraint (Full, No_Elist);
12187 end if;
12188 end if;
12189
12190 if Ekind (Full_Base) = E_Record_Type
12191 and then Has_Discriminants (Full_Base)
12192 and then Has_Discriminants (Priv) -- might not, if errors
12193 and then not Has_Unknown_Discriminants (Priv)
12194 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
12195 then
12196 Create_Constrained_Components
12197 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
12198
12199 -- If the full base is itself derived from private, build a congruent
12200 -- subtype of its underlying type, for use by the back end. For a
12201 -- constrained record component, the declaration cannot be placed on
12202 -- the component list, but it must nevertheless be built an analyzed, to
12203 -- supply enough information for Gigi to compute the size of component.
12204
12205 elsif Ekind (Full_Base) in Private_Kind
12206 and then Is_Derived_Type (Full_Base)
12207 and then Has_Discriminants (Full_Base)
12208 and then (Ekind (Current_Scope) /= E_Record_Subtype)
12209 then
12210 if not Is_Itype (Priv)
12211 and then
12212 Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
12213 then
12214 Build_Underlying_Full_View
12215 (Parent (Priv), Full, Etype (Full_Base));
12216
12217 elsif Nkind (Related_Nod) = N_Component_Declaration then
12218 Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
12219 end if;
12220
12221 elsif Is_Record_Type (Full_Base) then
12222
12223 -- Show Full is simply a renaming of Full_Base
12224
12225 Set_Cloned_Subtype (Full, Full_Base);
12226 end if;
12227
12228 -- It is unsafe to share the bounds of a scalar type, because the Itype
12229 -- is elaborated on demand, and if a bound is non-static then different
12230 -- orders of elaboration in different units will lead to different
12231 -- external symbols.
12232
12233 if Is_Scalar_Type (Full_Base) then
12234 Set_Scalar_Range (Full,
12235 Make_Range (Sloc (Related_Nod),
12236 Low_Bound =>
12237 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
12238 High_Bound =>
12239 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
12240
12241 -- This completion inherits the bounds of the full parent, but if
12242 -- the parent is an unconstrained floating point type, so is the
12243 -- completion.
12244
12245 if Is_Floating_Point_Type (Full_Base) then
12246 Set_Includes_Infinities
12247 (Scalar_Range (Full), Has_Infinities (Full_Base));
12248 end if;
12249 end if;
12250
12251 -- ??? It seems that a lot of fields are missing that should be copied
12252 -- from Full_Base to Full. Here are some that are introduced in a
12253 -- non-disruptive way but a cleanup is necessary.
12254
12255 if Is_Tagged_Type (Full_Base) then
12256 Set_Is_Tagged_Type (Full);
12257 Set_Direct_Primitive_Operations
12258 (Full, Direct_Primitive_Operations (Full_Base));
12259 Set_No_Tagged_Streams_Pragma
12260 (Full, No_Tagged_Streams_Pragma (Full_Base));
12261
12262 -- Inherit class_wide type of full_base in case the partial view was
12263 -- not tagged. Otherwise it has already been created when the private
12264 -- subtype was analyzed.
12265
12266 if No (Class_Wide_Type (Full)) then
12267 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
12268 end if;
12269
12270 -- If this is a subtype of a protected or task type, constrain its
12271 -- corresponding record, unless this is a subtype without constraints,
12272 -- i.e. a simple renaming as with an actual subtype in an instance.
12273
12274 elsif Is_Concurrent_Type (Full_Base) then
12275 if Has_Discriminants (Full)
12276 and then Present (Corresponding_Record_Type (Full_Base))
12277 and then
12278 not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
12279 then
12280 Set_Corresponding_Record_Type (Full,
12281 Constrain_Corresponding_Record
12282 (Full, Corresponding_Record_Type (Full_Base), Related_Nod));
12283
12284 else
12285 Set_Corresponding_Record_Type (Full,
12286 Corresponding_Record_Type (Full_Base));
12287 end if;
12288 end if;
12289
12290 -- Link rep item chain, and also setting of Has_Predicates from private
12291 -- subtype to full subtype, since we will need these on the full subtype
12292 -- to create the predicate function. Note that the full subtype may
12293 -- already have rep items, inherited from the full view of the base
12294 -- type, so we must be sure not to overwrite these entries.
12295
12296 declare
12297 Append : Boolean;
12298 Item : Node_Id;
12299 Next_Item : Node_Id;
12300 Priv_Item : Node_Id;
12301
12302 begin
12303 Item := First_Rep_Item (Full);
12304 Priv_Item := First_Rep_Item (Priv);
12305
12306 -- If no existing rep items on full type, we can just link directly
12307 -- to the list of items on the private type, if any exist.. Same if
12308 -- the rep items are only those inherited from the base
12309
12310 if (No (Item)
12311 or else Nkind (Item) /= N_Aspect_Specification
12312 or else Entity (Item) = Full_Base)
12313 and then Present (First_Rep_Item (Priv))
12314 then
12315 Set_First_Rep_Item (Full, Priv_Item);
12316
12317 -- Otherwise, search to the end of items currently linked to the full
12318 -- subtype and append the private items to the end. However, if Priv
12319 -- and Full already have the same list of rep items, then the append
12320 -- is not done, as that would create a circularity.
12321 --
12322 -- The partial view may have a predicate and the rep item lists of
12323 -- both views agree when inherited from the same ancestor. In that
12324 -- case, simply propagate the list from one view to the other.
12325 -- A more complex analysis needed here ???
12326
12327 elsif Present (Priv_Item)
12328 and then Item = Next_Rep_Item (Priv_Item)
12329 then
12330 Set_First_Rep_Item (Full, Priv_Item);
12331
12332 elsif Item /= Priv_Item then
12333 Append := True;
12334 loop
12335 Next_Item := Next_Rep_Item (Item);
12336 exit when No (Next_Item);
12337 Item := Next_Item;
12338
12339 -- If the private view has aspect specifications, the full view
12340 -- inherits them. Since these aspects may already have been
12341 -- attached to the full view during derivation, do not append
12342 -- them if already present.
12343
12344 if Item = First_Rep_Item (Priv) then
12345 Append := False;
12346 exit;
12347 end if;
12348 end loop;
12349
12350 -- And link the private type items at the end of the chain
12351
12352 if Append then
12353 Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
12354 end if;
12355 end if;
12356 end;
12357
12358 -- Make sure Has_Predicates is set on full type if it is set on the
12359 -- private type. Note that it may already be set on the full type and
12360 -- if so, we don't want to unset it. Similarly, propagate information
12361 -- about delayed aspects, because the corresponding pragmas must be
12362 -- analyzed when one of the views is frozen. This last step is needed
12363 -- in particular when the full type is a scalar type for which an
12364 -- anonymous base type is constructed.
12365
12366 -- The predicate functions are generated either at the freeze point
12367 -- of the type or at the end of the visible part, and we must avoid
12368 -- generating them twice.
12369
12370 if Has_Predicates (Priv) then
12371 Set_Has_Predicates (Full);
12372
12373 if Present (Predicate_Function (Priv))
12374 and then No (Predicate_Function (Full))
12375 then
12376 Set_Predicate_Function (Full, Predicate_Function (Priv));
12377 end if;
12378 end if;
12379
12380 if Has_Delayed_Aspects (Priv) then
12381 Set_Has_Delayed_Aspects (Full);
12382 end if;
12383 end Complete_Private_Subtype;
12384
12385 ----------------------------
12386 -- Constant_Redeclaration --
12387 ----------------------------
12388
12389 procedure Constant_Redeclaration
12390 (Id : Entity_Id;
12391 N : Node_Id;
12392 T : out Entity_Id)
12393 is
12394 Prev : constant Entity_Id := Current_Entity_In_Scope (Id);
12395 Obj_Def : constant Node_Id := Object_Definition (N);
12396 New_T : Entity_Id;
12397
12398 procedure Check_Possible_Deferred_Completion
12399 (Prev_Id : Entity_Id;
12400 Prev_Obj_Def : Node_Id;
12401 Curr_Obj_Def : Node_Id);
12402 -- Determine whether the two object definitions describe the partial
12403 -- and the full view of a constrained deferred constant. Generate
12404 -- a subtype for the full view and verify that it statically matches
12405 -- the subtype of the partial view.
12406
12407 procedure Check_Recursive_Declaration (Typ : Entity_Id);
12408 -- If deferred constant is an access type initialized with an allocator,
12409 -- check whether there is an illegal recursion in the definition,
12410 -- through a default value of some record subcomponent. This is normally
12411 -- detected when generating init procs, but requires this additional
12412 -- mechanism when expansion is disabled.
12413
12414 ----------------------------------------
12415 -- Check_Possible_Deferred_Completion --
12416 ----------------------------------------
12417
12418 procedure Check_Possible_Deferred_Completion
12419 (Prev_Id : Entity_Id;
12420 Prev_Obj_Def : Node_Id;
12421 Curr_Obj_Def : Node_Id)
12422 is
12423 begin
12424 if Nkind (Prev_Obj_Def) = N_Subtype_Indication
12425 and then Present (Constraint (Prev_Obj_Def))
12426 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
12427 and then Present (Constraint (Curr_Obj_Def))
12428 then
12429 declare
12430 Loc : constant Source_Ptr := Sloc (N);
12431 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
12432 Decl : constant Node_Id :=
12433 Make_Subtype_Declaration (Loc,
12434 Defining_Identifier => Def_Id,
12435 Subtype_Indication =>
12436 Relocate_Node (Curr_Obj_Def));
12437
12438 begin
12439 Insert_Before_And_Analyze (N, Decl);
12440 Set_Etype (Id, Def_Id);
12441
12442 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
12443 Error_Msg_Sloc := Sloc (Prev_Id);
12444 Error_Msg_N ("subtype does not statically match deferred "
12445 & "declaration #", N);
12446 end if;
12447 end;
12448 end if;
12449 end Check_Possible_Deferred_Completion;
12450
12451 ---------------------------------
12452 -- Check_Recursive_Declaration --
12453 ---------------------------------
12454
12455 procedure Check_Recursive_Declaration (Typ : Entity_Id) is
12456 Comp : Entity_Id;
12457
12458 begin
12459 if Is_Record_Type (Typ) then
12460 Comp := First_Component (Typ);
12461 while Present (Comp) loop
12462 if Comes_From_Source (Comp) then
12463 if Present (Expression (Parent (Comp)))
12464 and then Is_Entity_Name (Expression (Parent (Comp)))
12465 and then Entity (Expression (Parent (Comp))) = Prev
12466 then
12467 Error_Msg_Sloc := Sloc (Parent (Comp));
12468 Error_Msg_NE
12469 ("illegal circularity with declaration for & #",
12470 N, Comp);
12471 return;
12472
12473 elsif Is_Record_Type (Etype (Comp)) then
12474 Check_Recursive_Declaration (Etype (Comp));
12475 end if;
12476 end if;
12477
12478 Next_Component (Comp);
12479 end loop;
12480 end if;
12481 end Check_Recursive_Declaration;
12482
12483 -- Start of processing for Constant_Redeclaration
12484
12485 begin
12486 if Nkind (Parent (Prev)) = N_Object_Declaration then
12487 if Nkind (Object_Definition
12488 (Parent (Prev))) = N_Subtype_Indication
12489 then
12490 -- Find type of new declaration. The constraints of the two
12491 -- views must match statically, but there is no point in
12492 -- creating an itype for the full view.
12493
12494 if Nkind (Obj_Def) = N_Subtype_Indication then
12495 Find_Type (Subtype_Mark (Obj_Def));
12496 New_T := Entity (Subtype_Mark (Obj_Def));
12497
12498 else
12499 Find_Type (Obj_Def);
12500 New_T := Entity (Obj_Def);
12501 end if;
12502
12503 T := Etype (Prev);
12504
12505 else
12506 -- The full view may impose a constraint, even if the partial
12507 -- view does not, so construct the subtype.
12508
12509 New_T := Find_Type_Of_Object (Obj_Def, N);
12510 T := New_T;
12511 end if;
12512
12513 else
12514 -- Current declaration is illegal, diagnosed below in Enter_Name
12515
12516 T := Empty;
12517 New_T := Any_Type;
12518 end if;
12519
12520 -- If previous full declaration or a renaming declaration exists, or if
12521 -- a homograph is present, let Enter_Name handle it, either with an
12522 -- error or with the removal of an overridden implicit subprogram.
12523 -- The previous one is a full declaration if it has an expression
12524 -- (which in the case of an aggregate is indicated by the Init flag).
12525
12526 if Ekind (Prev) /= E_Constant
12527 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
12528 or else Present (Expression (Parent (Prev)))
12529 or else Has_Init_Expression (Parent (Prev))
12530 or else Present (Full_View (Prev))
12531 then
12532 Enter_Name (Id);
12533
12534 -- Verify that types of both declarations match, or else that both types
12535 -- are anonymous access types whose designated subtypes statically match
12536 -- (as allowed in Ada 2005 by AI-385).
12537
12538 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
12539 and then
12540 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
12541 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
12542 or else Is_Access_Constant (Etype (New_T)) /=
12543 Is_Access_Constant (Etype (Prev))
12544 or else Can_Never_Be_Null (Etype (New_T)) /=
12545 Can_Never_Be_Null (Etype (Prev))
12546 or else Null_Exclusion_Present (Parent (Prev)) /=
12547 Null_Exclusion_Present (Parent (Id))
12548 or else not Subtypes_Statically_Match
12549 (Designated_Type (Etype (Prev)),
12550 Designated_Type (Etype (New_T))))
12551 then
12552 Error_Msg_Sloc := Sloc (Prev);
12553 Error_Msg_N ("type does not match declaration#", N);
12554 Set_Full_View (Prev, Id);
12555 Set_Etype (Id, Any_Type);
12556
12557 -- A deferred constant whose type is an anonymous array is always
12558 -- illegal (unless imported). A detailed error message might be
12559 -- helpful for Ada beginners.
12560
12561 if Nkind (Object_Definition (Parent (Prev)))
12562 = N_Constrained_Array_Definition
12563 and then Nkind (Object_Definition (N))
12564 = N_Constrained_Array_Definition
12565 then
12566 Error_Msg_N ("\each anonymous array is a distinct type", N);
12567 Error_Msg_N ("a deferred constant must have a named type",
12568 Object_Definition (Parent (Prev)));
12569 end if;
12570
12571 elsif
12572 Null_Exclusion_Present (Parent (Prev))
12573 and then not Null_Exclusion_Present (N)
12574 then
12575 Error_Msg_Sloc := Sloc (Prev);
12576 Error_Msg_N ("null-exclusion does not match declaration#", N);
12577 Set_Full_View (Prev, Id);
12578 Set_Etype (Id, Any_Type);
12579
12580 -- If so, process the full constant declaration
12581
12582 else
12583 -- RM 7.4 (6): If the subtype defined by the subtype_indication in
12584 -- the deferred declaration is constrained, then the subtype defined
12585 -- by the subtype_indication in the full declaration shall match it
12586 -- statically.
12587
12588 Check_Possible_Deferred_Completion
12589 (Prev_Id => Prev,
12590 Prev_Obj_Def => Object_Definition (Parent (Prev)),
12591 Curr_Obj_Def => Obj_Def);
12592
12593 Set_Full_View (Prev, Id);
12594 Set_Is_Public (Id, Is_Public (Prev));
12595 Set_Is_Internal (Id);
12596 Append_Entity (Id, Current_Scope);
12597
12598 -- Check ALIASED present if present before (RM 7.4(7))
12599
12600 if Is_Aliased (Prev)
12601 and then not Aliased_Present (N)
12602 then
12603 Error_Msg_Sloc := Sloc (Prev);
12604 Error_Msg_N ("ALIASED required (see declaration #)", N);
12605 end if;
12606
12607 -- Check that placement is in private part and that the incomplete
12608 -- declaration appeared in the visible part.
12609
12610 if Ekind (Current_Scope) = E_Package
12611 and then not In_Private_Part (Current_Scope)
12612 then
12613 Error_Msg_Sloc := Sloc (Prev);
12614 Error_Msg_N
12615 ("full constant for declaration # must be in private part", N);
12616
12617 elsif Ekind (Current_Scope) = E_Package
12618 and then
12619 List_Containing (Parent (Prev)) /=
12620 Visible_Declarations (Package_Specification (Current_Scope))
12621 then
12622 Error_Msg_N
12623 ("deferred constant must be declared in visible part",
12624 Parent (Prev));
12625 end if;
12626
12627 if Is_Access_Type (T)
12628 and then Nkind (Expression (N)) = N_Allocator
12629 then
12630 Check_Recursive_Declaration (Designated_Type (T));
12631 end if;
12632
12633 -- A deferred constant is a visible entity. If type has invariants,
12634 -- verify that the initial value satisfies them.
12635
12636 if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
12637 Insert_After (N,
12638 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
12639 end if;
12640 end if;
12641 end Constant_Redeclaration;
12642
12643 ----------------------
12644 -- Constrain_Access --
12645 ----------------------
12646
12647 procedure Constrain_Access
12648 (Def_Id : in out Entity_Id;
12649 S : Node_Id;
12650 Related_Nod : Node_Id)
12651 is
12652 T : constant Entity_Id := Entity (Subtype_Mark (S));
12653 Desig_Type : constant Entity_Id := Designated_Type (T);
12654 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
12655 Constraint_OK : Boolean := True;
12656
12657 begin
12658 if Is_Array_Type (Desig_Type) then
12659 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
12660
12661 elsif (Is_Record_Type (Desig_Type)
12662 or else Is_Incomplete_Or_Private_Type (Desig_Type))
12663 and then not Is_Constrained (Desig_Type)
12664 then
12665 -- ??? The following code is a temporary bypass to ignore a
12666 -- discriminant constraint on access type if it is constraining
12667 -- the current record. Avoid creating the implicit subtype of the
12668 -- record we are currently compiling since right now, we cannot
12669 -- handle these. For now, just return the access type itself.
12670
12671 if Desig_Type = Current_Scope
12672 and then No (Def_Id)
12673 then
12674 Set_Ekind (Desig_Subtype, E_Record_Subtype);
12675 Def_Id := Entity (Subtype_Mark (S));
12676
12677 -- This call added to ensure that the constraint is analyzed
12678 -- (needed for a B test). Note that we still return early from
12679 -- this procedure to avoid recursive processing. ???
12680
12681 Constrain_Discriminated_Type
12682 (Desig_Subtype, S, Related_Nod, For_Access => True);
12683 return;
12684 end if;
12685
12686 -- Enforce rule that the constraint is illegal if there is an
12687 -- unconstrained view of the designated type. This means that the
12688 -- partial view (either a private type declaration or a derivation
12689 -- from a private type) has no discriminants. (Defect Report
12690 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
12691
12692 -- Rule updated for Ada 2005: The private type is said to have
12693 -- a constrained partial view, given that objects of the type
12694 -- can be declared. Furthermore, the rule applies to all access
12695 -- types, unlike the rule concerning default discriminants (see
12696 -- RM 3.7.1(7/3))
12697
12698 if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005)
12699 and then Has_Private_Declaration (Desig_Type)
12700 and then In_Open_Scopes (Scope (Desig_Type))
12701 and then Has_Discriminants (Desig_Type)
12702 then
12703 declare
12704 Pack : constant Node_Id :=
12705 Unit_Declaration_Node (Scope (Desig_Type));
12706 Decls : List_Id;
12707 Decl : Node_Id;
12708
12709 begin
12710 if Nkind (Pack) = N_Package_Declaration then
12711 Decls := Visible_Declarations (Specification (Pack));
12712 Decl := First (Decls);
12713 while Present (Decl) loop
12714 if (Nkind (Decl) = N_Private_Type_Declaration
12715 and then Chars (Defining_Identifier (Decl)) =
12716 Chars (Desig_Type))
12717
12718 or else
12719 (Nkind (Decl) = N_Full_Type_Declaration
12720 and then
12721 Chars (Defining_Identifier (Decl)) =
12722 Chars (Desig_Type)
12723 and then Is_Derived_Type (Desig_Type)
12724 and then
12725 Has_Private_Declaration (Etype (Desig_Type)))
12726 then
12727 if No (Discriminant_Specifications (Decl)) then
12728 Error_Msg_N
12729 ("cannot constrain access type if designated "
12730 & "type has constrained partial view", S);
12731 end if;
12732
12733 exit;
12734 end if;
12735
12736 Next (Decl);
12737 end loop;
12738 end if;
12739 end;
12740 end if;
12741
12742 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
12743 For_Access => True);
12744
12745 elsif Is_Concurrent_Type (Desig_Type)
12746 and then not Is_Constrained (Desig_Type)
12747 then
12748 Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
12749
12750 else
12751 Error_Msg_N ("invalid constraint on access type", S);
12752
12753 -- We simply ignore an invalid constraint
12754
12755 Desig_Subtype := Desig_Type;
12756 Constraint_OK := False;
12757 end if;
12758
12759 if No (Def_Id) then
12760 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
12761 else
12762 Set_Ekind (Def_Id, E_Access_Subtype);
12763 end if;
12764
12765 if Constraint_OK then
12766 Set_Etype (Def_Id, Base_Type (T));
12767
12768 if Is_Private_Type (Desig_Type) then
12769 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
12770 end if;
12771 else
12772 Set_Etype (Def_Id, Any_Type);
12773 end if;
12774
12775 Set_Size_Info (Def_Id, T);
12776 Set_Is_Constrained (Def_Id, Constraint_OK);
12777 Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
12778 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
12779 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T));
12780
12781 Conditional_Delay (Def_Id, T);
12782
12783 -- AI-363 : Subtypes of general access types whose designated types have
12784 -- default discriminants are disallowed. In instances, the rule has to
12785 -- be checked against the actual, of which T is the subtype. In a
12786 -- generic body, the rule is checked assuming that the actual type has
12787 -- defaulted discriminants.
12788
12789 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
12790 if Ekind (Base_Type (T)) = E_General_Access_Type
12791 and then Has_Defaulted_Discriminants (Desig_Type)
12792 then
12793 if Ada_Version < Ada_2005 then
12794 Error_Msg_N
12795 ("access subtype of general access type would not " &
12796 "be allowed in Ada 2005?y?", S);
12797 else
12798 Error_Msg_N
12799 ("access subtype of general access type not allowed", S);
12800 end if;
12801
12802 Error_Msg_N ("\discriminants have defaults", S);
12803
12804 elsif Is_Access_Type (T)
12805 and then Is_Generic_Type (Desig_Type)
12806 and then Has_Discriminants (Desig_Type)
12807 and then In_Package_Body (Current_Scope)
12808 then
12809 if Ada_Version < Ada_2005 then
12810 Error_Msg_N
12811 ("access subtype would not be allowed in generic body "
12812 & "in Ada 2005?y?", S);
12813 else
12814 Error_Msg_N
12815 ("access subtype not allowed in generic body", S);
12816 end if;
12817
12818 Error_Msg_N
12819 ("\designated type is a discriminated formal", S);
12820 end if;
12821 end if;
12822 end Constrain_Access;
12823
12824 ---------------------
12825 -- Constrain_Array --
12826 ---------------------
12827
12828 procedure Constrain_Array
12829 (Def_Id : in out Entity_Id;
12830 SI : Node_Id;
12831 Related_Nod : Node_Id;
12832 Related_Id : Entity_Id;
12833 Suffix : Character)
12834 is
12835 C : constant Node_Id := Constraint (SI);
12836 Number_Of_Constraints : Nat := 0;
12837 Index : Node_Id;
12838 S, T : Entity_Id;
12839 Constraint_OK : Boolean := True;
12840
12841 begin
12842 T := Entity (Subtype_Mark (SI));
12843
12844 if Is_Access_Type (T) then
12845 T := Designated_Type (T);
12846 end if;
12847
12848 -- If an index constraint follows a subtype mark in a subtype indication
12849 -- then the type or subtype denoted by the subtype mark must not already
12850 -- impose an index constraint. The subtype mark must denote either an
12851 -- unconstrained array type or an access type whose designated type
12852 -- is such an array type... (RM 3.6.1)
12853
12854 if Is_Constrained (T) then
12855 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
12856 Constraint_OK := False;
12857
12858 else
12859 S := First (Constraints (C));
12860 while Present (S) loop
12861 Number_Of_Constraints := Number_Of_Constraints + 1;
12862 Next (S);
12863 end loop;
12864
12865 -- In either case, the index constraint must provide a discrete
12866 -- range for each index of the array type and the type of each
12867 -- discrete range must be the same as that of the corresponding
12868 -- index. (RM 3.6.1)
12869
12870 if Number_Of_Constraints /= Number_Dimensions (T) then
12871 Error_Msg_NE ("incorrect number of index constraints for }", C, T);
12872 Constraint_OK := False;
12873
12874 else
12875 S := First (Constraints (C));
12876 Index := First_Index (T);
12877 Analyze (Index);
12878
12879 -- Apply constraints to each index type
12880
12881 for J in 1 .. Number_Of_Constraints loop
12882 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
12883 Next (Index);
12884 Next (S);
12885 end loop;
12886
12887 end if;
12888 end if;
12889
12890 if No (Def_Id) then
12891 Def_Id :=
12892 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
12893 Set_Parent (Def_Id, Related_Nod);
12894
12895 else
12896 Set_Ekind (Def_Id, E_Array_Subtype);
12897 end if;
12898
12899 Set_Size_Info (Def_Id, (T));
12900 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
12901 Set_Etype (Def_Id, Base_Type (T));
12902
12903 if Constraint_OK then
12904 Set_First_Index (Def_Id, First (Constraints (C)));
12905 else
12906 Set_First_Index (Def_Id, First_Index (T));
12907 end if;
12908
12909 Set_Is_Constrained (Def_Id, True);
12910 Set_Is_Aliased (Def_Id, Is_Aliased (T));
12911 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
12912
12913 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
12914 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
12915
12916 -- A subtype does not inherit the Packed_Array_Impl_Type of is parent.
12917 -- We need to initialize the attribute because if Def_Id is previously
12918 -- analyzed through a limited_with clause, it will have the attributes
12919 -- of an incomplete type, one of which is an Elist that overlaps the
12920 -- Packed_Array_Impl_Type field.
12921
12922 Set_Packed_Array_Impl_Type (Def_Id, Empty);
12923
12924 -- Build a freeze node if parent still needs one. Also make sure that
12925 -- the Depends_On_Private status is set because the subtype will need
12926 -- reprocessing at the time the base type does, and also we must set a
12927 -- conditional delay.
12928
12929 Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
12930 Conditional_Delay (Def_Id, T);
12931 end Constrain_Array;
12932
12933 ------------------------------
12934 -- Constrain_Component_Type --
12935 ------------------------------
12936
12937 function Constrain_Component_Type
12938 (Comp : Entity_Id;
12939 Constrained_Typ : Entity_Id;
12940 Related_Node : Node_Id;
12941 Typ : Entity_Id;
12942 Constraints : Elist_Id) return Entity_Id
12943 is
12944 Loc : constant Source_Ptr := Sloc (Constrained_Typ);
12945 Compon_Type : constant Entity_Id := Etype (Comp);
12946
12947 function Build_Constrained_Array_Type
12948 (Old_Type : Entity_Id) return Entity_Id;
12949 -- If Old_Type is an array type, one of whose indexes is constrained
12950 -- by a discriminant, build an Itype whose constraint replaces the
12951 -- discriminant with its value in the constraint.
12952
12953 function Build_Constrained_Discriminated_Type
12954 (Old_Type : Entity_Id) return Entity_Id;
12955 -- Ditto for record components
12956
12957 function Build_Constrained_Access_Type
12958 (Old_Type : Entity_Id) return Entity_Id;
12959 -- Ditto for access types. Makes use of previous two functions, to
12960 -- constrain designated type.
12961
12962 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
12963 -- T is an array or discriminated type, C is a list of constraints
12964 -- that apply to T. This routine builds the constrained subtype.
12965
12966 function Is_Discriminant (Expr : Node_Id) return Boolean;
12967 -- Returns True if Expr is a discriminant
12968
12969 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
12970 -- Find the value of discriminant Discrim in Constraint
12971
12972 -----------------------------------
12973 -- Build_Constrained_Access_Type --
12974 -----------------------------------
12975
12976 function Build_Constrained_Access_Type
12977 (Old_Type : Entity_Id) return Entity_Id
12978 is
12979 Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
12980 Itype : Entity_Id;
12981 Desig_Subtype : Entity_Id;
12982 Scop : Entity_Id;
12983
12984 begin
12985 -- if the original access type was not embedded in the enclosing
12986 -- type definition, there is no need to produce a new access
12987 -- subtype. In fact every access type with an explicit constraint
12988 -- generates an itype whose scope is the enclosing record.
12989
12990 if not Is_Type (Scope (Old_Type)) then
12991 return Old_Type;
12992
12993 elsif Is_Array_Type (Desig_Type) then
12994 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
12995
12996 elsif Has_Discriminants (Desig_Type) then
12997
12998 -- This may be an access type to an enclosing record type for
12999 -- which we are constructing the constrained components. Return
13000 -- the enclosing record subtype. This is not always correct,
13001 -- but avoids infinite recursion. ???
13002
13003 Desig_Subtype := Any_Type;
13004
13005 for J in reverse 0 .. Scope_Stack.Last loop
13006 Scop := Scope_Stack.Table (J).Entity;
13007
13008 if Is_Type (Scop)
13009 and then Base_Type (Scop) = Base_Type (Desig_Type)
13010 then
13011 Desig_Subtype := Scop;
13012 end if;
13013
13014 exit when not Is_Type (Scop);
13015 end loop;
13016
13017 if Desig_Subtype = Any_Type then
13018 Desig_Subtype :=
13019 Build_Constrained_Discriminated_Type (Desig_Type);
13020 end if;
13021
13022 else
13023 return Old_Type;
13024 end if;
13025
13026 if Desig_Subtype /= Desig_Type then
13027
13028 -- The Related_Node better be here or else we won't be able
13029 -- to attach new itypes to a node in the tree.
13030
13031 pragma Assert (Present (Related_Node));
13032
13033 Itype := Create_Itype (E_Access_Subtype, Related_Node);
13034
13035 Set_Etype (Itype, Base_Type (Old_Type));
13036 Set_Size_Info (Itype, (Old_Type));
13037 Set_Directly_Designated_Type (Itype, Desig_Subtype);
13038 Set_Depends_On_Private (Itype, Has_Private_Component
13039 (Old_Type));
13040 Set_Is_Access_Constant (Itype, Is_Access_Constant
13041 (Old_Type));
13042
13043 -- The new itype needs freezing when it depends on a not frozen
13044 -- type and the enclosing subtype needs freezing.
13045
13046 if Has_Delayed_Freeze (Constrained_Typ)
13047 and then not Is_Frozen (Constrained_Typ)
13048 then
13049 Conditional_Delay (Itype, Base_Type (Old_Type));
13050 end if;
13051
13052 return Itype;
13053
13054 else
13055 return Old_Type;
13056 end if;
13057 end Build_Constrained_Access_Type;
13058
13059 ----------------------------------
13060 -- Build_Constrained_Array_Type --
13061 ----------------------------------
13062
13063 function Build_Constrained_Array_Type
13064 (Old_Type : Entity_Id) return Entity_Id
13065 is
13066 Lo_Expr : Node_Id;
13067 Hi_Expr : Node_Id;
13068 Old_Index : Node_Id;
13069 Range_Node : Node_Id;
13070 Constr_List : List_Id;
13071
13072 Need_To_Create_Itype : Boolean := False;
13073
13074 begin
13075 Old_Index := First_Index (Old_Type);
13076 while Present (Old_Index) loop
13077 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
13078
13079 if Is_Discriminant (Lo_Expr)
13080 or else
13081 Is_Discriminant (Hi_Expr)
13082 then
13083 Need_To_Create_Itype := True;
13084 end if;
13085
13086 Next_Index (Old_Index);
13087 end loop;
13088
13089 if Need_To_Create_Itype then
13090 Constr_List := New_List;
13091
13092 Old_Index := First_Index (Old_Type);
13093 while Present (Old_Index) loop
13094 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
13095
13096 if Is_Discriminant (Lo_Expr) then
13097 Lo_Expr := Get_Discr_Value (Lo_Expr);
13098 end if;
13099
13100 if Is_Discriminant (Hi_Expr) then
13101 Hi_Expr := Get_Discr_Value (Hi_Expr);
13102 end if;
13103
13104 Range_Node :=
13105 Make_Range
13106 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
13107
13108 Append (Range_Node, To => Constr_List);
13109
13110 Next_Index (Old_Index);
13111 end loop;
13112
13113 return Build_Subtype (Old_Type, Constr_List);
13114
13115 else
13116 return Old_Type;
13117 end if;
13118 end Build_Constrained_Array_Type;
13119
13120 ------------------------------------------
13121 -- Build_Constrained_Discriminated_Type --
13122 ------------------------------------------
13123
13124 function Build_Constrained_Discriminated_Type
13125 (Old_Type : Entity_Id) return Entity_Id
13126 is
13127 Expr : Node_Id;
13128 Constr_List : List_Id;
13129 Old_Constraint : Elmt_Id;
13130
13131 Need_To_Create_Itype : Boolean := False;
13132
13133 begin
13134 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
13135 while Present (Old_Constraint) loop
13136 Expr := Node (Old_Constraint);
13137
13138 if Is_Discriminant (Expr) then
13139 Need_To_Create_Itype := True;
13140 end if;
13141
13142 Next_Elmt (Old_Constraint);
13143 end loop;
13144
13145 if Need_To_Create_Itype then
13146 Constr_List := New_List;
13147
13148 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
13149 while Present (Old_Constraint) loop
13150 Expr := Node (Old_Constraint);
13151
13152 if Is_Discriminant (Expr) then
13153 Expr := Get_Discr_Value (Expr);
13154 end if;
13155
13156 Append (New_Copy_Tree (Expr), To => Constr_List);
13157
13158 Next_Elmt (Old_Constraint);
13159 end loop;
13160
13161 return Build_Subtype (Old_Type, Constr_List);
13162
13163 else
13164 return Old_Type;
13165 end if;
13166 end Build_Constrained_Discriminated_Type;
13167
13168 -------------------
13169 -- Build_Subtype --
13170 -------------------
13171
13172 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
13173 Indic : Node_Id;
13174 Subtyp_Decl : Node_Id;
13175 Def_Id : Entity_Id;
13176 Btyp : Entity_Id := Base_Type (T);
13177
13178 begin
13179 -- The Related_Node better be here or else we won't be able to
13180 -- attach new itypes to a node in the tree.
13181
13182 pragma Assert (Present (Related_Node));
13183
13184 -- If the view of the component's type is incomplete or private
13185 -- with unknown discriminants, then the constraint must be applied
13186 -- to the full type.
13187
13188 if Has_Unknown_Discriminants (Btyp)
13189 and then Present (Underlying_Type (Btyp))
13190 then
13191 Btyp := Underlying_Type (Btyp);
13192 end if;
13193
13194 Indic :=
13195 Make_Subtype_Indication (Loc,
13196 Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
13197 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
13198
13199 Def_Id := Create_Itype (Ekind (T), Related_Node);
13200
13201 Subtyp_Decl :=
13202 Make_Subtype_Declaration (Loc,
13203 Defining_Identifier => Def_Id,
13204 Subtype_Indication => Indic);
13205
13206 Set_Parent (Subtyp_Decl, Parent (Related_Node));
13207
13208 -- Itypes must be analyzed with checks off (see package Itypes)
13209
13210 Analyze (Subtyp_Decl, Suppress => All_Checks);
13211
13212 return Def_Id;
13213 end Build_Subtype;
13214
13215 ---------------------
13216 -- Get_Discr_Value --
13217 ---------------------
13218
13219 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
13220 D : Entity_Id;
13221 E : Elmt_Id;
13222
13223 begin
13224 -- The discriminant may be declared for the type, in which case we
13225 -- find it by iterating over the list of discriminants. If the
13226 -- discriminant is inherited from a parent type, it appears as the
13227 -- corresponding discriminant of the current type. This will be the
13228 -- case when constraining an inherited component whose constraint is
13229 -- given by a discriminant of the parent.
13230
13231 D := First_Discriminant (Typ);
13232 E := First_Elmt (Constraints);
13233
13234 while Present (D) loop
13235 if D = Entity (Discrim)
13236 or else D = CR_Discriminant (Entity (Discrim))
13237 or else Corresponding_Discriminant (D) = Entity (Discrim)
13238 then
13239 return Node (E);
13240 end if;
13241
13242 Next_Discriminant (D);
13243 Next_Elmt (E);
13244 end loop;
13245
13246 -- The Corresponding_Discriminant mechanism is incomplete, because
13247 -- the correspondence between new and old discriminants is not one
13248 -- to one: one new discriminant can constrain several old ones. In
13249 -- that case, scan sequentially the stored_constraint, the list of
13250 -- discriminants of the parents, and the constraints.
13251
13252 -- Previous code checked for the present of the Stored_Constraint
13253 -- list for the derived type, but did not use it at all. Should it
13254 -- be present when the component is a discriminated task type?
13255
13256 if Is_Derived_Type (Typ)
13257 and then Scope (Entity (Discrim)) = Etype (Typ)
13258 then
13259 D := First_Discriminant (Etype (Typ));
13260 E := First_Elmt (Constraints);
13261 while Present (D) loop
13262 if D = Entity (Discrim) then
13263 return Node (E);
13264 end if;
13265
13266 Next_Discriminant (D);
13267 Next_Elmt (E);
13268 end loop;
13269 end if;
13270
13271 -- Something is wrong if we did not find the value
13272
13273 raise Program_Error;
13274 end Get_Discr_Value;
13275
13276 ---------------------
13277 -- Is_Discriminant --
13278 ---------------------
13279
13280 function Is_Discriminant (Expr : Node_Id) return Boolean is
13281 Discrim_Scope : Entity_Id;
13282
13283 begin
13284 if Denotes_Discriminant (Expr) then
13285 Discrim_Scope := Scope (Entity (Expr));
13286
13287 -- Either we have a reference to one of Typ's discriminants,
13288
13289 pragma Assert (Discrim_Scope = Typ
13290
13291 -- or to the discriminants of the parent type, in the case
13292 -- of a derivation of a tagged type with variants.
13293
13294 or else Discrim_Scope = Etype (Typ)
13295 or else Full_View (Discrim_Scope) = Etype (Typ)
13296
13297 -- or same as above for the case where the discriminants
13298 -- were declared in Typ's private view.
13299
13300 or else (Is_Private_Type (Discrim_Scope)
13301 and then Chars (Discrim_Scope) = Chars (Typ))
13302
13303 -- or else we are deriving from the full view and the
13304 -- discriminant is declared in the private entity.
13305
13306 or else (Is_Private_Type (Typ)
13307 and then Chars (Discrim_Scope) = Chars (Typ))
13308
13309 -- Or we are constrained the corresponding record of a
13310 -- synchronized type that completes a private declaration.
13311
13312 or else (Is_Concurrent_Record_Type (Typ)
13313 and then
13314 Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
13315
13316 -- or we have a class-wide type, in which case make sure the
13317 -- discriminant found belongs to the root type.
13318
13319 or else (Is_Class_Wide_Type (Typ)
13320 and then Etype (Typ) = Discrim_Scope));
13321
13322 return True;
13323 end if;
13324
13325 -- In all other cases we have something wrong
13326
13327 return False;
13328 end Is_Discriminant;
13329
13330 -- Start of processing for Constrain_Component_Type
13331
13332 begin
13333 if Nkind (Parent (Comp)) = N_Component_Declaration
13334 and then Comes_From_Source (Parent (Comp))
13335 and then Comes_From_Source
13336 (Subtype_Indication (Component_Definition (Parent (Comp))))
13337 and then
13338 Is_Entity_Name
13339 (Subtype_Indication (Component_Definition (Parent (Comp))))
13340 then
13341 return Compon_Type;
13342
13343 elsif Is_Array_Type (Compon_Type) then
13344 return Build_Constrained_Array_Type (Compon_Type);
13345
13346 elsif Has_Discriminants (Compon_Type) then
13347 return Build_Constrained_Discriminated_Type (Compon_Type);
13348
13349 elsif Is_Access_Type (Compon_Type) then
13350 return Build_Constrained_Access_Type (Compon_Type);
13351
13352 else
13353 return Compon_Type;
13354 end if;
13355 end Constrain_Component_Type;
13356
13357 --------------------------
13358 -- Constrain_Concurrent --
13359 --------------------------
13360
13361 -- For concurrent types, the associated record value type carries the same
13362 -- discriminants, so when we constrain a concurrent type, we must constrain
13363 -- the corresponding record type as well.
13364
13365 procedure Constrain_Concurrent
13366 (Def_Id : in out Entity_Id;
13367 SI : Node_Id;
13368 Related_Nod : Node_Id;
13369 Related_Id : Entity_Id;
13370 Suffix : Character)
13371 is
13372 -- Retrieve Base_Type to ensure getting to the concurrent type in the
13373 -- case of a private subtype (needed when only doing semantic analysis).
13374
13375 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
13376 T_Val : Entity_Id;
13377
13378 begin
13379 if Is_Access_Type (T_Ent) then
13380 T_Ent := Designated_Type (T_Ent);
13381 end if;
13382
13383 T_Val := Corresponding_Record_Type (T_Ent);
13384
13385 if Present (T_Val) then
13386
13387 if No (Def_Id) then
13388 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
13389
13390 -- Elaborate itype now, as it may be used in a subsequent
13391 -- synchronized operation in another scope.
13392
13393 if Nkind (Related_Nod) = N_Full_Type_Declaration then
13394 Build_Itype_Reference (Def_Id, Related_Nod);
13395 end if;
13396 end if;
13397
13398 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
13399
13400 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
13401 Set_Corresponding_Record_Type (Def_Id,
13402 Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod));
13403
13404 else
13405 -- If there is no associated record, expansion is disabled and this
13406 -- is a generic context. Create a subtype in any case, so that
13407 -- semantic analysis can proceed.
13408
13409 if No (Def_Id) then
13410 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
13411 end if;
13412
13413 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
13414 end if;
13415 end Constrain_Concurrent;
13416
13417 ------------------------------------
13418 -- Constrain_Corresponding_Record --
13419 ------------------------------------
13420
13421 function Constrain_Corresponding_Record
13422 (Prot_Subt : Entity_Id;
13423 Corr_Rec : Entity_Id;
13424 Related_Nod : Node_Id) return Entity_Id
13425 is
13426 T_Sub : constant Entity_Id :=
13427 Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
13428
13429 begin
13430 Set_Etype (T_Sub, Corr_Rec);
13431 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
13432 Set_Is_Constrained (T_Sub, True);
13433 Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
13434 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
13435
13436 if Has_Discriminants (Prot_Subt) then -- False only if errors.
13437 Set_Discriminant_Constraint
13438 (T_Sub, Discriminant_Constraint (Prot_Subt));
13439 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
13440 Create_Constrained_Components
13441 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
13442 end if;
13443
13444 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
13445
13446 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
13447 Conditional_Delay (T_Sub, Corr_Rec);
13448
13449 else
13450 -- This is a component subtype: it will be frozen in the context of
13451 -- the enclosing record's init_proc, so that discriminant references
13452 -- are resolved to discriminals. (Note: we used to skip freezing
13453 -- altogether in that case, which caused errors downstream for
13454 -- components of a bit packed array type).
13455
13456 Set_Has_Delayed_Freeze (T_Sub);
13457 end if;
13458
13459 return T_Sub;
13460 end Constrain_Corresponding_Record;
13461
13462 -----------------------
13463 -- Constrain_Decimal --
13464 -----------------------
13465
13466 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is
13467 T : constant Entity_Id := Entity (Subtype_Mark (S));
13468 C : constant Node_Id := Constraint (S);
13469 Loc : constant Source_Ptr := Sloc (C);
13470 Range_Expr : Node_Id;
13471 Digits_Expr : Node_Id;
13472 Digits_Val : Uint;
13473 Bound_Val : Ureal;
13474
13475 begin
13476 Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
13477
13478 if Nkind (C) = N_Range_Constraint then
13479 Range_Expr := Range_Expression (C);
13480 Digits_Val := Digits_Value (T);
13481
13482 else
13483 pragma Assert (Nkind (C) = N_Digits_Constraint);
13484
13485 Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
13486
13487 Digits_Expr := Digits_Expression (C);
13488 Analyze_And_Resolve (Digits_Expr, Any_Integer);
13489
13490 Check_Digits_Expression (Digits_Expr);
13491 Digits_Val := Expr_Value (Digits_Expr);
13492
13493 if Digits_Val > Digits_Value (T) then
13494 Error_Msg_N
13495 ("digits expression is incompatible with subtype", C);
13496 Digits_Val := Digits_Value (T);
13497 end if;
13498
13499 if Present (Range_Constraint (C)) then
13500 Range_Expr := Range_Expression (Range_Constraint (C));
13501 else
13502 Range_Expr := Empty;
13503 end if;
13504 end if;
13505
13506 Set_Etype (Def_Id, Base_Type (T));
13507 Set_Size_Info (Def_Id, (T));
13508 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13509 Set_Delta_Value (Def_Id, Delta_Value (T));
13510 Set_Scale_Value (Def_Id, Scale_Value (T));
13511 Set_Small_Value (Def_Id, Small_Value (T));
13512 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
13513 Set_Digits_Value (Def_Id, Digits_Val);
13514
13515 -- Manufacture range from given digits value if no range present
13516
13517 if No (Range_Expr) then
13518 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
13519 Range_Expr :=
13520 Make_Range (Loc,
13521 Low_Bound =>
13522 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
13523 High_Bound =>
13524 Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
13525 end if;
13526
13527 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
13528 Set_Discrete_RM_Size (Def_Id);
13529
13530 -- Unconditionally delay the freeze, since we cannot set size
13531 -- information in all cases correctly until the freeze point.
13532
13533 Set_Has_Delayed_Freeze (Def_Id);
13534 end Constrain_Decimal;
13535
13536 ----------------------------------
13537 -- Constrain_Discriminated_Type --
13538 ----------------------------------
13539
13540 procedure Constrain_Discriminated_Type
13541 (Def_Id : Entity_Id;
13542 S : Node_Id;
13543 Related_Nod : Node_Id;
13544 For_Access : Boolean := False)
13545 is
13546 E : Entity_Id := Entity (Subtype_Mark (S));
13547 T : Entity_Id;
13548
13549 procedure Fixup_Bad_Constraint;
13550 -- Called after finding a bad constraint, and after having posted an
13551 -- appropriate error message. The goal is to leave type Def_Id in as
13552 -- reasonable state as possible.
13553
13554 --------------------------
13555 -- Fixup_Bad_Constraint --
13556 --------------------------
13557
13558 procedure Fixup_Bad_Constraint is
13559 begin
13560 -- Set a reasonable Ekind for the entity. For an incomplete type,
13561 -- we can't do much, but for other types, we can set the proper
13562 -- corresponding subtype kind.
13563
13564 if Ekind (T) = E_Incomplete_Type then
13565 Set_Ekind (Def_Id, Ekind (T));
13566 else
13567 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
13568 end if;
13569
13570 -- Set Etype to the known type, to reduce chances of cascaded errors
13571
13572 Set_Etype (Def_Id, E);
13573 Set_Error_Posted (Def_Id);
13574 end Fixup_Bad_Constraint;
13575
13576 -- Local variables
13577
13578 C : Node_Id;
13579 Constr : Elist_Id := New_Elmt_List;
13580
13581 -- Start of processing for Constrain_Discriminated_Type
13582
13583 begin
13584 C := Constraint (S);
13585
13586 -- A discriminant constraint is only allowed in a subtype indication,
13587 -- after a subtype mark. This subtype mark must denote either a type
13588 -- with discriminants, or an access type whose designated type is a
13589 -- type with discriminants. A discriminant constraint specifies the
13590 -- values of these discriminants (RM 3.7.2(5)).
13591
13592 T := Base_Type (Entity (Subtype_Mark (S)));
13593
13594 if Is_Access_Type (T) then
13595 T := Designated_Type (T);
13596 end if;
13597
13598 -- In an instance it may be necessary to retrieve the full view of a
13599 -- type with unknown discriminants, or a full view with defaulted
13600 -- discriminants. In other contexts the constraint is illegal.
13601
13602 if In_Instance
13603 and then Is_Private_Type (T)
13604 and then Present (Full_View (T))
13605 and then
13606 (Has_Unknown_Discriminants (T)
13607 or else
13608 (not Has_Discriminants (T)
13609 and then Has_Discriminants (Full_View (T))
13610 and then Present (Discriminant_Default_Value
13611 (First_Discriminant (Full_View (T))))))
13612 then
13613 T := Full_View (T);
13614 E := Full_View (E);
13615 end if;
13616
13617 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid
13618 -- generating an error for access-to-incomplete subtypes.
13619
13620 if Ada_Version >= Ada_2005
13621 and then Ekind (T) = E_Incomplete_Type
13622 and then Nkind (Parent (S)) = N_Subtype_Declaration
13623 and then not Is_Itype (Def_Id)
13624 then
13625 -- A little sanity check: emit an error message if the type has
13626 -- discriminants to begin with. Type T may be a regular incomplete
13627 -- type or imported via a limited with clause.
13628
13629 if Has_Discriminants (T)
13630 or else (From_Limited_With (T)
13631 and then Present (Non_Limited_View (T))
13632 and then Nkind (Parent (Non_Limited_View (T))) =
13633 N_Full_Type_Declaration
13634 and then Present (Discriminant_Specifications
13635 (Parent (Non_Limited_View (T)))))
13636 then
13637 Error_Msg_N
13638 ("(Ada 2005) incomplete subtype may not be constrained", C);
13639 else
13640 Error_Msg_N ("invalid constraint: type has no discriminant", C);
13641 end if;
13642
13643 Fixup_Bad_Constraint;
13644 return;
13645
13646 -- Check that the type has visible discriminants. The type may be
13647 -- a private type with unknown discriminants whose full view has
13648 -- discriminants which are invisible.
13649
13650 elsif not Has_Discriminants (T)
13651 or else
13652 (Has_Unknown_Discriminants (T)
13653 and then Is_Private_Type (T))
13654 then
13655 Error_Msg_N ("invalid constraint: type has no discriminant", C);
13656 Fixup_Bad_Constraint;
13657 return;
13658
13659 elsif Is_Constrained (E)
13660 or else (Ekind (E) = E_Class_Wide_Subtype
13661 and then Present (Discriminant_Constraint (E)))
13662 then
13663 Error_Msg_N ("type is already constrained", Subtype_Mark (S));
13664 Fixup_Bad_Constraint;
13665 return;
13666 end if;
13667
13668 -- T may be an unconstrained subtype (e.g. a generic actual). Constraint
13669 -- applies to the base type.
13670
13671 T := Base_Type (T);
13672
13673 Constr := Build_Discriminant_Constraints (T, S);
13674
13675 -- If the list returned was empty we had an error in building the
13676 -- discriminant constraint. We have also already signalled an error
13677 -- in the incomplete type case
13678
13679 if Is_Empty_Elmt_List (Constr) then
13680 Fixup_Bad_Constraint;
13681 return;
13682 end if;
13683
13684 Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access);
13685 end Constrain_Discriminated_Type;
13686
13687 ---------------------------
13688 -- Constrain_Enumeration --
13689 ---------------------------
13690
13691 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
13692 T : constant Entity_Id := Entity (Subtype_Mark (S));
13693 C : constant Node_Id := Constraint (S);
13694
13695 begin
13696 Set_Ekind (Def_Id, E_Enumeration_Subtype);
13697
13698 Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
13699
13700 Set_Etype (Def_Id, Base_Type (T));
13701 Set_Size_Info (Def_Id, (T));
13702 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13703 Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
13704
13705 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
13706
13707 Set_Discrete_RM_Size (Def_Id);
13708 end Constrain_Enumeration;
13709
13710 ----------------------
13711 -- Constrain_Float --
13712 ----------------------
13713
13714 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
13715 T : constant Entity_Id := Entity (Subtype_Mark (S));
13716 C : Node_Id;
13717 D : Node_Id;
13718 Rais : Node_Id;
13719
13720 begin
13721 Set_Ekind (Def_Id, E_Floating_Point_Subtype);
13722
13723 Set_Etype (Def_Id, Base_Type (T));
13724 Set_Size_Info (Def_Id, (T));
13725 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13726
13727 -- Process the constraint
13728
13729 C := Constraint (S);
13730
13731 -- Digits constraint present
13732
13733 if Nkind (C) = N_Digits_Constraint then
13734
13735 Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
13736 Check_Restriction (No_Obsolescent_Features, C);
13737
13738 if Warn_On_Obsolescent_Feature then
13739 Error_Msg_N
13740 ("subtype digits constraint is an " &
13741 "obsolescent feature (RM J.3(8))?j?", C);
13742 end if;
13743
13744 D := Digits_Expression (C);
13745 Analyze_And_Resolve (D, Any_Integer);
13746 Check_Digits_Expression (D);
13747 Set_Digits_Value (Def_Id, Expr_Value (D));
13748
13749 -- Check that digits value is in range. Obviously we can do this
13750 -- at compile time, but it is strictly a runtime check, and of
13751 -- course there is an ACVC test that checks this.
13752
13753 if Digits_Value (Def_Id) > Digits_Value (T) then
13754 Error_Msg_Uint_1 := Digits_Value (T);
13755 Error_Msg_N ("??digits value is too large, maximum is ^", D);
13756 Rais :=
13757 Make_Raise_Constraint_Error (Sloc (D),
13758 Reason => CE_Range_Check_Failed);
13759 Insert_Action (Declaration_Node (Def_Id), Rais);
13760 end if;
13761
13762 C := Range_Constraint (C);
13763
13764 -- No digits constraint present
13765
13766 else
13767 Set_Digits_Value (Def_Id, Digits_Value (T));
13768 end if;
13769
13770 -- Range constraint present
13771
13772 if Nkind (C) = N_Range_Constraint then
13773 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
13774
13775 -- No range constraint present
13776
13777 else
13778 pragma Assert (No (C));
13779 Set_Scalar_Range (Def_Id, Scalar_Range (T));
13780 end if;
13781
13782 Set_Is_Constrained (Def_Id);
13783 end Constrain_Float;
13784
13785 ---------------------
13786 -- Constrain_Index --
13787 ---------------------
13788
13789 procedure Constrain_Index
13790 (Index : Node_Id;
13791 S : Node_Id;
13792 Related_Nod : Node_Id;
13793 Related_Id : Entity_Id;
13794 Suffix : Character;
13795 Suffix_Index : Nat)
13796 is
13797 Def_Id : Entity_Id;
13798 R : Node_Id := Empty;
13799 T : constant Entity_Id := Etype (Index);
13800
13801 begin
13802 Def_Id :=
13803 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
13804 Set_Etype (Def_Id, Base_Type (T));
13805
13806 if Nkind (S) = N_Range
13807 or else
13808 (Nkind (S) = N_Attribute_Reference
13809 and then Attribute_Name (S) = Name_Range)
13810 then
13811 -- A Range attribute will be transformed into N_Range by Resolve
13812
13813 Analyze (S);
13814 Set_Etype (S, T);
13815 R := S;
13816
13817 Process_Range_Expr_In_Decl (R, T);
13818
13819 if not Error_Posted (S)
13820 and then
13821 (Nkind (S) /= N_Range
13822 or else not Covers (T, (Etype (Low_Bound (S))))
13823 or else not Covers (T, (Etype (High_Bound (S)))))
13824 then
13825 if Base_Type (T) /= Any_Type
13826 and then Etype (Low_Bound (S)) /= Any_Type
13827 and then Etype (High_Bound (S)) /= Any_Type
13828 then
13829 Error_Msg_N ("range expected", S);
13830 end if;
13831 end if;
13832
13833 elsif Nkind (S) = N_Subtype_Indication then
13834
13835 -- The parser has verified that this is a discrete indication
13836
13837 Resolve_Discrete_Subtype_Indication (S, T);
13838 Bad_Predicated_Subtype_Use
13839 ("subtype& has predicate, not allowed in index constraint",
13840 S, Entity (Subtype_Mark (S)));
13841
13842 R := Range_Expression (Constraint (S));
13843
13844 -- Capture values of bounds and generate temporaries for them if
13845 -- needed, since checks may cause duplication of the expressions
13846 -- which must not be reevaluated.
13847
13848 -- The forced evaluation removes side effects from expressions, which
13849 -- should occur also in GNATprove mode. Otherwise, we end up with
13850 -- unexpected insertions of actions at places where this is not
13851 -- supposed to occur, e.g. on default parameters of a call.
13852
13853 if Expander_Active or GNATprove_Mode then
13854 Force_Evaluation
13855 (Low_Bound (R), Related_Id => Def_Id, Is_Low_Bound => True);
13856 Force_Evaluation
13857 (High_Bound (R), Related_Id => Def_Id, Is_High_Bound => True);
13858 end if;
13859
13860 elsif Nkind (S) = N_Discriminant_Association then
13861
13862 -- Syntactically valid in subtype indication
13863
13864 Error_Msg_N ("invalid index constraint", S);
13865 Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
13866 return;
13867
13868 -- Subtype_Mark case, no anonymous subtypes to construct
13869
13870 else
13871 Analyze (S);
13872
13873 if Is_Entity_Name (S) then
13874 if not Is_Type (Entity (S)) then
13875 Error_Msg_N ("expect subtype mark for index constraint", S);
13876
13877 elsif Base_Type (Entity (S)) /= Base_Type (T) then
13878 Wrong_Type (S, Base_Type (T));
13879
13880 -- Check error of subtype with predicate in index constraint
13881
13882 else
13883 Bad_Predicated_Subtype_Use
13884 ("subtype& has predicate, not allowed in index constraint",
13885 S, Entity (S));
13886 end if;
13887
13888 return;
13889
13890 else
13891 Error_Msg_N ("invalid index constraint", S);
13892 Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
13893 return;
13894 end if;
13895 end if;
13896
13897 -- Complete construction of the Itype
13898
13899 if Is_Modular_Integer_Type (T) then
13900 Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
13901
13902 elsif Is_Integer_Type (T) then
13903 Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
13904
13905 else
13906 Set_Ekind (Def_Id, E_Enumeration_Subtype);
13907 Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
13908 Set_First_Literal (Def_Id, First_Literal (T));
13909 end if;
13910
13911 Set_Size_Info (Def_Id, (T));
13912 Set_RM_Size (Def_Id, RM_Size (T));
13913 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13914
13915 Set_Scalar_Range (Def_Id, R);
13916
13917 Set_Etype (S, Def_Id);
13918 Set_Discrete_RM_Size (Def_Id);
13919 end Constrain_Index;
13920
13921 -----------------------
13922 -- Constrain_Integer --
13923 -----------------------
13924
13925 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is
13926 T : constant Entity_Id := Entity (Subtype_Mark (S));
13927 C : constant Node_Id := Constraint (S);
13928
13929 begin
13930 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
13931
13932 if Is_Modular_Integer_Type (T) then
13933 Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
13934 else
13935 Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
13936 end if;
13937
13938 Set_Etype (Def_Id, Base_Type (T));
13939 Set_Size_Info (Def_Id, (T));
13940 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13941 Set_Discrete_RM_Size (Def_Id);
13942 end Constrain_Integer;
13943
13944 ------------------------------
13945 -- Constrain_Ordinary_Fixed --
13946 ------------------------------
13947
13948 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
13949 T : constant Entity_Id := Entity (Subtype_Mark (S));
13950 C : Node_Id;
13951 D : Node_Id;
13952 Rais : Node_Id;
13953
13954 begin
13955 Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
13956 Set_Etype (Def_Id, Base_Type (T));
13957 Set_Size_Info (Def_Id, (T));
13958 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
13959 Set_Small_Value (Def_Id, Small_Value (T));
13960
13961 -- Process the constraint
13962
13963 C := Constraint (S);
13964
13965 -- Delta constraint present
13966
13967 if Nkind (C) = N_Delta_Constraint then
13968
13969 Check_SPARK_05_Restriction ("delta constraint is not allowed", S);
13970 Check_Restriction (No_Obsolescent_Features, C);
13971
13972 if Warn_On_Obsolescent_Feature then
13973 Error_Msg_S
13974 ("subtype delta constraint is an " &
13975 "obsolescent feature (RM J.3(7))?j?");
13976 end if;
13977
13978 D := Delta_Expression (C);
13979 Analyze_And_Resolve (D, Any_Real);
13980 Check_Delta_Expression (D);
13981 Set_Delta_Value (Def_Id, Expr_Value_R (D));
13982
13983 -- Check that delta value is in range. Obviously we can do this
13984 -- at compile time, but it is strictly a runtime check, and of
13985 -- course there is an ACVC test that checks this.
13986
13987 if Delta_Value (Def_Id) < Delta_Value (T) then
13988 Error_Msg_N ("??delta value is too small", D);
13989 Rais :=
13990 Make_Raise_Constraint_Error (Sloc (D),
13991 Reason => CE_Range_Check_Failed);
13992 Insert_Action (Declaration_Node (Def_Id), Rais);
13993 end if;
13994
13995 C := Range_Constraint (C);
13996
13997 -- No delta constraint present
13998
13999 else
14000 Set_Delta_Value (Def_Id, Delta_Value (T));
14001 end if;
14002
14003 -- Range constraint present
14004
14005 if Nkind (C) = N_Range_Constraint then
14006 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
14007
14008 -- No range constraint present
14009
14010 else
14011 pragma Assert (No (C));
14012 Set_Scalar_Range (Def_Id, Scalar_Range (T));
14013 end if;
14014
14015 Set_Discrete_RM_Size (Def_Id);
14016
14017 -- Unconditionally delay the freeze, since we cannot set size
14018 -- information in all cases correctly until the freeze point.
14019
14020 Set_Has_Delayed_Freeze (Def_Id);
14021 end Constrain_Ordinary_Fixed;
14022
14023 -----------------------
14024 -- Contain_Interface --
14025 -----------------------
14026
14027 function Contain_Interface
14028 (Iface : Entity_Id;
14029 Ifaces : Elist_Id) return Boolean
14030 is
14031 Iface_Elmt : Elmt_Id;
14032
14033 begin
14034 if Present (Ifaces) then
14035 Iface_Elmt := First_Elmt (Ifaces);
14036 while Present (Iface_Elmt) loop
14037 if Node (Iface_Elmt) = Iface then
14038 return True;
14039 end if;
14040
14041 Next_Elmt (Iface_Elmt);
14042 end loop;
14043 end if;
14044
14045 return False;
14046 end Contain_Interface;
14047
14048 ---------------------------
14049 -- Convert_Scalar_Bounds --
14050 ---------------------------
14051
14052 procedure Convert_Scalar_Bounds
14053 (N : Node_Id;
14054 Parent_Type : Entity_Id;
14055 Derived_Type : Entity_Id;
14056 Loc : Source_Ptr)
14057 is
14058 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
14059
14060 Lo : Node_Id;
14061 Hi : Node_Id;
14062 Rng : Node_Id;
14063
14064 begin
14065 -- Defend against previous errors
14066
14067 if No (Scalar_Range (Derived_Type)) then
14068 Check_Error_Detected;
14069 return;
14070 end if;
14071
14072 Lo := Build_Scalar_Bound
14073 (Type_Low_Bound (Derived_Type),
14074 Parent_Type, Implicit_Base);
14075
14076 Hi := Build_Scalar_Bound
14077 (Type_High_Bound (Derived_Type),
14078 Parent_Type, Implicit_Base);
14079
14080 Rng :=
14081 Make_Range (Loc,
14082 Low_Bound => Lo,
14083 High_Bound => Hi);
14084
14085 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
14086
14087 Set_Parent (Rng, N);
14088 Set_Scalar_Range (Derived_Type, Rng);
14089
14090 -- Analyze the bounds
14091
14092 Analyze_And_Resolve (Lo, Implicit_Base);
14093 Analyze_And_Resolve (Hi, Implicit_Base);
14094
14095 -- Analyze the range itself, except that we do not analyze it if
14096 -- the bounds are real literals, and we have a fixed-point type.
14097 -- The reason for this is that we delay setting the bounds in this
14098 -- case till we know the final Small and Size values (see circuit
14099 -- in Freeze.Freeze_Fixed_Point_Type for further details).
14100
14101 if Is_Fixed_Point_Type (Parent_Type)
14102 and then Nkind (Lo) = N_Real_Literal
14103 and then Nkind (Hi) = N_Real_Literal
14104 then
14105 return;
14106
14107 -- Here we do the analysis of the range
14108
14109 -- Note: we do this manually, since if we do a normal Analyze and
14110 -- Resolve call, there are problems with the conversions used for
14111 -- the derived type range.
14112
14113 else
14114 Set_Etype (Rng, Implicit_Base);
14115 Set_Analyzed (Rng, True);
14116 end if;
14117 end Convert_Scalar_Bounds;
14118
14119 -------------------
14120 -- Copy_And_Swap --
14121 -------------------
14122
14123 procedure Copy_And_Swap (Priv, Full : Entity_Id) is
14124 begin
14125 -- Initialize new full declaration entity by copying the pertinent
14126 -- fields of the corresponding private declaration entity.
14127
14128 -- We temporarily set Ekind to a value appropriate for a type to
14129 -- avoid assert failures in Einfo from checking for setting type
14130 -- attributes on something that is not a type. Ekind (Priv) is an
14131 -- appropriate choice, since it allowed the attributes to be set
14132 -- in the first place. This Ekind value will be modified later.
14133
14134 Set_Ekind (Full, Ekind (Priv));
14135
14136 -- Also set Etype temporarily to Any_Type, again, in the absence
14137 -- of errors, it will be properly reset, and if there are errors,
14138 -- then we want a value of Any_Type to remain.
14139
14140 Set_Etype (Full, Any_Type);
14141
14142 -- Now start copying attributes
14143
14144 Set_Has_Discriminants (Full, Has_Discriminants (Priv));
14145
14146 if Has_Discriminants (Full) then
14147 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
14148 Set_Stored_Constraint (Full, Stored_Constraint (Priv));
14149 end if;
14150
14151 Set_First_Rep_Item (Full, First_Rep_Item (Priv));
14152 Set_Homonym (Full, Homonym (Priv));
14153 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv));
14154 Set_Is_Public (Full, Is_Public (Priv));
14155 Set_Is_Pure (Full, Is_Pure (Priv));
14156 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv));
14157 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv));
14158 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv));
14159 Set_Has_Pragma_Unreferenced_Objects
14160 (Full, Has_Pragma_Unreferenced_Objects
14161 (Priv));
14162
14163 Conditional_Delay (Full, Priv);
14164
14165 if Is_Tagged_Type (Full) then
14166 Set_Direct_Primitive_Operations
14167 (Full, Direct_Primitive_Operations (Priv));
14168 Set_No_Tagged_Streams_Pragma
14169 (Full, No_Tagged_Streams_Pragma (Priv));
14170
14171 if Is_Base_Type (Priv) then
14172 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
14173 end if;
14174 end if;
14175
14176 Set_Is_Volatile (Full, Is_Volatile (Priv));
14177 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
14178 Set_Scope (Full, Scope (Priv));
14179 Set_Next_Entity (Full, Next_Entity (Priv));
14180 Set_First_Entity (Full, First_Entity (Priv));
14181 Set_Last_Entity (Full, Last_Entity (Priv));
14182
14183 -- If access types have been recorded for later handling, keep them in
14184 -- the full view so that they get handled when the full view freeze
14185 -- node is expanded.
14186
14187 if Present (Freeze_Node (Priv))
14188 and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
14189 then
14190 Ensure_Freeze_Node (Full);
14191 Set_Access_Types_To_Process
14192 (Freeze_Node (Full),
14193 Access_Types_To_Process (Freeze_Node (Priv)));
14194 end if;
14195
14196 -- Swap the two entities. Now Private is the full type entity and Full
14197 -- is the private one. They will be swapped back at the end of the
14198 -- private part. This swapping ensures that the entity that is visible
14199 -- in the private part is the full declaration.
14200
14201 Exchange_Entities (Priv, Full);
14202 Append_Entity (Full, Scope (Full));
14203 end Copy_And_Swap;
14204
14205 -------------------------------------
14206 -- Copy_Array_Base_Type_Attributes --
14207 -------------------------------------
14208
14209 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
14210 begin
14211 Set_Component_Alignment (T1, Component_Alignment (T2));
14212 Set_Component_Type (T1, Component_Type (T2));
14213 Set_Component_Size (T1, Component_Size (T2));
14214 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
14215 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
14216 Propagate_Concurrent_Flags (T1, T2);
14217 Set_Is_Packed (T1, Is_Packed (T2));
14218 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
14219 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
14220 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
14221 end Copy_Array_Base_Type_Attributes;
14222
14223 -----------------------------------
14224 -- Copy_Array_Subtype_Attributes --
14225 -----------------------------------
14226
14227 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
14228 begin
14229 Set_Size_Info (T1, T2);
14230
14231 Set_First_Index (T1, First_Index (T2));
14232 Set_Is_Aliased (T1, Is_Aliased (T2));
14233 Set_Is_Volatile (T1, Is_Volatile (T2));
14234 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
14235 Set_Is_Constrained (T1, Is_Constrained (T2));
14236 Set_Depends_On_Private (T1, Has_Private_Component (T2));
14237 Inherit_Rep_Item_Chain (T1, T2);
14238 Set_Convention (T1, Convention (T2));
14239 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
14240 Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
14241 Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
14242 end Copy_Array_Subtype_Attributes;
14243
14244 -----------------------------------
14245 -- Create_Constrained_Components --
14246 -----------------------------------
14247
14248 procedure Create_Constrained_Components
14249 (Subt : Entity_Id;
14250 Decl_Node : Node_Id;
14251 Typ : Entity_Id;
14252 Constraints : Elist_Id)
14253 is
14254 Loc : constant Source_Ptr := Sloc (Subt);
14255 Comp_List : constant Elist_Id := New_Elmt_List;
14256 Parent_Type : constant Entity_Id := Etype (Typ);
14257 Assoc_List : constant List_Id := New_List;
14258 Discr_Val : Elmt_Id;
14259 Errors : Boolean;
14260 New_C : Entity_Id;
14261 Old_C : Entity_Id;
14262 Is_Static : Boolean := True;
14263
14264 procedure Collect_Fixed_Components (Typ : Entity_Id);
14265 -- Collect parent type components that do not appear in a variant part
14266
14267 procedure Create_All_Components;
14268 -- Iterate over Comp_List to create the components of the subtype
14269
14270 function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
14271 -- Creates a new component from Old_Compon, copying all the fields from
14272 -- it, including its Etype, inserts the new component in the Subt entity
14273 -- chain and returns the new component.
14274
14275 function Is_Variant_Record (T : Entity_Id) return Boolean;
14276 -- If true, and discriminants are static, collect only components from
14277 -- variants selected by discriminant values.
14278
14279 ------------------------------
14280 -- Collect_Fixed_Components --
14281 ------------------------------
14282
14283 procedure Collect_Fixed_Components (Typ : Entity_Id) is
14284 begin
14285 -- Build association list for discriminants, and find components of the
14286 -- variant part selected by the values of the discriminants.
14287
14288 Old_C := First_Discriminant (Typ);
14289 Discr_Val := First_Elmt (Constraints);
14290 while Present (Old_C) loop
14291 Append_To (Assoc_List,
14292 Make_Component_Association (Loc,
14293 Choices => New_List (New_Occurrence_Of (Old_C, Loc)),
14294 Expression => New_Copy (Node (Discr_Val))));
14295
14296 Next_Elmt (Discr_Val);
14297 Next_Discriminant (Old_C);
14298 end loop;
14299
14300 -- The tag and the possible parent component are unconditionally in
14301 -- the subtype.
14302
14303 if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
14304 Old_C := First_Component (Typ);
14305 while Present (Old_C) loop
14306 if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then
14307 Append_Elmt (Old_C, Comp_List);
14308 end if;
14309
14310 Next_Component (Old_C);
14311 end loop;
14312 end if;
14313 end Collect_Fixed_Components;
14314
14315 ---------------------------
14316 -- Create_All_Components --
14317 ---------------------------
14318
14319 procedure Create_All_Components is
14320 Comp : Elmt_Id;
14321
14322 begin
14323 Comp := First_Elmt (Comp_List);
14324 while Present (Comp) loop
14325 Old_C := Node (Comp);
14326 New_C := Create_Component (Old_C);
14327
14328 Set_Etype
14329 (New_C,
14330 Constrain_Component_Type
14331 (Old_C, Subt, Decl_Node, Typ, Constraints));
14332 Set_Is_Public (New_C, Is_Public (Subt));
14333
14334 Next_Elmt (Comp);
14335 end loop;
14336 end Create_All_Components;
14337
14338 ----------------------
14339 -- Create_Component --
14340 ----------------------
14341
14342 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
14343 New_Compon : constant Entity_Id := New_Copy (Old_Compon);
14344
14345 begin
14346 if Ekind (Old_Compon) = E_Discriminant
14347 and then Is_Completely_Hidden (Old_Compon)
14348 then
14349 -- This is a shadow discriminant created for a discriminant of
14350 -- the parent type, which needs to be present in the subtype.
14351 -- Give the shadow discriminant an internal name that cannot
14352 -- conflict with that of visible components.
14353
14354 Set_Chars (New_Compon, New_Internal_Name ('C'));
14355 end if;
14356
14357 -- Set the parent so we have a proper link for freezing etc. This is
14358 -- not a real parent pointer, since of course our parent does not own
14359 -- up to us and reference us, we are an illegitimate child of the
14360 -- original parent.
14361
14362 Set_Parent (New_Compon, Parent (Old_Compon));
14363
14364 -- If the old component's Esize was already determined and is a
14365 -- static value, then the new component simply inherits it. Otherwise
14366 -- the old component's size may require run-time determination, but
14367 -- the new component's size still might be statically determinable
14368 -- (if, for example it has a static constraint). In that case we want
14369 -- Layout_Type to recompute the component's size, so we reset its
14370 -- size and positional fields.
14371
14372 if Frontend_Layout_On_Target
14373 and then not Known_Static_Esize (Old_Compon)
14374 then
14375 Set_Esize (New_Compon, Uint_0);
14376 Init_Normalized_First_Bit (New_Compon);
14377 Init_Normalized_Position (New_Compon);
14378 Init_Normalized_Position_Max (New_Compon);
14379 end if;
14380
14381 -- We do not want this node marked as Comes_From_Source, since
14382 -- otherwise it would get first class status and a separate cross-
14383 -- reference line would be generated. Illegitimate children do not
14384 -- rate such recognition.
14385
14386 Set_Comes_From_Source (New_Compon, False);
14387
14388 -- But it is a real entity, and a birth certificate must be properly
14389 -- registered by entering it into the entity list.
14390
14391 Enter_Name (New_Compon);
14392
14393 return New_Compon;
14394 end Create_Component;
14395
14396 -----------------------
14397 -- Is_Variant_Record --
14398 -----------------------
14399
14400 function Is_Variant_Record (T : Entity_Id) return Boolean is
14401 begin
14402 return Nkind (Parent (T)) = N_Full_Type_Declaration
14403 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
14404 and then Present (Component_List (Type_Definition (Parent (T))))
14405 and then
14406 Present
14407 (Variant_Part (Component_List (Type_Definition (Parent (T)))));
14408 end Is_Variant_Record;
14409
14410 -- Start of processing for Create_Constrained_Components
14411
14412 begin
14413 pragma Assert (Subt /= Base_Type (Subt));
14414 pragma Assert (Typ = Base_Type (Typ));
14415
14416 Set_First_Entity (Subt, Empty);
14417 Set_Last_Entity (Subt, Empty);
14418
14419 -- Check whether constraint is fully static, in which case we can
14420 -- optimize the list of components.
14421
14422 Discr_Val := First_Elmt (Constraints);
14423 while Present (Discr_Val) loop
14424 if not Is_OK_Static_Expression (Node (Discr_Val)) then
14425 Is_Static := False;
14426 exit;
14427 end if;
14428
14429 Next_Elmt (Discr_Val);
14430 end loop;
14431
14432 Set_Has_Static_Discriminants (Subt, Is_Static);
14433
14434 Push_Scope (Subt);
14435
14436 -- Inherit the discriminants of the parent type
14437
14438 Add_Discriminants : declare
14439 Num_Disc : Nat;
14440 Num_Gird : Nat;
14441
14442 begin
14443 Num_Disc := 0;
14444 Old_C := First_Discriminant (Typ);
14445
14446 while Present (Old_C) loop
14447 Num_Disc := Num_Disc + 1;
14448 New_C := Create_Component (Old_C);
14449 Set_Is_Public (New_C, Is_Public (Subt));
14450 Next_Discriminant (Old_C);
14451 end loop;
14452
14453 -- For an untagged derived subtype, the number of discriminants may
14454 -- be smaller than the number of inherited discriminants, because
14455 -- several of them may be renamed by a single new discriminant or
14456 -- constrained. In this case, add the hidden discriminants back into
14457 -- the subtype, because they need to be present if the optimizer of
14458 -- the GCC 4.x back-end decides to break apart assignments between
14459 -- objects using the parent view into member-wise assignments.
14460
14461 Num_Gird := 0;
14462
14463 if Is_Derived_Type (Typ)
14464 and then not Is_Tagged_Type (Typ)
14465 then
14466 Old_C := First_Stored_Discriminant (Typ);
14467
14468 while Present (Old_C) loop
14469 Num_Gird := Num_Gird + 1;
14470 Next_Stored_Discriminant (Old_C);
14471 end loop;
14472 end if;
14473
14474 if Num_Gird > Num_Disc then
14475
14476 -- Find out multiple uses of new discriminants, and add hidden
14477 -- components for the extra renamed discriminants. We recognize
14478 -- multiple uses through the Corresponding_Discriminant of a
14479 -- new discriminant: if it constrains several old discriminants,
14480 -- this field points to the last one in the parent type. The
14481 -- stored discriminants of the derived type have the same name
14482 -- as those of the parent.
14483
14484 declare
14485 Constr : Elmt_Id;
14486 New_Discr : Entity_Id;
14487 Old_Discr : Entity_Id;
14488
14489 begin
14490 Constr := First_Elmt (Stored_Constraint (Typ));
14491 Old_Discr := First_Stored_Discriminant (Typ);
14492 while Present (Constr) loop
14493 if Is_Entity_Name (Node (Constr))
14494 and then Ekind (Entity (Node (Constr))) = E_Discriminant
14495 then
14496 New_Discr := Entity (Node (Constr));
14497
14498 if Chars (Corresponding_Discriminant (New_Discr)) /=
14499 Chars (Old_Discr)
14500 then
14501 -- The new discriminant has been used to rename a
14502 -- subsequent old discriminant. Introduce a shadow
14503 -- component for the current old discriminant.
14504
14505 New_C := Create_Component (Old_Discr);
14506 Set_Original_Record_Component (New_C, Old_Discr);
14507 end if;
14508
14509 else
14510 -- The constraint has eliminated the old discriminant.
14511 -- Introduce a shadow component.
14512
14513 New_C := Create_Component (Old_Discr);
14514 Set_Original_Record_Component (New_C, Old_Discr);
14515 end if;
14516
14517 Next_Elmt (Constr);
14518 Next_Stored_Discriminant (Old_Discr);
14519 end loop;
14520 end;
14521 end if;
14522 end Add_Discriminants;
14523
14524 if Is_Static
14525 and then Is_Variant_Record (Typ)
14526 then
14527 Collect_Fixed_Components (Typ);
14528
14529 Gather_Components (
14530 Typ,
14531 Component_List (Type_Definition (Parent (Typ))),
14532 Governed_By => Assoc_List,
14533 Into => Comp_List,
14534 Report_Errors => Errors);
14535 pragma Assert (not Errors
14536 or else Serious_Errors_Detected > 0);
14537
14538 Create_All_Components;
14539
14540 -- If the subtype declaration is created for a tagged type derivation
14541 -- with constraints, we retrieve the record definition of the parent
14542 -- type to select the components of the proper variant.
14543
14544 elsif Is_Static
14545 and then Is_Tagged_Type (Typ)
14546 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
14547 and then
14548 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
14549 and then Is_Variant_Record (Parent_Type)
14550 then
14551 Collect_Fixed_Components (Typ);
14552
14553 Gather_Components
14554 (Typ,
14555 Component_List (Type_Definition (Parent (Parent_Type))),
14556 Governed_By => Assoc_List,
14557 Into => Comp_List,
14558 Report_Errors => Errors);
14559
14560 -- Note: previously there was a check at this point that no errors
14561 -- were detected. As a consequence of AI05-220 there may be an error
14562 -- if an inherited discriminant that controls a variant has a non-
14563 -- static constraint.
14564
14565 -- If the tagged derivation has a type extension, collect all the
14566 -- new components therein.
14567
14568 if Present (Record_Extension_Part (Type_Definition (Parent (Typ))))
14569 then
14570 Old_C := First_Component (Typ);
14571 while Present (Old_C) loop
14572 if Original_Record_Component (Old_C) = Old_C
14573 and then Chars (Old_C) /= Name_uTag
14574 and then Chars (Old_C) /= Name_uParent
14575 then
14576 Append_Elmt (Old_C, Comp_List);
14577 end if;
14578
14579 Next_Component (Old_C);
14580 end loop;
14581 end if;
14582
14583 Create_All_Components;
14584
14585 else
14586 -- If discriminants are not static, or if this is a multi-level type
14587 -- extension, we have to include all components of the parent type.
14588
14589 Old_C := First_Component (Typ);
14590 while Present (Old_C) loop
14591 New_C := Create_Component (Old_C);
14592
14593 Set_Etype
14594 (New_C,
14595 Constrain_Component_Type
14596 (Old_C, Subt, Decl_Node, Typ, Constraints));
14597 Set_Is_Public (New_C, Is_Public (Subt));
14598
14599 Next_Component (Old_C);
14600 end loop;
14601 end if;
14602
14603 End_Scope;
14604 end Create_Constrained_Components;
14605
14606 ------------------------------------------
14607 -- Decimal_Fixed_Point_Type_Declaration --
14608 ------------------------------------------
14609
14610 procedure Decimal_Fixed_Point_Type_Declaration
14611 (T : Entity_Id;
14612 Def : Node_Id)
14613 is
14614 Loc : constant Source_Ptr := Sloc (Def);
14615 Digs_Expr : constant Node_Id := Digits_Expression (Def);
14616 Delta_Expr : constant Node_Id := Delta_Expression (Def);
14617 Implicit_Base : Entity_Id;
14618 Digs_Val : Uint;
14619 Delta_Val : Ureal;
14620 Scale_Val : Uint;
14621 Bound_Val : Ureal;
14622
14623 begin
14624 Check_SPARK_05_Restriction
14625 ("decimal fixed point type is not allowed", Def);
14626 Check_Restriction (No_Fixed_Point, Def);
14627
14628 -- Create implicit base type
14629
14630 Implicit_Base :=
14631 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
14632 Set_Etype (Implicit_Base, Implicit_Base);
14633
14634 -- Analyze and process delta expression
14635
14636 Analyze_And_Resolve (Delta_Expr, Universal_Real);
14637
14638 Check_Delta_Expression (Delta_Expr);
14639 Delta_Val := Expr_Value_R (Delta_Expr);
14640
14641 -- Check delta is power of 10, and determine scale value from it
14642
14643 declare
14644 Val : Ureal;
14645
14646 begin
14647 Scale_Val := Uint_0;
14648 Val := Delta_Val;
14649
14650 if Val < Ureal_1 then
14651 while Val < Ureal_1 loop
14652 Val := Val * Ureal_10;
14653 Scale_Val := Scale_Val + 1;
14654 end loop;
14655
14656 if Scale_Val > 18 then
14657 Error_Msg_N ("scale exceeds maximum value of 18", Def);
14658 Scale_Val := UI_From_Int (+18);
14659 end if;
14660
14661 else
14662 while Val > Ureal_1 loop
14663 Val := Val / Ureal_10;
14664 Scale_Val := Scale_Val - 1;
14665 end loop;
14666
14667 if Scale_Val < -18 then
14668 Error_Msg_N ("scale is less than minimum value of -18", Def);
14669 Scale_Val := UI_From_Int (-18);
14670 end if;
14671 end if;
14672
14673 if Val /= Ureal_1 then
14674 Error_Msg_N ("delta expression must be a power of 10", Def);
14675 Delta_Val := Ureal_10 ** (-Scale_Val);
14676 end if;
14677 end;
14678
14679 -- Set delta, scale and small (small = delta for decimal type)
14680
14681 Set_Delta_Value (Implicit_Base, Delta_Val);
14682 Set_Scale_Value (Implicit_Base, Scale_Val);
14683 Set_Small_Value (Implicit_Base, Delta_Val);
14684
14685 -- Analyze and process digits expression
14686
14687 Analyze_And_Resolve (Digs_Expr, Any_Integer);
14688 Check_Digits_Expression (Digs_Expr);
14689 Digs_Val := Expr_Value (Digs_Expr);
14690
14691 if Digs_Val > 18 then
14692 Digs_Val := UI_From_Int (+18);
14693 Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
14694 end if;
14695
14696 Set_Digits_Value (Implicit_Base, Digs_Val);
14697 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
14698
14699 -- Set range of base type from digits value for now. This will be
14700 -- expanded to represent the true underlying base range by Freeze.
14701
14702 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
14703
14704 -- Note: We leave size as zero for now, size will be set at freeze
14705 -- time. We have to do this for ordinary fixed-point, because the size
14706 -- depends on the specified small, and we might as well do the same for
14707 -- decimal fixed-point.
14708
14709 pragma Assert (Esize (Implicit_Base) = Uint_0);
14710
14711 -- If there are bounds given in the declaration use them as the
14712 -- bounds of the first named subtype.
14713
14714 if Present (Real_Range_Specification (Def)) then
14715 declare
14716 RRS : constant Node_Id := Real_Range_Specification (Def);
14717 Low : constant Node_Id := Low_Bound (RRS);
14718 High : constant Node_Id := High_Bound (RRS);
14719 Low_Val : Ureal;
14720 High_Val : Ureal;
14721
14722 begin
14723 Analyze_And_Resolve (Low, Any_Real);
14724 Analyze_And_Resolve (High, Any_Real);
14725 Check_Real_Bound (Low);
14726 Check_Real_Bound (High);
14727 Low_Val := Expr_Value_R (Low);
14728 High_Val := Expr_Value_R (High);
14729
14730 if Low_Val < (-Bound_Val) then
14731 Error_Msg_N
14732 ("range low bound too small for digits value", Low);
14733 Low_Val := -Bound_Val;
14734 end if;
14735
14736 if High_Val > Bound_Val then
14737 Error_Msg_N
14738 ("range high bound too large for digits value", High);
14739 High_Val := Bound_Val;
14740 end if;
14741
14742 Set_Fixed_Range (T, Loc, Low_Val, High_Val);
14743 end;
14744
14745 -- If no explicit range, use range that corresponds to given
14746 -- digits value. This will end up as the final range for the
14747 -- first subtype.
14748
14749 else
14750 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
14751 end if;
14752
14753 -- Complete entity for first subtype. The inheritance of the rep item
14754 -- chain ensures that SPARK-related pragmas are not clobbered when the
14755 -- decimal fixed point type acts as a full view of a private type.
14756
14757 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
14758 Set_Etype (T, Implicit_Base);
14759 Set_Size_Info (T, Implicit_Base);
14760 Inherit_Rep_Item_Chain (T, Implicit_Base);
14761 Set_Digits_Value (T, Digs_Val);
14762 Set_Delta_Value (T, Delta_Val);
14763 Set_Small_Value (T, Delta_Val);
14764 Set_Scale_Value (T, Scale_Val);
14765 Set_Is_Constrained (T);
14766 end Decimal_Fixed_Point_Type_Declaration;
14767
14768 -----------------------------------
14769 -- Derive_Progenitor_Subprograms --
14770 -----------------------------------
14771
14772 procedure Derive_Progenitor_Subprograms
14773 (Parent_Type : Entity_Id;
14774 Tagged_Type : Entity_Id)
14775 is
14776 E : Entity_Id;
14777 Elmt : Elmt_Id;
14778 Iface : Entity_Id;
14779 Iface_Elmt : Elmt_Id;
14780 Iface_Subp : Entity_Id;
14781 New_Subp : Entity_Id := Empty;
14782 Prim_Elmt : Elmt_Id;
14783 Subp : Entity_Id;
14784 Typ : Entity_Id;
14785
14786 begin
14787 pragma Assert (Ada_Version >= Ada_2005
14788 and then Is_Record_Type (Tagged_Type)
14789 and then Is_Tagged_Type (Tagged_Type)
14790 and then Has_Interfaces (Tagged_Type));
14791
14792 -- Step 1: Transfer to the full-view primitives associated with the
14793 -- partial-view that cover interface primitives. Conceptually this
14794 -- work should be done later by Process_Full_View; done here to
14795 -- simplify its implementation at later stages. It can be safely
14796 -- done here because interfaces must be visible in the partial and
14797 -- private view (RM 7.3(7.3/2)).
14798
14799 -- Small optimization: This work is only required if the parent may
14800 -- have entities whose Alias attribute reference an interface primitive.
14801 -- Such a situation may occur if the parent is an abstract type and the
14802 -- primitive has not been yet overridden or if the parent is a generic
14803 -- formal type covering interfaces.
14804
14805 -- If the tagged type is not abstract, it cannot have abstract
14806 -- primitives (the only entities in the list of primitives of
14807 -- non-abstract tagged types that can reference abstract primitives
14808 -- through its Alias attribute are the internal entities that have
14809 -- attribute Interface_Alias, and these entities are generated later
14810 -- by Add_Internal_Interface_Entities).
14811
14812 if In_Private_Part (Current_Scope)
14813 and then (Is_Abstract_Type (Parent_Type)
14814 or else
14815 Is_Generic_Type (Parent_Type))
14816 then
14817 Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
14818 while Present (Elmt) loop
14819 Subp := Node (Elmt);
14820
14821 -- At this stage it is not possible to have entities in the list
14822 -- of primitives that have attribute Interface_Alias.
14823
14824 pragma Assert (No (Interface_Alias (Subp)));
14825
14826 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
14827
14828 if Is_Interface (Typ) then
14829 E := Find_Primitive_Covering_Interface
14830 (Tagged_Type => Tagged_Type,
14831 Iface_Prim => Subp);
14832
14833 if Present (E)
14834 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
14835 then
14836 Replace_Elmt (Elmt, E);
14837 Remove_Homonym (Subp);
14838 end if;
14839 end if;
14840
14841 Next_Elmt (Elmt);
14842 end loop;
14843 end if;
14844
14845 -- Step 2: Add primitives of progenitors that are not implemented by
14846 -- parents of Tagged_Type.
14847
14848 if Present (Interfaces (Base_Type (Tagged_Type))) then
14849 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
14850 while Present (Iface_Elmt) loop
14851 Iface := Node (Iface_Elmt);
14852
14853 Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
14854 while Present (Prim_Elmt) loop
14855 Iface_Subp := Node (Prim_Elmt);
14856
14857 -- Exclude derivation of predefined primitives except those
14858 -- that come from source, or are inherited from one that comes
14859 -- from source. Required to catch declarations of equality
14860 -- operators of interfaces. For example:
14861
14862 -- type Iface is interface;
14863 -- function "=" (Left, Right : Iface) return Boolean;
14864
14865 if not Is_Predefined_Dispatching_Operation (Iface_Subp)
14866 or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
14867 then
14868 E := Find_Primitive_Covering_Interface
14869 (Tagged_Type => Tagged_Type,
14870 Iface_Prim => Iface_Subp);
14871
14872 -- If not found we derive a new primitive leaving its alias
14873 -- attribute referencing the interface primitive.
14874
14875 if No (E) then
14876 Derive_Subprogram
14877 (New_Subp, Iface_Subp, Tagged_Type, Iface);
14878
14879 -- Ada 2012 (AI05-0197): If the covering primitive's name
14880 -- differs from the name of the interface primitive then it
14881 -- is a private primitive inherited from a parent type. In
14882 -- such case, given that Tagged_Type covers the interface,
14883 -- the inherited private primitive becomes visible. For such
14884 -- purpose we add a new entity that renames the inherited
14885 -- private primitive.
14886
14887 elsif Chars (E) /= Chars (Iface_Subp) then
14888 pragma Assert (Has_Suffix (E, 'P'));
14889 Derive_Subprogram
14890 (New_Subp, Iface_Subp, Tagged_Type, Iface);
14891 Set_Alias (New_Subp, E);
14892 Set_Is_Abstract_Subprogram (New_Subp,
14893 Is_Abstract_Subprogram (E));
14894
14895 -- Propagate to the full view interface entities associated
14896 -- with the partial view.
14897
14898 elsif In_Private_Part (Current_Scope)
14899 and then Present (Alias (E))
14900 and then Alias (E) = Iface_Subp
14901 and then
14902 List_Containing (Parent (E)) /=
14903 Private_Declarations
14904 (Specification
14905 (Unit_Declaration_Node (Current_Scope)))
14906 then
14907 Append_Elmt (E, Primitive_Operations (Tagged_Type));
14908 end if;
14909 end if;
14910
14911 Next_Elmt (Prim_Elmt);
14912 end loop;
14913
14914 Next_Elmt (Iface_Elmt);
14915 end loop;
14916 end if;
14917 end Derive_Progenitor_Subprograms;
14918
14919 -----------------------
14920 -- Derive_Subprogram --
14921 -----------------------
14922
14923 procedure Derive_Subprogram
14924 (New_Subp : out Entity_Id;
14925 Parent_Subp : Entity_Id;
14926 Derived_Type : Entity_Id;
14927 Parent_Type : Entity_Id;
14928 Actual_Subp : Entity_Id := Empty)
14929 is
14930 Formal : Entity_Id;
14931 -- Formal parameter of parent primitive operation
14932
14933 Formal_Of_Actual : Entity_Id;
14934 -- Formal parameter of actual operation, when the derivation is to
14935 -- create a renaming for a primitive operation of an actual in an
14936 -- instantiation.
14937
14938 New_Formal : Entity_Id;
14939 -- Formal of inherited operation
14940
14941 Visible_Subp : Entity_Id := Parent_Subp;
14942
14943 function Is_Private_Overriding return Boolean;
14944 -- If Subp is a private overriding of a visible operation, the inherited
14945 -- operation derives from the overridden op (even though its body is the
14946 -- overriding one) and the inherited operation is visible now. See
14947 -- sem_disp to see the full details of the handling of the overridden
14948 -- subprogram, which is removed from the list of primitive operations of
14949 -- the type. The overridden subprogram is saved locally in Visible_Subp,
14950 -- and used to diagnose abstract operations that need overriding in the
14951 -- derived type.
14952
14953 procedure Replace_Type (Id, New_Id : Entity_Id);
14954 -- When the type is an anonymous access type, create a new access type
14955 -- designating the derived type.
14956
14957 procedure Set_Derived_Name;
14958 -- This procedure sets the appropriate Chars name for New_Subp. This
14959 -- is normally just a copy of the parent name. An exception arises for
14960 -- type support subprograms, where the name is changed to reflect the
14961 -- name of the derived type, e.g. if type foo is derived from type bar,
14962 -- then a procedure barDA is derived with a name fooDA.
14963
14964 ---------------------------
14965 -- Is_Private_Overriding --
14966 ---------------------------
14967
14968 function Is_Private_Overriding return Boolean is
14969 Prev : Entity_Id;
14970
14971 begin
14972 -- If the parent is not a dispatching operation there is no
14973 -- need to investigate overridings
14974
14975 if not Is_Dispatching_Operation (Parent_Subp) then
14976 return False;
14977 end if;
14978
14979 -- The visible operation that is overridden is a homonym of the
14980 -- parent subprogram. We scan the homonym chain to find the one
14981 -- whose alias is the subprogram we are deriving.
14982
14983 Prev := Current_Entity (Parent_Subp);
14984 while Present (Prev) loop
14985 if Ekind (Prev) = Ekind (Parent_Subp)
14986 and then Alias (Prev) = Parent_Subp
14987 and then Scope (Parent_Subp) = Scope (Prev)
14988 and then not Is_Hidden (Prev)
14989 then
14990 Visible_Subp := Prev;
14991 return True;
14992 end if;
14993
14994 Prev := Homonym (Prev);
14995 end loop;
14996
14997 return False;
14998 end Is_Private_Overriding;
14999
15000 ------------------
15001 -- Replace_Type --
15002 ------------------
15003
15004 procedure Replace_Type (Id, New_Id : Entity_Id) is
15005 Id_Type : constant Entity_Id := Etype (Id);
15006 Acc_Type : Entity_Id;
15007 Par : constant Node_Id := Parent (Derived_Type);
15008
15009 begin
15010 -- When the type is an anonymous access type, create a new access
15011 -- type designating the derived type. This itype must be elaborated
15012 -- at the point of the derivation, not on subsequent calls that may
15013 -- be out of the proper scope for Gigi, so we insert a reference to
15014 -- it after the derivation.
15015
15016 if Ekind (Id_Type) = E_Anonymous_Access_Type then
15017 declare
15018 Desig_Typ : Entity_Id := Designated_Type (Id_Type);
15019
15020 begin
15021 if Ekind (Desig_Typ) = E_Record_Type_With_Private
15022 and then Present (Full_View (Desig_Typ))
15023 and then not Is_Private_Type (Parent_Type)
15024 then
15025 Desig_Typ := Full_View (Desig_Typ);
15026 end if;
15027
15028 if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
15029
15030 -- Ada 2005 (AI-251): Handle also derivations of abstract
15031 -- interface primitives.
15032
15033 or else (Is_Interface (Desig_Typ)
15034 and then not Is_Class_Wide_Type (Desig_Typ))
15035 then
15036 Acc_Type := New_Copy (Id_Type);
15037 Set_Etype (Acc_Type, Acc_Type);
15038 Set_Scope (Acc_Type, New_Subp);
15039
15040 -- Set size of anonymous access type. If we have an access
15041 -- to an unconstrained array, this is a fat pointer, so it
15042 -- is sizes at twice addtress size.
15043
15044 if Is_Array_Type (Desig_Typ)
15045 and then not Is_Constrained (Desig_Typ)
15046 then
15047 Init_Size (Acc_Type, 2 * System_Address_Size);
15048
15049 -- Other cases use a thin pointer
15050
15051 else
15052 Init_Size (Acc_Type, System_Address_Size);
15053 end if;
15054
15055 -- Set remaining characterstics of anonymous access type
15056
15057 Init_Alignment (Acc_Type);
15058 Set_Directly_Designated_Type (Acc_Type, Derived_Type);
15059
15060 Set_Etype (New_Id, Acc_Type);
15061 Set_Scope (New_Id, New_Subp);
15062
15063 -- Create a reference to it
15064
15065 Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
15066
15067 else
15068 Set_Etype (New_Id, Id_Type);
15069 end if;
15070 end;
15071
15072 -- In Ada2012, a formal may have an incomplete type but the type
15073 -- derivation that inherits the primitive follows the full view.
15074
15075 elsif Base_Type (Id_Type) = Base_Type (Parent_Type)
15076 or else
15077 (Ekind (Id_Type) = E_Record_Type_With_Private
15078 and then Present (Full_View (Id_Type))
15079 and then
15080 Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type))
15081 or else
15082 (Ada_Version >= Ada_2012
15083 and then Ekind (Id_Type) = E_Incomplete_Type
15084 and then Full_View (Id_Type) = Parent_Type)
15085 then
15086 -- Constraint checks on formals are generated during expansion,
15087 -- based on the signature of the original subprogram. The bounds
15088 -- of the derived type are not relevant, and thus we can use
15089 -- the base type for the formals. However, the return type may be
15090 -- used in a context that requires that the proper static bounds
15091 -- be used (a case statement, for example) and for those cases
15092 -- we must use the derived type (first subtype), not its base.
15093
15094 -- If the derived_type_definition has no constraints, we know that
15095 -- the derived type has the same constraints as the first subtype
15096 -- of the parent, and we can also use it rather than its base,
15097 -- which can lead to more efficient code.
15098
15099 if Etype (Id) = Parent_Type then
15100 if Is_Scalar_Type (Parent_Type)
15101 and then
15102 Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
15103 then
15104 Set_Etype (New_Id, Derived_Type);
15105
15106 elsif Nkind (Par) = N_Full_Type_Declaration
15107 and then
15108 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
15109 and then
15110 Is_Entity_Name
15111 (Subtype_Indication (Type_Definition (Par)))
15112 then
15113 Set_Etype (New_Id, Derived_Type);
15114
15115 else
15116 Set_Etype (New_Id, Base_Type (Derived_Type));
15117 end if;
15118
15119 else
15120 Set_Etype (New_Id, Base_Type (Derived_Type));
15121 end if;
15122
15123 else
15124 Set_Etype (New_Id, Etype (Id));
15125 end if;
15126 end Replace_Type;
15127
15128 ----------------------
15129 -- Set_Derived_Name --
15130 ----------------------
15131
15132 procedure Set_Derived_Name is
15133 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
15134 begin
15135 if Nm = TSS_Null then
15136 Set_Chars (New_Subp, Chars (Parent_Subp));
15137 else
15138 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
15139 end if;
15140 end Set_Derived_Name;
15141
15142 -- Start of processing for Derive_Subprogram
15143
15144 begin
15145 New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
15146 Set_Ekind (New_Subp, Ekind (Parent_Subp));
15147
15148 -- Check whether the inherited subprogram is a private operation that
15149 -- should be inherited but not yet made visible. Such subprograms can
15150 -- become visible at a later point (e.g., the private part of a public
15151 -- child unit) via Declare_Inherited_Private_Subprograms. If the
15152 -- following predicate is true, then this is not such a private
15153 -- operation and the subprogram simply inherits the name of the parent
15154 -- subprogram. Note the special check for the names of controlled
15155 -- operations, which are currently exempted from being inherited with
15156 -- a hidden name because they must be findable for generation of
15157 -- implicit run-time calls.
15158
15159 if not Is_Hidden (Parent_Subp)
15160 or else Is_Internal (Parent_Subp)
15161 or else Is_Private_Overriding
15162 or else Is_Internal_Name (Chars (Parent_Subp))
15163 or else (Is_Controlled (Parent_Type)
15164 and then Nam_In (Chars (Parent_Subp), Name_Adjust,
15165 Name_Finalize,
15166 Name_Initialize))
15167 then
15168 Set_Derived_Name;
15169
15170 -- An inherited dispatching equality will be overridden by an internally
15171 -- generated one, or by an explicit one, so preserve its name and thus
15172 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a
15173 -- private operation it may become invisible if the full view has
15174 -- progenitors, and the dispatch table will be malformed.
15175 -- We check that the type is limited to handle the anomalous declaration
15176 -- of Limited_Controlled, which is derived from a non-limited type, and
15177 -- which is handled specially elsewhere as well.
15178
15179 elsif Chars (Parent_Subp) = Name_Op_Eq
15180 and then Is_Dispatching_Operation (Parent_Subp)
15181 and then Etype (Parent_Subp) = Standard_Boolean
15182 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
15183 and then
15184 Etype (First_Formal (Parent_Subp)) =
15185 Etype (Next_Formal (First_Formal (Parent_Subp)))
15186 then
15187 Set_Derived_Name;
15188
15189 -- If parent is hidden, this can be a regular derivation if the
15190 -- parent is immediately visible in a non-instantiating context,
15191 -- or if we are in the private part of an instance. This test
15192 -- should still be refined ???
15193
15194 -- The test for In_Instance_Not_Visible avoids inheriting the derived
15195 -- operation as a non-visible operation in cases where the parent
15196 -- subprogram might not be visible now, but was visible within the
15197 -- original generic, so it would be wrong to make the inherited
15198 -- subprogram non-visible now. (Not clear if this test is fully
15199 -- correct; are there any cases where we should declare the inherited
15200 -- operation as not visible to avoid it being overridden, e.g., when
15201 -- the parent type is a generic actual with private primitives ???)
15202
15203 -- (they should be treated the same as other private inherited
15204 -- subprograms, but it's not clear how to do this cleanly). ???
15205
15206 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
15207 and then Is_Immediately_Visible (Parent_Subp)
15208 and then not In_Instance)
15209 or else In_Instance_Not_Visible
15210 then
15211 Set_Derived_Name;
15212
15213 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram
15214 -- overrides an interface primitive because interface primitives
15215 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
15216
15217 elsif Ada_Version >= Ada_2005
15218 and then Is_Dispatching_Operation (Parent_Subp)
15219 and then Present (Covered_Interface_Op (Parent_Subp))
15220 then
15221 Set_Derived_Name;
15222
15223 -- Otherwise, the type is inheriting a private operation, so enter it
15224 -- with a special name so it can't be overridden.
15225
15226 else
15227 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
15228 end if;
15229
15230 Set_Parent (New_Subp, Parent (Derived_Type));
15231
15232 if Present (Actual_Subp) then
15233 Replace_Type (Actual_Subp, New_Subp);
15234 else
15235 Replace_Type (Parent_Subp, New_Subp);
15236 end if;
15237
15238 Conditional_Delay (New_Subp, Parent_Subp);
15239
15240 -- If we are creating a renaming for a primitive operation of an
15241 -- actual of a generic derived type, we must examine the signature
15242 -- of the actual primitive, not that of the generic formal, which for
15243 -- example may be an interface. However the name and initial value
15244 -- of the inherited operation are those of the formal primitive.
15245
15246 Formal := First_Formal (Parent_Subp);
15247
15248 if Present (Actual_Subp) then
15249 Formal_Of_Actual := First_Formal (Actual_Subp);
15250 else
15251 Formal_Of_Actual := Empty;
15252 end if;
15253
15254 while Present (Formal) loop
15255 New_Formal := New_Copy (Formal);
15256
15257 -- Normally we do not go copying parents, but in the case of
15258 -- formals, we need to link up to the declaration (which is the
15259 -- parameter specification), and it is fine to link up to the
15260 -- original formal's parameter specification in this case.
15261
15262 Set_Parent (New_Formal, Parent (Formal));
15263 Append_Entity (New_Formal, New_Subp);
15264
15265 if Present (Formal_Of_Actual) then
15266 Replace_Type (Formal_Of_Actual, New_Formal);
15267 Next_Formal (Formal_Of_Actual);
15268 else
15269 Replace_Type (Formal, New_Formal);
15270 end if;
15271
15272 Next_Formal (Formal);
15273 end loop;
15274
15275 -- If this derivation corresponds to a tagged generic actual, then
15276 -- primitive operations rename those of the actual. Otherwise the
15277 -- primitive operations rename those of the parent type, If the parent
15278 -- renames an intrinsic operator, so does the new subprogram. We except
15279 -- concatenation, which is always properly typed, and does not get
15280 -- expanded as other intrinsic operations.
15281
15282 if No (Actual_Subp) then
15283 if Is_Intrinsic_Subprogram (Parent_Subp) then
15284 Set_Is_Intrinsic_Subprogram (New_Subp);
15285
15286 if Present (Alias (Parent_Subp))
15287 and then Chars (Parent_Subp) /= Name_Op_Concat
15288 then
15289 Set_Alias (New_Subp, Alias (Parent_Subp));
15290 else
15291 Set_Alias (New_Subp, Parent_Subp);
15292 end if;
15293
15294 else
15295 Set_Alias (New_Subp, Parent_Subp);
15296 end if;
15297
15298 else
15299 Set_Alias (New_Subp, Actual_Subp);
15300 end if;
15301
15302 -- Derived subprograms of a tagged type must inherit the convention
15303 -- of the parent subprogram (a requirement of AI-117). Derived
15304 -- subprograms of untagged types simply get convention Ada by default.
15305
15306 -- If the derived type is a tagged generic formal type with unknown
15307 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)).
15308
15309 -- However, if the type is derived from a generic formal, the further
15310 -- inherited subprogram has the convention of the non-generic ancestor.
15311 -- Otherwise there would be no way to override the operation.
15312 -- (This is subject to forthcoming ARG discussions).
15313
15314 if Is_Tagged_Type (Derived_Type) then
15315 if Is_Generic_Type (Derived_Type)
15316 and then Has_Unknown_Discriminants (Derived_Type)
15317 then
15318 Set_Convention (New_Subp, Convention_Intrinsic);
15319
15320 else
15321 if Is_Generic_Type (Parent_Type)
15322 and then Has_Unknown_Discriminants (Parent_Type)
15323 then
15324 Set_Convention (New_Subp, Convention (Alias (Parent_Subp)));
15325 else
15326 Set_Convention (New_Subp, Convention (Parent_Subp));
15327 end if;
15328 end if;
15329 end if;
15330
15331 -- Predefined controlled operations retain their name even if the parent
15332 -- is hidden (see above), but they are not primitive operations if the
15333 -- ancestor is not visible, for example if the parent is a private
15334 -- extension completed with a controlled extension. Note that a full
15335 -- type that is controlled can break privacy: the flag Is_Controlled is
15336 -- set on both views of the type.
15337
15338 if Is_Controlled (Parent_Type)
15339 and then Nam_In (Chars (Parent_Subp), Name_Initialize,
15340 Name_Adjust,
15341 Name_Finalize)
15342 and then Is_Hidden (Parent_Subp)
15343 and then not Is_Visibly_Controlled (Parent_Type)
15344 then
15345 Set_Is_Hidden (New_Subp);
15346 end if;
15347
15348 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
15349 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
15350
15351 if Ekind (Parent_Subp) = E_Procedure then
15352 Set_Is_Valued_Procedure
15353 (New_Subp, Is_Valued_Procedure (Parent_Subp));
15354 else
15355 Set_Has_Controlling_Result
15356 (New_Subp, Has_Controlling_Result (Parent_Subp));
15357 end if;
15358
15359 -- No_Return must be inherited properly. If this is overridden in the
15360 -- case of a dispatching operation, then a check is made in Sem_Disp
15361 -- that the overriding operation is also No_Return (no such check is
15362 -- required for the case of non-dispatching operation.
15363
15364 Set_No_Return (New_Subp, No_Return (Parent_Subp));
15365
15366 -- A derived function with a controlling result is abstract. If the
15367 -- Derived_Type is a nonabstract formal generic derived type, then
15368 -- inherited operations are not abstract: the required check is done at
15369 -- instantiation time. If the derivation is for a generic actual, the
15370 -- function is not abstract unless the actual is.
15371
15372 if Is_Generic_Type (Derived_Type)
15373 and then not Is_Abstract_Type (Derived_Type)
15374 then
15375 null;
15376
15377 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
15378 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
15379
15380 -- A subprogram subject to pragma Extensions_Visible with value False
15381 -- requires overriding if the subprogram has at least one controlling
15382 -- OUT parameter (SPARK RM 6.1.7(6)).
15383
15384 elsif Ada_Version >= Ada_2005
15385 and then (Is_Abstract_Subprogram (Alias (New_Subp))
15386 or else (Is_Tagged_Type (Derived_Type)
15387 and then Etype (New_Subp) = Derived_Type
15388 and then not Is_Null_Extension (Derived_Type))
15389 or else (Is_Tagged_Type (Derived_Type)
15390 and then Ekind (Etype (New_Subp)) =
15391 E_Anonymous_Access_Type
15392 and then Designated_Type (Etype (New_Subp)) =
15393 Derived_Type
15394 and then not Is_Null_Extension (Derived_Type))
15395 or else (Comes_From_Source (Alias (New_Subp))
15396 and then Is_EVF_Procedure (Alias (New_Subp))))
15397 and then No (Actual_Subp)
15398 then
15399 if not Is_Tagged_Type (Derived_Type)
15400 or else Is_Abstract_Type (Derived_Type)
15401 or else Is_Abstract_Subprogram (Alias (New_Subp))
15402 then
15403 Set_Is_Abstract_Subprogram (New_Subp);
15404 else
15405 Set_Requires_Overriding (New_Subp);
15406 end if;
15407
15408 elsif Ada_Version < Ada_2005
15409 and then (Is_Abstract_Subprogram (Alias (New_Subp))
15410 or else (Is_Tagged_Type (Derived_Type)
15411 and then Etype (New_Subp) = Derived_Type
15412 and then No (Actual_Subp)))
15413 then
15414 Set_Is_Abstract_Subprogram (New_Subp);
15415
15416 -- AI05-0097 : an inherited operation that dispatches on result is
15417 -- abstract if the derived type is abstract, even if the parent type
15418 -- is concrete and the derived type is a null extension.
15419
15420 elsif Has_Controlling_Result (Alias (New_Subp))
15421 and then Is_Abstract_Type (Etype (New_Subp))
15422 then
15423 Set_Is_Abstract_Subprogram (New_Subp);
15424
15425 -- Finally, if the parent type is abstract we must verify that all
15426 -- inherited operations are either non-abstract or overridden, or that
15427 -- the derived type itself is abstract (this check is performed at the
15428 -- end of a package declaration, in Check_Abstract_Overriding). A
15429 -- private overriding in the parent type will not be visible in the
15430 -- derivation if we are not in an inner package or in a child unit of
15431 -- the parent type, in which case the abstractness of the inherited
15432 -- operation is carried to the new subprogram.
15433
15434 elsif Is_Abstract_Type (Parent_Type)
15435 and then not In_Open_Scopes (Scope (Parent_Type))
15436 and then Is_Private_Overriding
15437 and then Is_Abstract_Subprogram (Visible_Subp)
15438 then
15439 if No (Actual_Subp) then
15440 Set_Alias (New_Subp, Visible_Subp);
15441 Set_Is_Abstract_Subprogram (New_Subp, True);
15442
15443 else
15444 -- If this is a derivation for an instance of a formal derived
15445 -- type, abstractness comes from the primitive operation of the
15446 -- actual, not from the operation inherited from the ancestor.
15447
15448 Set_Is_Abstract_Subprogram
15449 (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
15450 end if;
15451 end if;
15452
15453 New_Overloaded_Entity (New_Subp, Derived_Type);
15454
15455 -- Ada RM 6.1.1 (15): If a subprogram inherits nonconforming class-wide
15456 -- preconditions and the derived type is abstract, the derived operation
15457 -- is abstract as well if parent subprogram is not abstract or null.
15458
15459 if Is_Abstract_Type (Derived_Type)
15460 and then Has_Non_Trivial_Precondition (Parent_Subp)
15461 and then Present (Interfaces (Derived_Type))
15462 then
15463 Set_Is_Dispatching_Operation (New_Subp);
15464
15465 declare
15466 Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp);
15467
15468 begin
15469 if Present (Iface_Prim)
15470 and then Has_Non_Trivial_Precondition (Iface_Prim)
15471 then
15472 Set_Is_Abstract_Subprogram (New_Subp);
15473 end if;
15474 end;
15475 end if;
15476
15477 -- Check for case of a derived subprogram for the instantiation of a
15478 -- formal derived tagged type, if so mark the subprogram as dispatching
15479 -- and inherit the dispatching attributes of the actual subprogram. The
15480 -- derived subprogram is effectively renaming of the actual subprogram,
15481 -- so it needs to have the same attributes as the actual.
15482
15483 if Present (Actual_Subp)
15484 and then Is_Dispatching_Operation (Actual_Subp)
15485 then
15486 Set_Is_Dispatching_Operation (New_Subp);
15487
15488 if Present (DTC_Entity (Actual_Subp)) then
15489 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
15490 Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp));
15491 end if;
15492 end if;
15493
15494 -- Indicate that a derived subprogram does not require a body and that
15495 -- it does not require processing of default expressions.
15496
15497 Set_Has_Completion (New_Subp);
15498 Set_Default_Expressions_Processed (New_Subp);
15499
15500 if Ekind (New_Subp) = E_Function then
15501 Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
15502 end if;
15503 end Derive_Subprogram;
15504
15505 ------------------------
15506 -- Derive_Subprograms --
15507 ------------------------
15508
15509 procedure Derive_Subprograms
15510 (Parent_Type : Entity_Id;
15511 Derived_Type : Entity_Id;
15512 Generic_Actual : Entity_Id := Empty)
15513 is
15514 Op_List : constant Elist_Id :=
15515 Collect_Primitive_Operations (Parent_Type);
15516
15517 function Check_Derived_Type return Boolean;
15518 -- Check that all the entities derived from Parent_Type are found in
15519 -- the list of primitives of Derived_Type exactly in the same order.
15520
15521 procedure Derive_Interface_Subprogram
15522 (New_Subp : out Entity_Id;
15523 Subp : Entity_Id;
15524 Actual_Subp : Entity_Id);
15525 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp
15526 -- (which is an interface primitive). If Generic_Actual is present then
15527 -- Actual_Subp is the actual subprogram corresponding with the generic
15528 -- subprogram Subp.
15529
15530 ------------------------
15531 -- Check_Derived_Type --
15532 ------------------------
15533
15534 function Check_Derived_Type return Boolean is
15535 E : Entity_Id;
15536 Elmt : Elmt_Id;
15537 List : Elist_Id;
15538 New_Subp : Entity_Id;
15539 Op_Elmt : Elmt_Id;
15540 Subp : Entity_Id;
15541
15542 begin
15543 -- Traverse list of entities in the current scope searching for
15544 -- an incomplete type whose full-view is derived type.
15545
15546 E := First_Entity (Scope (Derived_Type));
15547 while Present (E) and then E /= Derived_Type loop
15548 if Ekind (E) = E_Incomplete_Type
15549 and then Present (Full_View (E))
15550 and then Full_View (E) = Derived_Type
15551 then
15552 -- Disable this test if Derived_Type completes an incomplete
15553 -- type because in such case more primitives can be added
15554 -- later to the list of primitives of Derived_Type by routine
15555 -- Process_Incomplete_Dependents
15556
15557 return True;
15558 end if;
15559
15560 E := Next_Entity (E);
15561 end loop;
15562
15563 List := Collect_Primitive_Operations (Derived_Type);
15564 Elmt := First_Elmt (List);
15565
15566 Op_Elmt := First_Elmt (Op_List);
15567 while Present (Op_Elmt) loop
15568 Subp := Node (Op_Elmt);
15569 New_Subp := Node (Elmt);
15570
15571 -- At this early stage Derived_Type has no entities with attribute
15572 -- Interface_Alias. In addition, such primitives are always
15573 -- located at the end of the list of primitives of Parent_Type.
15574 -- Therefore, if found we can safely stop processing pending
15575 -- entities.
15576
15577 exit when Present (Interface_Alias (Subp));
15578
15579 -- Handle hidden entities
15580
15581 if not Is_Predefined_Dispatching_Operation (Subp)
15582 and then Is_Hidden (Subp)
15583 then
15584 if Present (New_Subp)
15585 and then Primitive_Names_Match (Subp, New_Subp)
15586 then
15587 Next_Elmt (Elmt);
15588 end if;
15589
15590 else
15591 if not Present (New_Subp)
15592 or else Ekind (Subp) /= Ekind (New_Subp)
15593 or else not Primitive_Names_Match (Subp, New_Subp)
15594 then
15595 return False;
15596 end if;
15597
15598 Next_Elmt (Elmt);
15599 end if;
15600
15601 Next_Elmt (Op_Elmt);
15602 end loop;
15603
15604 return True;
15605 end Check_Derived_Type;
15606
15607 ---------------------------------
15608 -- Derive_Interface_Subprogram --
15609 ---------------------------------
15610
15611 procedure Derive_Interface_Subprogram
15612 (New_Subp : out Entity_Id;
15613 Subp : Entity_Id;
15614 Actual_Subp : Entity_Id)
15615 is
15616 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
15617 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
15618
15619 begin
15620 pragma Assert (Is_Interface (Iface_Type));
15621
15622 Derive_Subprogram
15623 (New_Subp => New_Subp,
15624 Parent_Subp => Iface_Subp,
15625 Derived_Type => Derived_Type,
15626 Parent_Type => Iface_Type,
15627 Actual_Subp => Actual_Subp);
15628
15629 -- Given that this new interface entity corresponds with a primitive
15630 -- of the parent that was not overridden we must leave it associated
15631 -- with its parent primitive to ensure that it will share the same
15632 -- dispatch table slot when overridden. We must set the Alias to Subp
15633 -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram
15634 -- (in case we inherited Subp from Iface_Type via a nonabstract
15635 -- generic formal type).
15636
15637 if No (Actual_Subp) then
15638 Set_Alias (New_Subp, Subp);
15639
15640 declare
15641 T : Entity_Id := Find_Dispatching_Type (Subp);
15642 begin
15643 while Etype (T) /= T loop
15644 if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then
15645 Set_Is_Abstract_Subprogram (New_Subp, False);
15646 exit;
15647 end if;
15648
15649 T := Etype (T);
15650 end loop;
15651 end;
15652
15653 -- For instantiations this is not needed since the previous call to
15654 -- Derive_Subprogram leaves the entity well decorated.
15655
15656 else
15657 pragma Assert (Alias (New_Subp) = Actual_Subp);
15658 null;
15659 end if;
15660 end Derive_Interface_Subprogram;
15661
15662 -- Local variables
15663
15664 Alias_Subp : Entity_Id;
15665 Act_List : Elist_Id;
15666 Act_Elmt : Elmt_Id;
15667 Act_Subp : Entity_Id := Empty;
15668 Elmt : Elmt_Id;
15669 Need_Search : Boolean := False;
15670 New_Subp : Entity_Id := Empty;
15671 Parent_Base : Entity_Id;
15672 Subp : Entity_Id;
15673
15674 -- Start of processing for Derive_Subprograms
15675
15676 begin
15677 if Ekind (Parent_Type) = E_Record_Type_With_Private
15678 and then Has_Discriminants (Parent_Type)
15679 and then Present (Full_View (Parent_Type))
15680 then
15681 Parent_Base := Full_View (Parent_Type);
15682 else
15683 Parent_Base := Parent_Type;
15684 end if;
15685
15686 if Present (Generic_Actual) then
15687 Act_List := Collect_Primitive_Operations (Generic_Actual);
15688 Act_Elmt := First_Elmt (Act_List);
15689 else
15690 Act_List := No_Elist;
15691 Act_Elmt := No_Elmt;
15692 end if;
15693
15694 -- Derive primitives inherited from the parent. Note that if the generic
15695 -- actual is present, this is not really a type derivation, it is a
15696 -- completion within an instance.
15697
15698 -- Case 1: Derived_Type does not implement interfaces
15699
15700 if not Is_Tagged_Type (Derived_Type)
15701 or else (not Has_Interfaces (Derived_Type)
15702 and then not (Present (Generic_Actual)
15703 and then Has_Interfaces (Generic_Actual)))
15704 then
15705 Elmt := First_Elmt (Op_List);
15706 while Present (Elmt) loop
15707 Subp := Node (Elmt);
15708
15709 -- Literals are derived earlier in the process of building the
15710 -- derived type, and are skipped here.
15711
15712 if Ekind (Subp) = E_Enumeration_Literal then
15713 null;
15714
15715 -- The actual is a direct descendant and the common primitive
15716 -- operations appear in the same order.
15717
15718 -- If the generic parent type is present, the derived type is an
15719 -- instance of a formal derived type, and within the instance its
15720 -- operations are those of the actual. We derive from the formal
15721 -- type but make the inherited operations aliases of the
15722 -- corresponding operations of the actual.
15723
15724 else
15725 pragma Assert (No (Node (Act_Elmt))
15726 or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
15727 and then
15728 Type_Conformant
15729 (Subp, Node (Act_Elmt),
15730 Skip_Controlling_Formals => True)));
15731
15732 Derive_Subprogram
15733 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
15734
15735 if Present (Act_Elmt) then
15736 Next_Elmt (Act_Elmt);
15737 end if;
15738 end if;
15739
15740 Next_Elmt (Elmt);
15741 end loop;
15742
15743 -- Case 2: Derived_Type implements interfaces
15744
15745 else
15746 -- If the parent type has no predefined primitives we remove
15747 -- predefined primitives from the list of primitives of generic
15748 -- actual to simplify the complexity of this algorithm.
15749
15750 if Present (Generic_Actual) then
15751 declare
15752 Has_Predefined_Primitives : Boolean := False;
15753
15754 begin
15755 -- Check if the parent type has predefined primitives
15756
15757 Elmt := First_Elmt (Op_List);
15758 while Present (Elmt) loop
15759 Subp := Node (Elmt);
15760
15761 if Is_Predefined_Dispatching_Operation (Subp)
15762 and then not Comes_From_Source (Ultimate_Alias (Subp))
15763 then
15764 Has_Predefined_Primitives := True;
15765 exit;
15766 end if;
15767
15768 Next_Elmt (Elmt);
15769 end loop;
15770
15771 -- Remove predefined primitives of Generic_Actual. We must use
15772 -- an auxiliary list because in case of tagged types the value
15773 -- returned by Collect_Primitive_Operations is the value stored
15774 -- in its Primitive_Operations attribute (and we don't want to
15775 -- modify its current contents).
15776
15777 if not Has_Predefined_Primitives then
15778 declare
15779 Aux_List : constant Elist_Id := New_Elmt_List;
15780
15781 begin
15782 Elmt := First_Elmt (Act_List);
15783 while Present (Elmt) loop
15784 Subp := Node (Elmt);
15785
15786 if not Is_Predefined_Dispatching_Operation (Subp)
15787 or else Comes_From_Source (Subp)
15788 then
15789 Append_Elmt (Subp, Aux_List);
15790 end if;
15791
15792 Next_Elmt (Elmt);
15793 end loop;
15794
15795 Act_List := Aux_List;
15796 end;
15797 end if;
15798
15799 Act_Elmt := First_Elmt (Act_List);
15800 Act_Subp := Node (Act_Elmt);
15801 end;
15802 end if;
15803
15804 -- Stage 1: If the generic actual is not present we derive the
15805 -- primitives inherited from the parent type. If the generic parent
15806 -- type is present, the derived type is an instance of a formal
15807 -- derived type, and within the instance its operations are those of
15808 -- the actual. We derive from the formal type but make the inherited
15809 -- operations aliases of the corresponding operations of the actual.
15810
15811 Elmt := First_Elmt (Op_List);
15812 while Present (Elmt) loop
15813 Subp := Node (Elmt);
15814 Alias_Subp := Ultimate_Alias (Subp);
15815
15816 -- Do not derive internal entities of the parent that link
15817 -- interface primitives with their covering primitive. These
15818 -- entities will be added to this type when frozen.
15819
15820 if Present (Interface_Alias (Subp)) then
15821 goto Continue;
15822 end if;
15823
15824 -- If the generic actual is present find the corresponding
15825 -- operation in the generic actual. If the parent type is a
15826 -- direct ancestor of the derived type then, even if it is an
15827 -- interface, the operations are inherited from the primary
15828 -- dispatch table and are in the proper order. If we detect here
15829 -- that primitives are not in the same order we traverse the list
15830 -- of primitive operations of the actual to find the one that
15831 -- implements the interface primitive.
15832
15833 if Need_Search
15834 or else
15835 (Present (Generic_Actual)
15836 and then Present (Act_Subp)
15837 and then not
15838 (Primitive_Names_Match (Subp, Act_Subp)
15839 and then
15840 Type_Conformant (Subp, Act_Subp,
15841 Skip_Controlling_Formals => True)))
15842 then
15843 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual,
15844 Use_Full_View => True));
15845
15846 -- Remember that we need searching for all pending primitives
15847
15848 Need_Search := True;
15849
15850 -- Handle entities associated with interface primitives
15851
15852 if Present (Alias_Subp)
15853 and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
15854 and then not Is_Predefined_Dispatching_Operation (Subp)
15855 then
15856 -- Search for the primitive in the homonym chain
15857
15858 Act_Subp :=
15859 Find_Primitive_Covering_Interface
15860 (Tagged_Type => Generic_Actual,
15861 Iface_Prim => Alias_Subp);
15862
15863 -- Previous search may not locate primitives covering
15864 -- interfaces defined in generics units or instantiations.
15865 -- (it fails if the covering primitive has formals whose
15866 -- type is also defined in generics or instantiations).
15867 -- In such case we search in the list of primitives of the
15868 -- generic actual for the internal entity that links the
15869 -- interface primitive and the covering primitive.
15870
15871 if No (Act_Subp)
15872 and then Is_Generic_Type (Parent_Type)
15873 then
15874 -- This code has been designed to handle only generic
15875 -- formals that implement interfaces that are defined
15876 -- in a generic unit or instantiation. If this code is
15877 -- needed for other cases we must review it because
15878 -- (given that it relies on Original_Location to locate
15879 -- the primitive of Generic_Actual that covers the
15880 -- interface) it could leave linked through attribute
15881 -- Alias entities of unrelated instantiations).
15882
15883 pragma Assert
15884 (Is_Generic_Unit
15885 (Scope (Find_Dispatching_Type (Alias_Subp)))
15886 or else
15887 Instantiation_Depth
15888 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
15889
15890 declare
15891 Iface_Prim_Loc : constant Source_Ptr :=
15892 Original_Location (Sloc (Alias_Subp));
15893
15894 Elmt : Elmt_Id;
15895 Prim : Entity_Id;
15896
15897 begin
15898 Elmt :=
15899 First_Elmt (Primitive_Operations (Generic_Actual));
15900
15901 Search : while Present (Elmt) loop
15902 Prim := Node (Elmt);
15903
15904 if Present (Interface_Alias (Prim))
15905 and then Original_Location
15906 (Sloc (Interface_Alias (Prim))) =
15907 Iface_Prim_Loc
15908 then
15909 Act_Subp := Alias (Prim);
15910 exit Search;
15911 end if;
15912
15913 Next_Elmt (Elmt);
15914 end loop Search;
15915 end;
15916 end if;
15917
15918 pragma Assert (Present (Act_Subp)
15919 or else Is_Abstract_Type (Generic_Actual)
15920 or else Serious_Errors_Detected > 0);
15921
15922 -- Handle predefined primitives plus the rest of user-defined
15923 -- primitives
15924
15925 else
15926 Act_Elmt := First_Elmt (Act_List);
15927 while Present (Act_Elmt) loop
15928 Act_Subp := Node (Act_Elmt);
15929
15930 exit when Primitive_Names_Match (Subp, Act_Subp)
15931 and then Type_Conformant
15932 (Subp, Act_Subp,
15933 Skip_Controlling_Formals => True)
15934 and then No (Interface_Alias (Act_Subp));
15935
15936 Next_Elmt (Act_Elmt);
15937 end loop;
15938
15939 if No (Act_Elmt) then
15940 Act_Subp := Empty;
15941 end if;
15942 end if;
15943 end if;
15944
15945 -- Case 1: If the parent is a limited interface then it has the
15946 -- predefined primitives of synchronized interfaces. However, the
15947 -- actual type may be a non-limited type and hence it does not
15948 -- have such primitives.
15949
15950 if Present (Generic_Actual)
15951 and then not Present (Act_Subp)
15952 and then Is_Limited_Interface (Parent_Base)
15953 and then Is_Predefined_Interface_Primitive (Subp)
15954 then
15955 null;
15956
15957 -- Case 2: Inherit entities associated with interfaces that were
15958 -- not covered by the parent type. We exclude here null interface
15959 -- primitives because they do not need special management.
15960
15961 -- We also exclude interface operations that are renamings. If the
15962 -- subprogram is an explicit renaming of an interface primitive,
15963 -- it is a regular primitive operation, and the presence of its
15964 -- alias is not relevant: it has to be derived like any other
15965 -- primitive.
15966
15967 elsif Present (Alias (Subp))
15968 and then Nkind (Unit_Declaration_Node (Subp)) /=
15969 N_Subprogram_Renaming_Declaration
15970 and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
15971 and then not
15972 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
15973 and then Null_Present (Parent (Alias_Subp)))
15974 then
15975 -- If this is an abstract private type then we transfer the
15976 -- derivation of the interface primitive from the partial view
15977 -- to the full view. This is safe because all the interfaces
15978 -- must be visible in the partial view. Done to avoid adding
15979 -- a new interface derivation to the private part of the
15980 -- enclosing package; otherwise this new derivation would be
15981 -- decorated as hidden when the analysis of the enclosing
15982 -- package completes.
15983
15984 if Is_Abstract_Type (Derived_Type)
15985 and then In_Private_Part (Current_Scope)
15986 and then Has_Private_Declaration (Derived_Type)
15987 then
15988 declare
15989 Partial_View : Entity_Id;
15990 Elmt : Elmt_Id;
15991 Ent : Entity_Id;
15992
15993 begin
15994 Partial_View := First_Entity (Current_Scope);
15995 loop
15996 exit when No (Partial_View)
15997 or else (Has_Private_Declaration (Partial_View)
15998 and then
15999 Full_View (Partial_View) = Derived_Type);
16000
16001 Next_Entity (Partial_View);
16002 end loop;
16003
16004 -- If the partial view was not found then the source code
16005 -- has errors and the derivation is not needed.
16006
16007 if Present (Partial_View) then
16008 Elmt :=
16009 First_Elmt (Primitive_Operations (Partial_View));
16010 while Present (Elmt) loop
16011 Ent := Node (Elmt);
16012
16013 if Present (Alias (Ent))
16014 and then Ultimate_Alias (Ent) = Alias (Subp)
16015 then
16016 Append_Elmt
16017 (Ent, Primitive_Operations (Derived_Type));
16018 exit;
16019 end if;
16020
16021 Next_Elmt (Elmt);
16022 end loop;
16023
16024 -- If the interface primitive was not found in the
16025 -- partial view then this interface primitive was
16026 -- overridden. We add a derivation to activate in
16027 -- Derive_Progenitor_Subprograms the machinery to
16028 -- search for it.
16029
16030 if No (Elmt) then
16031 Derive_Interface_Subprogram
16032 (New_Subp => New_Subp,
16033 Subp => Subp,
16034 Actual_Subp => Act_Subp);
16035 end if;
16036 end if;
16037 end;
16038 else
16039 Derive_Interface_Subprogram
16040 (New_Subp => New_Subp,
16041 Subp => Subp,
16042 Actual_Subp => Act_Subp);
16043 end if;
16044
16045 -- Case 3: Common derivation
16046
16047 else
16048 Derive_Subprogram
16049 (New_Subp => New_Subp,
16050 Parent_Subp => Subp,
16051 Derived_Type => Derived_Type,
16052 Parent_Type => Parent_Base,
16053 Actual_Subp => Act_Subp);
16054 end if;
16055
16056 -- No need to update Act_Elm if we must search for the
16057 -- corresponding operation in the generic actual
16058
16059 if not Need_Search
16060 and then Present (Act_Elmt)
16061 then
16062 Next_Elmt (Act_Elmt);
16063 Act_Subp := Node (Act_Elmt);
16064 end if;
16065
16066 <<Continue>>
16067 Next_Elmt (Elmt);
16068 end loop;
16069
16070 -- Inherit additional operations from progenitors. If the derived
16071 -- type is a generic actual, there are not new primitive operations
16072 -- for the type because it has those of the actual, and therefore
16073 -- nothing needs to be done. The renamings generated above are not
16074 -- primitive operations, and their purpose is simply to make the
16075 -- proper operations visible within an instantiation.
16076
16077 if No (Generic_Actual) then
16078 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
16079 end if;
16080 end if;
16081
16082 -- Final check: Direct descendants must have their primitives in the
16083 -- same order. We exclude from this test untagged types and instances
16084 -- of formal derived types. We skip this test if we have already
16085 -- reported serious errors in the sources.
16086
16087 pragma Assert (not Is_Tagged_Type (Derived_Type)
16088 or else Present (Generic_Actual)
16089 or else Serious_Errors_Detected > 0
16090 or else Check_Derived_Type);
16091 end Derive_Subprograms;
16092
16093 --------------------------------
16094 -- Derived_Standard_Character --
16095 --------------------------------
16096
16097 procedure Derived_Standard_Character
16098 (N : Node_Id;
16099 Parent_Type : Entity_Id;
16100 Derived_Type : Entity_Id)
16101 is
16102 Loc : constant Source_Ptr := Sloc (N);
16103 Def : constant Node_Id := Type_Definition (N);
16104 Indic : constant Node_Id := Subtype_Indication (Def);
16105 Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
16106 Implicit_Base : constant Entity_Id :=
16107 Create_Itype
16108 (E_Enumeration_Type, N, Derived_Type, 'B');
16109
16110 Lo : Node_Id;
16111 Hi : Node_Id;
16112
16113 begin
16114 Discard_Node (Process_Subtype (Indic, N));
16115
16116 Set_Etype (Implicit_Base, Parent_Base);
16117 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
16118 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
16119
16120 Set_Is_Character_Type (Implicit_Base, True);
16121 Set_Has_Delayed_Freeze (Implicit_Base);
16122
16123 -- The bounds of the implicit base are the bounds of the parent base.
16124 -- Note that their type is the parent base.
16125
16126 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
16127 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
16128
16129 Set_Scalar_Range (Implicit_Base,
16130 Make_Range (Loc,
16131 Low_Bound => Lo,
16132 High_Bound => Hi));
16133
16134 Conditional_Delay (Derived_Type, Parent_Type);
16135
16136 Set_Ekind (Derived_Type, E_Enumeration_Subtype);
16137 Set_Etype (Derived_Type, Implicit_Base);
16138 Set_Size_Info (Derived_Type, Parent_Type);
16139
16140 if Unknown_RM_Size (Derived_Type) then
16141 Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
16142 end if;
16143
16144 Set_Is_Character_Type (Derived_Type, True);
16145
16146 if Nkind (Indic) /= N_Subtype_Indication then
16147
16148 -- If no explicit constraint, the bounds are those
16149 -- of the parent type.
16150
16151 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
16152 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
16153 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
16154 end if;
16155
16156 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
16157
16158 -- Because the implicit base is used in the conversion of the bounds, we
16159 -- have to freeze it now. This is similar to what is done for numeric
16160 -- types, and it equally suspicious, but otherwise a non-static bound
16161 -- will have a reference to an unfrozen type, which is rejected by Gigi
16162 -- (???). This requires specific care for definition of stream
16163 -- attributes. For details, see comments at the end of
16164 -- Build_Derived_Numeric_Type.
16165
16166 Freeze_Before (N, Implicit_Base);
16167 end Derived_Standard_Character;
16168
16169 ------------------------------
16170 -- Derived_Type_Declaration --
16171 ------------------------------
16172
16173 procedure Derived_Type_Declaration
16174 (T : Entity_Id;
16175 N : Node_Id;
16176 Is_Completion : Boolean)
16177 is
16178 Parent_Type : Entity_Id;
16179
16180 function Comes_From_Generic (Typ : Entity_Id) return Boolean;
16181 -- Check whether the parent type is a generic formal, or derives
16182 -- directly or indirectly from one.
16183
16184 ------------------------
16185 -- Comes_From_Generic --
16186 ------------------------
16187
16188 function Comes_From_Generic (Typ : Entity_Id) return Boolean is
16189 begin
16190 if Is_Generic_Type (Typ) then
16191 return True;
16192
16193 elsif Is_Generic_Type (Root_Type (Parent_Type)) then
16194 return True;
16195
16196 elsif Is_Private_Type (Typ)
16197 and then Present (Full_View (Typ))
16198 and then Is_Generic_Type (Root_Type (Full_View (Typ)))
16199 then
16200 return True;
16201
16202 elsif Is_Generic_Actual_Type (Typ) then
16203 return True;
16204
16205 else
16206 return False;
16207 end if;
16208 end Comes_From_Generic;
16209
16210 -- Local variables
16211
16212 Def : constant Node_Id := Type_Definition (N);
16213 Iface_Def : Node_Id;
16214 Indic : constant Node_Id := Subtype_Indication (Def);
16215 Extension : constant Node_Id := Record_Extension_Part (Def);
16216 Parent_Node : Node_Id;
16217 Taggd : Boolean;
16218
16219 -- Start of processing for Derived_Type_Declaration
16220
16221 begin
16222 Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
16223
16224 -- Ada 2005 (AI-251): In case of interface derivation check that the
16225 -- parent is also an interface.
16226
16227 if Interface_Present (Def) then
16228 Check_SPARK_05_Restriction ("interface is not allowed", Def);
16229
16230 if not Is_Interface (Parent_Type) then
16231 Diagnose_Interface (Indic, Parent_Type);
16232
16233 else
16234 Parent_Node := Parent (Base_Type (Parent_Type));
16235 Iface_Def := Type_Definition (Parent_Node);
16236
16237 -- Ada 2005 (AI-251): Limited interfaces can only inherit from
16238 -- other limited interfaces.
16239
16240 if Limited_Present (Def) then
16241 if Limited_Present (Iface_Def) then
16242 null;
16243
16244 elsif Protected_Present (Iface_Def) then
16245 Error_Msg_NE
16246 ("descendant of & must be declared as a protected "
16247 & "interface", N, Parent_Type);
16248
16249 elsif Synchronized_Present (Iface_Def) then
16250 Error_Msg_NE
16251 ("descendant of & must be declared as a synchronized "
16252 & "interface", N, Parent_Type);
16253
16254 elsif Task_Present (Iface_Def) then
16255 Error_Msg_NE
16256 ("descendant of & must be declared as a task interface",
16257 N, Parent_Type);
16258
16259 else
16260 Error_Msg_N
16261 ("(Ada 2005) limited interface cannot inherit from "
16262 & "non-limited interface", Indic);
16263 end if;
16264
16265 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
16266 -- from non-limited or limited interfaces.
16267
16268 elsif not Protected_Present (Def)
16269 and then not Synchronized_Present (Def)
16270 and then not Task_Present (Def)
16271 then
16272 if Limited_Present (Iface_Def) then
16273 null;
16274
16275 elsif Protected_Present (Iface_Def) then
16276 Error_Msg_NE
16277 ("descendant of & must be declared as a protected "
16278 & "interface", N, Parent_Type);
16279
16280 elsif Synchronized_Present (Iface_Def) then
16281 Error_Msg_NE
16282 ("descendant of & must be declared as a synchronized "
16283 & "interface", N, Parent_Type);
16284
16285 elsif Task_Present (Iface_Def) then
16286 Error_Msg_NE
16287 ("descendant of & must be declared as a task interface",
16288 N, Parent_Type);
16289 else
16290 null;
16291 end if;
16292 end if;
16293 end if;
16294 end if;
16295
16296 if Is_Tagged_Type (Parent_Type)
16297 and then Is_Concurrent_Type (Parent_Type)
16298 and then not Is_Interface (Parent_Type)
16299 then
16300 Error_Msg_N
16301 ("parent type of a record extension cannot be a synchronized "
16302 & "tagged type (RM 3.9.1 (3/1))", N);
16303 Set_Etype (T, Any_Type);
16304 return;
16305 end if;
16306
16307 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
16308 -- interfaces
16309
16310 if Is_Tagged_Type (Parent_Type)
16311 and then Is_Non_Empty_List (Interface_List (Def))
16312 then
16313 declare
16314 Intf : Node_Id;
16315 T : Entity_Id;
16316
16317 begin
16318 Intf := First (Interface_List (Def));
16319 while Present (Intf) loop
16320 T := Find_Type_Of_Subtype_Indic (Intf);
16321
16322 if not Is_Interface (T) then
16323 Diagnose_Interface (Intf, T);
16324
16325 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
16326 -- a limited type from having a nonlimited progenitor.
16327
16328 elsif (Limited_Present (Def)
16329 or else (not Is_Interface (Parent_Type)
16330 and then Is_Limited_Type (Parent_Type)))
16331 and then not Is_Limited_Interface (T)
16332 then
16333 Error_Msg_NE
16334 ("progenitor interface& of limited type must be limited",
16335 N, T);
16336 end if;
16337
16338 Next (Intf);
16339 end loop;
16340 end;
16341 end if;
16342
16343 if Parent_Type = Any_Type
16344 or else Etype (Parent_Type) = Any_Type
16345 or else (Is_Class_Wide_Type (Parent_Type)
16346 and then Etype (Parent_Type) = T)
16347 then
16348 -- If Parent_Type is undefined or illegal, make new type into a
16349 -- subtype of Any_Type, and set a few attributes to prevent cascaded
16350 -- errors. If this is a self-definition, emit error now.
16351
16352 if T = Parent_Type or else T = Etype (Parent_Type) then
16353 Error_Msg_N ("type cannot be used in its own definition", Indic);
16354 end if;
16355
16356 Set_Ekind (T, Ekind (Parent_Type));
16357 Set_Etype (T, Any_Type);
16358 Set_Scalar_Range (T, Scalar_Range (Any_Type));
16359
16360 if Is_Tagged_Type (T)
16361 and then Is_Record_Type (T)
16362 then
16363 Set_Direct_Primitive_Operations (T, New_Elmt_List);
16364 end if;
16365
16366 return;
16367 end if;
16368
16369 -- Ada 2005 (AI-251): The case in which the parent of the full-view is
16370 -- an interface is special because the list of interfaces in the full
16371 -- view can be given in any order. For example:
16372
16373 -- type A is interface;
16374 -- type B is interface and A;
16375 -- type D is new B with private;
16376 -- private
16377 -- type D is new A and B with null record; -- 1 --
16378
16379 -- In this case we perform the following transformation of -1-:
16380
16381 -- type D is new B and A with null record;
16382
16383 -- If the parent of the full-view covers the parent of the partial-view
16384 -- we have two possible cases:
16385
16386 -- 1) They have the same parent
16387 -- 2) The parent of the full-view implements some further interfaces
16388
16389 -- In both cases we do not need to perform the transformation. In the
16390 -- first case the source program is correct and the transformation is
16391 -- not needed; in the second case the source program does not fulfill
16392 -- the no-hidden interfaces rule (AI-396) and the error will be reported
16393 -- later.
16394
16395 -- This transformation not only simplifies the rest of the analysis of
16396 -- this type declaration but also simplifies the correct generation of
16397 -- the object layout to the expander.
16398
16399 if In_Private_Part (Current_Scope)
16400 and then Is_Interface (Parent_Type)
16401 then
16402 declare
16403 Iface : Node_Id;
16404 Partial_View : Entity_Id;
16405 Partial_View_Parent : Entity_Id;
16406 New_Iface : Node_Id;
16407
16408 begin
16409 -- Look for the associated private type declaration
16410
16411 Partial_View := First_Entity (Current_Scope);
16412 loop
16413 exit when No (Partial_View)
16414 or else (Has_Private_Declaration (Partial_View)
16415 and then Full_View (Partial_View) = T);
16416
16417 Next_Entity (Partial_View);
16418 end loop;
16419
16420 -- If the partial view was not found then the source code has
16421 -- errors and the transformation is not needed.
16422
16423 if Present (Partial_View) then
16424 Partial_View_Parent := Etype (Partial_View);
16425
16426 -- If the parent of the full-view covers the parent of the
16427 -- partial-view we have nothing else to do.
16428
16429 if Interface_Present_In_Ancestor
16430 (Parent_Type, Partial_View_Parent)
16431 then
16432 null;
16433
16434 -- Traverse the list of interfaces of the full-view to look
16435 -- for the parent of the partial-view and perform the tree
16436 -- transformation.
16437
16438 else
16439 Iface := First (Interface_List (Def));
16440 while Present (Iface) loop
16441 if Etype (Iface) = Etype (Partial_View) then
16442 Rewrite (Subtype_Indication (Def),
16443 New_Copy (Subtype_Indication
16444 (Parent (Partial_View))));
16445
16446 New_Iface :=
16447 Make_Identifier (Sloc (N), Chars (Parent_Type));
16448 Append (New_Iface, Interface_List (Def));
16449
16450 -- Analyze the transformed code
16451
16452 Derived_Type_Declaration (T, N, Is_Completion);
16453 return;
16454 end if;
16455
16456 Next (Iface);
16457 end loop;
16458 end if;
16459 end if;
16460 end;
16461 end if;
16462
16463 -- Only composite types other than array types are allowed to have
16464 -- discriminants.
16465
16466 if Present (Discriminant_Specifications (N)) then
16467 if (Is_Elementary_Type (Parent_Type)
16468 or else
16469 Is_Array_Type (Parent_Type))
16470 and then not Error_Posted (N)
16471 then
16472 Error_Msg_N
16473 ("elementary or array type cannot have discriminants",
16474 Defining_Identifier (First (Discriminant_Specifications (N))));
16475 Set_Has_Discriminants (T, False);
16476
16477 -- The type is allowed to have discriminants
16478
16479 else
16480 Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
16481 end if;
16482 end if;
16483
16484 -- In Ada 83, a derived type defined in a package specification cannot
16485 -- be used for further derivation until the end of its visible part.
16486 -- Note that derivation in the private part of the package is allowed.
16487
16488 if Ada_Version = Ada_83
16489 and then Is_Derived_Type (Parent_Type)
16490 and then In_Visible_Part (Scope (Parent_Type))
16491 then
16492 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
16493 Error_Msg_N
16494 ("(Ada 83): premature use of type for derivation", Indic);
16495 end if;
16496 end if;
16497
16498 -- Check for early use of incomplete or private type
16499
16500 if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
16501 Error_Msg_N ("premature derivation of incomplete type", Indic);
16502 return;
16503
16504 elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
16505 and then not Comes_From_Generic (Parent_Type))
16506 or else Has_Private_Component (Parent_Type)
16507 then
16508 -- The ancestor type of a formal type can be incomplete, in which
16509 -- case only the operations of the partial view are available in the
16510 -- generic. Subsequent checks may be required when the full view is
16511 -- analyzed to verify that a derivation from a tagged type has an
16512 -- extension.
16513
16514 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
16515 null;
16516
16517 elsif No (Underlying_Type (Parent_Type))
16518 or else Has_Private_Component (Parent_Type)
16519 then
16520 Error_Msg_N
16521 ("premature derivation of derived or private type", Indic);
16522
16523 -- Flag the type itself as being in error, this prevents some
16524 -- nasty problems with subsequent uses of the malformed type.
16525
16526 Set_Error_Posted (T);
16527
16528 -- Check that within the immediate scope of an untagged partial
16529 -- view it's illegal to derive from the partial view if the
16530 -- full view is tagged. (7.3(7))
16531
16532 -- We verify that the Parent_Type is a partial view by checking
16533 -- that it is not a Full_Type_Declaration (i.e. a private type or
16534 -- private extension declaration), to distinguish a partial view
16535 -- from a derivation from a private type which also appears as
16536 -- E_Private_Type. If the parent base type is not declared in an
16537 -- enclosing scope there is no need to check.
16538
16539 elsif Present (Full_View (Parent_Type))
16540 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
16541 and then not Is_Tagged_Type (Parent_Type)
16542 and then Is_Tagged_Type (Full_View (Parent_Type))
16543 and then In_Open_Scopes (Scope (Base_Type (Parent_Type)))
16544 then
16545 Error_Msg_N
16546 ("premature derivation from type with tagged full view",
16547 Indic);
16548 end if;
16549 end if;
16550
16551 -- Check that form of derivation is appropriate
16552
16553 Taggd := Is_Tagged_Type (Parent_Type);
16554
16555 -- Set the parent type to the class-wide type's specific type in this
16556 -- case to prevent cascading errors
16557
16558 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
16559 Error_Msg_N ("parent type must not be a class-wide type", Indic);
16560 Set_Etype (T, Etype (Parent_Type));
16561 return;
16562 end if;
16563
16564 if Present (Extension) and then not Taggd then
16565 Error_Msg_N
16566 ("type derived from untagged type cannot have extension", Indic);
16567
16568 elsif No (Extension) and then Taggd then
16569
16570 -- If this declaration is within a private part (or body) of a
16571 -- generic instantiation then the derivation is allowed (the parent
16572 -- type can only appear tagged in this case if it's a generic actual
16573 -- type, since it would otherwise have been rejected in the analysis
16574 -- of the generic template).
16575
16576 if not Is_Generic_Actual_Type (Parent_Type)
16577 or else In_Visible_Part (Scope (Parent_Type))
16578 then
16579 if Is_Class_Wide_Type (Parent_Type) then
16580 Error_Msg_N
16581 ("parent type must not be a class-wide type", Indic);
16582
16583 -- Use specific type to prevent cascaded errors.
16584
16585 Parent_Type := Etype (Parent_Type);
16586
16587 else
16588 Error_Msg_N
16589 ("type derived from tagged type must have extension", Indic);
16590 end if;
16591 end if;
16592 end if;
16593
16594 -- AI-443: Synchronized formal derived types require a private
16595 -- extension. There is no point in checking the ancestor type or
16596 -- the progenitors since the construct is wrong to begin with.
16597
16598 if Ada_Version >= Ada_2005
16599 and then Is_Generic_Type (T)
16600 and then Present (Original_Node (N))
16601 then
16602 declare
16603 Decl : constant Node_Id := Original_Node (N);
16604
16605 begin
16606 if Nkind (Decl) = N_Formal_Type_Declaration
16607 and then Nkind (Formal_Type_Definition (Decl)) =
16608 N_Formal_Derived_Type_Definition
16609 and then Synchronized_Present (Formal_Type_Definition (Decl))
16610 and then No (Extension)
16611
16612 -- Avoid emitting a duplicate error message
16613
16614 and then not Error_Posted (Indic)
16615 then
16616 Error_Msg_N
16617 ("synchronized derived type must have extension", N);
16618 end if;
16619 end;
16620 end if;
16621
16622 if Null_Exclusion_Present (Def)
16623 and then not Is_Access_Type (Parent_Type)
16624 then
16625 Error_Msg_N ("null exclusion can only apply to an access type", N);
16626 end if;
16627
16628 -- Avoid deriving parent primitives of underlying record views
16629
16630 Build_Derived_Type (N, Parent_Type, T, Is_Completion,
16631 Derive_Subps => not Is_Underlying_Record_View (T));
16632
16633 -- AI-419: The parent type of an explicitly limited derived type must
16634 -- be a limited type or a limited interface.
16635
16636 if Limited_Present (Def) then
16637 Set_Is_Limited_Record (T);
16638
16639 if Is_Interface (T) then
16640 Set_Is_Limited_Interface (T);
16641 end if;
16642
16643 if not Is_Limited_Type (Parent_Type)
16644 and then
16645 (not Is_Interface (Parent_Type)
16646 or else not Is_Limited_Interface (Parent_Type))
16647 then
16648 -- AI05-0096: a derivation in the private part of an instance is
16649 -- legal if the generic formal is untagged limited, and the actual
16650 -- is non-limited.
16651
16652 if Is_Generic_Actual_Type (Parent_Type)
16653 and then In_Private_Part (Current_Scope)
16654 and then
16655 not Is_Tagged_Type
16656 (Generic_Parent_Type (Parent (Parent_Type)))
16657 then
16658 null;
16659
16660 else
16661 Error_Msg_NE
16662 ("parent type& of limited type must be limited",
16663 N, Parent_Type);
16664 end if;
16665 end if;
16666 end if;
16667
16668 -- In SPARK, there are no derived type definitions other than type
16669 -- extensions of tagged record types.
16670
16671 if No (Extension) then
16672 Check_SPARK_05_Restriction
16673 ("derived type is not allowed", Original_Node (N));
16674 end if;
16675 end Derived_Type_Declaration;
16676
16677 ------------------------
16678 -- Diagnose_Interface --
16679 ------------------------
16680
16681 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
16682 begin
16683 if not Is_Interface (E) and then E /= Any_Type then
16684 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
16685 end if;
16686 end Diagnose_Interface;
16687
16688 ----------------------------------
16689 -- Enumeration_Type_Declaration --
16690 ----------------------------------
16691
16692 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
16693 Ev : Uint;
16694 L : Node_Id;
16695 R_Node : Node_Id;
16696 B_Node : Node_Id;
16697
16698 begin
16699 -- Create identifier node representing lower bound
16700
16701 B_Node := New_Node (N_Identifier, Sloc (Def));
16702 L := First (Literals (Def));
16703 Set_Chars (B_Node, Chars (L));
16704 Set_Entity (B_Node, L);
16705 Set_Etype (B_Node, T);
16706 Set_Is_Static_Expression (B_Node, True);
16707
16708 R_Node := New_Node (N_Range, Sloc (Def));
16709 Set_Low_Bound (R_Node, B_Node);
16710
16711 Set_Ekind (T, E_Enumeration_Type);
16712 Set_First_Literal (T, L);
16713 Set_Etype (T, T);
16714 Set_Is_Constrained (T);
16715
16716 Ev := Uint_0;
16717
16718 -- Loop through literals of enumeration type setting pos and rep values
16719 -- except that if the Ekind is already set, then it means the literal
16720 -- was already constructed (case of a derived type declaration and we
16721 -- should not disturb the Pos and Rep values.
16722
16723 while Present (L) loop
16724 if Ekind (L) /= E_Enumeration_Literal then
16725 Set_Ekind (L, E_Enumeration_Literal);
16726 Set_Enumeration_Pos (L, Ev);
16727 Set_Enumeration_Rep (L, Ev);
16728 Set_Is_Known_Valid (L, True);
16729 end if;
16730
16731 Set_Etype (L, T);
16732 New_Overloaded_Entity (L);
16733 Generate_Definition (L);
16734 Set_Convention (L, Convention_Intrinsic);
16735
16736 -- Case of character literal
16737
16738 if Nkind (L) = N_Defining_Character_Literal then
16739 Set_Is_Character_Type (T, True);
16740
16741 -- Check violation of No_Wide_Characters
16742
16743 if Restriction_Check_Required (No_Wide_Characters) then
16744 Get_Name_String (Chars (L));
16745
16746 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
16747 Check_Restriction (No_Wide_Characters, L);
16748 end if;
16749 end if;
16750 end if;
16751
16752 Ev := Ev + 1;
16753 Next (L);
16754 end loop;
16755
16756 -- Now create a node representing upper bound
16757
16758 B_Node := New_Node (N_Identifier, Sloc (Def));
16759 Set_Chars (B_Node, Chars (Last (Literals (Def))));
16760 Set_Entity (B_Node, Last (Literals (Def)));
16761 Set_Etype (B_Node, T);
16762 Set_Is_Static_Expression (B_Node, True);
16763
16764 Set_High_Bound (R_Node, B_Node);
16765
16766 -- Initialize various fields of the type. Some of this information
16767 -- may be overwritten later through rep.clauses.
16768
16769 Set_Scalar_Range (T, R_Node);
16770 Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
16771 Set_Enum_Esize (T);
16772 Set_Enum_Pos_To_Rep (T, Empty);
16773
16774 -- Set Discard_Names if configuration pragma set, or if there is
16775 -- a parameterless pragma in the current declarative region
16776
16777 if Global_Discard_Names or else Discard_Names (Scope (T)) then
16778 Set_Discard_Names (T);
16779 end if;
16780
16781 -- Process end label if there is one
16782
16783 if Present (Def) then
16784 Process_End_Label (Def, 'e', T);
16785 end if;
16786 end Enumeration_Type_Declaration;
16787
16788 ---------------------------------
16789 -- Expand_To_Stored_Constraint --
16790 ---------------------------------
16791
16792 function Expand_To_Stored_Constraint
16793 (Typ : Entity_Id;
16794 Constraint : Elist_Id) return Elist_Id
16795 is
16796 Explicitly_Discriminated_Type : Entity_Id;
16797 Expansion : Elist_Id;
16798 Discriminant : Entity_Id;
16799
16800 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
16801 -- Find the nearest type that actually specifies discriminants
16802
16803 ---------------------------------
16804 -- Type_With_Explicit_Discrims --
16805 ---------------------------------
16806
16807 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
16808 Typ : constant E := Base_Type (Id);
16809
16810 begin
16811 if Ekind (Typ) in Incomplete_Or_Private_Kind then
16812 if Present (Full_View (Typ)) then
16813 return Type_With_Explicit_Discrims (Full_View (Typ));
16814 end if;
16815
16816 else
16817 if Has_Discriminants (Typ) then
16818 return Typ;
16819 end if;
16820 end if;
16821
16822 if Etype (Typ) = Typ then
16823 return Empty;
16824 elsif Has_Discriminants (Typ) then
16825 return Typ;
16826 else
16827 return Type_With_Explicit_Discrims (Etype (Typ));
16828 end if;
16829
16830 end Type_With_Explicit_Discrims;
16831
16832 -- Start of processing for Expand_To_Stored_Constraint
16833
16834 begin
16835 if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then
16836 return No_Elist;
16837 end if;
16838
16839 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
16840
16841 if No (Explicitly_Discriminated_Type) then
16842 return No_Elist;
16843 end if;
16844
16845 Expansion := New_Elmt_List;
16846
16847 Discriminant :=
16848 First_Stored_Discriminant (Explicitly_Discriminated_Type);
16849 while Present (Discriminant) loop
16850 Append_Elmt
16851 (Get_Discriminant_Value
16852 (Discriminant, Explicitly_Discriminated_Type, Constraint),
16853 To => Expansion);
16854 Next_Stored_Discriminant (Discriminant);
16855 end loop;
16856
16857 return Expansion;
16858 end Expand_To_Stored_Constraint;
16859
16860 ---------------------------
16861 -- Find_Hidden_Interface --
16862 ---------------------------
16863
16864 function Find_Hidden_Interface
16865 (Src : Elist_Id;
16866 Dest : Elist_Id) return Entity_Id
16867 is
16868 Iface : Entity_Id;
16869 Iface_Elmt : Elmt_Id;
16870
16871 begin
16872 if Present (Src) and then Present (Dest) then
16873 Iface_Elmt := First_Elmt (Src);
16874 while Present (Iface_Elmt) loop
16875 Iface := Node (Iface_Elmt);
16876
16877 if Is_Interface (Iface)
16878 and then not Contain_Interface (Iface, Dest)
16879 then
16880 return Iface;
16881 end if;
16882
16883 Next_Elmt (Iface_Elmt);
16884 end loop;
16885 end if;
16886
16887 return Empty;
16888 end Find_Hidden_Interface;
16889
16890 --------------------
16891 -- Find_Type_Name --
16892 --------------------
16893
16894 function Find_Type_Name (N : Node_Id) return Entity_Id is
16895 Id : constant Entity_Id := Defining_Identifier (N);
16896 New_Id : Entity_Id;
16897 Prev : Entity_Id;
16898 Prev_Par : Node_Id;
16899
16900 procedure Check_Duplicate_Aspects;
16901 -- Check that aspects specified in a completion have not been specified
16902 -- already in the partial view.
16903
16904 procedure Tag_Mismatch;
16905 -- Diagnose a tagged partial view whose full view is untagged. We post
16906 -- the message on the full view, with a reference to the previous
16907 -- partial view. The partial view can be private or incomplete, and
16908 -- these are handled in a different manner, so we determine the position
16909 -- of the error message from the respective slocs of both.
16910
16911 -----------------------------
16912 -- Check_Duplicate_Aspects --
16913 -----------------------------
16914
16915 procedure Check_Duplicate_Aspects is
16916 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id;
16917 -- Return the corresponding aspect of the partial view which matches
16918 -- the aspect id of Asp. Return Empty is no such aspect exists.
16919
16920 -----------------------------
16921 -- Get_Partial_View_Aspect --
16922 -----------------------------
16923
16924 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is
16925 Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
16926 Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par);
16927 Prev_Asp : Node_Id;
16928
16929 begin
16930 if Present (Prev_Asps) then
16931 Prev_Asp := First (Prev_Asps);
16932 while Present (Prev_Asp) loop
16933 if Get_Aspect_Id (Prev_Asp) = Asp_Id then
16934 return Prev_Asp;
16935 end if;
16936
16937 Next (Prev_Asp);
16938 end loop;
16939 end if;
16940
16941 return Empty;
16942 end Get_Partial_View_Aspect;
16943
16944 -- Local variables
16945
16946 Full_Asps : constant List_Id := Aspect_Specifications (N);
16947 Full_Asp : Node_Id;
16948 Part_Asp : Node_Id;
16949
16950 -- Start of processing for Check_Duplicate_Aspects
16951
16952 begin
16953 if Present (Full_Asps) then
16954 Full_Asp := First (Full_Asps);
16955 while Present (Full_Asp) loop
16956 Part_Asp := Get_Partial_View_Aspect (Full_Asp);
16957
16958 -- An aspect and its class-wide counterpart are two distinct
16959 -- aspects and may apply to both views of an entity.
16960
16961 if Present (Part_Asp)
16962 and then Class_Present (Part_Asp) = Class_Present (Full_Asp)
16963 then
16964 Error_Msg_N
16965 ("aspect already specified in private declaration",
16966 Full_Asp);
16967
16968 Remove (Full_Asp);
16969 return;
16970 end if;
16971
16972 if Has_Discriminants (Prev)
16973 and then not Has_Unknown_Discriminants (Prev)
16974 and then Get_Aspect_Id (Full_Asp) =
16975 Aspect_Implicit_Dereference
16976 then
16977 Error_Msg_N
16978 ("cannot specify aspect if partial view has known "
16979 & "discriminants", Full_Asp);
16980 end if;
16981
16982 Next (Full_Asp);
16983 end loop;
16984 end if;
16985 end Check_Duplicate_Aspects;
16986
16987 ------------------
16988 -- Tag_Mismatch --
16989 ------------------
16990
16991 procedure Tag_Mismatch is
16992 begin
16993 if Sloc (Prev) < Sloc (Id) then
16994 if Ada_Version >= Ada_2012
16995 and then Nkind (N) = N_Private_Type_Declaration
16996 then
16997 Error_Msg_NE
16998 ("declaration of private } must be a tagged type ", Id, Prev);
16999 else
17000 Error_Msg_NE
17001 ("full declaration of } must be a tagged type ", Id, Prev);
17002 end if;
17003
17004 else
17005 if Ada_Version >= Ada_2012
17006 and then Nkind (N) = N_Private_Type_Declaration
17007 then
17008 Error_Msg_NE
17009 ("declaration of private } must be a tagged type ", Prev, Id);
17010 else
17011 Error_Msg_NE
17012 ("full declaration of } must be a tagged type ", Prev, Id);
17013 end if;
17014 end if;
17015 end Tag_Mismatch;
17016
17017 -- Start of processing for Find_Type_Name
17018
17019 begin
17020 -- Find incomplete declaration, if one was given
17021
17022 Prev := Current_Entity_In_Scope (Id);
17023
17024 -- New type declaration
17025
17026 if No (Prev) then
17027 Enter_Name (Id);
17028 return Id;
17029
17030 -- Previous declaration exists
17031
17032 else
17033 Prev_Par := Parent (Prev);
17034
17035 -- Error if not incomplete/private case except if previous
17036 -- declaration is implicit, etc. Enter_Name will emit error if
17037 -- appropriate.
17038
17039 if not Is_Incomplete_Or_Private_Type (Prev) then
17040 Enter_Name (Id);
17041 New_Id := Id;
17042
17043 -- Check invalid completion of private or incomplete type
17044
17045 elsif not Nkind_In (N, N_Full_Type_Declaration,
17046 N_Task_Type_Declaration,
17047 N_Protected_Type_Declaration)
17048 and then
17049 (Ada_Version < Ada_2012
17050 or else not Is_Incomplete_Type (Prev)
17051 or else not Nkind_In (N, N_Private_Type_Declaration,
17052 N_Private_Extension_Declaration))
17053 then
17054 -- Completion must be a full type declarations (RM 7.3(4))
17055
17056 Error_Msg_Sloc := Sloc (Prev);
17057 Error_Msg_NE ("invalid completion of }", Id, Prev);
17058
17059 -- Set scope of Id to avoid cascaded errors. Entity is never
17060 -- examined again, except when saving globals in generics.
17061
17062 Set_Scope (Id, Current_Scope);
17063 New_Id := Id;
17064
17065 -- If this is a repeated incomplete declaration, no further
17066 -- checks are possible.
17067
17068 if Nkind (N) = N_Incomplete_Type_Declaration then
17069 return Prev;
17070 end if;
17071
17072 -- Case of full declaration of incomplete type
17073
17074 elsif Ekind (Prev) = E_Incomplete_Type
17075 and then (Ada_Version < Ada_2012
17076 or else No (Full_View (Prev))
17077 or else not Is_Private_Type (Full_View (Prev)))
17078 then
17079 -- Indicate that the incomplete declaration has a matching full
17080 -- declaration. The defining occurrence of the incomplete
17081 -- declaration remains the visible one, and the procedure
17082 -- Get_Full_View dereferences it whenever the type is used.
17083
17084 if Present (Full_View (Prev)) then
17085 Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
17086 end if;
17087
17088 Set_Full_View (Prev, Id);
17089 Append_Entity (Id, Current_Scope);
17090 Set_Is_Public (Id, Is_Public (Prev));
17091 Set_Is_Internal (Id);
17092 New_Id := Prev;
17093
17094 -- If the incomplete view is tagged, a class_wide type has been
17095 -- created already. Use it for the private type as well, in order
17096 -- to prevent multiple incompatible class-wide types that may be
17097 -- created for self-referential anonymous access components.
17098
17099 if Is_Tagged_Type (Prev)
17100 and then Present (Class_Wide_Type (Prev))
17101 then
17102 Set_Ekind (Id, Ekind (Prev)); -- will be reset later
17103 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
17104
17105 -- Type of the class-wide type is the current Id. Previously
17106 -- this was not done for private declarations because of order-
17107 -- of-elaboration issues in the back end, but gigi now handles
17108 -- this properly.
17109
17110 Set_Etype (Class_Wide_Type (Id), Id);
17111 end if;
17112
17113 -- Case of full declaration of private type
17114
17115 else
17116 -- If the private type was a completion of an incomplete type then
17117 -- update Prev to reference the private type
17118
17119 if Ada_Version >= Ada_2012
17120 and then Ekind (Prev) = E_Incomplete_Type
17121 and then Present (Full_View (Prev))
17122 and then Is_Private_Type (Full_View (Prev))
17123 then
17124 Prev := Full_View (Prev);
17125 Prev_Par := Parent (Prev);
17126 end if;
17127
17128 if Nkind (N) = N_Full_Type_Declaration
17129 and then Nkind_In
17130 (Type_Definition (N), N_Record_Definition,
17131 N_Derived_Type_Definition)
17132 and then Interface_Present (Type_Definition (N))
17133 then
17134 Error_Msg_N
17135 ("completion of private type cannot be an interface", N);
17136 end if;
17137
17138 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
17139 if Etype (Prev) /= Prev then
17140
17141 -- Prev is a private subtype or a derived type, and needs
17142 -- no completion.
17143
17144 Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
17145 New_Id := Id;
17146
17147 elsif Ekind (Prev) = E_Private_Type
17148 and then Nkind_In (N, N_Task_Type_Declaration,
17149 N_Protected_Type_Declaration)
17150 then
17151 Error_Msg_N
17152 ("completion of nonlimited type cannot be limited", N);
17153
17154 elsif Ekind (Prev) = E_Record_Type_With_Private
17155 and then Nkind_In (N, N_Task_Type_Declaration,
17156 N_Protected_Type_Declaration)
17157 then
17158 if not Is_Limited_Record (Prev) then
17159 Error_Msg_N
17160 ("completion of nonlimited type cannot be limited", N);
17161
17162 elsif No (Interface_List (N)) then
17163 Error_Msg_N
17164 ("completion of tagged private type must be tagged",
17165 N);
17166 end if;
17167 end if;
17168
17169 -- Ada 2005 (AI-251): Private extension declaration of a task
17170 -- type or a protected type. This case arises when covering
17171 -- interface types.
17172
17173 elsif Nkind_In (N, N_Task_Type_Declaration,
17174 N_Protected_Type_Declaration)
17175 then
17176 null;
17177
17178 elsif Nkind (N) /= N_Full_Type_Declaration
17179 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
17180 then
17181 Error_Msg_N
17182 ("full view of private extension must be an extension", N);
17183
17184 elsif not (Abstract_Present (Parent (Prev)))
17185 and then Abstract_Present (Type_Definition (N))
17186 then
17187 Error_Msg_N
17188 ("full view of non-abstract extension cannot be abstract", N);
17189 end if;
17190
17191 if not In_Private_Part (Current_Scope) then
17192 Error_Msg_N
17193 ("declaration of full view must appear in private part", N);
17194 end if;
17195
17196 if Ada_Version >= Ada_2012 then
17197 Check_Duplicate_Aspects;
17198 end if;
17199
17200 Copy_And_Swap (Prev, Id);
17201 Set_Has_Private_Declaration (Prev);
17202 Set_Has_Private_Declaration (Id);
17203
17204 -- AI12-0133: Indicate whether we have a partial view with
17205 -- unknown discriminants, in which case initialization of objects
17206 -- of the type do not receive an invariant check.
17207
17208 Set_Partial_View_Has_Unknown_Discr
17209 (Prev, Has_Unknown_Discriminants (Id));
17210
17211 -- Preserve aspect and iterator flags that may have been set on
17212 -- the partial view.
17213
17214 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
17215 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
17216
17217 -- If no error, propagate freeze_node from private to full view.
17218 -- It may have been generated for an early operational item.
17219
17220 if Present (Freeze_Node (Id))
17221 and then Serious_Errors_Detected = 0
17222 and then No (Full_View (Id))
17223 then
17224 Set_Freeze_Node (Prev, Freeze_Node (Id));
17225 Set_Freeze_Node (Id, Empty);
17226 Set_First_Rep_Item (Prev, First_Rep_Item (Id));
17227 end if;
17228
17229 Set_Full_View (Id, Prev);
17230 New_Id := Prev;
17231 end if;
17232
17233 -- Verify that full declaration conforms to partial one
17234
17235 if Is_Incomplete_Or_Private_Type (Prev)
17236 and then Present (Discriminant_Specifications (Prev_Par))
17237 then
17238 if Present (Discriminant_Specifications (N)) then
17239 if Ekind (Prev) = E_Incomplete_Type then
17240 Check_Discriminant_Conformance (N, Prev, Prev);
17241 else
17242 Check_Discriminant_Conformance (N, Prev, Id);
17243 end if;
17244
17245 else
17246 Error_Msg_N
17247 ("missing discriminants in full type declaration", N);
17248
17249 -- To avoid cascaded errors on subsequent use, share the
17250 -- discriminants of the partial view.
17251
17252 Set_Discriminant_Specifications (N,
17253 Discriminant_Specifications (Prev_Par));
17254 end if;
17255 end if;
17256
17257 -- A prior untagged partial view can have an associated class-wide
17258 -- type due to use of the class attribute, and in this case the full
17259 -- type must also be tagged. This Ada 95 usage is deprecated in favor
17260 -- of incomplete tagged declarations, but we check for it.
17261
17262 if Is_Type (Prev)
17263 and then (Is_Tagged_Type (Prev)
17264 or else Present (Class_Wide_Type (Prev)))
17265 then
17266 -- Ada 2012 (AI05-0162): A private type may be the completion of
17267 -- an incomplete type.
17268
17269 if Ada_Version >= Ada_2012
17270 and then Is_Incomplete_Type (Prev)
17271 and then Nkind_In (N, N_Private_Type_Declaration,
17272 N_Private_Extension_Declaration)
17273 then
17274 -- No need to check private extensions since they are tagged
17275
17276 if Nkind (N) = N_Private_Type_Declaration
17277 and then not Tagged_Present (N)
17278 then
17279 Tag_Mismatch;
17280 end if;
17281
17282 -- The full declaration is either a tagged type (including
17283 -- a synchronized type that implements interfaces) or a
17284 -- type extension, otherwise this is an error.
17285
17286 elsif Nkind_In (N, N_Task_Type_Declaration,
17287 N_Protected_Type_Declaration)
17288 then
17289 if No (Interface_List (N)) and then not Error_Posted (N) then
17290 Tag_Mismatch;
17291 end if;
17292
17293 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
17294
17295 -- Indicate that the previous declaration (tagged incomplete
17296 -- or private declaration) requires the same on the full one.
17297
17298 if not Tagged_Present (Type_Definition (N)) then
17299 Tag_Mismatch;
17300 Set_Is_Tagged_Type (Id);
17301 end if;
17302
17303 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
17304 if No (Record_Extension_Part (Type_Definition (N))) then
17305 Error_Msg_NE
17306 ("full declaration of } must be a record extension",
17307 Prev, Id);
17308
17309 -- Set some attributes to produce a usable full view
17310
17311 Set_Is_Tagged_Type (Id);
17312 end if;
17313
17314 else
17315 Tag_Mismatch;
17316 end if;
17317 end if;
17318
17319 if Present (Prev)
17320 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
17321 and then Present (Premature_Use (Parent (Prev)))
17322 then
17323 Error_Msg_Sloc := Sloc (N);
17324 Error_Msg_N
17325 ("\full declaration #", Premature_Use (Parent (Prev)));
17326 end if;
17327
17328 return New_Id;
17329 end if;
17330 end Find_Type_Name;
17331
17332 -------------------------
17333 -- Find_Type_Of_Object --
17334 -------------------------
17335
17336 function Find_Type_Of_Object
17337 (Obj_Def : Node_Id;
17338 Related_Nod : Node_Id) return Entity_Id
17339 is
17340 Def_Kind : constant Node_Kind := Nkind (Obj_Def);
17341 P : Node_Id := Parent (Obj_Def);
17342 T : Entity_Id;
17343 Nam : Name_Id;
17344
17345 begin
17346 -- If the parent is a component_definition node we climb to the
17347 -- component_declaration node
17348
17349 if Nkind (P) = N_Component_Definition then
17350 P := Parent (P);
17351 end if;
17352
17353 -- Case of an anonymous array subtype
17354
17355 if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
17356 N_Unconstrained_Array_Definition)
17357 then
17358 T := Empty;
17359 Array_Type_Declaration (T, Obj_Def);
17360
17361 -- Create an explicit subtype whenever possible
17362
17363 elsif Nkind (P) /= N_Component_Declaration
17364 and then Def_Kind = N_Subtype_Indication
17365 then
17366 -- Base name of subtype on object name, which will be unique in
17367 -- the current scope.
17368
17369 -- If this is a duplicate declaration, return base type, to avoid
17370 -- generating duplicate anonymous types.
17371
17372 if Error_Posted (P) then
17373 Analyze (Subtype_Mark (Obj_Def));
17374 return Entity (Subtype_Mark (Obj_Def));
17375 end if;
17376
17377 Nam :=
17378 New_External_Name
17379 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
17380
17381 T := Make_Defining_Identifier (Sloc (P), Nam);
17382
17383 Insert_Action (Obj_Def,
17384 Make_Subtype_Declaration (Sloc (P),
17385 Defining_Identifier => T,
17386 Subtype_Indication => Relocate_Node (Obj_Def)));
17387
17388 -- This subtype may need freezing, and this will not be done
17389 -- automatically if the object declaration is not in declarative
17390 -- part. Since this is an object declaration, the type cannot always
17391 -- be frozen here. Deferred constants do not freeze their type
17392 -- (which often enough will be private).
17393
17394 if Nkind (P) = N_Object_Declaration
17395 and then Constant_Present (P)
17396 and then No (Expression (P))
17397 then
17398 null;
17399
17400 -- Here we freeze the base type of object type to catch premature use
17401 -- of discriminated private type without a full view.
17402
17403 else
17404 Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P));
17405 end if;
17406
17407 -- Ada 2005 AI-406: the object definition in an object declaration
17408 -- can be an access definition.
17409
17410 elsif Def_Kind = N_Access_Definition then
17411 T := Access_Definition (Related_Nod, Obj_Def);
17412
17413 Set_Is_Local_Anonymous_Access
17414 (T,
17415 V => (Ada_Version < Ada_2012)
17416 or else (Nkind (P) /= N_Object_Declaration)
17417 or else Is_Library_Level_Entity (Defining_Identifier (P)));
17418
17419 -- Otherwise, the object definition is just a subtype_mark
17420
17421 else
17422 T := Process_Subtype (Obj_Def, Related_Nod);
17423
17424 -- If expansion is disabled an object definition that is an aggregate
17425 -- will not get expanded and may lead to scoping problems in the back
17426 -- end, if the object is referenced in an inner scope. In that case
17427 -- create an itype reference for the object definition now. This
17428 -- may be redundant in some cases, but harmless.
17429
17430 if Is_Itype (T)
17431 and then Nkind (Related_Nod) = N_Object_Declaration
17432 and then ASIS_Mode
17433 then
17434 Build_Itype_Reference (T, Related_Nod);
17435 end if;
17436 end if;
17437
17438 return T;
17439 end Find_Type_Of_Object;
17440
17441 --------------------------------
17442 -- Find_Type_Of_Subtype_Indic --
17443 --------------------------------
17444
17445 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
17446 Typ : Entity_Id;
17447
17448 begin
17449 -- Case of subtype mark with a constraint
17450
17451 if Nkind (S) = N_Subtype_Indication then
17452 Find_Type (Subtype_Mark (S));
17453 Typ := Entity (Subtype_Mark (S));
17454
17455 if not
17456 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
17457 then
17458 Error_Msg_N
17459 ("incorrect constraint for this kind of type", Constraint (S));
17460 Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
17461 end if;
17462
17463 -- Otherwise we have a subtype mark without a constraint
17464
17465 elsif Error_Posted (S) then
17466 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
17467 return Any_Type;
17468
17469 else
17470 Find_Type (S);
17471 Typ := Entity (S);
17472 end if;
17473
17474 -- Check No_Wide_Characters restriction
17475
17476 Check_Wide_Character_Restriction (Typ, S);
17477
17478 return Typ;
17479 end Find_Type_Of_Subtype_Indic;
17480
17481 -------------------------------------
17482 -- Floating_Point_Type_Declaration --
17483 -------------------------------------
17484
17485 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
17486 Digs : constant Node_Id := Digits_Expression (Def);
17487 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float);
17488 Digs_Val : Uint;
17489 Base_Typ : Entity_Id;
17490 Implicit_Base : Entity_Id;
17491 Bound : Node_Id;
17492
17493 function Can_Derive_From (E : Entity_Id) return Boolean;
17494 -- Find if given digits value, and possibly a specified range, allows
17495 -- derivation from specified type
17496
17497 function Find_Base_Type return Entity_Id;
17498 -- Find a predefined base type that Def can derive from, or generate
17499 -- an error and substitute Long_Long_Float if none exists.
17500
17501 ---------------------
17502 -- Can_Derive_From --
17503 ---------------------
17504
17505 function Can_Derive_From (E : Entity_Id) return Boolean is
17506 Spec : constant Entity_Id := Real_Range_Specification (Def);
17507
17508 begin
17509 -- Check specified "digits" constraint
17510
17511 if Digs_Val > Digits_Value (E) then
17512 return False;
17513 end if;
17514
17515 -- Check for matching range, if specified
17516
17517 if Present (Spec) then
17518 if Expr_Value_R (Type_Low_Bound (E)) >
17519 Expr_Value_R (Low_Bound (Spec))
17520 then
17521 return False;
17522 end if;
17523
17524 if Expr_Value_R (Type_High_Bound (E)) <
17525 Expr_Value_R (High_Bound (Spec))
17526 then
17527 return False;
17528 end if;
17529 end if;
17530
17531 return True;
17532 end Can_Derive_From;
17533
17534 --------------------
17535 -- Find_Base_Type --
17536 --------------------
17537
17538 function Find_Base_Type return Entity_Id is
17539 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types);
17540
17541 begin
17542 -- Iterate over the predefined types in order, returning the first
17543 -- one that Def can derive from.
17544
17545 while Present (Choice) loop
17546 if Can_Derive_From (Node (Choice)) then
17547 return Node (Choice);
17548 end if;
17549
17550 Next_Elmt (Choice);
17551 end loop;
17552
17553 -- If we can't derive from any existing type, use Long_Long_Float
17554 -- and give appropriate message explaining the problem.
17555
17556 if Digs_Val > Max_Digs_Val then
17557 -- It might be the case that there is a type with the requested
17558 -- range, just not the combination of digits and range.
17559
17560 Error_Msg_N
17561 ("no predefined type has requested range and precision",
17562 Real_Range_Specification (Def));
17563
17564 else
17565 Error_Msg_N
17566 ("range too large for any predefined type",
17567 Real_Range_Specification (Def));
17568 end if;
17569
17570 return Standard_Long_Long_Float;
17571 end Find_Base_Type;
17572
17573 -- Start of processing for Floating_Point_Type_Declaration
17574
17575 begin
17576 Check_Restriction (No_Floating_Point, Def);
17577
17578 -- Create an implicit base type
17579
17580 Implicit_Base :=
17581 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
17582
17583 -- Analyze and verify digits value
17584
17585 Analyze_And_Resolve (Digs, Any_Integer);
17586 Check_Digits_Expression (Digs);
17587 Digs_Val := Expr_Value (Digs);
17588
17589 -- Process possible range spec and find correct type to derive from
17590
17591 Process_Real_Range_Specification (Def);
17592
17593 -- Check that requested number of digits is not too high.
17594
17595 if Digs_Val > Max_Digs_Val then
17596
17597 -- The check for Max_Base_Digits may be somewhat expensive, as it
17598 -- requires reading System, so only do it when necessary.
17599
17600 declare
17601 Max_Base_Digits : constant Uint :=
17602 Expr_Value
17603 (Expression
17604 (Parent (RTE (RE_Max_Base_Digits))));
17605
17606 begin
17607 if Digs_Val > Max_Base_Digits then
17608 Error_Msg_Uint_1 := Max_Base_Digits;
17609 Error_Msg_N ("digits value out of range, maximum is ^", Digs);
17610
17611 elsif No (Real_Range_Specification (Def)) then
17612 Error_Msg_Uint_1 := Max_Digs_Val;
17613 Error_Msg_N ("types with more than ^ digits need range spec "
17614 & "(RM 3.5.7(6))", Digs);
17615 end if;
17616 end;
17617 end if;
17618
17619 -- Find a suitable type to derive from or complain and use a substitute
17620
17621 Base_Typ := Find_Base_Type;
17622
17623 -- If there are bounds given in the declaration use them as the bounds
17624 -- of the type, otherwise use the bounds of the predefined base type
17625 -- that was chosen based on the Digits value.
17626
17627 if Present (Real_Range_Specification (Def)) then
17628 Set_Scalar_Range (T, Real_Range_Specification (Def));
17629 Set_Is_Constrained (T);
17630
17631 -- The bounds of this range must be converted to machine numbers
17632 -- in accordance with RM 4.9(38).
17633
17634 Bound := Type_Low_Bound (T);
17635
17636 if Nkind (Bound) = N_Real_Literal then
17637 Set_Realval
17638 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
17639 Set_Is_Machine_Number (Bound);
17640 end if;
17641
17642 Bound := Type_High_Bound (T);
17643
17644 if Nkind (Bound) = N_Real_Literal then
17645 Set_Realval
17646 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
17647 Set_Is_Machine_Number (Bound);
17648 end if;
17649
17650 else
17651 Set_Scalar_Range (T, Scalar_Range (Base_Typ));
17652 end if;
17653
17654 -- Complete definition of implicit base and declared first subtype. The
17655 -- inheritance of the rep item chain ensures that SPARK-related pragmas
17656 -- are not clobbered when the floating point type acts as a full view of
17657 -- a private type.
17658
17659 Set_Etype (Implicit_Base, Base_Typ);
17660 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
17661 Set_Size_Info (Implicit_Base, Base_Typ);
17662 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
17663 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
17664 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ));
17665 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ));
17666
17667 Set_Ekind (T, E_Floating_Point_Subtype);
17668 Set_Etype (T, Implicit_Base);
17669 Set_Size_Info (T, Implicit_Base);
17670 Set_RM_Size (T, RM_Size (Implicit_Base));
17671 Inherit_Rep_Item_Chain (T, Implicit_Base);
17672 Set_Digits_Value (T, Digs_Val);
17673 end Floating_Point_Type_Declaration;
17674
17675 ----------------------------
17676 -- Get_Discriminant_Value --
17677 ----------------------------
17678
17679 -- This is the situation:
17680
17681 -- There is a non-derived type
17682
17683 -- type T0 (Dx, Dy, Dz...)
17684
17685 -- There are zero or more levels of derivation, with each derivation
17686 -- either purely inheriting the discriminants, or defining its own.
17687
17688 -- type Ti is new Ti-1
17689 -- or
17690 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
17691 -- or
17692 -- subtype Ti is ...
17693
17694 -- The subtype issue is avoided by the use of Original_Record_Component,
17695 -- and the fact that derived subtypes also derive the constraints.
17696
17697 -- This chain leads back from
17698
17699 -- Typ_For_Constraint
17700
17701 -- Typ_For_Constraint has discriminants, and the value for each
17702 -- discriminant is given by its corresponding Elmt of Constraints.
17703
17704 -- Discriminant is some discriminant in this hierarchy
17705
17706 -- We need to return its value
17707
17708 -- We do this by recursively searching each level, and looking for
17709 -- Discriminant. Once we get to the bottom, we start backing up
17710 -- returning the value for it which may in turn be a discriminant
17711 -- further up, so on the backup we continue the substitution.
17712
17713 function Get_Discriminant_Value
17714 (Discriminant : Entity_Id;
17715 Typ_For_Constraint : Entity_Id;
17716 Constraint : Elist_Id) return Node_Id
17717 is
17718 function Root_Corresponding_Discriminant
17719 (Discr : Entity_Id) return Entity_Id;
17720 -- Given a discriminant, traverse the chain of inherited discriminants
17721 -- and return the topmost discriminant.
17722
17723 function Search_Derivation_Levels
17724 (Ti : Entity_Id;
17725 Discrim_Values : Elist_Id;
17726 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
17727 -- This is the routine that performs the recursive search of levels
17728 -- as described above.
17729
17730 -------------------------------------
17731 -- Root_Corresponding_Discriminant --
17732 -------------------------------------
17733
17734 function Root_Corresponding_Discriminant
17735 (Discr : Entity_Id) return Entity_Id
17736 is
17737 D : Entity_Id;
17738
17739 begin
17740 D := Discr;
17741 while Present (Corresponding_Discriminant (D)) loop
17742 D := Corresponding_Discriminant (D);
17743 end loop;
17744
17745 return D;
17746 end Root_Corresponding_Discriminant;
17747
17748 ------------------------------
17749 -- Search_Derivation_Levels --
17750 ------------------------------
17751
17752 function Search_Derivation_Levels
17753 (Ti : Entity_Id;
17754 Discrim_Values : Elist_Id;
17755 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
17756 is
17757 Assoc : Elmt_Id;
17758 Disc : Entity_Id;
17759 Result : Node_Or_Entity_Id;
17760 Result_Entity : Node_Id;
17761
17762 begin
17763 -- If inappropriate type, return Error, this happens only in
17764 -- cascaded error situations, and we want to avoid a blow up.
17765
17766 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
17767 return Error;
17768 end if;
17769
17770 -- Look deeper if possible. Use Stored_Constraints only for
17771 -- untagged types. For tagged types use the given constraint.
17772 -- This asymmetry needs explanation???
17773
17774 if not Stored_Discrim_Values
17775 and then Present (Stored_Constraint (Ti))
17776 and then not Is_Tagged_Type (Ti)
17777 then
17778 Result :=
17779 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
17780 else
17781 declare
17782 Td : constant Entity_Id := Etype (Ti);
17783
17784 begin
17785 if Td = Ti then
17786 Result := Discriminant;
17787
17788 else
17789 if Present (Stored_Constraint (Ti)) then
17790 Result :=
17791 Search_Derivation_Levels
17792 (Td, Stored_Constraint (Ti), True);
17793 else
17794 Result :=
17795 Search_Derivation_Levels
17796 (Td, Discrim_Values, Stored_Discrim_Values);
17797 end if;
17798 end if;
17799 end;
17800 end if;
17801
17802 -- Extra underlying places to search, if not found above. For
17803 -- concurrent types, the relevant discriminant appears in the
17804 -- corresponding record. For a type derived from a private type
17805 -- without discriminant, the full view inherits the discriminants
17806 -- of the full view of the parent.
17807
17808 if Result = Discriminant then
17809 if Is_Concurrent_Type (Ti)
17810 and then Present (Corresponding_Record_Type (Ti))
17811 then
17812 Result :=
17813 Search_Derivation_Levels (
17814 Corresponding_Record_Type (Ti),
17815 Discrim_Values,
17816 Stored_Discrim_Values);
17817
17818 elsif Is_Private_Type (Ti)
17819 and then not Has_Discriminants (Ti)
17820 and then Present (Full_View (Ti))
17821 and then Etype (Full_View (Ti)) /= Ti
17822 then
17823 Result :=
17824 Search_Derivation_Levels (
17825 Full_View (Ti),
17826 Discrim_Values,
17827 Stored_Discrim_Values);
17828 end if;
17829 end if;
17830
17831 -- If Result is not a (reference to a) discriminant, return it,
17832 -- otherwise set Result_Entity to the discriminant.
17833
17834 if Nkind (Result) = N_Defining_Identifier then
17835 pragma Assert (Result = Discriminant);
17836 Result_Entity := Result;
17837
17838 else
17839 if not Denotes_Discriminant (Result) then
17840 return Result;
17841 end if;
17842
17843 Result_Entity := Entity (Result);
17844 end if;
17845
17846 -- See if this level of derivation actually has discriminants because
17847 -- tagged derivations can add them, hence the lower levels need not
17848 -- have any.
17849
17850 if not Has_Discriminants (Ti) then
17851 return Result;
17852 end if;
17853
17854 -- Scan Ti's discriminants for Result_Entity, and return its
17855 -- corresponding value, if any.
17856
17857 Result_Entity := Original_Record_Component (Result_Entity);
17858
17859 Assoc := First_Elmt (Discrim_Values);
17860
17861 if Stored_Discrim_Values then
17862 Disc := First_Stored_Discriminant (Ti);
17863 else
17864 Disc := First_Discriminant (Ti);
17865 end if;
17866
17867 while Present (Disc) loop
17868
17869 -- If no further associations return the discriminant, value will
17870 -- be found on the second pass.
17871
17872 if No (Assoc) then
17873 return Result;
17874 end if;
17875
17876 if Original_Record_Component (Disc) = Result_Entity then
17877 return Node (Assoc);
17878 end if;
17879
17880 Next_Elmt (Assoc);
17881
17882 if Stored_Discrim_Values then
17883 Next_Stored_Discriminant (Disc);
17884 else
17885 Next_Discriminant (Disc);
17886 end if;
17887 end loop;
17888
17889 -- Could not find it
17890
17891 return Result;
17892 end Search_Derivation_Levels;
17893
17894 -- Local Variables
17895
17896 Result : Node_Or_Entity_Id;
17897
17898 -- Start of processing for Get_Discriminant_Value
17899
17900 begin
17901 -- ??? This routine is a gigantic mess and will be deleted. For the
17902 -- time being just test for the trivial case before calling recurse.
17903
17904 -- We are now celebrating the 20th anniversary of this comment!
17905
17906 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
17907 declare
17908 D : Entity_Id;
17909 E : Elmt_Id;
17910
17911 begin
17912 D := First_Discriminant (Typ_For_Constraint);
17913 E := First_Elmt (Constraint);
17914 while Present (D) loop
17915 if Chars (D) = Chars (Discriminant) then
17916 return Node (E);
17917 end if;
17918
17919 Next_Discriminant (D);
17920 Next_Elmt (E);
17921 end loop;
17922 end;
17923 end if;
17924
17925 Result := Search_Derivation_Levels
17926 (Typ_For_Constraint, Constraint, False);
17927
17928 -- ??? hack to disappear when this routine is gone
17929
17930 if Nkind (Result) = N_Defining_Identifier then
17931 declare
17932 D : Entity_Id;
17933 E : Elmt_Id;
17934
17935 begin
17936 D := First_Discriminant (Typ_For_Constraint);
17937 E := First_Elmt (Constraint);
17938 while Present (D) loop
17939 if Root_Corresponding_Discriminant (D) = Discriminant then
17940 return Node (E);
17941 end if;
17942
17943 Next_Discriminant (D);
17944 Next_Elmt (E);
17945 end loop;
17946 end;
17947 end if;
17948
17949 pragma Assert (Nkind (Result) /= N_Defining_Identifier);
17950 return Result;
17951 end Get_Discriminant_Value;
17952
17953 --------------------------
17954 -- Has_Range_Constraint --
17955 --------------------------
17956
17957 function Has_Range_Constraint (N : Node_Id) return Boolean is
17958 C : constant Node_Id := Constraint (N);
17959
17960 begin
17961 if Nkind (C) = N_Range_Constraint then
17962 return True;
17963
17964 elsif Nkind (C) = N_Digits_Constraint then
17965 return
17966 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
17967 or else Present (Range_Constraint (C));
17968
17969 elsif Nkind (C) = N_Delta_Constraint then
17970 return Present (Range_Constraint (C));
17971
17972 else
17973 return False;
17974 end if;
17975 end Has_Range_Constraint;
17976
17977 ------------------------
17978 -- Inherit_Components --
17979 ------------------------
17980
17981 function Inherit_Components
17982 (N : Node_Id;
17983 Parent_Base : Entity_Id;
17984 Derived_Base : Entity_Id;
17985 Is_Tagged : Boolean;
17986 Inherit_Discr : Boolean;
17987 Discs : Elist_Id) return Elist_Id
17988 is
17989 Assoc_List : constant Elist_Id := New_Elmt_List;
17990
17991 procedure Inherit_Component
17992 (Old_C : Entity_Id;
17993 Plain_Discrim : Boolean := False;
17994 Stored_Discrim : Boolean := False);
17995 -- Inherits component Old_C from Parent_Base to the Derived_Base. If
17996 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
17997 -- True, Old_C is a stored discriminant. If they are both false then
17998 -- Old_C is a regular component.
17999
18000 -----------------------
18001 -- Inherit_Component --
18002 -----------------------
18003
18004 procedure Inherit_Component
18005 (Old_C : Entity_Id;
18006 Plain_Discrim : Boolean := False;
18007 Stored_Discrim : Boolean := False)
18008 is
18009 procedure Set_Anonymous_Type (Id : Entity_Id);
18010 -- Id denotes the entity of an access discriminant or anonymous
18011 -- access component. Set the type of Id to either the same type of
18012 -- Old_C or create a new one depending on whether the parent and
18013 -- the child types are in the same scope.
18014
18015 ------------------------
18016 -- Set_Anonymous_Type --
18017 ------------------------
18018
18019 procedure Set_Anonymous_Type (Id : Entity_Id) is
18020 Old_Typ : constant Entity_Id := Etype (Old_C);
18021
18022 begin
18023 if Scope (Parent_Base) = Scope (Derived_Base) then
18024 Set_Etype (Id, Old_Typ);
18025
18026 -- The parent and the derived type are in two different scopes.
18027 -- Reuse the type of the original discriminant / component by
18028 -- copying it in order to preserve all attributes.
18029
18030 else
18031 declare
18032 Typ : constant Entity_Id := New_Copy (Old_Typ);
18033
18034 begin
18035 Set_Etype (Id, Typ);
18036
18037 -- Since we do not generate component declarations for
18038 -- inherited components, associate the itype with the
18039 -- derived type.
18040
18041 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
18042 Set_Scope (Typ, Derived_Base);
18043 end;
18044 end if;
18045 end Set_Anonymous_Type;
18046
18047 -- Local variables and constants
18048
18049 New_C : constant Entity_Id := New_Copy (Old_C);
18050
18051 Corr_Discrim : Entity_Id;
18052 Discrim : Entity_Id;
18053
18054 -- Start of processing for Inherit_Component
18055
18056 begin
18057 pragma Assert (not Is_Tagged or not Stored_Discrim);
18058
18059 Set_Parent (New_C, Parent (Old_C));
18060
18061 -- Regular discriminants and components must be inserted in the scope
18062 -- of the Derived_Base. Do it here.
18063
18064 if not Stored_Discrim then
18065 Enter_Name (New_C);
18066 end if;
18067
18068 -- For tagged types the Original_Record_Component must point to
18069 -- whatever this field was pointing to in the parent type. This has
18070 -- already been achieved by the call to New_Copy above.
18071
18072 if not Is_Tagged then
18073 Set_Original_Record_Component (New_C, New_C);
18074 end if;
18075
18076 -- Set the proper type of an access discriminant
18077
18078 if Ekind (New_C) = E_Discriminant
18079 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
18080 then
18081 Set_Anonymous_Type (New_C);
18082 end if;
18083
18084 -- If we have inherited a component then see if its Etype contains
18085 -- references to Parent_Base discriminants. In this case, replace
18086 -- these references with the constraints given in Discs. We do not
18087 -- do this for the partial view of private types because this is
18088 -- not needed (only the components of the full view will be used
18089 -- for code generation) and cause problem. We also avoid this
18090 -- transformation in some error situations.
18091
18092 if Ekind (New_C) = E_Component then
18093
18094 -- Set the proper type of an anonymous access component
18095
18096 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
18097 Set_Anonymous_Type (New_C);
18098
18099 elsif (Is_Private_Type (Derived_Base)
18100 and then not Is_Generic_Type (Derived_Base))
18101 or else (Is_Empty_Elmt_List (Discs)
18102 and then not Expander_Active)
18103 then
18104 Set_Etype (New_C, Etype (Old_C));
18105
18106 else
18107 -- The current component introduces a circularity of the
18108 -- following kind:
18109
18110 -- limited with Pack_2;
18111 -- package Pack_1 is
18112 -- type T_1 is tagged record
18113 -- Comp : access Pack_2.T_2;
18114 -- ...
18115 -- end record;
18116 -- end Pack_1;
18117
18118 -- with Pack_1;
18119 -- package Pack_2 is
18120 -- type T_2 is new Pack_1.T_1 with ...;
18121 -- end Pack_2;
18122
18123 Set_Etype
18124 (New_C,
18125 Constrain_Component_Type
18126 (Old_C, Derived_Base, N, Parent_Base, Discs));
18127 end if;
18128 end if;
18129
18130 -- In derived tagged types it is illegal to reference a non
18131 -- discriminant component in the parent type. To catch this, mark
18132 -- these components with an Ekind of E_Void. This will be reset in
18133 -- Record_Type_Definition after processing the record extension of
18134 -- the derived type.
18135
18136 -- If the declaration is a private extension, there is no further
18137 -- record extension to process, and the components retain their
18138 -- current kind, because they are visible at this point.
18139
18140 if Is_Tagged and then Ekind (New_C) = E_Component
18141 and then Nkind (N) /= N_Private_Extension_Declaration
18142 then
18143 Set_Ekind (New_C, E_Void);
18144 end if;
18145
18146 if Plain_Discrim then
18147 Set_Corresponding_Discriminant (New_C, Old_C);
18148 Build_Discriminal (New_C);
18149
18150 -- If we are explicitly inheriting a stored discriminant it will be
18151 -- completely hidden.
18152
18153 elsif Stored_Discrim then
18154 Set_Corresponding_Discriminant (New_C, Empty);
18155 Set_Discriminal (New_C, Empty);
18156 Set_Is_Completely_Hidden (New_C);
18157
18158 -- Set the Original_Record_Component of each discriminant in the
18159 -- derived base to point to the corresponding stored that we just
18160 -- created.
18161
18162 Discrim := First_Discriminant (Derived_Base);
18163 while Present (Discrim) loop
18164 Corr_Discrim := Corresponding_Discriminant (Discrim);
18165
18166 -- Corr_Discrim could be missing in an error situation
18167
18168 if Present (Corr_Discrim)
18169 and then Original_Record_Component (Corr_Discrim) = Old_C
18170 then
18171 Set_Original_Record_Component (Discrim, New_C);
18172 end if;
18173
18174 Next_Discriminant (Discrim);
18175 end loop;
18176
18177 Append_Entity (New_C, Derived_Base);
18178 end if;
18179
18180 if not Is_Tagged then
18181 Append_Elmt (Old_C, Assoc_List);
18182 Append_Elmt (New_C, Assoc_List);
18183 end if;
18184 end Inherit_Component;
18185
18186 -- Variables local to Inherit_Component
18187
18188 Loc : constant Source_Ptr := Sloc (N);
18189
18190 Parent_Discrim : Entity_Id;
18191 Stored_Discrim : Entity_Id;
18192 D : Entity_Id;
18193 Component : Entity_Id;
18194
18195 -- Start of processing for Inherit_Components
18196
18197 begin
18198 if not Is_Tagged then
18199 Append_Elmt (Parent_Base, Assoc_List);
18200 Append_Elmt (Derived_Base, Assoc_List);
18201 end if;
18202
18203 -- Inherit parent discriminants if needed
18204
18205 if Inherit_Discr then
18206 Parent_Discrim := First_Discriminant (Parent_Base);
18207 while Present (Parent_Discrim) loop
18208 Inherit_Component (Parent_Discrim, Plain_Discrim => True);
18209 Next_Discriminant (Parent_Discrim);
18210 end loop;
18211 end if;
18212
18213 -- Create explicit stored discrims for untagged types when necessary
18214
18215 if not Has_Unknown_Discriminants (Derived_Base)
18216 and then Has_Discriminants (Parent_Base)
18217 and then not Is_Tagged
18218 and then
18219 (not Inherit_Discr
18220 or else First_Discriminant (Parent_Base) /=
18221 First_Stored_Discriminant (Parent_Base))
18222 then
18223 Stored_Discrim := First_Stored_Discriminant (Parent_Base);
18224 while Present (Stored_Discrim) loop
18225 Inherit_Component (Stored_Discrim, Stored_Discrim => True);
18226 Next_Stored_Discriminant (Stored_Discrim);
18227 end loop;
18228 end if;
18229
18230 -- See if we can apply the second transformation for derived types, as
18231 -- explained in point 6. in the comments above Build_Derived_Record_Type
18232 -- This is achieved by appending Derived_Base discriminants into Discs,
18233 -- which has the side effect of returning a non empty Discs list to the
18234 -- caller of Inherit_Components, which is what we want. This must be
18235 -- done for private derived types if there are explicit stored
18236 -- discriminants, to ensure that we can retrieve the values of the
18237 -- constraints provided in the ancestors.
18238
18239 if Inherit_Discr
18240 and then Is_Empty_Elmt_List (Discs)
18241 and then Present (First_Discriminant (Derived_Base))
18242 and then
18243 (not Is_Private_Type (Derived_Base)
18244 or else Is_Completely_Hidden
18245 (First_Stored_Discriminant (Derived_Base))
18246 or else Is_Generic_Type (Derived_Base))
18247 then
18248 D := First_Discriminant (Derived_Base);
18249 while Present (D) loop
18250 Append_Elmt (New_Occurrence_Of (D, Loc), Discs);
18251 Next_Discriminant (D);
18252 end loop;
18253 end if;
18254
18255 -- Finally, inherit non-discriminant components unless they are not
18256 -- visible because defined or inherited from the full view of the
18257 -- parent. Don't inherit the _parent field of the parent type.
18258
18259 Component := First_Entity (Parent_Base);
18260 while Present (Component) loop
18261
18262 -- Ada 2005 (AI-251): Do not inherit components associated with
18263 -- secondary tags of the parent.
18264
18265 if Ekind (Component) = E_Component
18266 and then Present (Related_Type (Component))
18267 then
18268 null;
18269
18270 elsif Ekind (Component) /= E_Component
18271 or else Chars (Component) = Name_uParent
18272 then
18273 null;
18274
18275 -- If the derived type is within the parent type's declarative
18276 -- region, then the components can still be inherited even though
18277 -- they aren't visible at this point. This can occur for cases
18278 -- such as within public child units where the components must
18279 -- become visible upon entering the child unit's private part.
18280
18281 elsif not Is_Visible_Component (Component)
18282 and then not In_Open_Scopes (Scope (Parent_Base))
18283 then
18284 null;
18285
18286 elsif Ekind_In (Derived_Base, E_Private_Type,
18287 E_Limited_Private_Type)
18288 then
18289 null;
18290
18291 else
18292 Inherit_Component (Component);
18293 end if;
18294
18295 Next_Entity (Component);
18296 end loop;
18297
18298 -- For tagged derived types, inherited discriminants cannot be used in
18299 -- component declarations of the record extension part. To achieve this
18300 -- we mark the inherited discriminants as not visible.
18301
18302 if Is_Tagged and then Inherit_Discr then
18303 D := First_Discriminant (Derived_Base);
18304 while Present (D) loop
18305 Set_Is_Immediately_Visible (D, False);
18306 Next_Discriminant (D);
18307 end loop;
18308 end if;
18309
18310 return Assoc_List;
18311 end Inherit_Components;
18312
18313 -----------------------------
18314 -- Inherit_Predicate_Flags --
18315 -----------------------------
18316
18317 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
18318 begin
18319 Set_Has_Predicates (Subt, Has_Predicates (Par));
18320 Set_Has_Static_Predicate_Aspect
18321 (Subt, Has_Static_Predicate_Aspect (Par));
18322 Set_Has_Dynamic_Predicate_Aspect
18323 (Subt, Has_Dynamic_Predicate_Aspect (Par));
18324 end Inherit_Predicate_Flags;
18325
18326 ----------------------
18327 -- Is_EVF_Procedure --
18328 ----------------------
18329
18330 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is
18331 Formal : Entity_Id;
18332
18333 begin
18334 -- Examine the formals of an Extensions_Visible False procedure looking
18335 -- for a controlling OUT parameter.
18336
18337 if Ekind (Subp) = E_Procedure
18338 and then Extensions_Visible_Status (Subp) = Extensions_Visible_False
18339 then
18340 Formal := First_Formal (Subp);
18341 while Present (Formal) loop
18342 if Ekind (Formal) = E_Out_Parameter
18343 and then Is_Controlling_Formal (Formal)
18344 then
18345 return True;
18346 end if;
18347
18348 Next_Formal (Formal);
18349 end loop;
18350 end if;
18351
18352 return False;
18353 end Is_EVF_Procedure;
18354
18355 -----------------------
18356 -- Is_Null_Extension --
18357 -----------------------
18358
18359 function Is_Null_Extension (T : Entity_Id) return Boolean is
18360 Type_Decl : constant Node_Id := Parent (Base_Type (T));
18361 Comp_List : Node_Id;
18362 Comp : Node_Id;
18363
18364 begin
18365 if Nkind (Type_Decl) /= N_Full_Type_Declaration
18366 or else not Is_Tagged_Type (T)
18367 or else Nkind (Type_Definition (Type_Decl)) /=
18368 N_Derived_Type_Definition
18369 or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
18370 then
18371 return False;
18372 end if;
18373
18374 Comp_List :=
18375 Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
18376
18377 if Present (Discriminant_Specifications (Type_Decl)) then
18378 return False;
18379
18380 elsif Present (Comp_List)
18381 and then Is_Non_Empty_List (Component_Items (Comp_List))
18382 then
18383 Comp := First (Component_Items (Comp_List));
18384
18385 -- Only user-defined components are relevant. The component list
18386 -- may also contain a parent component and internal components
18387 -- corresponding to secondary tags, but these do not determine
18388 -- whether this is a null extension.
18389
18390 while Present (Comp) loop
18391 if Comes_From_Source (Comp) then
18392 return False;
18393 end if;
18394
18395 Next (Comp);
18396 end loop;
18397
18398 return True;
18399
18400 else
18401 return True;
18402 end if;
18403 end Is_Null_Extension;
18404
18405 ------------------------------
18406 -- Is_Valid_Constraint_Kind --
18407 ------------------------------
18408
18409 function Is_Valid_Constraint_Kind
18410 (T_Kind : Type_Kind;
18411 Constraint_Kind : Node_Kind) return Boolean
18412 is
18413 begin
18414 case T_Kind is
18415 when Enumeration_Kind
18416 | Integer_Kind
18417 =>
18418 return Constraint_Kind = N_Range_Constraint;
18419
18420 when Decimal_Fixed_Point_Kind =>
18421 return Nkind_In (Constraint_Kind, N_Digits_Constraint,
18422 N_Range_Constraint);
18423
18424 when Ordinary_Fixed_Point_Kind =>
18425 return Nkind_In (Constraint_Kind, N_Delta_Constraint,
18426 N_Range_Constraint);
18427
18428 when Float_Kind =>
18429 return Nkind_In (Constraint_Kind, N_Digits_Constraint,
18430 N_Range_Constraint);
18431
18432 when Access_Kind
18433 | Array_Kind
18434 | Class_Wide_Kind
18435 | Concurrent_Kind
18436 | Private_Kind
18437 | E_Incomplete_Type
18438 | E_Record_Subtype
18439 | E_Record_Type
18440 =>
18441 return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
18442
18443 when others =>
18444 return True; -- Error will be detected later
18445 end case;
18446 end Is_Valid_Constraint_Kind;
18447
18448 --------------------------
18449 -- Is_Visible_Component --
18450 --------------------------
18451
18452 function Is_Visible_Component
18453 (C : Entity_Id;
18454 N : Node_Id := Empty) return Boolean
18455 is
18456 Original_Comp : Entity_Id := Empty;
18457 Original_Type : Entity_Id;
18458 Type_Scope : Entity_Id;
18459
18460 function Is_Local_Type (Typ : Entity_Id) return Boolean;
18461 -- Check whether parent type of inherited component is declared locally,
18462 -- possibly within a nested package or instance. The current scope is
18463 -- the derived record itself.
18464
18465 -------------------
18466 -- Is_Local_Type --
18467 -------------------
18468
18469 function Is_Local_Type (Typ : Entity_Id) return Boolean is
18470 Scop : Entity_Id;
18471
18472 begin
18473 Scop := Scope (Typ);
18474 while Present (Scop)
18475 and then Scop /= Standard_Standard
18476 loop
18477 if Scop = Scope (Current_Scope) then
18478 return True;
18479 end if;
18480
18481 Scop := Scope (Scop);
18482 end loop;
18483
18484 return False;
18485 end Is_Local_Type;
18486
18487 -- Start of processing for Is_Visible_Component
18488
18489 begin
18490 if Ekind_In (C, E_Component, E_Discriminant) then
18491 Original_Comp := Original_Record_Component (C);
18492 end if;
18493
18494 if No (Original_Comp) then
18495
18496 -- Premature usage, or previous error
18497
18498 return False;
18499
18500 else
18501 Original_Type := Scope (Original_Comp);
18502 Type_Scope := Scope (Base_Type (Scope (C)));
18503 end if;
18504
18505 -- This test only concerns tagged types
18506
18507 if not Is_Tagged_Type (Original_Type) then
18508 return True;
18509
18510 -- If it is _Parent or _Tag, there is no visibility issue
18511
18512 elsif not Comes_From_Source (Original_Comp) then
18513 return True;
18514
18515 -- Discriminants are visible unless the (private) type has unknown
18516 -- discriminants. If the discriminant reference is inserted for a
18517 -- discriminant check on a full view it is also visible.
18518
18519 elsif Ekind (Original_Comp) = E_Discriminant
18520 and then
18521 (not Has_Unknown_Discriminants (Original_Type)
18522 or else (Present (N)
18523 and then Nkind (N) = N_Selected_Component
18524 and then Nkind (Prefix (N)) = N_Type_Conversion
18525 and then not Comes_From_Source (Prefix (N))))
18526 then
18527 return True;
18528
18529 -- In the body of an instantiation, check the visibility of a component
18530 -- in case it has a homograph that is a primitive operation of a private
18531 -- type which was not visible in the generic unit.
18532
18533 -- Should Is_Prefixed_Call be propagated from template to instance???
18534
18535 elsif In_Instance_Body then
18536 if not Is_Tagged_Type (Original_Type)
18537 or else not Is_Private_Type (Original_Type)
18538 then
18539 return True;
18540
18541 else
18542 declare
18543 Subp_Elmt : Elmt_Id;
18544
18545 begin
18546 Subp_Elmt := First_Elmt (Primitive_Operations (Original_Type));
18547 while Present (Subp_Elmt) loop
18548
18549 -- The component is hidden by a primitive operation
18550
18551 if Chars (Node (Subp_Elmt)) = Chars (C) then
18552 return False;
18553 end if;
18554
18555 Next_Elmt (Subp_Elmt);
18556 end loop;
18557
18558 return True;
18559 end;
18560 end if;
18561
18562 -- If the component has been declared in an ancestor which is currently
18563 -- a private type, then it is not visible. The same applies if the
18564 -- component's containing type is not in an open scope and the original
18565 -- component's enclosing type is a visible full view of a private type
18566 -- (which can occur in cases where an attempt is being made to reference
18567 -- a component in a sibling package that is inherited from a visible
18568 -- component of a type in an ancestor package; the component in the
18569 -- sibling package should not be visible even though the component it
18570 -- inherited from is visible). This does not apply however in the case
18571 -- where the scope of the type is a private child unit, or when the
18572 -- parent comes from a local package in which the ancestor is currently
18573 -- visible. The latter suppression of visibility is needed for cases
18574 -- that are tested in B730006.
18575
18576 elsif Is_Private_Type (Original_Type)
18577 or else
18578 (not Is_Private_Descendant (Type_Scope)
18579 and then not In_Open_Scopes (Type_Scope)
18580 and then Has_Private_Declaration (Original_Type))
18581 then
18582 -- If the type derives from an entity in a formal package, there
18583 -- are no additional visible components.
18584
18585 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
18586 N_Formal_Package_Declaration
18587 then
18588 return False;
18589
18590 -- if we are not in the private part of the current package, there
18591 -- are no additional visible components.
18592
18593 elsif Ekind (Scope (Current_Scope)) = E_Package
18594 and then not In_Private_Part (Scope (Current_Scope))
18595 then
18596 return False;
18597 else
18598 return
18599 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
18600 and then In_Open_Scopes (Scope (Original_Type))
18601 and then Is_Local_Type (Type_Scope);
18602 end if;
18603
18604 -- There is another weird way in which a component may be invisible when
18605 -- the private and the full view are not derived from the same ancestor.
18606 -- Here is an example :
18607
18608 -- type A1 is tagged record F1 : integer; end record;
18609 -- type A2 is new A1 with record F2 : integer; end record;
18610 -- type T is new A1 with private;
18611 -- private
18612 -- type T is new A2 with null record;
18613
18614 -- In this case, the full view of T inherits F1 and F2 but the private
18615 -- view inherits only F1
18616
18617 else
18618 declare
18619 Ancestor : Entity_Id := Scope (C);
18620
18621 begin
18622 loop
18623 if Ancestor = Original_Type then
18624 return True;
18625
18626 -- The ancestor may have a partial view of the original type,
18627 -- but if the full view is in scope, as in a child body, the
18628 -- component is visible.
18629
18630 elsif In_Private_Part (Scope (Original_Type))
18631 and then Full_View (Ancestor) = Original_Type
18632 then
18633 return True;
18634
18635 elsif Ancestor = Etype (Ancestor) then
18636
18637 -- No further ancestors to examine
18638
18639 return False;
18640 end if;
18641
18642 Ancestor := Etype (Ancestor);
18643 end loop;
18644 end;
18645 end if;
18646 end Is_Visible_Component;
18647
18648 --------------------------
18649 -- Make_Class_Wide_Type --
18650 --------------------------
18651
18652 procedure Make_Class_Wide_Type (T : Entity_Id) is
18653 CW_Type : Entity_Id;
18654 CW_Name : Name_Id;
18655 Next_E : Entity_Id;
18656
18657 begin
18658 if Present (Class_Wide_Type (T)) then
18659
18660 -- The class-wide type is a partially decorated entity created for a
18661 -- unanalyzed tagged type referenced through a limited with clause.
18662 -- When the tagged type is analyzed, its class-wide type needs to be
18663 -- redecorated. Note that we reuse the entity created by Decorate_
18664 -- Tagged_Type in order to preserve all links.
18665
18666 if Materialize_Entity (Class_Wide_Type (T)) then
18667 CW_Type := Class_Wide_Type (T);
18668 Set_Materialize_Entity (CW_Type, False);
18669
18670 -- The class wide type can have been defined by the partial view, in
18671 -- which case everything is already done.
18672
18673 else
18674 return;
18675 end if;
18676
18677 -- Default case, we need to create a new class-wide type
18678
18679 else
18680 CW_Type :=
18681 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
18682 end if;
18683
18684 -- Inherit root type characteristics
18685
18686 CW_Name := Chars (CW_Type);
18687 Next_E := Next_Entity (CW_Type);
18688 Copy_Node (T, CW_Type);
18689 Set_Comes_From_Source (CW_Type, False);
18690 Set_Chars (CW_Type, CW_Name);
18691 Set_Parent (CW_Type, Parent (T));
18692 Set_Next_Entity (CW_Type, Next_E);
18693
18694 -- Ensure we have a new freeze node for the class-wide type. The partial
18695 -- view may have freeze action of its own, requiring a proper freeze
18696 -- node, and the same freeze node cannot be shared between the two
18697 -- types.
18698
18699 Set_Has_Delayed_Freeze (CW_Type);
18700 Set_Freeze_Node (CW_Type, Empty);
18701
18702 -- Customize the class-wide type: It has no prim. op., it cannot be
18703 -- abstract, its Etype points back to the specific root type, and it
18704 -- cannot have any invariants.
18705
18706 Set_Ekind (CW_Type, E_Class_Wide_Type);
18707 Set_Is_Tagged_Type (CW_Type, True);
18708 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
18709 Set_Is_Abstract_Type (CW_Type, False);
18710 Set_Is_Constrained (CW_Type, False);
18711 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
18712 Set_Default_SSO (CW_Type);
18713 Set_Has_Inheritable_Invariants (CW_Type, False);
18714 Set_Has_Inherited_Invariants (CW_Type, False);
18715 Set_Has_Own_Invariants (CW_Type, False);
18716
18717 if Ekind (T) = E_Class_Wide_Subtype then
18718 Set_Etype (CW_Type, Etype (Base_Type (T)));
18719 else
18720 Set_Etype (CW_Type, T);
18721 end if;
18722
18723 Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams);
18724
18725 -- If this is the class_wide type of a constrained subtype, it does
18726 -- not have discriminants.
18727
18728 Set_Has_Discriminants (CW_Type,
18729 Has_Discriminants (T) and then not Is_Constrained (T));
18730
18731 Set_Has_Unknown_Discriminants (CW_Type, True);
18732 Set_Class_Wide_Type (T, CW_Type);
18733 Set_Equivalent_Type (CW_Type, Empty);
18734
18735 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
18736
18737 Set_Class_Wide_Type (CW_Type, CW_Type);
18738 end Make_Class_Wide_Type;
18739
18740 ----------------
18741 -- Make_Index --
18742 ----------------
18743
18744 procedure Make_Index
18745 (N : Node_Id;
18746 Related_Nod : Node_Id;
18747 Related_Id : Entity_Id := Empty;
18748 Suffix_Index : Nat := 1;
18749 In_Iter_Schm : Boolean := False)
18750 is
18751 R : Node_Id;
18752 T : Entity_Id;
18753 Def_Id : Entity_Id := Empty;
18754 Found : Boolean := False;
18755
18756 begin
18757 -- For a discrete range used in a constrained array definition and
18758 -- defined by a range, an implicit conversion to the predefined type
18759 -- INTEGER is assumed if each bound is either a numeric literal, a named
18760 -- number, or an attribute, and the type of both bounds (prior to the
18761 -- implicit conversion) is the type universal_integer. Otherwise, both
18762 -- bounds must be of the same discrete type, other than universal
18763 -- integer; this type must be determinable independently of the
18764 -- context, but using the fact that the type must be discrete and that
18765 -- both bounds must have the same type.
18766
18767 -- Character literals also have a universal type in the absence of
18768 -- of additional context, and are resolved to Standard_Character.
18769
18770 if Nkind (N) = N_Range then
18771
18772 -- The index is given by a range constraint. The bounds are known
18773 -- to be of a consistent type.
18774
18775 if not Is_Overloaded (N) then
18776 T := Etype (N);
18777
18778 -- For universal bounds, choose the specific predefined type
18779
18780 if T = Universal_Integer then
18781 T := Standard_Integer;
18782
18783 elsif T = Any_Character then
18784 Ambiguous_Character (Low_Bound (N));
18785
18786 T := Standard_Character;
18787 end if;
18788
18789 -- The node may be overloaded because some user-defined operators
18790 -- are available, but if a universal interpretation exists it is
18791 -- also the selected one.
18792
18793 elsif Universal_Interpretation (N) = Universal_Integer then
18794 T := Standard_Integer;
18795
18796 else
18797 T := Any_Type;
18798
18799 declare
18800 Ind : Interp_Index;
18801 It : Interp;
18802
18803 begin
18804 Get_First_Interp (N, Ind, It);
18805 while Present (It.Typ) loop
18806 if Is_Discrete_Type (It.Typ) then
18807
18808 if Found
18809 and then not Covers (It.Typ, T)
18810 and then not Covers (T, It.Typ)
18811 then
18812 Error_Msg_N ("ambiguous bounds in discrete range", N);
18813 exit;
18814 else
18815 T := It.Typ;
18816 Found := True;
18817 end if;
18818 end if;
18819
18820 Get_Next_Interp (Ind, It);
18821 end loop;
18822
18823 if T = Any_Type then
18824 Error_Msg_N ("discrete type required for range", N);
18825 Set_Etype (N, Any_Type);
18826 return;
18827
18828 elsif T = Universal_Integer then
18829 T := Standard_Integer;
18830 end if;
18831 end;
18832 end if;
18833
18834 if not Is_Discrete_Type (T) then
18835 Error_Msg_N ("discrete type required for range", N);
18836 Set_Etype (N, Any_Type);
18837 return;
18838 end if;
18839
18840 if Nkind (Low_Bound (N)) = N_Attribute_Reference
18841 and then Attribute_Name (Low_Bound (N)) = Name_First
18842 and then Is_Entity_Name (Prefix (Low_Bound (N)))
18843 and then Is_Type (Entity (Prefix (Low_Bound (N))))
18844 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N))))
18845 then
18846 -- The type of the index will be the type of the prefix, as long
18847 -- as the upper bound is 'Last of the same type.
18848
18849 Def_Id := Entity (Prefix (Low_Bound (N)));
18850
18851 if Nkind (High_Bound (N)) /= N_Attribute_Reference
18852 or else Attribute_Name (High_Bound (N)) /= Name_Last
18853 or else not Is_Entity_Name (Prefix (High_Bound (N)))
18854 or else Entity (Prefix (High_Bound (N))) /= Def_Id
18855 then
18856 Def_Id := Empty;
18857 end if;
18858 end if;
18859
18860 R := N;
18861 Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
18862
18863 elsif Nkind (N) = N_Subtype_Indication then
18864
18865 -- The index is given by a subtype with a range constraint
18866
18867 T := Base_Type (Entity (Subtype_Mark (N)));
18868
18869 if not Is_Discrete_Type (T) then
18870 Error_Msg_N ("discrete type required for range", N);
18871 Set_Etype (N, Any_Type);
18872 return;
18873 end if;
18874
18875 R := Range_Expression (Constraint (N));
18876
18877 Resolve (R, T);
18878 Process_Range_Expr_In_Decl
18879 (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm);
18880
18881 elsif Nkind (N) = N_Attribute_Reference then
18882
18883 -- Catch beginner's error (use of attribute other than 'Range)
18884
18885 if Attribute_Name (N) /= Name_Range then
18886 Error_Msg_N ("expect attribute ''Range", N);
18887 Set_Etype (N, Any_Type);
18888 return;
18889 end if;
18890
18891 -- If the node denotes the range of a type mark, that is also the
18892 -- resulting type, and we do not need to create an Itype for it.
18893
18894 if Is_Entity_Name (Prefix (N))
18895 and then Comes_From_Source (N)
18896 and then Is_Type (Entity (Prefix (N)))
18897 and then Is_Discrete_Type (Entity (Prefix (N)))
18898 then
18899 Def_Id := Entity (Prefix (N));
18900 end if;
18901
18902 Analyze_And_Resolve (N);
18903 T := Etype (N);
18904 R := N;
18905
18906 -- If none of the above, must be a subtype. We convert this to a
18907 -- range attribute reference because in the case of declared first
18908 -- named subtypes, the types in the range reference can be different
18909 -- from the type of the entity. A range attribute normalizes the
18910 -- reference and obtains the correct types for the bounds.
18911
18912 -- This transformation is in the nature of an expansion, is only
18913 -- done if expansion is active. In particular, it is not done on
18914 -- formal generic types, because we need to retain the name of the
18915 -- original index for instantiation purposes.
18916
18917 else
18918 if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
18919 Error_Msg_N ("invalid subtype mark in discrete range ", N);
18920 Set_Etype (N, Any_Integer);
18921 return;
18922
18923 else
18924 -- The type mark may be that of an incomplete type. It is only
18925 -- now that we can get the full view, previous analysis does
18926 -- not look specifically for a type mark.
18927
18928 Set_Entity (N, Get_Full_View (Entity (N)));
18929 Set_Etype (N, Entity (N));
18930 Def_Id := Entity (N);
18931
18932 if not Is_Discrete_Type (Def_Id) then
18933 Error_Msg_N ("discrete type required for index", N);
18934 Set_Etype (N, Any_Type);
18935 return;
18936 end if;
18937 end if;
18938
18939 if Expander_Active then
18940 Rewrite (N,
18941 Make_Attribute_Reference (Sloc (N),
18942 Attribute_Name => Name_Range,
18943 Prefix => Relocate_Node (N)));
18944
18945 -- The original was a subtype mark that does not freeze. This
18946 -- means that the rewritten version must not freeze either.
18947
18948 Set_Must_Not_Freeze (N);
18949 Set_Must_Not_Freeze (Prefix (N));
18950 Analyze_And_Resolve (N);
18951 T := Etype (N);
18952 R := N;
18953
18954 -- If expander is inactive, type is legal, nothing else to construct
18955
18956 else
18957 return;
18958 end if;
18959 end if;
18960
18961 if not Is_Discrete_Type (T) then
18962 Error_Msg_N ("discrete type required for range", N);
18963 Set_Etype (N, Any_Type);
18964 return;
18965
18966 elsif T = Any_Type then
18967 Set_Etype (N, Any_Type);
18968 return;
18969 end if;
18970
18971 -- We will now create the appropriate Itype to describe the range, but
18972 -- first a check. If we originally had a subtype, then we just label
18973 -- the range with this subtype. Not only is there no need to construct
18974 -- a new subtype, but it is wrong to do so for two reasons:
18975
18976 -- 1. A legality concern, if we have a subtype, it must not freeze,
18977 -- and the Itype would cause freezing incorrectly
18978
18979 -- 2. An efficiency concern, if we created an Itype, it would not be
18980 -- recognized as the same type for the purposes of eliminating
18981 -- checks in some circumstances.
18982
18983 -- We signal this case by setting the subtype entity in Def_Id
18984
18985 if No (Def_Id) then
18986 Def_Id :=
18987 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
18988 Set_Etype (Def_Id, Base_Type (T));
18989
18990 if Is_Signed_Integer_Type (T) then
18991 Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
18992
18993 elsif Is_Modular_Integer_Type (T) then
18994 Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
18995
18996 else
18997 Set_Ekind (Def_Id, E_Enumeration_Subtype);
18998 Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
18999 Set_First_Literal (Def_Id, First_Literal (T));
19000 end if;
19001
19002 Set_Size_Info (Def_Id, (T));
19003 Set_RM_Size (Def_Id, RM_Size (T));
19004 Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
19005
19006 Set_Scalar_Range (Def_Id, R);
19007 Conditional_Delay (Def_Id, T);
19008
19009 if Nkind (N) = N_Subtype_Indication then
19010 Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N)));
19011 end if;
19012
19013 -- In the subtype indication case, if the immediate parent of the
19014 -- new subtype is non-static, then the subtype we create is non-
19015 -- static, even if its bounds are static.
19016
19017 if Nkind (N) = N_Subtype_Indication
19018 and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
19019 then
19020 Set_Is_Non_Static_Subtype (Def_Id);
19021 end if;
19022 end if;
19023
19024 -- Final step is to label the index with this constructed type
19025
19026 Set_Etype (N, Def_Id);
19027 end Make_Index;
19028
19029 ------------------------------
19030 -- Modular_Type_Declaration --
19031 ------------------------------
19032
19033 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
19034 Mod_Expr : constant Node_Id := Expression (Def);
19035 M_Val : Uint;
19036
19037 procedure Set_Modular_Size (Bits : Int);
19038 -- Sets RM_Size to Bits, and Esize to normal word size above this
19039
19040 ----------------------
19041 -- Set_Modular_Size --
19042 ----------------------
19043
19044 procedure Set_Modular_Size (Bits : Int) is
19045 begin
19046 Set_RM_Size (T, UI_From_Int (Bits));
19047
19048 if Bits <= 8 then
19049 Init_Esize (T, 8);
19050
19051 elsif Bits <= 16 then
19052 Init_Esize (T, 16);
19053
19054 elsif Bits <= 32 then
19055 Init_Esize (T, 32);
19056
19057 else
19058 Init_Esize (T, System_Max_Binary_Modulus_Power);
19059 end if;
19060
19061 if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then
19062 Set_Is_Known_Valid (T);
19063 end if;
19064 end Set_Modular_Size;
19065
19066 -- Start of processing for Modular_Type_Declaration
19067
19068 begin
19069 -- If the mod expression is (exactly) 2 * literal, where literal is
19070 -- 64 or less,then almost certainly the * was meant to be **. Warn.
19071
19072 if Warn_On_Suspicious_Modulus_Value
19073 and then Nkind (Mod_Expr) = N_Op_Multiply
19074 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal
19075 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2
19076 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
19077 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
19078 then
19079 Error_Msg_N
19080 ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr);
19081 end if;
19082
19083 -- Proceed with analysis of mod expression
19084
19085 Analyze_And_Resolve (Mod_Expr, Any_Integer);
19086 Set_Etype (T, T);
19087 Set_Ekind (T, E_Modular_Integer_Type);
19088 Init_Alignment (T);
19089 Set_Is_Constrained (T);
19090
19091 if not Is_OK_Static_Expression (Mod_Expr) then
19092 Flag_Non_Static_Expr
19093 ("non-static expression used for modular type bound!", Mod_Expr);
19094 M_Val := 2 ** System_Max_Binary_Modulus_Power;
19095 else
19096 M_Val := Expr_Value (Mod_Expr);
19097 end if;
19098
19099 if M_Val < 1 then
19100 Error_Msg_N ("modulus value must be positive", Mod_Expr);
19101 M_Val := 2 ** System_Max_Binary_Modulus_Power;
19102 end if;
19103
19104 if M_Val > 2 ** Standard_Long_Integer_Size then
19105 Check_Restriction (No_Long_Long_Integers, Mod_Expr);
19106 end if;
19107
19108 Set_Modulus (T, M_Val);
19109
19110 -- Create bounds for the modular type based on the modulus given in
19111 -- the type declaration and then analyze and resolve those bounds.
19112
19113 Set_Scalar_Range (T,
19114 Make_Range (Sloc (Mod_Expr),
19115 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0),
19116 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
19117
19118 -- Properly analyze the literals for the range. We do this manually
19119 -- because we can't go calling Resolve, since we are resolving these
19120 -- bounds with the type, and this type is certainly not complete yet.
19121
19122 Set_Etype (Low_Bound (Scalar_Range (T)), T);
19123 Set_Etype (High_Bound (Scalar_Range (T)), T);
19124 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T)));
19125 Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
19126
19127 -- Loop through powers of two to find number of bits required
19128
19129 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
19130
19131 -- Binary case
19132
19133 if M_Val = 2 ** Bits then
19134 Set_Modular_Size (Bits);
19135 return;
19136
19137 -- Nonbinary case
19138
19139 elsif M_Val < 2 ** Bits then
19140 Check_SPARK_05_Restriction ("modulus should be a power of 2", T);
19141 Set_Non_Binary_Modulus (T);
19142
19143 if Bits > System_Max_Nonbinary_Modulus_Power then
19144 Error_Msg_Uint_1 :=
19145 UI_From_Int (System_Max_Nonbinary_Modulus_Power);
19146 Error_Msg_F
19147 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
19148 Set_Modular_Size (System_Max_Binary_Modulus_Power);
19149 return;
19150
19151 else
19152 -- In the nonbinary case, set size as per RM 13.3(55)
19153
19154 Set_Modular_Size (Bits);
19155 return;
19156 end if;
19157 end if;
19158
19159 end loop;
19160
19161 -- If we fall through, then the size exceed System.Max_Binary_Modulus
19162 -- so we just signal an error and set the maximum size.
19163
19164 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
19165 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
19166
19167 Set_Modular_Size (System_Max_Binary_Modulus_Power);
19168 Init_Alignment (T);
19169
19170 end Modular_Type_Declaration;
19171
19172 --------------------------
19173 -- New_Concatenation_Op --
19174 --------------------------
19175
19176 procedure New_Concatenation_Op (Typ : Entity_Id) is
19177 Loc : constant Source_Ptr := Sloc (Typ);
19178 Op : Entity_Id;
19179
19180 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
19181 -- Create abbreviated declaration for the formal of a predefined
19182 -- Operator 'Op' of type 'Typ'
19183
19184 --------------------
19185 -- Make_Op_Formal --
19186 --------------------
19187
19188 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
19189 Formal : Entity_Id;
19190 begin
19191 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
19192 Set_Etype (Formal, Typ);
19193 Set_Mechanism (Formal, Default_Mechanism);
19194 return Formal;
19195 end Make_Op_Formal;
19196
19197 -- Start of processing for New_Concatenation_Op
19198
19199 begin
19200 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
19201
19202 Set_Ekind (Op, E_Operator);
19203 Set_Scope (Op, Current_Scope);
19204 Set_Etype (Op, Typ);
19205 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
19206 Set_Is_Immediately_Visible (Op);
19207 Set_Is_Intrinsic_Subprogram (Op);
19208 Set_Has_Completion (Op);
19209 Append_Entity (Op, Current_Scope);
19210
19211 Set_Name_Entity_Id (Name_Op_Concat, Op);
19212
19213 Append_Entity (Make_Op_Formal (Typ, Op), Op);
19214 Append_Entity (Make_Op_Formal (Typ, Op), Op);
19215 end New_Concatenation_Op;
19216
19217 -------------------------
19218 -- OK_For_Limited_Init --
19219 -------------------------
19220
19221 -- ???Check all calls of this, and compare the conditions under which it's
19222 -- called.
19223
19224 function OK_For_Limited_Init
19225 (Typ : Entity_Id;
19226 Exp : Node_Id) return Boolean
19227 is
19228 begin
19229 return Is_CPP_Constructor_Call (Exp)
19230 or else (Ada_Version >= Ada_2005
19231 and then not Debug_Flag_Dot_L
19232 and then OK_For_Limited_Init_In_05 (Typ, Exp));
19233 end OK_For_Limited_Init;
19234
19235 -------------------------------
19236 -- OK_For_Limited_Init_In_05 --
19237 -------------------------------
19238
19239 function OK_For_Limited_Init_In_05
19240 (Typ : Entity_Id;
19241 Exp : Node_Id) return Boolean
19242 is
19243 begin
19244 -- An object of a limited interface type can be initialized with any
19245 -- expression of a nonlimited descendant type. However this does not
19246 -- apply if this is a view conversion of some other expression. This
19247 -- is checked below.
19248
19249 if Is_Class_Wide_Type (Typ)
19250 and then Is_Limited_Interface (Typ)
19251 and then not Is_Limited_Type (Etype (Exp))
19252 and then Nkind (Exp) /= N_Type_Conversion
19253 then
19254 return True;
19255 end if;
19256
19257 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
19258 -- case of limited aggregates (including extension aggregates), and
19259 -- function calls. The function call may have been given in prefixed
19260 -- notation, in which case the original node is an indexed component.
19261 -- If the function is parameterless, the original node was an explicit
19262 -- dereference. The function may also be parameterless, in which case
19263 -- the source node is just an identifier.
19264
19265 -- A branch of a conditional expression may have been removed if the
19266 -- condition is statically known. This happens during expansion, and
19267 -- thus will not happen if previous errors were encountered. The check
19268 -- will have been performed on the chosen branch, which replaces the
19269 -- original conditional expression.
19270
19271 if No (Exp) then
19272 return True;
19273 end if;
19274
19275 case Nkind (Original_Node (Exp)) is
19276 when N_Aggregate
19277 | N_Extension_Aggregate
19278 | N_Function_Call
19279 | N_Op
19280 =>
19281 return True;
19282
19283 when N_Identifier =>
19284 return Present (Entity (Original_Node (Exp)))
19285 and then Ekind (Entity (Original_Node (Exp))) = E_Function;
19286
19287 when N_Qualified_Expression =>
19288 return
19289 OK_For_Limited_Init_In_05
19290 (Typ, Expression (Original_Node (Exp)));
19291
19292 -- Ada 2005 (AI-251): If a class-wide interface object is initialized
19293 -- with a function call, the expander has rewritten the call into an
19294 -- N_Type_Conversion node to force displacement of the pointer to
19295 -- reference the component containing the secondary dispatch table.
19296 -- Otherwise a type conversion is not a legal context.
19297 -- A return statement for a build-in-place function returning a
19298 -- synchronized type also introduces an unchecked conversion.
19299
19300 when N_Type_Conversion
19301 | N_Unchecked_Type_Conversion
19302 =>
19303 return not Comes_From_Source (Exp)
19304 and then
19305 OK_For_Limited_Init_In_05
19306 (Typ, Expression (Original_Node (Exp)));
19307
19308 when N_Explicit_Dereference
19309 | N_Indexed_Component
19310 | N_Selected_Component
19311 =>
19312 return Nkind (Exp) = N_Function_Call;
19313
19314 -- A use of 'Input is a function call, hence allowed. Normally the
19315 -- attribute will be changed to a call, but the attribute by itself
19316 -- can occur with -gnatc.
19317
19318 when N_Attribute_Reference =>
19319 return Attribute_Name (Original_Node (Exp)) = Name_Input;
19320
19321 -- For a case expression, all dependent expressions must be legal
19322
19323 when N_Case_Expression =>
19324 declare
19325 Alt : Node_Id;
19326
19327 begin
19328 Alt := First (Alternatives (Original_Node (Exp)));
19329 while Present (Alt) loop
19330 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
19331 return False;
19332 end if;
19333
19334 Next (Alt);
19335 end loop;
19336
19337 return True;
19338 end;
19339
19340 -- For an if expression, all dependent expressions must be legal
19341
19342 when N_If_Expression =>
19343 declare
19344 Then_Expr : constant Node_Id :=
19345 Next (First (Expressions (Original_Node (Exp))));
19346 Else_Expr : constant Node_Id := Next (Then_Expr);
19347 begin
19348 return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
19349 and then
19350 OK_For_Limited_Init_In_05 (Typ, Else_Expr);
19351 end;
19352
19353 when others =>
19354 return False;
19355 end case;
19356 end OK_For_Limited_Init_In_05;
19357
19358 -------------------------------------------
19359 -- Ordinary_Fixed_Point_Type_Declaration --
19360 -------------------------------------------
19361
19362 procedure Ordinary_Fixed_Point_Type_Declaration
19363 (T : Entity_Id;
19364 Def : Node_Id)
19365 is
19366 Loc : constant Source_Ptr := Sloc (Def);
19367 Delta_Expr : constant Node_Id := Delta_Expression (Def);
19368 RRS : constant Node_Id := Real_Range_Specification (Def);
19369 Implicit_Base : Entity_Id;
19370 Delta_Val : Ureal;
19371 Small_Val : Ureal;
19372 Low_Val : Ureal;
19373 High_Val : Ureal;
19374
19375 begin
19376 Check_Restriction (No_Fixed_Point, Def);
19377
19378 -- Create implicit base type
19379
19380 Implicit_Base :=
19381 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
19382 Set_Etype (Implicit_Base, Implicit_Base);
19383
19384 -- Analyze and process delta expression
19385
19386 Analyze_And_Resolve (Delta_Expr, Any_Real);
19387
19388 Check_Delta_Expression (Delta_Expr);
19389 Delta_Val := Expr_Value_R (Delta_Expr);
19390
19391 Set_Delta_Value (Implicit_Base, Delta_Val);
19392
19393 -- Compute default small from given delta, which is the largest power
19394 -- of two that does not exceed the given delta value.
19395
19396 declare
19397 Tmp : Ureal;
19398 Scale : Int;
19399
19400 begin
19401 Tmp := Ureal_1;
19402 Scale := 0;
19403
19404 if Delta_Val < Ureal_1 then
19405 while Delta_Val < Tmp loop
19406 Tmp := Tmp / Ureal_2;
19407 Scale := Scale + 1;
19408 end loop;
19409
19410 else
19411 loop
19412 Tmp := Tmp * Ureal_2;
19413 exit when Tmp > Delta_Val;
19414 Scale := Scale - 1;
19415 end loop;
19416 end if;
19417
19418 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
19419 end;
19420
19421 Set_Small_Value (Implicit_Base, Small_Val);
19422
19423 -- If no range was given, set a dummy range
19424
19425 if RRS <= Empty_Or_Error then
19426 Low_Val := -Small_Val;
19427 High_Val := Small_Val;
19428
19429 -- Otherwise analyze and process given range
19430
19431 else
19432 declare
19433 Low : constant Node_Id := Low_Bound (RRS);
19434 High : constant Node_Id := High_Bound (RRS);
19435
19436 begin
19437 Analyze_And_Resolve (Low, Any_Real);
19438 Analyze_And_Resolve (High, Any_Real);
19439 Check_Real_Bound (Low);
19440 Check_Real_Bound (High);
19441
19442 -- Obtain and set the range
19443
19444 Low_Val := Expr_Value_R (Low);
19445 High_Val := Expr_Value_R (High);
19446
19447 if Low_Val > High_Val then
19448 Error_Msg_NE ("??fixed point type& has null range", Def, T);
19449 end if;
19450 end;
19451 end if;
19452
19453 -- The range for both the implicit base and the declared first subtype
19454 -- cannot be set yet, so we use the special routine Set_Fixed_Range to
19455 -- set a temporary range in place. Note that the bounds of the base
19456 -- type will be widened to be symmetrical and to fill the available
19457 -- bits when the type is frozen.
19458
19459 -- We could do this with all discrete types, and probably should, but
19460 -- we absolutely have to do it for fixed-point, since the end-points
19461 -- of the range and the size are determined by the small value, which
19462 -- could be reset before the freeze point.
19463
19464 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
19465 Set_Fixed_Range (T, Loc, Low_Val, High_Val);
19466
19467 -- Complete definition of first subtype. The inheritance of the rep item
19468 -- chain ensures that SPARK-related pragmas are not clobbered when the
19469 -- ordinary fixed point type acts as a full view of a private type.
19470
19471 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
19472 Set_Etype (T, Implicit_Base);
19473 Init_Size_Align (T);
19474 Inherit_Rep_Item_Chain (T, Implicit_Base);
19475 Set_Small_Value (T, Small_Val);
19476 Set_Delta_Value (T, Delta_Val);
19477 Set_Is_Constrained (T);
19478 end Ordinary_Fixed_Point_Type_Declaration;
19479
19480 ----------------------------------
19481 -- Preanalyze_Assert_Expression --
19482 ----------------------------------
19483
19484 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
19485 begin
19486 In_Assertion_Expr := In_Assertion_Expr + 1;
19487 Preanalyze_Spec_Expression (N, T);
19488 In_Assertion_Expr := In_Assertion_Expr - 1;
19489 end Preanalyze_Assert_Expression;
19490
19491 -----------------------------------
19492 -- Preanalyze_Default_Expression --
19493 -----------------------------------
19494
19495 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
19496 Save_In_Default_Expr : constant Boolean := In_Default_Expr;
19497 begin
19498 In_Default_Expr := True;
19499 Preanalyze_Spec_Expression (N, T);
19500 In_Default_Expr := Save_In_Default_Expr;
19501 end Preanalyze_Default_Expression;
19502
19503 --------------------------------
19504 -- Preanalyze_Spec_Expression --
19505 --------------------------------
19506
19507 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
19508 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
19509 begin
19510 In_Spec_Expression := True;
19511 Preanalyze_And_Resolve (N, T);
19512 In_Spec_Expression := Save_In_Spec_Expression;
19513 end Preanalyze_Spec_Expression;
19514
19515 ----------------------------------------
19516 -- Prepare_Private_Subtype_Completion --
19517 ----------------------------------------
19518
19519 procedure Prepare_Private_Subtype_Completion
19520 (Id : Entity_Id;
19521 Related_Nod : Node_Id)
19522 is
19523 Id_B : constant Entity_Id := Base_Type (Id);
19524 Full_B : Entity_Id := Full_View (Id_B);
19525 Full : Entity_Id;
19526
19527 begin
19528 if Present (Full_B) then
19529
19530 -- Get to the underlying full view if necessary
19531
19532 if Is_Private_Type (Full_B)
19533 and then Present (Underlying_Full_View (Full_B))
19534 then
19535 Full_B := Underlying_Full_View (Full_B);
19536 end if;
19537
19538 -- The Base_Type is already completed, we can complete the subtype
19539 -- now. We have to create a new entity with the same name, Thus we
19540 -- can't use Create_Itype.
19541
19542 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
19543 Set_Is_Itype (Full);
19544 Set_Associated_Node_For_Itype (Full, Related_Nod);
19545 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
19546 end if;
19547
19548 -- The parent subtype may be private, but the base might not, in some
19549 -- nested instances. In that case, the subtype does not need to be
19550 -- exchanged. It would still be nice to make private subtypes and their
19551 -- bases consistent at all times ???
19552
19553 if Is_Private_Type (Id_B) then
19554 Append_Elmt (Id, Private_Dependents (Id_B));
19555 end if;
19556 end Prepare_Private_Subtype_Completion;
19557
19558 ---------------------------
19559 -- Process_Discriminants --
19560 ---------------------------
19561
19562 procedure Process_Discriminants
19563 (N : Node_Id;
19564 Prev : Entity_Id := Empty)
19565 is
19566 Elist : constant Elist_Id := New_Elmt_List;
19567 Id : Node_Id;
19568 Discr : Node_Id;
19569 Discr_Number : Uint;
19570 Discr_Type : Entity_Id;
19571 Default_Present : Boolean := False;
19572 Default_Not_Present : Boolean := False;
19573
19574 begin
19575 -- A composite type other than an array type can have discriminants.
19576 -- On entry, the current scope is the composite type.
19577
19578 -- The discriminants are initially entered into the scope of the type
19579 -- via Enter_Name with the default Ekind of E_Void to prevent premature
19580 -- use, as explained at the end of this procedure.
19581
19582 Discr := First (Discriminant_Specifications (N));
19583 while Present (Discr) loop
19584 Enter_Name (Defining_Identifier (Discr));
19585
19586 -- For navigation purposes we add a reference to the discriminant
19587 -- in the entity for the type. If the current declaration is a
19588 -- completion, place references on the partial view. Otherwise the
19589 -- type is the current scope.
19590
19591 if Present (Prev) then
19592
19593 -- The references go on the partial view, if present. If the
19594 -- partial view has discriminants, the references have been
19595 -- generated already.
19596
19597 if not Has_Discriminants (Prev) then
19598 Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
19599 end if;
19600 else
19601 Generate_Reference
19602 (Current_Scope, Defining_Identifier (Discr), 'd');
19603 end if;
19604
19605 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
19606 Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
19607
19608 -- Ada 2005 (AI-254)
19609
19610 if Present (Access_To_Subprogram_Definition
19611 (Discriminant_Type (Discr)))
19612 and then Protected_Present (Access_To_Subprogram_Definition
19613 (Discriminant_Type (Discr)))
19614 then
19615 Discr_Type :=
19616 Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
19617 end if;
19618
19619 else
19620 Find_Type (Discriminant_Type (Discr));
19621 Discr_Type := Etype (Discriminant_Type (Discr));
19622
19623 if Error_Posted (Discriminant_Type (Discr)) then
19624 Discr_Type := Any_Type;
19625 end if;
19626 end if;
19627
19628 -- Handling of discriminants that are access types
19629
19630 if Is_Access_Type (Discr_Type) then
19631
19632 -- Ada 2005 (AI-230): Access discriminant allowed in non-
19633 -- limited record types
19634
19635 if Ada_Version < Ada_2005 then
19636 Check_Access_Discriminant_Requires_Limited
19637 (Discr, Discriminant_Type (Discr));
19638 end if;
19639
19640 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
19641 Error_Msg_N
19642 ("(Ada 83) access discriminant not allowed", Discr);
19643 end if;
19644
19645 -- If not access type, must be a discrete type
19646
19647 elsif not Is_Discrete_Type (Discr_Type) then
19648 Error_Msg_N
19649 ("discriminants must have a discrete or access type",
19650 Discriminant_Type (Discr));
19651 end if;
19652
19653 Set_Etype (Defining_Identifier (Discr), Discr_Type);
19654
19655 -- If a discriminant specification includes the assignment compound
19656 -- delimiter followed by an expression, the expression is the default
19657 -- expression of the discriminant; the default expression must be of
19658 -- the type of the discriminant. (RM 3.7.1) Since this expression is
19659 -- a default expression, we do the special preanalysis, since this
19660 -- expression does not freeze (see section "Handling of Default and
19661 -- Per-Object Expressions" in spec of package Sem).
19662
19663 if Present (Expression (Discr)) then
19664 Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
19665
19666 -- Legaity checks
19667
19668 if Nkind (N) = N_Formal_Type_Declaration then
19669 Error_Msg_N
19670 ("discriminant defaults not allowed for formal type",
19671 Expression (Discr));
19672
19673 -- Flag an error for a tagged type with defaulted discriminants,
19674 -- excluding limited tagged types when compiling for Ada 2012
19675 -- (see AI05-0214).
19676
19677 elsif Is_Tagged_Type (Current_Scope)
19678 and then (not Is_Limited_Type (Current_Scope)
19679 or else Ada_Version < Ada_2012)
19680 and then Comes_From_Source (N)
19681 then
19682 -- Note: see similar test in Check_Or_Process_Discriminants, to
19683 -- handle the (illegal) case of the completion of an untagged
19684 -- view with discriminants with defaults by a tagged full view.
19685 -- We skip the check if Discr does not come from source, to
19686 -- account for the case of an untagged derived type providing
19687 -- defaults for a renamed discriminant from a private untagged
19688 -- ancestor with a tagged full view (ACATS B460006).
19689
19690 if Ada_Version >= Ada_2012 then
19691 Error_Msg_N
19692 ("discriminants of nonlimited tagged type cannot have"
19693 & " defaults",
19694 Expression (Discr));
19695 else
19696 Error_Msg_N
19697 ("discriminants of tagged type cannot have defaults",
19698 Expression (Discr));
19699 end if;
19700
19701 else
19702 Default_Present := True;
19703 Append_Elmt (Expression (Discr), Elist);
19704
19705 -- Tag the defining identifiers for the discriminants with
19706 -- their corresponding default expressions from the tree.
19707
19708 Set_Discriminant_Default_Value
19709 (Defining_Identifier (Discr), Expression (Discr));
19710 end if;
19711
19712 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag
19713 -- gets set unless we can be sure that no range check is required.
19714
19715 if (GNATprove_Mode or not Expander_Active)
19716 and then not
19717 Is_In_Range
19718 (Expression (Discr), Discr_Type, Assume_Valid => True)
19719 then
19720 Set_Do_Range_Check (Expression (Discr));
19721 end if;
19722
19723 -- No default discriminant value given
19724
19725 else
19726 Default_Not_Present := True;
19727 end if;
19728
19729 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
19730 -- Discr_Type but with the null-exclusion attribute
19731
19732 if Ada_Version >= Ada_2005 then
19733
19734 -- Ada 2005 (AI-231): Static checks
19735
19736 if Can_Never_Be_Null (Discr_Type) then
19737 Null_Exclusion_Static_Checks (Discr);
19738
19739 elsif Is_Access_Type (Discr_Type)
19740 and then Null_Exclusion_Present (Discr)
19741
19742 -- No need to check itypes because in their case this check
19743 -- was done at their point of creation
19744
19745 and then not Is_Itype (Discr_Type)
19746 then
19747 if Can_Never_Be_Null (Discr_Type) then
19748 Error_Msg_NE
19749 ("`NOT NULL` not allowed (& already excludes null)",
19750 Discr,
19751 Discr_Type);
19752 end if;
19753
19754 Set_Etype (Defining_Identifier (Discr),
19755 Create_Null_Excluding_Itype
19756 (T => Discr_Type,
19757 Related_Nod => Discr));
19758
19759 -- Check for improper null exclusion if the type is otherwise
19760 -- legal for a discriminant.
19761
19762 elsif Null_Exclusion_Present (Discr)
19763 and then Is_Discrete_Type (Discr_Type)
19764 then
19765 Error_Msg_N
19766 ("null exclusion can only apply to an access type", Discr);
19767 end if;
19768
19769 -- Ada 2005 (AI-402): access discriminants of nonlimited types
19770 -- can't have defaults. Synchronized types, or types that are
19771 -- explicitly limited are fine, but special tests apply to derived
19772 -- types in generics: in a generic body we have to assume the
19773 -- worst, and therefore defaults are not allowed if the parent is
19774 -- a generic formal private type (see ACATS B370001).
19775
19776 if Is_Access_Type (Discr_Type) and then Default_Present then
19777 if Ekind (Discr_Type) /= E_Anonymous_Access_Type
19778 or else Is_Limited_Record (Current_Scope)
19779 or else Is_Concurrent_Type (Current_Scope)
19780 or else Is_Concurrent_Record_Type (Current_Scope)
19781 or else Ekind (Current_Scope) = E_Limited_Private_Type
19782 then
19783 if not Is_Derived_Type (Current_Scope)
19784 or else not Is_Generic_Type (Etype (Current_Scope))
19785 or else not In_Package_Body (Scope (Etype (Current_Scope)))
19786 or else Limited_Present
19787 (Type_Definition (Parent (Current_Scope)))
19788 then
19789 null;
19790
19791 else
19792 Error_Msg_N
19793 ("access discriminants of nonlimited types cannot "
19794 & "have defaults", Expression (Discr));
19795 end if;
19796
19797 elsif Present (Expression (Discr)) then
19798 Error_Msg_N
19799 ("(Ada 2005) access discriminants of nonlimited types "
19800 & "cannot have defaults", Expression (Discr));
19801 end if;
19802 end if;
19803 end if;
19804
19805 -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)).
19806 -- This check is relevant only when SPARK_Mode is on as it is not a
19807 -- standard Ada legality rule.
19808
19809 if SPARK_Mode = On
19810 and then Is_Effectively_Volatile (Defining_Identifier (Discr))
19811 then
19812 Error_Msg_N ("discriminant cannot be volatile", Discr);
19813 end if;
19814
19815 Next (Discr);
19816 end loop;
19817
19818 -- An element list consisting of the default expressions of the
19819 -- discriminants is constructed in the above loop and used to set
19820 -- the Discriminant_Constraint attribute for the type. If an object
19821 -- is declared of this (record or task) type without any explicit
19822 -- discriminant constraint given, this element list will form the
19823 -- actual parameters for the corresponding initialization procedure
19824 -- for the type.
19825
19826 Set_Discriminant_Constraint (Current_Scope, Elist);
19827 Set_Stored_Constraint (Current_Scope, No_Elist);
19828
19829 -- Default expressions must be provided either for all or for none
19830 -- of the discriminants of a discriminant part. (RM 3.7.1)
19831
19832 if Default_Present and then Default_Not_Present then
19833 Error_Msg_N
19834 ("incomplete specification of defaults for discriminants", N);
19835 end if;
19836
19837 -- The use of the name of a discriminant is not allowed in default
19838 -- expressions of a discriminant part if the specification of the
19839 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
19840
19841 -- To detect this, the discriminant names are entered initially with an
19842 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
19843 -- attempt to use a void entity (for example in an expression that is
19844 -- type-checked) produces the error message: premature usage. Now after
19845 -- completing the semantic analysis of the discriminant part, we can set
19846 -- the Ekind of all the discriminants appropriately.
19847
19848 Discr := First (Discriminant_Specifications (N));
19849 Discr_Number := Uint_1;
19850 while Present (Discr) loop
19851 Id := Defining_Identifier (Discr);
19852 Set_Ekind (Id, E_Discriminant);
19853 Init_Component_Location (Id);
19854 Init_Esize (Id);
19855 Set_Discriminant_Number (Id, Discr_Number);
19856
19857 -- Make sure this is always set, even in illegal programs
19858
19859 Set_Corresponding_Discriminant (Id, Empty);
19860
19861 -- Initialize the Original_Record_Component to the entity itself.
19862 -- Inherit_Components will propagate the right value to
19863 -- discriminants in derived record types.
19864
19865 Set_Original_Record_Component (Id, Id);
19866
19867 -- Create the discriminal for the discriminant
19868
19869 Build_Discriminal (Id);
19870
19871 Next (Discr);
19872 Discr_Number := Discr_Number + 1;
19873 end loop;
19874
19875 Set_Has_Discriminants (Current_Scope);
19876 end Process_Discriminants;
19877
19878 -----------------------
19879 -- Process_Full_View --
19880 -----------------------
19881
19882 -- WARNING: This routine manages Ghost regions. Return statements must be
19883 -- replaced by gotos which jump to the end of the routine and restore the
19884 -- Ghost mode.
19885
19886 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
19887 procedure Collect_Implemented_Interfaces
19888 (Typ : Entity_Id;
19889 Ifaces : Elist_Id);
19890 -- Ada 2005: Gather all the interfaces that Typ directly or
19891 -- inherently implements. Duplicate entries are not added to
19892 -- the list Ifaces.
19893
19894 ------------------------------------
19895 -- Collect_Implemented_Interfaces --
19896 ------------------------------------
19897
19898 procedure Collect_Implemented_Interfaces
19899 (Typ : Entity_Id;
19900 Ifaces : Elist_Id)
19901 is
19902 Iface : Entity_Id;
19903 Iface_Elmt : Elmt_Id;
19904
19905 begin
19906 -- Abstract interfaces are only associated with tagged record types
19907
19908 if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then
19909 return;
19910 end if;
19911
19912 -- Recursively climb to the ancestors
19913
19914 if Etype (Typ) /= Typ
19915
19916 -- Protect the frontend against wrong cyclic declarations like:
19917
19918 -- type B is new A with private;
19919 -- type C is new A with private;
19920 -- private
19921 -- type B is new C with null record;
19922 -- type C is new B with null record;
19923
19924 and then Etype (Typ) /= Priv_T
19925 and then Etype (Typ) /= Full_T
19926 then
19927 -- Keep separate the management of private type declarations
19928
19929 if Ekind (Typ) = E_Record_Type_With_Private then
19930
19931 -- Handle the following illegal usage:
19932 -- type Private_Type is tagged private;
19933 -- private
19934 -- type Private_Type is new Type_Implementing_Iface;
19935
19936 if Present (Full_View (Typ))
19937 and then Etype (Typ) /= Full_View (Typ)
19938 then
19939 if Is_Interface (Etype (Typ)) then
19940 Append_Unique_Elmt (Etype (Typ), Ifaces);
19941 end if;
19942
19943 Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
19944 end if;
19945
19946 -- Non-private types
19947
19948 else
19949 if Is_Interface (Etype (Typ)) then
19950 Append_Unique_Elmt (Etype (Typ), Ifaces);
19951 end if;
19952
19953 Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
19954 end if;
19955 end if;
19956
19957 -- Handle entities in the list of abstract interfaces
19958
19959 if Present (Interfaces (Typ)) then
19960 Iface_Elmt := First_Elmt (Interfaces (Typ));
19961 while Present (Iface_Elmt) loop
19962 Iface := Node (Iface_Elmt);
19963
19964 pragma Assert (Is_Interface (Iface));
19965
19966 if not Contain_Interface (Iface, Ifaces) then
19967 Append_Elmt (Iface, Ifaces);
19968 Collect_Implemented_Interfaces (Iface, Ifaces);
19969 end if;
19970
19971 Next_Elmt (Iface_Elmt);
19972 end loop;
19973 end if;
19974 end Collect_Implemented_Interfaces;
19975
19976 -- Local variables
19977
19978 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
19979
19980 Full_Indic : Node_Id;
19981 Full_Parent : Entity_Id;
19982 Priv_Parent : Entity_Id;
19983
19984 -- Start of processing for Process_Full_View
19985
19986 begin
19987 Mark_And_Set_Ghost_Completion (N, Priv_T);
19988
19989 -- First some sanity checks that must be done after semantic
19990 -- decoration of the full view and thus cannot be placed with other
19991 -- similar checks in Find_Type_Name
19992
19993 if not Is_Limited_Type (Priv_T)
19994 and then (Is_Limited_Type (Full_T)
19995 or else Is_Limited_Composite (Full_T))
19996 then
19997 if In_Instance then
19998 null;
19999 else
20000 Error_Msg_N
20001 ("completion of nonlimited type cannot be limited", Full_T);
20002 Explain_Limited_Type (Full_T, Full_T);
20003 end if;
20004
20005 elsif Is_Abstract_Type (Full_T)
20006 and then not Is_Abstract_Type (Priv_T)
20007 then
20008 Error_Msg_N
20009 ("completion of nonabstract type cannot be abstract", Full_T);
20010
20011 elsif Is_Tagged_Type (Priv_T)
20012 and then Is_Limited_Type (Priv_T)
20013 and then not Is_Limited_Type (Full_T)
20014 then
20015 -- If pragma CPP_Class was applied to the private declaration
20016 -- propagate the limitedness to the full-view
20017
20018 if Is_CPP_Class (Priv_T) then
20019 Set_Is_Limited_Record (Full_T);
20020
20021 -- GNAT allow its own definition of Limited_Controlled to disobey
20022 -- this rule in order in ease the implementation. This test is safe
20023 -- because Root_Controlled is defined in a child of System that
20024 -- normal programs are not supposed to use.
20025
20026 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
20027 Set_Is_Limited_Composite (Full_T);
20028 else
20029 Error_Msg_N
20030 ("completion of limited tagged type must be limited", Full_T);
20031 end if;
20032
20033 elsif Is_Generic_Type (Priv_T) then
20034 Error_Msg_N ("generic type cannot have a completion", Full_T);
20035 end if;
20036
20037 -- Check that ancestor interfaces of private and full views are
20038 -- consistent. We omit this check for synchronized types because
20039 -- they are performed on the corresponding record type when frozen.
20040
20041 if Ada_Version >= Ada_2005
20042 and then Is_Tagged_Type (Priv_T)
20043 and then Is_Tagged_Type (Full_T)
20044 and then not Is_Concurrent_Type (Full_T)
20045 then
20046 declare
20047 Iface : Entity_Id;
20048 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
20049 Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
20050
20051 begin
20052 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
20053 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
20054
20055 -- Ada 2005 (AI-251): The partial view shall be a descendant of
20056 -- an interface type if and only if the full type is descendant
20057 -- of the interface type (AARM 7.3 (7.3/2)).
20058
20059 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
20060
20061 if Present (Iface) then
20062 Error_Msg_NE
20063 ("interface in partial view& not implemented by full type "
20064 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
20065 end if;
20066
20067 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
20068
20069 if Present (Iface) then
20070 Error_Msg_NE
20071 ("interface & not implemented by partial view "
20072 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
20073 end if;
20074 end;
20075 end if;
20076
20077 if Is_Tagged_Type (Priv_T)
20078 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
20079 and then Is_Derived_Type (Full_T)
20080 then
20081 Priv_Parent := Etype (Priv_T);
20082
20083 -- The full view of a private extension may have been transformed
20084 -- into an unconstrained derived type declaration and a subtype
20085 -- declaration (see build_derived_record_type for details).
20086
20087 if Nkind (N) = N_Subtype_Declaration then
20088 Full_Indic := Subtype_Indication (N);
20089 Full_Parent := Etype (Base_Type (Full_T));
20090 else
20091 Full_Indic := Subtype_Indication (Type_Definition (N));
20092 Full_Parent := Etype (Full_T);
20093 end if;
20094
20095 -- Check that the parent type of the full type is a descendant of
20096 -- the ancestor subtype given in the private extension. If either
20097 -- entity has an Etype equal to Any_Type then we had some previous
20098 -- error situation [7.3(8)].
20099
20100 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
20101 goto Leave;
20102
20103 -- Ada 2005 (AI-251): Interfaces in the full type can be given in
20104 -- any order. Therefore we don't have to check that its parent must
20105 -- be a descendant of the parent of the private type declaration.
20106
20107 elsif Is_Interface (Priv_Parent)
20108 and then Is_Interface (Full_Parent)
20109 then
20110 null;
20111
20112 -- Ada 2005 (AI-251): If the parent of the private type declaration
20113 -- is an interface there is no need to check that it is an ancestor
20114 -- of the associated full type declaration. The required tests for
20115 -- this case are performed by Build_Derived_Record_Type.
20116
20117 elsif not Is_Interface (Base_Type (Priv_Parent))
20118 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
20119 then
20120 Error_Msg_N
20121 ("parent of full type must descend from parent of private "
20122 & "extension", Full_Indic);
20123
20124 -- First check a formal restriction, and then proceed with checking
20125 -- Ada rules. Since the formal restriction is not a serious error, we
20126 -- don't prevent further error detection for this check, hence the
20127 -- ELSE.
20128
20129 else
20130 -- In formal mode, when completing a private extension the type
20131 -- named in the private part must be exactly the same as that
20132 -- named in the visible part.
20133
20134 if Priv_Parent /= Full_Parent then
20135 Error_Msg_Name_1 := Chars (Priv_Parent);
20136 Check_SPARK_05_Restriction ("% expected", Full_Indic);
20137 end if;
20138
20139 -- Check the rules of 7.3(10): if the private extension inherits
20140 -- known discriminants, then the full type must also inherit those
20141 -- discriminants from the same (ancestor) type, and the parent
20142 -- subtype of the full type must be constrained if and only if
20143 -- the ancestor subtype of the private extension is constrained.
20144
20145 if No (Discriminant_Specifications (Parent (Priv_T)))
20146 and then not Has_Unknown_Discriminants (Priv_T)
20147 and then Has_Discriminants (Base_Type (Priv_Parent))
20148 then
20149 declare
20150 Priv_Indic : constant Node_Id :=
20151 Subtype_Indication (Parent (Priv_T));
20152
20153 Priv_Constr : constant Boolean :=
20154 Is_Constrained (Priv_Parent)
20155 or else
20156 Nkind (Priv_Indic) = N_Subtype_Indication
20157 or else
20158 Is_Constrained (Entity (Priv_Indic));
20159
20160 Full_Constr : constant Boolean :=
20161 Is_Constrained (Full_Parent)
20162 or else
20163 Nkind (Full_Indic) = N_Subtype_Indication
20164 or else
20165 Is_Constrained (Entity (Full_Indic));
20166
20167 Priv_Discr : Entity_Id;
20168 Full_Discr : Entity_Id;
20169
20170 begin
20171 Priv_Discr := First_Discriminant (Priv_Parent);
20172 Full_Discr := First_Discriminant (Full_Parent);
20173 while Present (Priv_Discr) and then Present (Full_Discr) loop
20174 if Original_Record_Component (Priv_Discr) =
20175 Original_Record_Component (Full_Discr)
20176 or else
20177 Corresponding_Discriminant (Priv_Discr) =
20178 Corresponding_Discriminant (Full_Discr)
20179 then
20180 null;
20181 else
20182 exit;
20183 end if;
20184
20185 Next_Discriminant (Priv_Discr);
20186 Next_Discriminant (Full_Discr);
20187 end loop;
20188
20189 if Present (Priv_Discr) or else Present (Full_Discr) then
20190 Error_Msg_N
20191 ("full view must inherit discriminants of the parent "
20192 & "type used in the private extension", Full_Indic);
20193
20194 elsif Priv_Constr and then not Full_Constr then
20195 Error_Msg_N
20196 ("parent subtype of full type must be constrained",
20197 Full_Indic);
20198
20199 elsif Full_Constr and then not Priv_Constr then
20200 Error_Msg_N
20201 ("parent subtype of full type must be unconstrained",
20202 Full_Indic);
20203 end if;
20204 end;
20205
20206 -- Check the rules of 7.3(12): if a partial view has neither
20207 -- known or unknown discriminants, then the full type
20208 -- declaration shall define a definite subtype.
20209
20210 elsif not Has_Unknown_Discriminants (Priv_T)
20211 and then not Has_Discriminants (Priv_T)
20212 and then not Is_Constrained (Full_T)
20213 then
20214 Error_Msg_N
20215 ("full view must define a constrained type if partial view "
20216 & "has no discriminants", Full_T);
20217 end if;
20218
20219 -- ??????? Do we implement the following properly ?????
20220 -- If the ancestor subtype of a private extension has constrained
20221 -- discriminants, then the parent subtype of the full view shall
20222 -- impose a statically matching constraint on those discriminants
20223 -- [7.3(13)].
20224 end if;
20225
20226 else
20227 -- For untagged types, verify that a type without discriminants is
20228 -- not completed with an unconstrained type. A separate error message
20229 -- is produced if the full type has defaulted discriminants.
20230
20231 if Is_Definite_Subtype (Priv_T)
20232 and then not Is_Definite_Subtype (Full_T)
20233 then
20234 Error_Msg_Sloc := Sloc (Parent (Priv_T));
20235 Error_Msg_NE
20236 ("full view of& not compatible with declaration#",
20237 Full_T, Priv_T);
20238
20239 if not Is_Tagged_Type (Full_T) then
20240 Error_Msg_N
20241 ("\one is constrained, the other unconstrained", Full_T);
20242 end if;
20243 end if;
20244 end if;
20245
20246 -- AI-419: verify that the use of "limited" is consistent
20247
20248 declare
20249 Orig_Decl : constant Node_Id := Original_Node (N);
20250
20251 begin
20252 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
20253 and then Nkind (Orig_Decl) = N_Full_Type_Declaration
20254 and then Nkind
20255 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
20256 then
20257 if not Limited_Present (Parent (Priv_T))
20258 and then not Synchronized_Present (Parent (Priv_T))
20259 and then Limited_Present (Type_Definition (Orig_Decl))
20260 then
20261 Error_Msg_N
20262 ("full view of non-limited extension cannot be limited", N);
20263
20264 -- Conversely, if the partial view carries the limited keyword,
20265 -- the full view must as well, even if it may be redundant.
20266
20267 elsif Limited_Present (Parent (Priv_T))
20268 and then not Limited_Present (Type_Definition (Orig_Decl))
20269 then
20270 Error_Msg_N
20271 ("full view of limited extension must be explicitly limited",
20272 N);
20273 end if;
20274 end if;
20275 end;
20276
20277 -- Ada 2005 (AI-443): A synchronized private extension must be
20278 -- completed by a task or protected type.
20279
20280 if Ada_Version >= Ada_2005
20281 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
20282 and then Synchronized_Present (Parent (Priv_T))
20283 and then not Is_Concurrent_Type (Full_T)
20284 then
20285 Error_Msg_N ("full view of synchronized extension must " &
20286 "be synchronized type", N);
20287 end if;
20288
20289 -- Ada 2005 AI-363: if the full view has discriminants with
20290 -- defaults, it is illegal to declare constrained access subtypes
20291 -- whose designated type is the current type. This allows objects
20292 -- of the type that are declared in the heap to be unconstrained.
20293
20294 if not Has_Unknown_Discriminants (Priv_T)
20295 and then not Has_Discriminants (Priv_T)
20296 and then Has_Discriminants (Full_T)
20297 and then
20298 Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
20299 then
20300 Set_Has_Constrained_Partial_View (Full_T);
20301 Set_Has_Constrained_Partial_View (Priv_T);
20302 end if;
20303
20304 -- Create a full declaration for all its subtypes recorded in
20305 -- Private_Dependents and swap them similarly to the base type. These
20306 -- are subtypes that have been define before the full declaration of
20307 -- the private type. We also swap the entry in Private_Dependents list
20308 -- so we can properly restore the private view on exit from the scope.
20309
20310 declare
20311 Priv_Elmt : Elmt_Id;
20312 Priv_Scop : Entity_Id;
20313 Priv : Entity_Id;
20314 Full : Entity_Id;
20315
20316 begin
20317 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
20318 while Present (Priv_Elmt) loop
20319 Priv := Node (Priv_Elmt);
20320 Priv_Scop := Scope (Priv);
20321
20322 if Ekind_In (Priv, E_Private_Subtype,
20323 E_Limited_Private_Subtype,
20324 E_Record_Subtype_With_Private)
20325 then
20326 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
20327 Set_Is_Itype (Full);
20328 Set_Parent (Full, Parent (Priv));
20329 Set_Associated_Node_For_Itype (Full, N);
20330
20331 -- Now we need to complete the private subtype, but since the
20332 -- base type has already been swapped, we must also swap the
20333 -- subtypes (and thus, reverse the arguments in the call to
20334 -- Complete_Private_Subtype). Also note that we may need to
20335 -- re-establish the scope of the private subtype.
20336
20337 Copy_And_Swap (Priv, Full);
20338
20339 if not In_Open_Scopes (Priv_Scop) then
20340 Push_Scope (Priv_Scop);
20341
20342 else
20343 -- Reset Priv_Scop to Empty to indicate no scope was pushed
20344
20345 Priv_Scop := Empty;
20346 end if;
20347
20348 Complete_Private_Subtype (Full, Priv, Full_T, N);
20349
20350 if Present (Priv_Scop) then
20351 Pop_Scope;
20352 end if;
20353
20354 Replace_Elmt (Priv_Elmt, Full);
20355 end if;
20356
20357 Next_Elmt (Priv_Elmt);
20358 end loop;
20359 end;
20360
20361 -- If the private view was tagged, copy the new primitive operations
20362 -- from the private view to the full view.
20363
20364 if Is_Tagged_Type (Full_T) then
20365 declare
20366 Disp_Typ : Entity_Id;
20367 Full_List : Elist_Id;
20368 Prim : Entity_Id;
20369 Prim_Elmt : Elmt_Id;
20370 Priv_List : Elist_Id;
20371
20372 function Contains
20373 (E : Entity_Id;
20374 L : Elist_Id) return Boolean;
20375 -- Determine whether list L contains element E
20376
20377 --------------
20378 -- Contains --
20379 --------------
20380
20381 function Contains
20382 (E : Entity_Id;
20383 L : Elist_Id) return Boolean
20384 is
20385 List_Elmt : Elmt_Id;
20386
20387 begin
20388 List_Elmt := First_Elmt (L);
20389 while Present (List_Elmt) loop
20390 if Node (List_Elmt) = E then
20391 return True;
20392 end if;
20393
20394 Next_Elmt (List_Elmt);
20395 end loop;
20396
20397 return False;
20398 end Contains;
20399
20400 -- Start of processing
20401
20402 begin
20403 if Is_Tagged_Type (Priv_T) then
20404 Priv_List := Primitive_Operations (Priv_T);
20405 Prim_Elmt := First_Elmt (Priv_List);
20406
20407 -- In the case of a concurrent type completing a private tagged
20408 -- type, primitives may have been declared in between the two
20409 -- views. These subprograms need to be wrapped the same way
20410 -- entries and protected procedures are handled because they
20411 -- cannot be directly shared by the two views.
20412
20413 if Is_Concurrent_Type (Full_T) then
20414 declare
20415 Conc_Typ : constant Entity_Id :=
20416 Corresponding_Record_Type (Full_T);
20417 Curr_Nod : Node_Id := Parent (Conc_Typ);
20418 Wrap_Spec : Node_Id;
20419
20420 begin
20421 while Present (Prim_Elmt) loop
20422 Prim := Node (Prim_Elmt);
20423
20424 if Comes_From_Source (Prim)
20425 and then not Is_Abstract_Subprogram (Prim)
20426 then
20427 Wrap_Spec :=
20428 Make_Subprogram_Declaration (Sloc (Prim),
20429 Specification =>
20430 Build_Wrapper_Spec
20431 (Subp_Id => Prim,
20432 Obj_Typ => Conc_Typ,
20433 Formals =>
20434 Parameter_Specifications
20435 (Parent (Prim))));
20436
20437 Insert_After (Curr_Nod, Wrap_Spec);
20438 Curr_Nod := Wrap_Spec;
20439
20440 Analyze (Wrap_Spec);
20441
20442 -- Remove the wrapper from visibility to avoid
20443 -- spurious conflict with the wrapped entity.
20444
20445 Set_Is_Immediately_Visible
20446 (Defining_Entity (Specification (Wrap_Spec)),
20447 False);
20448 end if;
20449
20450 Next_Elmt (Prim_Elmt);
20451 end loop;
20452
20453 goto Leave;
20454 end;
20455
20456 -- For non-concurrent types, transfer explicit primitives, but
20457 -- omit those inherited from the parent of the private view
20458 -- since they will be re-inherited later on.
20459
20460 else
20461 Full_List := Primitive_Operations (Full_T);
20462
20463 while Present (Prim_Elmt) loop
20464 Prim := Node (Prim_Elmt);
20465
20466 if Comes_From_Source (Prim)
20467 and then not Contains (Prim, Full_List)
20468 then
20469 Append_Elmt (Prim, Full_List);
20470 end if;
20471
20472 Next_Elmt (Prim_Elmt);
20473 end loop;
20474 end if;
20475
20476 -- Untagged private view
20477
20478 else
20479 Full_List := Primitive_Operations (Full_T);
20480
20481 -- In this case the partial view is untagged, so here we locate
20482 -- all of the earlier primitives that need to be treated as
20483 -- dispatching (those that appear between the two views). Note
20484 -- that these additional operations must all be new operations
20485 -- (any earlier operations that override inherited operations
20486 -- of the full view will already have been inserted in the
20487 -- primitives list, marked by Check_Operation_From_Private_View
20488 -- as dispatching. Note that implicit "/=" operators are
20489 -- excluded from being added to the primitives list since they
20490 -- shouldn't be treated as dispatching (tagged "/=" is handled
20491 -- specially).
20492
20493 Prim := Next_Entity (Full_T);
20494 while Present (Prim) and then Prim /= Priv_T loop
20495 if Ekind_In (Prim, E_Procedure, E_Function) then
20496 Disp_Typ := Find_Dispatching_Type (Prim);
20497
20498 if Disp_Typ = Full_T
20499 and then (Chars (Prim) /= Name_Op_Ne
20500 or else Comes_From_Source (Prim))
20501 then
20502 Check_Controlling_Formals (Full_T, Prim);
20503
20504 if not Is_Dispatching_Operation (Prim) then
20505 Append_Elmt (Prim, Full_List);
20506 Set_Is_Dispatching_Operation (Prim, True);
20507 Set_DT_Position_Value (Prim, No_Uint);
20508 end if;
20509
20510 elsif Is_Dispatching_Operation (Prim)
20511 and then Disp_Typ /= Full_T
20512 then
20513
20514 -- Verify that it is not otherwise controlled by a
20515 -- formal or a return value of type T.
20516
20517 Check_Controlling_Formals (Disp_Typ, Prim);
20518 end if;
20519 end if;
20520
20521 Next_Entity (Prim);
20522 end loop;
20523 end if;
20524
20525 -- For the tagged case, the two views can share the same primitive
20526 -- operations list and the same class-wide type. Update attributes
20527 -- of the class-wide type which depend on the full declaration.
20528
20529 if Is_Tagged_Type (Priv_T) then
20530 Set_Direct_Primitive_Operations (Priv_T, Full_List);
20531 Set_Class_Wide_Type
20532 (Base_Type (Full_T), Class_Wide_Type (Priv_T));
20533
20534 Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T);
20535 end if;
20536 end;
20537 end if;
20538
20539 -- Ada 2005 AI 161: Check preelaborable initialization consistency
20540
20541 if Known_To_Have_Preelab_Init (Priv_T) then
20542
20543 -- Case where there is a pragma Preelaborable_Initialization. We
20544 -- always allow this in predefined units, which is cheating a bit,
20545 -- but it means we don't have to struggle to meet the requirements in
20546 -- the RM for having Preelaborable Initialization. Otherwise we
20547 -- require that the type meets the RM rules. But we can't check that
20548 -- yet, because of the rule about overriding Initialize, so we simply
20549 -- set a flag that will be checked at freeze time.
20550
20551 if not In_Predefined_Unit (Full_T) then
20552 Set_Must_Have_Preelab_Init (Full_T);
20553 end if;
20554 end if;
20555
20556 -- If pragma CPP_Class was applied to the private type declaration,
20557 -- propagate it now to the full type declaration.
20558
20559 if Is_CPP_Class (Priv_T) then
20560 Set_Is_CPP_Class (Full_T);
20561 Set_Convention (Full_T, Convention_CPP);
20562
20563 -- Check that components of imported CPP types do not have default
20564 -- expressions.
20565
20566 Check_CPP_Type_Has_No_Defaults (Full_T);
20567 end if;
20568
20569 -- If the private view has user specified stream attributes, then so has
20570 -- the full view.
20571
20572 -- Why the test, how could these flags be already set in Full_T ???
20573
20574 if Has_Specified_Stream_Read (Priv_T) then
20575 Set_Has_Specified_Stream_Read (Full_T);
20576 end if;
20577
20578 if Has_Specified_Stream_Write (Priv_T) then
20579 Set_Has_Specified_Stream_Write (Full_T);
20580 end if;
20581
20582 if Has_Specified_Stream_Input (Priv_T) then
20583 Set_Has_Specified_Stream_Input (Full_T);
20584 end if;
20585
20586 if Has_Specified_Stream_Output (Priv_T) then
20587 Set_Has_Specified_Stream_Output (Full_T);
20588 end if;
20589
20590 -- Propagate Default_Initial_Condition-related attributes from the
20591 -- partial view to the full view and its base type.
20592
20593 Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T);
20594 Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
20595
20596 -- Propagate invariant-related attributes from the partial view to the
20597 -- full view and its base type.
20598
20599 Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T);
20600 Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
20601
20602 -- AI12-0041: Detect an attempt to inherit a class-wide type invariant
20603 -- in the full view without advertising the inheritance in the partial
20604 -- view. This can only occur when the partial view has no parent type
20605 -- and the full view has an interface as a parent. Any other scenarios
20606 -- are illegal because implemented interfaces must match between the
20607 -- two views.
20608
20609 if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then
20610 declare
20611 Full_Par : constant Entity_Id := Etype (Full_T);
20612 Priv_Par : constant Entity_Id := Etype (Priv_T);
20613
20614 begin
20615 if not Is_Interface (Priv_Par)
20616 and then Is_Interface (Full_Par)
20617 and then Has_Inheritable_Invariants (Full_Par)
20618 then
20619 Error_Msg_N
20620 ("hidden inheritance of class-wide type invariants not "
20621 & "allowed", N);
20622 end if;
20623 end;
20624 end if;
20625
20626 -- Propagate predicates to full type, and predicate function if already
20627 -- defined. It is not clear that this can actually happen? the partial
20628 -- view cannot be frozen yet, and the predicate function has not been
20629 -- built. Still it is a cheap check and seems safer to make it.
20630
20631 if Has_Predicates (Priv_T) then
20632 Set_Has_Predicates (Full_T);
20633
20634 if Present (Predicate_Function (Priv_T)) then
20635 Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
20636 end if;
20637 end if;
20638
20639 <<Leave>>
20640 Restore_Ghost_Mode (Saved_GM);
20641 end Process_Full_View;
20642
20643 -----------------------------------
20644 -- Process_Incomplete_Dependents --
20645 -----------------------------------
20646
20647 procedure Process_Incomplete_Dependents
20648 (N : Node_Id;
20649 Full_T : Entity_Id;
20650 Inc_T : Entity_Id)
20651 is
20652 Inc_Elmt : Elmt_Id;
20653 Priv_Dep : Entity_Id;
20654 New_Subt : Entity_Id;
20655
20656 Disc_Constraint : Elist_Id;
20657
20658 begin
20659 if No (Private_Dependents (Inc_T)) then
20660 return;
20661 end if;
20662
20663 -- Itypes that may be generated by the completion of an incomplete
20664 -- subtype are not used by the back-end and not attached to the tree.
20665 -- They are created only for constraint-checking purposes.
20666
20667 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
20668 while Present (Inc_Elmt) loop
20669 Priv_Dep := Node (Inc_Elmt);
20670
20671 if Ekind (Priv_Dep) = E_Subprogram_Type then
20672
20673 -- An Access_To_Subprogram type may have a return type or a
20674 -- parameter type that is incomplete. Replace with the full view.
20675
20676 if Etype (Priv_Dep) = Inc_T then
20677 Set_Etype (Priv_Dep, Full_T);
20678 end if;
20679
20680 declare
20681 Formal : Entity_Id;
20682
20683 begin
20684 Formal := First_Formal (Priv_Dep);
20685 while Present (Formal) loop
20686 if Etype (Formal) = Inc_T then
20687 Set_Etype (Formal, Full_T);
20688 end if;
20689
20690 Next_Formal (Formal);
20691 end loop;
20692 end;
20693
20694 elsif Is_Overloadable (Priv_Dep) then
20695
20696 -- If a subprogram in the incomplete dependents list is primitive
20697 -- for a tagged full type then mark it as a dispatching operation,
20698 -- check whether it overrides an inherited subprogram, and check
20699 -- restrictions on its controlling formals. Note that a protected
20700 -- operation is never dispatching: only its wrapper operation
20701 -- (which has convention Ada) is.
20702
20703 if Is_Tagged_Type (Full_T)
20704 and then Is_Primitive (Priv_Dep)
20705 and then Convention (Priv_Dep) /= Convention_Protected
20706 then
20707 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
20708 Set_Is_Dispatching_Operation (Priv_Dep);
20709 Check_Controlling_Formals (Full_T, Priv_Dep);
20710 end if;
20711
20712 elsif Ekind (Priv_Dep) = E_Subprogram_Body then
20713
20714 -- Can happen during processing of a body before the completion
20715 -- of a TA type. Ignore, because spec is also on dependent list.
20716
20717 return;
20718
20719 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
20720 -- corresponding subtype of the full view.
20721
20722 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
20723 Set_Subtype_Indication
20724 (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
20725 Set_Etype (Priv_Dep, Full_T);
20726 Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
20727 Set_Analyzed (Parent (Priv_Dep), False);
20728
20729 -- Reanalyze the declaration, suppressing the call to
20730 -- Enter_Name to avoid duplicate names.
20731
20732 Analyze_Subtype_Declaration
20733 (N => Parent (Priv_Dep),
20734 Skip => True);
20735
20736 -- Dependent is a subtype
20737
20738 else
20739 -- We build a new subtype indication using the full view of the
20740 -- incomplete parent. The discriminant constraints have been
20741 -- elaborated already at the point of the subtype declaration.
20742
20743 New_Subt := Create_Itype (E_Void, N);
20744
20745 if Has_Discriminants (Full_T) then
20746 Disc_Constraint := Discriminant_Constraint (Priv_Dep);
20747 else
20748 Disc_Constraint := No_Elist;
20749 end if;
20750
20751 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
20752 Set_Full_View (Priv_Dep, New_Subt);
20753 end if;
20754
20755 Next_Elmt (Inc_Elmt);
20756 end loop;
20757 end Process_Incomplete_Dependents;
20758
20759 --------------------------------
20760 -- Process_Range_Expr_In_Decl --
20761 --------------------------------
20762
20763 procedure Process_Range_Expr_In_Decl
20764 (R : Node_Id;
20765 T : Entity_Id;
20766 Subtyp : Entity_Id := Empty;
20767 Check_List : List_Id := Empty_List;
20768 R_Check_Off : Boolean := False;
20769 In_Iter_Schm : Boolean := False)
20770 is
20771 Lo, Hi : Node_Id;
20772 R_Checks : Check_Result;
20773 Insert_Node : Node_Id;
20774 Def_Id : Entity_Id;
20775
20776 begin
20777 Analyze_And_Resolve (R, Base_Type (T));
20778
20779 if Nkind (R) = N_Range then
20780
20781 -- In SPARK, all ranges should be static, with the exception of the
20782 -- discrete type definition of a loop parameter specification.
20783
20784 if not In_Iter_Schm
20785 and then not Is_OK_Static_Range (R)
20786 then
20787 Check_SPARK_05_Restriction ("range should be static", R);
20788 end if;
20789
20790 Lo := Low_Bound (R);
20791 Hi := High_Bound (R);
20792
20793 -- Validity checks on the range of a quantified expression are
20794 -- delayed until the construct is transformed into a loop.
20795
20796 if Nkind (Parent (R)) = N_Loop_Parameter_Specification
20797 and then Nkind (Parent (Parent (R))) = N_Quantified_Expression
20798 then
20799 null;
20800
20801 -- We need to ensure validity of the bounds here, because if we
20802 -- go ahead and do the expansion, then the expanded code will get
20803 -- analyzed with range checks suppressed and we miss the check.
20804
20805 -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and
20806 -- the temporaries generated by routine Remove_Side_Effects by means
20807 -- of validity checks must use the same names. When a range appears
20808 -- in the parent of a generic, the range is processed with checks
20809 -- disabled as part of the generic context and with checks enabled
20810 -- for code generation purposes. This leads to link issues as the
20811 -- generic contains references to xxx_FIRST/_LAST, but the inlined
20812 -- template sees the temporaries generated by Remove_Side_Effects.
20813
20814 else
20815 Validity_Check_Range (R, Subtyp);
20816 end if;
20817
20818 -- If there were errors in the declaration, try and patch up some
20819 -- common mistakes in the bounds. The cases handled are literals
20820 -- which are Integer where the expected type is Real and vice versa.
20821 -- These corrections allow the compilation process to proceed further
20822 -- along since some basic assumptions of the format of the bounds
20823 -- are guaranteed.
20824
20825 if Etype (R) = Any_Type then
20826 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
20827 Rewrite (Lo,
20828 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
20829
20830 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
20831 Rewrite (Hi,
20832 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
20833
20834 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
20835 Rewrite (Lo,
20836 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
20837
20838 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
20839 Rewrite (Hi,
20840 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
20841 end if;
20842
20843 Set_Etype (Lo, T);
20844 Set_Etype (Hi, T);
20845 end if;
20846
20847 -- If the bounds of the range have been mistakenly given as string
20848 -- literals (perhaps in place of character literals), then an error
20849 -- has already been reported, but we rewrite the string literal as a
20850 -- bound of the range's type to avoid blowups in later processing
20851 -- that looks at static values.
20852
20853 if Nkind (Lo) = N_String_Literal then
20854 Rewrite (Lo,
20855 Make_Attribute_Reference (Sloc (Lo),
20856 Prefix => New_Occurrence_Of (T, Sloc (Lo)),
20857 Attribute_Name => Name_First));
20858 Analyze_And_Resolve (Lo);
20859 end if;
20860
20861 if Nkind (Hi) = N_String_Literal then
20862 Rewrite (Hi,
20863 Make_Attribute_Reference (Sloc (Hi),
20864 Prefix => New_Occurrence_Of (T, Sloc (Hi)),
20865 Attribute_Name => Name_First));
20866 Analyze_And_Resolve (Hi);
20867 end if;
20868
20869 -- If bounds aren't scalar at this point then exit, avoiding
20870 -- problems with further processing of the range in this procedure.
20871
20872 if not Is_Scalar_Type (Etype (Lo)) then
20873 return;
20874 end if;
20875
20876 -- Resolve (actually Sem_Eval) has checked that the bounds are in
20877 -- then range of the base type. Here we check whether the bounds
20878 -- are in the range of the subtype itself. Note that if the bounds
20879 -- represent the null range the Constraint_Error exception should
20880 -- not be raised.
20881
20882 -- ??? The following code should be cleaned up as follows
20883
20884 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
20885 -- is done in the call to Range_Check (R, T); below
20886
20887 -- 2. The use of R_Check_Off should be investigated and possibly
20888 -- removed, this would clean up things a bit.
20889
20890 if Is_Null_Range (Lo, Hi) then
20891 null;
20892
20893 else
20894 -- Capture values of bounds and generate temporaries for them
20895 -- if needed, before applying checks, since checks may cause
20896 -- duplication of the expression without forcing evaluation.
20897
20898 -- The forced evaluation removes side effects from expressions,
20899 -- which should occur also in GNATprove mode. Otherwise, we end up
20900 -- with unexpected insertions of actions at places where this is
20901 -- not supposed to occur, e.g. on default parameters of a call.
20902
20903 if Expander_Active or GNATprove_Mode then
20904
20905 -- Call Force_Evaluation to create declarations as needed to
20906 -- deal with side effects, and also create typ_FIRST/LAST
20907 -- entities for bounds if we have a subtype name.
20908
20909 -- Note: we do this transformation even if expansion is not
20910 -- active if we are in GNATprove_Mode since the transformation
20911 -- is in general required to ensure that the resulting tree has
20912 -- proper Ada semantics.
20913
20914 Force_Evaluation
20915 (Lo, Related_Id => Subtyp, Is_Low_Bound => True);
20916 Force_Evaluation
20917 (Hi, Related_Id => Subtyp, Is_High_Bound => True);
20918 end if;
20919
20920 -- We use a flag here instead of suppressing checks on the type
20921 -- because the type we check against isn't necessarily the place
20922 -- where we put the check.
20923
20924 if not R_Check_Off then
20925 R_Checks := Get_Range_Checks (R, T);
20926
20927 -- Look up tree to find an appropriate insertion point. We
20928 -- can't just use insert_actions because later processing
20929 -- depends on the insertion node. Prior to Ada 2012 the
20930 -- insertion point could only be a declaration or a loop, but
20931 -- quantified expressions can appear within any context in an
20932 -- expression, and the insertion point can be any statement,
20933 -- pragma, or declaration.
20934
20935 Insert_Node := Parent (R);
20936 while Present (Insert_Node) loop
20937 exit when
20938 Nkind (Insert_Node) in N_Declaration
20939 and then
20940 not Nkind_In
20941 (Insert_Node, N_Component_Declaration,
20942 N_Loop_Parameter_Specification,
20943 N_Function_Specification,
20944 N_Procedure_Specification);
20945
20946 exit when Nkind (Insert_Node) in N_Later_Decl_Item
20947 or else Nkind (Insert_Node) in
20948 N_Statement_Other_Than_Procedure_Call
20949 or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
20950 N_Pragma);
20951
20952 Insert_Node := Parent (Insert_Node);
20953 end loop;
20954
20955 -- Why would Type_Decl not be present??? Without this test,
20956 -- short regression tests fail.
20957
20958 if Present (Insert_Node) then
20959
20960 -- Case of loop statement. Verify that the range is part
20961 -- of the subtype indication of the iteration scheme.
20962
20963 if Nkind (Insert_Node) = N_Loop_Statement then
20964 declare
20965 Indic : Node_Id;
20966
20967 begin
20968 Indic := Parent (R);
20969 while Present (Indic)
20970 and then Nkind (Indic) /= N_Subtype_Indication
20971 loop
20972 Indic := Parent (Indic);
20973 end loop;
20974
20975 if Present (Indic) then
20976 Def_Id := Etype (Subtype_Mark (Indic));
20977
20978 Insert_Range_Checks
20979 (R_Checks,
20980 Insert_Node,
20981 Def_Id,
20982 Sloc (Insert_Node),
20983 R,
20984 Do_Before => True);
20985 end if;
20986 end;
20987
20988 -- Insertion before a declaration. If the declaration
20989 -- includes discriminants, the list of applicable checks
20990 -- is given by the caller.
20991
20992 elsif Nkind (Insert_Node) in N_Declaration then
20993 Def_Id := Defining_Identifier (Insert_Node);
20994
20995 if (Ekind (Def_Id) = E_Record_Type
20996 and then Depends_On_Discriminant (R))
20997 or else
20998 (Ekind (Def_Id) = E_Protected_Type
20999 and then Has_Discriminants (Def_Id))
21000 then
21001 Append_Range_Checks
21002 (R_Checks,
21003 Check_List, Def_Id, Sloc (Insert_Node), R);
21004
21005 else
21006 Insert_Range_Checks
21007 (R_Checks,
21008 Insert_Node, Def_Id, Sloc (Insert_Node), R);
21009
21010 end if;
21011
21012 -- Insertion before a statement. Range appears in the
21013 -- context of a quantified expression. Insertion will
21014 -- take place when expression is expanded.
21015
21016 else
21017 null;
21018 end if;
21019 end if;
21020 end if;
21021 end if;
21022
21023 -- Case of other than an explicit N_Range node
21024
21025 -- The forced evaluation removes side effects from expressions, which
21026 -- should occur also in GNATprove mode. Otherwise, we end up with
21027 -- unexpected insertions of actions at places where this is not
21028 -- supposed to occur, e.g. on default parameters of a call.
21029
21030 elsif Expander_Active or GNATprove_Mode then
21031 Get_Index_Bounds (R, Lo, Hi);
21032 Force_Evaluation (Lo);
21033 Force_Evaluation (Hi);
21034 end if;
21035 end Process_Range_Expr_In_Decl;
21036
21037 --------------------------------------
21038 -- Process_Real_Range_Specification --
21039 --------------------------------------
21040
21041 procedure Process_Real_Range_Specification (Def : Node_Id) is
21042 Spec : constant Node_Id := Real_Range_Specification (Def);
21043 Lo : Node_Id;
21044 Hi : Node_Id;
21045 Err : Boolean := False;
21046
21047 procedure Analyze_Bound (N : Node_Id);
21048 -- Analyze and check one bound
21049
21050 -------------------
21051 -- Analyze_Bound --
21052 -------------------
21053
21054 procedure Analyze_Bound (N : Node_Id) is
21055 begin
21056 Analyze_And_Resolve (N, Any_Real);
21057
21058 if not Is_OK_Static_Expression (N) then
21059 Flag_Non_Static_Expr
21060 ("bound in real type definition is not static!", N);
21061 Err := True;
21062 end if;
21063 end Analyze_Bound;
21064
21065 -- Start of processing for Process_Real_Range_Specification
21066
21067 begin
21068 if Present (Spec) then
21069 Lo := Low_Bound (Spec);
21070 Hi := High_Bound (Spec);
21071 Analyze_Bound (Lo);
21072 Analyze_Bound (Hi);
21073
21074 -- If error, clear away junk range specification
21075
21076 if Err then
21077 Set_Real_Range_Specification (Def, Empty);
21078 end if;
21079 end if;
21080 end Process_Real_Range_Specification;
21081
21082 ---------------------
21083 -- Process_Subtype --
21084 ---------------------
21085
21086 function Process_Subtype
21087 (S : Node_Id;
21088 Related_Nod : Node_Id;
21089 Related_Id : Entity_Id := Empty;
21090 Suffix : Character := ' ') return Entity_Id
21091 is
21092 P : Node_Id;
21093 Def_Id : Entity_Id;
21094 Error_Node : Node_Id;
21095 Full_View_Id : Entity_Id;
21096 Subtype_Mark_Id : Entity_Id;
21097
21098 May_Have_Null_Exclusion : Boolean;
21099
21100 procedure Check_Incomplete (T : Node_Id);
21101 -- Called to verify that an incomplete type is not used prematurely
21102
21103 ----------------------
21104 -- Check_Incomplete --
21105 ----------------------
21106
21107 procedure Check_Incomplete (T : Node_Id) is
21108 begin
21109 -- Ada 2005 (AI-412): Incomplete subtypes are legal
21110
21111 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
21112 and then
21113 not (Ada_Version >= Ada_2005
21114 and then
21115 (Nkind (Parent (T)) = N_Subtype_Declaration
21116 or else (Nkind (Parent (T)) = N_Subtype_Indication
21117 and then Nkind (Parent (Parent (T))) =
21118 N_Subtype_Declaration)))
21119 then
21120 Error_Msg_N ("invalid use of type before its full declaration", T);
21121 end if;
21122 end Check_Incomplete;
21123
21124 -- Start of processing for Process_Subtype
21125
21126 begin
21127 -- Case of no constraints present
21128
21129 if Nkind (S) /= N_Subtype_Indication then
21130 Find_Type (S);
21131 Check_Incomplete (S);
21132 P := Parent (S);
21133
21134 -- Ada 2005 (AI-231): Static check
21135
21136 if Ada_Version >= Ada_2005
21137 and then Present (P)
21138 and then Null_Exclusion_Present (P)
21139 and then Nkind (P) /= N_Access_To_Object_Definition
21140 and then not Is_Access_Type (Entity (S))
21141 then
21142 Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
21143 end if;
21144
21145 -- The following is ugly, can't we have a range or even a flag???
21146
21147 May_Have_Null_Exclusion :=
21148 Nkind_In (P, N_Access_Definition,
21149 N_Access_Function_Definition,
21150 N_Access_Procedure_Definition,
21151 N_Access_To_Object_Definition,
21152 N_Allocator,
21153 N_Component_Definition)
21154 or else
21155 Nkind_In (P, N_Derived_Type_Definition,
21156 N_Discriminant_Specification,
21157 N_Formal_Object_Declaration,
21158 N_Object_Declaration,
21159 N_Object_Renaming_Declaration,
21160 N_Parameter_Specification,
21161 N_Subtype_Declaration);
21162
21163 -- Create an Itype that is a duplicate of Entity (S) but with the
21164 -- null-exclusion attribute.
21165
21166 if May_Have_Null_Exclusion
21167 and then Is_Access_Type (Entity (S))
21168 and then Null_Exclusion_Present (P)
21169
21170 -- No need to check the case of an access to object definition.
21171 -- It is correct to define double not-null pointers.
21172
21173 -- Example:
21174 -- type Not_Null_Int_Ptr is not null access Integer;
21175 -- type Acc is not null access Not_Null_Int_Ptr;
21176
21177 and then Nkind (P) /= N_Access_To_Object_Definition
21178 then
21179 if Can_Never_Be_Null (Entity (S)) then
21180 case Nkind (Related_Nod) is
21181 when N_Full_Type_Declaration =>
21182 if Nkind (Type_Definition (Related_Nod))
21183 in N_Array_Type_Definition
21184 then
21185 Error_Node :=
21186 Subtype_Indication
21187 (Component_Definition
21188 (Type_Definition (Related_Nod)));
21189 else
21190 Error_Node :=
21191 Subtype_Indication (Type_Definition (Related_Nod));
21192 end if;
21193
21194 when N_Subtype_Declaration =>
21195 Error_Node := Subtype_Indication (Related_Nod);
21196
21197 when N_Object_Declaration =>
21198 Error_Node := Object_Definition (Related_Nod);
21199
21200 when N_Component_Declaration =>
21201 Error_Node :=
21202 Subtype_Indication (Component_Definition (Related_Nod));
21203
21204 when N_Allocator =>
21205 Error_Node := Expression (Related_Nod);
21206
21207 when others =>
21208 pragma Assert (False);
21209 Error_Node := Related_Nod;
21210 end case;
21211
21212 Error_Msg_NE
21213 ("`NOT NULL` not allowed (& already excludes null)",
21214 Error_Node,
21215 Entity (S));
21216 end if;
21217
21218 Set_Etype (S,
21219 Create_Null_Excluding_Itype
21220 (T => Entity (S),
21221 Related_Nod => P));
21222 Set_Entity (S, Etype (S));
21223 end if;
21224
21225 return Entity (S);
21226
21227 -- Case of constraint present, so that we have an N_Subtype_Indication
21228 -- node (this node is created only if constraints are present).
21229
21230 else
21231 Find_Type (Subtype_Mark (S));
21232
21233 if Nkind (Parent (S)) /= N_Access_To_Object_Definition
21234 and then not
21235 (Nkind (Parent (S)) = N_Subtype_Declaration
21236 and then Is_Itype (Defining_Identifier (Parent (S))))
21237 then
21238 Check_Incomplete (Subtype_Mark (S));
21239 end if;
21240
21241 P := Parent (S);
21242 Subtype_Mark_Id := Entity (Subtype_Mark (S));
21243
21244 -- Explicit subtype declaration case
21245
21246 if Nkind (P) = N_Subtype_Declaration then
21247 Def_Id := Defining_Identifier (P);
21248
21249 -- Explicit derived type definition case
21250
21251 elsif Nkind (P) = N_Derived_Type_Definition then
21252 Def_Id := Defining_Identifier (Parent (P));
21253
21254 -- Implicit case, the Def_Id must be created as an implicit type.
21255 -- The one exception arises in the case of concurrent types, array
21256 -- and access types, where other subsidiary implicit types may be
21257 -- created and must appear before the main implicit type. In these
21258 -- cases we leave Def_Id set to Empty as a signal that Create_Itype
21259 -- has not yet been called to create Def_Id.
21260
21261 else
21262 if Is_Array_Type (Subtype_Mark_Id)
21263 or else Is_Concurrent_Type (Subtype_Mark_Id)
21264 or else Is_Access_Type (Subtype_Mark_Id)
21265 then
21266 Def_Id := Empty;
21267
21268 -- For the other cases, we create a new unattached Itype,
21269 -- and set the indication to ensure it gets attached later.
21270
21271 else
21272 Def_Id :=
21273 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
21274 end if;
21275 end if;
21276
21277 -- If the kind of constraint is invalid for this kind of type,
21278 -- then give an error, and then pretend no constraint was given.
21279
21280 if not Is_Valid_Constraint_Kind
21281 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
21282 then
21283 Error_Msg_N
21284 ("incorrect constraint for this kind of type", Constraint (S));
21285
21286 Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
21287
21288 -- Set Ekind of orphan itype, to prevent cascaded errors
21289
21290 if Present (Def_Id) then
21291 Set_Ekind (Def_Id, Ekind (Any_Type));
21292 end if;
21293
21294 -- Make recursive call, having got rid of the bogus constraint
21295
21296 return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
21297 end if;
21298
21299 -- Remaining processing depends on type. Select on Base_Type kind to
21300 -- ensure getting to the concrete type kind in the case of a private
21301 -- subtype (needed when only doing semantic analysis).
21302
21303 case Ekind (Base_Type (Subtype_Mark_Id)) is
21304 when Access_Kind =>
21305
21306 -- If this is a constraint on a class-wide type, discard it.
21307 -- There is currently no way to express a partial discriminant
21308 -- constraint on a type with unknown discriminants. This is
21309 -- a pathology that the ACATS wisely decides not to test.
21310
21311 if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
21312 if Comes_From_Source (S) then
21313 Error_Msg_N
21314 ("constraint on class-wide type ignored??",
21315 Constraint (S));
21316 end if;
21317
21318 if Nkind (P) = N_Subtype_Declaration then
21319 Set_Subtype_Indication (P,
21320 New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
21321 end if;
21322
21323 return Subtype_Mark_Id;
21324 end if;
21325
21326 Constrain_Access (Def_Id, S, Related_Nod);
21327
21328 if Expander_Active
21329 and then Is_Itype (Designated_Type (Def_Id))
21330 and then Nkind (Related_Nod) = N_Subtype_Declaration
21331 and then not Is_Incomplete_Type (Designated_Type (Def_Id))
21332 then
21333 Build_Itype_Reference
21334 (Designated_Type (Def_Id), Related_Nod);
21335 end if;
21336
21337 when Array_Kind =>
21338 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
21339
21340 when Decimal_Fixed_Point_Kind =>
21341 Constrain_Decimal (Def_Id, S);
21342
21343 when Enumeration_Kind =>
21344 Constrain_Enumeration (Def_Id, S);
21345 Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
21346
21347 when Ordinary_Fixed_Point_Kind =>
21348 Constrain_Ordinary_Fixed (Def_Id, S);
21349
21350 when Float_Kind =>
21351 Constrain_Float (Def_Id, S);
21352
21353 when Integer_Kind =>
21354 Constrain_Integer (Def_Id, S);
21355 Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
21356
21357 when Class_Wide_Kind
21358 | E_Incomplete_Type
21359 | E_Record_Subtype
21360 | E_Record_Type
21361 =>
21362 Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
21363
21364 if Ekind (Def_Id) = E_Incomplete_Type then
21365 Set_Private_Dependents (Def_Id, New_Elmt_List);
21366 end if;
21367
21368 when Private_Kind =>
21369 Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
21370
21371 -- The base type may be private but Def_Id may be a full view
21372 -- in an instance.
21373
21374 if Is_Private_Type (Def_Id) then
21375 Set_Private_Dependents (Def_Id, New_Elmt_List);
21376 end if;
21377
21378 -- In case of an invalid constraint prevent further processing
21379 -- since the type constructed is missing expected fields.
21380
21381 if Etype (Def_Id) = Any_Type then
21382 return Def_Id;
21383 end if;
21384
21385 -- If the full view is that of a task with discriminants,
21386 -- we must constrain both the concurrent type and its
21387 -- corresponding record type. Otherwise we will just propagate
21388 -- the constraint to the full view, if available.
21389
21390 if Present (Full_View (Subtype_Mark_Id))
21391 and then Has_Discriminants (Subtype_Mark_Id)
21392 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
21393 then
21394 Full_View_Id :=
21395 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
21396
21397 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
21398 Constrain_Concurrent (Full_View_Id, S,
21399 Related_Nod, Related_Id, Suffix);
21400 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
21401 Set_Full_View (Def_Id, Full_View_Id);
21402
21403 -- Introduce an explicit reference to the private subtype,
21404 -- to prevent scope anomalies in gigi if first use appears
21405 -- in a nested context, e.g. a later function body.
21406 -- Should this be generated in other contexts than a full
21407 -- type declaration?
21408
21409 if Is_Itype (Def_Id)
21410 and then
21411 Nkind (Parent (P)) = N_Full_Type_Declaration
21412 then
21413 Build_Itype_Reference (Def_Id, Parent (P));
21414 end if;
21415
21416 else
21417 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
21418 end if;
21419
21420 when Concurrent_Kind =>
21421 Constrain_Concurrent (Def_Id, S,
21422 Related_Nod, Related_Id, Suffix);
21423
21424 when others =>
21425 Error_Msg_N ("invalid subtype mark in subtype indication", S);
21426 end case;
21427
21428 -- Size and Convention are always inherited from the base type
21429
21430 Set_Size_Info (Def_Id, (Subtype_Mark_Id));
21431 Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
21432
21433 return Def_Id;
21434 end if;
21435 end Process_Subtype;
21436
21437 -----------------------------
21438 -- Record_Type_Declaration --
21439 -----------------------------
21440
21441 procedure Record_Type_Declaration
21442 (T : Entity_Id;
21443 N : Node_Id;
21444 Prev : Entity_Id)
21445 is
21446 Def : constant Node_Id := Type_Definition (N);
21447 Is_Tagged : Boolean;
21448 Tag_Comp : Entity_Id;
21449
21450 begin
21451 -- These flags must be initialized before calling Process_Discriminants
21452 -- because this routine makes use of them.
21453
21454 Set_Ekind (T, E_Record_Type);
21455 Set_Etype (T, T);
21456 Init_Size_Align (T);
21457 Set_Interfaces (T, No_Elist);
21458 Set_Stored_Constraint (T, No_Elist);
21459 Set_Default_SSO (T);
21460
21461 -- Normal case
21462
21463 if Ada_Version < Ada_2005 or else not Interface_Present (Def) then
21464 if Limited_Present (Def) then
21465 Check_SPARK_05_Restriction ("limited is not allowed", N);
21466 end if;
21467
21468 if Abstract_Present (Def) then
21469 Check_SPARK_05_Restriction ("abstract is not allowed", N);
21470 end if;
21471
21472 -- The flag Is_Tagged_Type might have already been set by
21473 -- Find_Type_Name if it detected an error for declaration T. This
21474 -- arises in the case of private tagged types where the full view
21475 -- omits the word tagged.
21476
21477 Is_Tagged :=
21478 Tagged_Present (Def)
21479 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
21480
21481 Set_Is_Limited_Record (T, Limited_Present (Def));
21482
21483 if Is_Tagged then
21484 Set_Is_Tagged_Type (T, True);
21485 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
21486 end if;
21487
21488 -- Type is abstract if full declaration carries keyword, or if
21489 -- previous partial view did.
21490
21491 Set_Is_Abstract_Type (T, Is_Abstract_Type (T)
21492 or else Abstract_Present (Def));
21493
21494 else
21495 Check_SPARK_05_Restriction ("interface is not allowed", N);
21496
21497 Is_Tagged := True;
21498 Analyze_Interface_Declaration (T, Def);
21499
21500 if Present (Discriminant_Specifications (N)) then
21501 Error_Msg_N
21502 ("interface types cannot have discriminants",
21503 Defining_Identifier
21504 (First (Discriminant_Specifications (N))));
21505 end if;
21506 end if;
21507
21508 -- First pass: if there are self-referential access components,
21509 -- create the required anonymous access type declarations, and if
21510 -- need be an incomplete type declaration for T itself.
21511
21512 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def));
21513
21514 if Ada_Version >= Ada_2005
21515 and then Present (Interface_List (Def))
21516 then
21517 Check_Interfaces (N, Def);
21518
21519 declare
21520 Ifaces_List : Elist_Id;
21521
21522 begin
21523 -- Ada 2005 (AI-251): Collect the list of progenitors that are not
21524 -- already in the parents.
21525
21526 Collect_Interfaces
21527 (T => T,
21528 Ifaces_List => Ifaces_List,
21529 Exclude_Parents => True);
21530
21531 Set_Interfaces (T, Ifaces_List);
21532 end;
21533 end if;
21534
21535 -- Records constitute a scope for the component declarations within.
21536 -- The scope is created prior to the processing of these declarations.
21537 -- Discriminants are processed first, so that they are visible when
21538 -- processing the other components. The Ekind of the record type itself
21539 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
21540
21541 -- Enter record scope
21542
21543 Push_Scope (T);
21544
21545 -- If an incomplete or private type declaration was already given for
21546 -- the type, then this scope already exists, and the discriminants have
21547 -- been declared within. We must verify that the full declaration
21548 -- matches the incomplete one.
21549
21550 Check_Or_Process_Discriminants (N, T, Prev);
21551
21552 Set_Is_Constrained (T, not Has_Discriminants (T));
21553 Set_Has_Delayed_Freeze (T, True);
21554
21555 -- For tagged types add a manually analyzed component corresponding
21556 -- to the component _tag, the corresponding piece of tree will be
21557 -- expanded as part of the freezing actions if it is not a CPP_Class.
21558
21559 if Is_Tagged then
21560
21561 -- Do not add the tag unless we are in expansion mode
21562
21563 if Expander_Active then
21564 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
21565 Enter_Name (Tag_Comp);
21566
21567 Set_Ekind (Tag_Comp, E_Component);
21568 Set_Is_Tag (Tag_Comp);
21569 Set_Is_Aliased (Tag_Comp);
21570 Set_Etype (Tag_Comp, RTE (RE_Tag));
21571 Set_DT_Entry_Count (Tag_Comp, No_Uint);
21572 Set_Original_Record_Component (Tag_Comp, Tag_Comp);
21573 Init_Component_Location (Tag_Comp);
21574
21575 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
21576 -- implemented interfaces.
21577
21578 if Has_Interfaces (T) then
21579 Add_Interface_Tag_Components (N, T);
21580 end if;
21581 end if;
21582
21583 Make_Class_Wide_Type (T);
21584 Set_Direct_Primitive_Operations (T, New_Elmt_List);
21585 end if;
21586
21587 -- We must suppress range checks when processing record components in
21588 -- the presence of discriminants, since we don't want spurious checks to
21589 -- be generated during their analysis, but Suppress_Range_Checks flags
21590 -- must be reset the after processing the record definition.
21591
21592 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd,
21593 -- couldn't we just use the normal range check suppression method here.
21594 -- That would seem cleaner ???
21595
21596 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then
21597 Set_Kill_Range_Checks (T, True);
21598 Record_Type_Definition (Def, Prev);
21599 Set_Kill_Range_Checks (T, False);
21600 else
21601 Record_Type_Definition (Def, Prev);
21602 end if;
21603
21604 -- Exit from record scope
21605
21606 End_Scope;
21607
21608 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all
21609 -- the implemented interfaces and associate them an aliased entity.
21610
21611 if Is_Tagged
21612 and then not Is_Empty_List (Interface_List (Def))
21613 then
21614 Derive_Progenitor_Subprograms (T, T);
21615 end if;
21616
21617 Check_Function_Writable_Actuals (N);
21618 end Record_Type_Declaration;
21619
21620 ----------------------------
21621 -- Record_Type_Definition --
21622 ----------------------------
21623
21624 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
21625 Component : Entity_Id;
21626 Ctrl_Components : Boolean := False;
21627 Final_Storage_Only : Boolean;
21628 T : Entity_Id;
21629
21630 begin
21631 if Ekind (Prev_T) = E_Incomplete_Type then
21632 T := Full_View (Prev_T);
21633 else
21634 T := Prev_T;
21635 end if;
21636
21637 -- In SPARK, tagged types and type extensions may only be declared in
21638 -- the specification of library unit packages.
21639
21640 if Present (Def) and then Is_Tagged_Type (T) then
21641 declare
21642 Typ : Node_Id;
21643 Ctxt : Node_Id;
21644
21645 begin
21646 if Nkind (Parent (Def)) = N_Full_Type_Declaration then
21647 Typ := Parent (Def);
21648 else
21649 pragma Assert
21650 (Nkind (Parent (Def)) = N_Derived_Type_Definition);
21651 Typ := Parent (Parent (Def));
21652 end if;
21653
21654 Ctxt := Parent (Typ);
21655
21656 if Nkind (Ctxt) = N_Package_Body
21657 and then Nkind (Parent (Ctxt)) = N_Compilation_Unit
21658 then
21659 Check_SPARK_05_Restriction
21660 ("type should be defined in package specification", Typ);
21661
21662 elsif Nkind (Ctxt) /= N_Package_Specification
21663 or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
21664 then
21665 Check_SPARK_05_Restriction
21666 ("type should be defined in library unit package", Typ);
21667 end if;
21668 end;
21669 end if;
21670
21671 Final_Storage_Only := not Is_Controlled_Active (T);
21672
21673 -- Ada 2005: Check whether an explicit Limited is present in a derived
21674 -- type declaration.
21675
21676 if Nkind (Parent (Def)) = N_Derived_Type_Definition
21677 and then Limited_Present (Parent (Def))
21678 then
21679 Set_Is_Limited_Record (T);
21680 end if;
21681
21682 -- If the component list of a record type is defined by the reserved
21683 -- word null and there is no discriminant part, then the record type has
21684 -- no components and all records of the type are null records (RM 3.7)
21685 -- This procedure is also called to process the extension part of a
21686 -- record extension, in which case the current scope may have inherited
21687 -- components.
21688
21689 if No (Def)
21690 or else No (Component_List (Def))
21691 or else Null_Present (Component_List (Def))
21692 then
21693 if not Is_Tagged_Type (T) then
21694 Check_SPARK_05_Restriction ("untagged record cannot be null", Def);
21695 end if;
21696
21697 else
21698 Analyze_Declarations (Component_Items (Component_List (Def)));
21699
21700 if Present (Variant_Part (Component_List (Def))) then
21701 Check_SPARK_05_Restriction ("variant part is not allowed", Def);
21702 Analyze (Variant_Part (Component_List (Def)));
21703 end if;
21704 end if;
21705
21706 -- After completing the semantic analysis of the record definition,
21707 -- record components, both new and inherited, are accessible. Set their
21708 -- kind accordingly. Exclude malformed itypes from illegal declarations,
21709 -- whose Ekind may be void.
21710
21711 Component := First_Entity (Current_Scope);
21712 while Present (Component) loop
21713 if Ekind (Component) = E_Void
21714 and then not Is_Itype (Component)
21715 then
21716 Set_Ekind (Component, E_Component);
21717 Init_Component_Location (Component);
21718 end if;
21719
21720 Propagate_Concurrent_Flags (T, Etype (Component));
21721
21722 if Ekind (Component) /= E_Component then
21723 null;
21724
21725 -- Do not set Has_Controlled_Component on a class-wide equivalent
21726 -- type. See Make_CW_Equivalent_Type.
21727
21728 elsif not Is_Class_Wide_Equivalent_Type (T)
21729 and then (Has_Controlled_Component (Etype (Component))
21730 or else (Chars (Component) /= Name_uParent
21731 and then Is_Controlled_Active
21732 (Etype (Component))))
21733 then
21734 Set_Has_Controlled_Component (T, True);
21735 Final_Storage_Only :=
21736 Final_Storage_Only
21737 and then Finalize_Storage_Only (Etype (Component));
21738 Ctrl_Components := True;
21739 end if;
21740
21741 Next_Entity (Component);
21742 end loop;
21743
21744 -- A Type is Finalize_Storage_Only only if all its controlled components
21745 -- are also.
21746
21747 if Ctrl_Components then
21748 Set_Finalize_Storage_Only (T, Final_Storage_Only);
21749 end if;
21750
21751 -- Place reference to end record on the proper entity, which may
21752 -- be a partial view.
21753
21754 if Present (Def) then
21755 Process_End_Label (Def, 'e', Prev_T);
21756 end if;
21757 end Record_Type_Definition;
21758
21759 ------------------------
21760 -- Replace_Components --
21761 ------------------------
21762
21763 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
21764 function Process (N : Node_Id) return Traverse_Result;
21765
21766 -------------
21767 -- Process --
21768 -------------
21769
21770 function Process (N : Node_Id) return Traverse_Result is
21771 Comp : Entity_Id;
21772
21773 begin
21774 if Nkind (N) = N_Discriminant_Specification then
21775 Comp := First_Discriminant (Typ);
21776 while Present (Comp) loop
21777 if Chars (Comp) = Chars (Defining_Identifier (N)) then
21778 Set_Defining_Identifier (N, Comp);
21779 exit;
21780 end if;
21781
21782 Next_Discriminant (Comp);
21783 end loop;
21784
21785 elsif Nkind (N) = N_Component_Declaration then
21786 Comp := First_Component (Typ);
21787 while Present (Comp) loop
21788 if Chars (Comp) = Chars (Defining_Identifier (N)) then
21789 Set_Defining_Identifier (N, Comp);
21790 exit;
21791 end if;
21792
21793 Next_Component (Comp);
21794 end loop;
21795 end if;
21796
21797 return OK;
21798 end Process;
21799
21800 procedure Replace is new Traverse_Proc (Process);
21801
21802 -- Start of processing for Replace_Components
21803
21804 begin
21805 Replace (Decl);
21806 end Replace_Components;
21807
21808 -------------------------------
21809 -- Set_Completion_Referenced --
21810 -------------------------------
21811
21812 procedure Set_Completion_Referenced (E : Entity_Id) is
21813 begin
21814 -- If in main unit, mark entity that is a completion as referenced,
21815 -- warnings go on the partial view when needed.
21816
21817 if In_Extended_Main_Source_Unit (E) then
21818 Set_Referenced (E);
21819 end if;
21820 end Set_Completion_Referenced;
21821
21822 ---------------------
21823 -- Set_Default_SSO --
21824 ---------------------
21825
21826 procedure Set_Default_SSO (T : Entity_Id) is
21827 begin
21828 case Opt.Default_SSO is
21829 when ' ' =>
21830 null;
21831 when 'L' =>
21832 Set_SSO_Set_Low_By_Default (T, True);
21833 when 'H' =>
21834 Set_SSO_Set_High_By_Default (T, True);
21835 when others =>
21836 raise Program_Error;
21837 end case;
21838 end Set_Default_SSO;
21839
21840 ---------------------
21841 -- Set_Fixed_Range --
21842 ---------------------
21843
21844 -- The range for fixed-point types is complicated by the fact that we
21845 -- do not know the exact end points at the time of the declaration. This
21846 -- is true for three reasons:
21847
21848 -- A size clause may affect the fudging of the end-points.
21849 -- A small clause may affect the values of the end-points.
21850 -- We try to include the end-points if it does not affect the size.
21851
21852 -- This means that the actual end-points must be established at the
21853 -- point when the type is frozen. Meanwhile, we first narrow the range
21854 -- as permitted (so that it will fit if necessary in a small specified
21855 -- size), and then build a range subtree with these narrowed bounds.
21856 -- Set_Fixed_Range constructs the range from real literal values, and
21857 -- sets the range as the Scalar_Range of the given fixed-point type entity.
21858
21859 -- The parent of this range is set to point to the entity so that it is
21860 -- properly hooked into the tree (unlike normal Scalar_Range entries for
21861 -- other scalar types, which are just pointers to the range in the
21862 -- original tree, this would otherwise be an orphan).
21863
21864 -- The tree is left unanalyzed. When the type is frozen, the processing
21865 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
21866 -- analyzed, and uses this as an indication that it should complete
21867 -- work on the range (it will know the final small and size values).
21868
21869 procedure Set_Fixed_Range
21870 (E : Entity_Id;
21871 Loc : Source_Ptr;
21872 Lo : Ureal;
21873 Hi : Ureal)
21874 is
21875 S : constant Node_Id :=
21876 Make_Range (Loc,
21877 Low_Bound => Make_Real_Literal (Loc, Lo),
21878 High_Bound => Make_Real_Literal (Loc, Hi));
21879 begin
21880 Set_Scalar_Range (E, S);
21881 Set_Parent (S, E);
21882
21883 -- Before the freeze point, the bounds of a fixed point are universal
21884 -- and carry the corresponding type.
21885
21886 Set_Etype (Low_Bound (S), Universal_Real);
21887 Set_Etype (High_Bound (S), Universal_Real);
21888 end Set_Fixed_Range;
21889
21890 ----------------------------------
21891 -- Set_Scalar_Range_For_Subtype --
21892 ----------------------------------
21893
21894 procedure Set_Scalar_Range_For_Subtype
21895 (Def_Id : Entity_Id;
21896 R : Node_Id;
21897 Subt : Entity_Id)
21898 is
21899 Kind : constant Entity_Kind := Ekind (Def_Id);
21900
21901 begin
21902 -- Defend against previous error
21903
21904 if Nkind (R) = N_Error then
21905 return;
21906 end if;
21907
21908 Set_Scalar_Range (Def_Id, R);
21909
21910 -- We need to link the range into the tree before resolving it so
21911 -- that types that are referenced, including importantly the subtype
21912 -- itself, are properly frozen (Freeze_Expression requires that the
21913 -- expression be properly linked into the tree). Of course if it is
21914 -- already linked in, then we do not disturb the current link.
21915
21916 if No (Parent (R)) then
21917 Set_Parent (R, Def_Id);
21918 end if;
21919
21920 -- Reset the kind of the subtype during analysis of the range, to
21921 -- catch possible premature use in the bounds themselves.
21922
21923 Set_Ekind (Def_Id, E_Void);
21924 Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id);
21925 Set_Ekind (Def_Id, Kind);
21926 end Set_Scalar_Range_For_Subtype;
21927
21928 --------------------------------------------------------
21929 -- Set_Stored_Constraint_From_Discriminant_Constraint --
21930 --------------------------------------------------------
21931
21932 procedure Set_Stored_Constraint_From_Discriminant_Constraint
21933 (E : Entity_Id)
21934 is
21935 begin
21936 -- Make sure set if encountered during Expand_To_Stored_Constraint
21937
21938 Set_Stored_Constraint (E, No_Elist);
21939
21940 -- Give it the right value
21941
21942 if Is_Constrained (E) and then Has_Discriminants (E) then
21943 Set_Stored_Constraint (E,
21944 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E)));
21945 end if;
21946 end Set_Stored_Constraint_From_Discriminant_Constraint;
21947
21948 -------------------------------------
21949 -- Signed_Integer_Type_Declaration --
21950 -------------------------------------
21951
21952 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
21953 Implicit_Base : Entity_Id;
21954 Base_Typ : Entity_Id;
21955 Lo_Val : Uint;
21956 Hi_Val : Uint;
21957 Errs : Boolean := False;
21958 Lo : Node_Id;
21959 Hi : Node_Id;
21960
21961 function Can_Derive_From (E : Entity_Id) return Boolean;
21962 -- Determine whether given bounds allow derivation from specified type
21963
21964 procedure Check_Bound (Expr : Node_Id);
21965 -- Check bound to make sure it is integral and static. If not, post
21966 -- appropriate error message and set Errs flag
21967
21968 ---------------------
21969 -- Can_Derive_From --
21970 ---------------------
21971
21972 -- Note we check both bounds against both end values, to deal with
21973 -- strange types like ones with a range of 0 .. -12341234.
21974
21975 function Can_Derive_From (E : Entity_Id) return Boolean is
21976 Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
21977 Hi : constant Uint := Expr_Value (Type_High_Bound (E));
21978 begin
21979 return Lo <= Lo_Val and then Lo_Val <= Hi
21980 and then
21981 Lo <= Hi_Val and then Hi_Val <= Hi;
21982 end Can_Derive_From;
21983
21984 -----------------
21985 -- Check_Bound --
21986 -----------------
21987
21988 procedure Check_Bound (Expr : Node_Id) is
21989 begin
21990 -- If a range constraint is used as an integer type definition, each
21991 -- bound of the range must be defined by a static expression of some
21992 -- integer type, but the two bounds need not have the same integer
21993 -- type (Negative bounds are allowed.) (RM 3.5.4)
21994
21995 if not Is_Integer_Type (Etype (Expr)) then
21996 Error_Msg_N
21997 ("integer type definition bounds must be of integer type", Expr);
21998 Errs := True;
21999
22000 elsif not Is_OK_Static_Expression (Expr) then
22001 Flag_Non_Static_Expr
22002 ("non-static expression used for integer type bound!", Expr);
22003 Errs := True;
22004
22005 -- The bounds are folded into literals, and we set their type to be
22006 -- universal, to avoid typing difficulties: we cannot set the type
22007 -- of the literal to the new type, because this would be a forward
22008 -- reference for the back end, and if the original type is user-
22009 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
22010
22011 else
22012 if Is_Entity_Name (Expr) then
22013 Fold_Uint (Expr, Expr_Value (Expr), True);
22014 end if;
22015
22016 Set_Etype (Expr, Universal_Integer);
22017 end if;
22018 end Check_Bound;
22019
22020 -- Start of processing for Signed_Integer_Type_Declaration
22021
22022 begin
22023 -- Create an anonymous base type
22024
22025 Implicit_Base :=
22026 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
22027
22028 -- Analyze and check the bounds, they can be of any integer type
22029
22030 Lo := Low_Bound (Def);
22031 Hi := High_Bound (Def);
22032
22033 -- Arbitrarily use Integer as the type if either bound had an error
22034
22035 if Hi = Error or else Lo = Error then
22036 Base_Typ := Any_Integer;
22037 Set_Error_Posted (T, True);
22038
22039 -- Here both bounds are OK expressions
22040
22041 else
22042 Analyze_And_Resolve (Lo, Any_Integer);
22043 Analyze_And_Resolve (Hi, Any_Integer);
22044
22045 Check_Bound (Lo);
22046 Check_Bound (Hi);
22047
22048 if Errs then
22049 Hi := Type_High_Bound (Standard_Long_Long_Integer);
22050 Lo := Type_Low_Bound (Standard_Long_Long_Integer);
22051 end if;
22052
22053 -- Find type to derive from
22054
22055 Lo_Val := Expr_Value (Lo);
22056 Hi_Val := Expr_Value (Hi);
22057
22058 if Can_Derive_From (Standard_Short_Short_Integer) then
22059 Base_Typ := Base_Type (Standard_Short_Short_Integer);
22060
22061 elsif Can_Derive_From (Standard_Short_Integer) then
22062 Base_Typ := Base_Type (Standard_Short_Integer);
22063
22064 elsif Can_Derive_From (Standard_Integer) then
22065 Base_Typ := Base_Type (Standard_Integer);
22066
22067 elsif Can_Derive_From (Standard_Long_Integer) then
22068 Base_Typ := Base_Type (Standard_Long_Integer);
22069
22070 elsif Can_Derive_From (Standard_Long_Long_Integer) then
22071 Check_Restriction (No_Long_Long_Integers, Def);
22072 Base_Typ := Base_Type (Standard_Long_Long_Integer);
22073
22074 else
22075 Base_Typ := Base_Type (Standard_Long_Long_Integer);
22076 Error_Msg_N ("integer type definition bounds out of range", Def);
22077 Hi := Type_High_Bound (Standard_Long_Long_Integer);
22078 Lo := Type_Low_Bound (Standard_Long_Long_Integer);
22079 end if;
22080 end if;
22081
22082 -- Complete both implicit base and declared first subtype entities. The
22083 -- inheritance of the rep item chain ensures that SPARK-related pragmas
22084 -- are not clobbered when the signed integer type acts as a full view of
22085 -- a private type.
22086
22087 Set_Etype (Implicit_Base, Base_Typ);
22088 Set_Size_Info (Implicit_Base, Base_Typ);
22089 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
22090 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
22091 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
22092
22093 Set_Ekind (T, E_Signed_Integer_Subtype);
22094 Set_Etype (T, Implicit_Base);
22095 Set_Size_Info (T, Implicit_Base);
22096 Inherit_Rep_Item_Chain (T, Implicit_Base);
22097 Set_Scalar_Range (T, Def);
22098 Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
22099 Set_Is_Constrained (T);
22100 end Signed_Integer_Type_Declaration;
22101
22102 end Sem_Ch3;