1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Elists; use Elists;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Ch3; use Exp_Ch3;
34 with Exp_Ch9; use Exp_Ch9;
35 with Exp_Disp; use Exp_Disp;
36 with Exp_Dist; use Exp_Dist;
37 with Exp_Tss; use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Fname; use Fname;
40 with Freeze; use Freeze;
41 with Itypes; use Itypes;
42 with Layout; use Layout;
44 with Lib.Xref; use Lib.Xref;
45 with Namet; use Namet;
46 with Nmake; use Nmake;
48 with Restrict; use Restrict;
49 with Rident; use Rident;
50 with Rtsfind; use Rtsfind;
52 with Sem_Aux; use Sem_Aux;
53 with Sem_Case; use Sem_Case;
54 with Sem_Cat; use Sem_Cat;
55 with Sem_Ch6; use Sem_Ch6;
56 with Sem_Ch7; use Sem_Ch7;
57 with Sem_Ch8; use Sem_Ch8;
58 with Sem_Ch13; use Sem_Ch13;
59 with Sem_Dim; use Sem_Dim;
60 with Sem_Disp; use Sem_Disp;
61 with Sem_Dist; use Sem_Dist;
62 with Sem_Elim; use Sem_Elim;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Mech; use Sem_Mech;
65 with Sem_Prag; use Sem_Prag;
66 with Sem_Res; use Sem_Res;
67 with Sem_Smem; use Sem_Smem;
68 with Sem_Type; use Sem_Type;
69 with Sem_Util; use Sem_Util;
70 with Sem_Warn; use Sem_Warn;
71 with Stand; use Stand;
72 with Sinfo; use Sinfo;
73 with Sinput; use Sinput;
74 with Snames; use Snames;
75 with Targparm; use Targparm;
76 with Tbuild; use Tbuild;
77 with Ttypes; use Ttypes;
78 with Uintp; use Uintp;
79 with Urealp; use Urealp;
81 package body Sem_Ch3 is
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id);
88 -- Ada 2005 (AI-251): Add the tag components corresponding to all the
89 -- abstract interface types implemented by a record type or a derived
92 procedure Build_Derived_Type
94 Parent_Type : Entity_Id;
95 Derived_Type : Entity_Id;
96 Is_Completion : Boolean;
97 Derive_Subps : Boolean := True);
98 -- Create and decorate a Derived_Type given the Parent_Type entity. N is
99 -- the N_Full_Type_Declaration node containing the derived type definition.
100 -- Parent_Type is the entity for the parent type in the derived type
101 -- definition and Derived_Type the actual derived type. Is_Completion must
102 -- be set to False if Derived_Type is the N_Defining_Identifier node in N
103 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the
104 -- completion of a private type declaration. If Is_Completion is set to
105 -- True, N is the completion of a private type declaration and Derived_Type
106 -- is different from the defining identifier inside N (i.e. Derived_Type /=
107 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent
108 -- subprograms should be derived. The only case where this parameter is
109 -- False is when Build_Derived_Type is recursively called to process an
110 -- implicit derived full type for a type derived from a private type (in
111 -- that case the subprograms must only be derived for the private view of
114 -- ??? These flags need a bit of re-examination and re-documentation:
115 -- ??? are they both necessary (both seem related to the recursion)?
117 procedure Build_Derived_Access_Type
119 Parent_Type : Entity_Id;
120 Derived_Type : Entity_Id);
121 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
122 -- create an implicit base if the parent type is constrained or if the
123 -- subtype indication has a constraint.
125 procedure Build_Derived_Array_Type
127 Parent_Type : Entity_Id;
128 Derived_Type : Entity_Id);
129 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
130 -- create an implicit base if the parent type is constrained or if the
131 -- subtype indication has a constraint.
133 procedure Build_Derived_Concurrent_Type
135 Parent_Type : Entity_Id;
136 Derived_Type : Entity_Id);
137 -- Subsidiary procedure to Build_Derived_Type. For a derived task or
138 -- protected type, inherit entries and protected subprograms, check
139 -- legality of discriminant constraints if any.
141 procedure Build_Derived_Enumeration_Type
143 Parent_Type : Entity_Id;
144 Derived_Type : Entity_Id);
145 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
146 -- type, we must create a new list of literals. Types derived from
147 -- Character and [Wide_]Wide_Character are special-cased.
149 procedure Build_Derived_Numeric_Type
151 Parent_Type : Entity_Id;
152 Derived_Type : Entity_Id);
153 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
154 -- an anonymous base type, and propagate constraint to subtype if needed.
156 procedure Build_Derived_Private_Type
158 Parent_Type : Entity_Id;
159 Derived_Type : Entity_Id;
160 Is_Completion : Boolean;
161 Derive_Subps : Boolean := True);
162 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
163 -- because the parent may or may not have a completion, and the derivation
164 -- may itself be a completion.
166 procedure Build_Derived_Record_Type
168 Parent_Type : Entity_Id;
169 Derived_Type : Entity_Id;
170 Derive_Subps : Boolean := True);
171 -- Subsidiary procedure for Build_Derived_Type and
172 -- Analyze_Private_Extension_Declaration used for tagged and untagged
173 -- record types. All parameters are as in Build_Derived_Type except that
174 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
175 -- N_Private_Extension_Declaration node. See the definition of this routine
176 -- for much more info. Derive_Subps indicates whether subprograms should
177 -- be derived from the parent type. The only case where Derive_Subps is
178 -- False is for an implicit derived full type for a type derived from a
179 -- private type (see Build_Derived_Type).
181 procedure Build_Discriminal (Discrim : Entity_Id);
182 -- Create the discriminal corresponding to discriminant Discrim, that is
183 -- the parameter corresponding to Discrim to be used in initialization
184 -- procedures for the type where Discrim is a discriminant. Discriminals
185 -- are not used during semantic analysis, and are not fully defined
186 -- entities until expansion. Thus they are not given a scope until
187 -- initialization procedures are built.
189 function Build_Discriminant_Constraints
192 Derived_Def : Boolean := False) return Elist_Id;
193 -- Validate discriminant constraints and return the list of the constraints
194 -- in order of discriminant declarations, where T is the discriminated
195 -- unconstrained type. Def is the N_Subtype_Indication node where the
196 -- discriminants constraints for T are specified. Derived_Def is True
197 -- when building the discriminant constraints in a derived type definition
198 -- of the form "type D (...) is new T (xxx)". In this case T is the parent
199 -- type and Def is the constraint "(xxx)" on T and this routine sets the
200 -- Corresponding_Discriminant field of the discriminants in the derived
201 -- type D to point to the corresponding discriminants in the parent type T.
203 procedure Build_Discriminated_Subtype
207 Related_Nod : Node_Id;
208 For_Access : Boolean := False);
209 -- Subsidiary procedure to Constrain_Discriminated_Type and to
210 -- Process_Incomplete_Dependents. Given
212 -- T (a possibly discriminated base type)
213 -- Def_Id (a very partially built subtype for T),
215 -- the call completes Def_Id to be the appropriate E_*_Subtype.
217 -- The Elist is the list of discriminant constraints if any (it is set
218 -- to No_Elist if T is not a discriminated type, and to an empty list if
219 -- T has discriminants but there are no discriminant constraints). The
220 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
221 -- The For_Access says whether or not this subtype is really constraining
222 -- an access type. That is its sole purpose is the designated type of an
223 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
224 -- is built to avoid freezing T when the access subtype is frozen.
226 function Build_Scalar_Bound
229 Der_T : Entity_Id) return Node_Id;
230 -- The bounds of a derived scalar type are conversions of the bounds of
231 -- the parent type. Optimize the representation if the bounds are literals.
232 -- Needs a more complete spec--what are the parameters exactly, and what
233 -- exactly is the returned value, and how is Bound affected???
235 procedure Build_Underlying_Full_View
239 -- If the completion of a private type is itself derived from a private
240 -- type, or if the full view of a private subtype is itself private, the
241 -- back-end has no way to compute the actual size of this type. We build
242 -- an internal subtype declaration of the proper parent type to convey
243 -- this information. This extra mechanism is needed because a full
244 -- view cannot itself have a full view (it would get clobbered during
247 procedure Check_Access_Discriminant_Requires_Limited
250 -- Check the restriction that the type to which an access discriminant
251 -- belongs must be a concurrent type or a descendant of a type with
252 -- the reserved word 'limited' in its declaration.
254 procedure Check_Anonymous_Access_Components
258 Comp_List : Node_Id);
259 -- Ada 2005 AI-382: an access component in a record definition can refer to
260 -- the enclosing record, in which case it denotes the type itself, and not
261 -- the current instance of the type. We create an anonymous access type for
262 -- the component, and flag it as an access to a component, so accessibility
263 -- checks are properly performed on it. The declaration of the access type
264 -- is placed ahead of that of the record to prevent order-of-elaboration
265 -- circularity issues in Gigi. We create an incomplete type for the record
266 -- declaration, which is the designated type of the anonymous access.
268 procedure Check_Delta_Expression (E : Node_Id);
269 -- Check that the expression represented by E is suitable for use as a
270 -- delta expression, i.e. it is of real type and is static.
272 procedure Check_Digits_Expression (E : Node_Id);
273 -- Check that the expression represented by E is suitable for use as a
274 -- digits expression, i.e. it is of integer type, positive and static.
276 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
277 -- Validate the initialization of an object declaration. T is the required
278 -- type, and Exp is the initialization expression.
280 procedure Check_Interfaces (N : Node_Id; Def : Node_Id);
281 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
283 procedure Check_Or_Process_Discriminants
286 Prev : Entity_Id := Empty);
287 -- If N is the full declaration of the completion T of an incomplete or
288 -- private type, check its discriminants (which are already known to be
289 -- conformant with those of the partial view, see Find_Type_Name),
290 -- otherwise process them. Prev is the entity of the partial declaration,
293 procedure Check_Real_Bound (Bound : Node_Id);
294 -- Check given bound for being of real type and static. If not, post an
295 -- appropriate message, and rewrite the bound with the real literal zero.
297 procedure Constant_Redeclaration
301 -- Various checks on legality of full declaration of deferred constant.
302 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
303 -- node. The caller has not yet set any attributes of this entity.
305 function Contain_Interface
307 Ifaces : Elist_Id) return Boolean;
308 -- Ada 2005: Determine whether Iface is present in the list Ifaces
310 procedure Convert_Scalar_Bounds
312 Parent_Type : Entity_Id;
313 Derived_Type : Entity_Id;
315 -- For derived scalar types, convert the bounds in the type definition to
316 -- the derived type, and complete their analysis. Given a constraint of the
317 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with
318 -- T'Base, the parent_type. The bounds of the derived type (the anonymous
319 -- base) are copies of Lo and Hi. Finally, the bounds of the derived
320 -- subtype are conversions of those bounds to the derived_type, so that
321 -- their typing is consistent.
323 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
324 -- Copies attributes from array base type T2 to array base type T1. Copies
325 -- only attributes that apply to base types, but not subtypes.
327 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
328 -- Copies attributes from array subtype T2 to array subtype T1. Copies
329 -- attributes that apply to both subtypes and base types.
331 procedure Create_Constrained_Components
335 Constraints : Elist_Id);
336 -- Build the list of entities for a constrained discriminated record
337 -- subtype. If a component depends on a discriminant, replace its subtype
338 -- using the discriminant values in the discriminant constraint. Subt
339 -- is the defining identifier for the subtype whose list of constrained
340 -- entities we will create. Decl_Node is the type declaration node where
341 -- we will attach all the itypes created. Typ is the base discriminated
342 -- type for the subtype Subt. Constraints is the list of discriminant
343 -- constraints for Typ.
345 function Constrain_Component_Type
347 Constrained_Typ : Entity_Id;
348 Related_Node : Node_Id;
350 Constraints : Elist_Id) return Entity_Id;
351 -- Given a discriminated base type Typ, a list of discriminant constraint
352 -- Constraints for Typ and a component of Typ, with type Compon_Type,
353 -- create and return the type corresponding to Compon_type where all
354 -- discriminant references are replaced with the corresponding constraint.
355 -- If no discriminant references occur in Compon_Typ then return it as is.
356 -- Constrained_Typ is the final constrained subtype to which the
357 -- constrained Compon_Type belongs. Related_Node is the node where we will
358 -- attach all the itypes created.
360 -- Above description is confused, what is Compon_Type???
362 procedure Constrain_Access
363 (Def_Id : in out Entity_Id;
365 Related_Nod : Node_Id);
366 -- Apply a list of constraints to an access type. If Def_Id is empty, it is
367 -- an anonymous type created for a subtype indication. In that case it is
368 -- created in the procedure and attached to Related_Nod.
370 procedure Constrain_Array
371 (Def_Id : in out Entity_Id;
373 Related_Nod : Node_Id;
374 Related_Id : Entity_Id;
376 -- Apply a list of index constraints to an unconstrained array type. The
377 -- first parameter is the entity for the resulting subtype. A value of
378 -- Empty for Def_Id indicates that an implicit type must be created, but
379 -- creation is delayed (and must be done by this procedure) because other
380 -- subsidiary implicit types must be created first (which is why Def_Id
381 -- is an in/out parameter). The second parameter is a subtype indication
382 -- node for the constrained array to be created (e.g. something of the
383 -- form string (1 .. 10)). Related_Nod gives the place where this type
384 -- has to be inserted in the tree. The Related_Id and Suffix parameters
385 -- are used to build the associated Implicit type name.
387 procedure Constrain_Concurrent
388 (Def_Id : in out Entity_Id;
390 Related_Nod : Node_Id;
391 Related_Id : Entity_Id;
393 -- Apply list of discriminant constraints to an unconstrained concurrent
396 -- SI is the N_Subtype_Indication node containing the constraint and
397 -- the unconstrained type to constrain.
399 -- Def_Id is the entity for the resulting constrained subtype. A value
400 -- of Empty for Def_Id indicates that an implicit type must be created,
401 -- but creation is delayed (and must be done by this procedure) because
402 -- other subsidiary implicit types must be created first (which is why
403 -- Def_Id is an in/out parameter).
405 -- Related_Nod gives the place where this type has to be inserted
408 -- The last two arguments are used to create its external name if needed.
410 function Constrain_Corresponding_Record
411 (Prot_Subt : Entity_Id;
412 Corr_Rec : Entity_Id;
413 Related_Nod : Node_Id;
414 Related_Id : Entity_Id) return Entity_Id;
415 -- When constraining a protected type or task type with discriminants,
416 -- constrain the corresponding record with the same discriminant values.
418 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
419 -- Constrain a decimal fixed point type with a digits constraint and/or a
420 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
422 procedure Constrain_Discriminated_Type
425 Related_Nod : Node_Id;
426 For_Access : Boolean := False);
427 -- Process discriminant constraints of composite type. Verify that values
428 -- have been provided for all discriminants, that the original type is
429 -- unconstrained, and that the types of the supplied expressions match
430 -- the discriminant types. The first three parameters are like in routine
431 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
434 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
435 -- Constrain an enumeration type with a range constraint. This is identical
436 -- to Constrain_Integer, but for the Ekind of the resulting subtype.
438 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
439 -- Constrain a floating point type with either a digits constraint
440 -- and/or a range constraint, building a E_Floating_Point_Subtype.
442 procedure Constrain_Index
445 Related_Nod : Node_Id;
446 Related_Id : Entity_Id;
449 -- Process an index constraint S in a constrained array declaration. The
450 -- constraint can be a subtype name, or a range with or without an explicit
451 -- subtype mark. The index is the corresponding index of the unconstrained
452 -- array. The Related_Id and Suffix parameters are used to build the
453 -- associated Implicit type name.
455 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
456 -- Build subtype of a signed or modular integer type
458 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
459 -- Constrain an ordinary fixed point type with a range constraint, and
460 -- build an E_Ordinary_Fixed_Point_Subtype entity.
462 procedure Copy_And_Swap (Priv, Full : Entity_Id);
463 -- Copy the Priv entity into the entity of its full declaration then swap
464 -- the two entities in such a manner that the former private type is now
465 -- seen as a full type.
467 procedure Decimal_Fixed_Point_Type_Declaration
470 -- Create a new decimal fixed point type, and apply the constraint to
471 -- obtain a subtype of this new type.
473 procedure Complete_Private_Subtype
476 Full_Base : Entity_Id;
477 Related_Nod : Node_Id);
478 -- Complete the implicit full view of a private subtype by setting the
479 -- appropriate semantic fields. If the full view of the parent is a record
480 -- type, build constrained components of subtype.
482 procedure Derive_Progenitor_Subprograms
483 (Parent_Type : Entity_Id;
484 Tagged_Type : Entity_Id);
485 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive
486 -- operations of progenitors of Tagged_Type, and replace the subsidiary
487 -- subtypes with Tagged_Type, to build the specs of the inherited interface
488 -- primitives. The derived primitives are aliased to those of the
489 -- interface. This routine takes care also of transferring to the full view
490 -- subprograms associated with the partial view of Tagged_Type that cover
491 -- interface primitives.
493 procedure Derived_Standard_Character
495 Parent_Type : Entity_Id;
496 Derived_Type : Entity_Id);
497 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
498 -- derivations from types Standard.Character and Standard.Wide_Character.
500 procedure Derived_Type_Declaration
503 Is_Completion : Boolean);
504 -- Process a derived type declaration. Build_Derived_Type is invoked
505 -- to process the actual derived type definition. Parameters N and
506 -- Is_Completion have the same meaning as in Build_Derived_Type.
507 -- T is the N_Defining_Identifier for the entity defined in the
508 -- N_Full_Type_Declaration node N, that is T is the derived type.
510 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
511 -- Insert each literal in symbol table, as an overloadable identifier. Each
512 -- enumeration type is mapped into a sequence of integers, and each literal
513 -- is defined as a constant with integer value. If any of the literals are
514 -- character literals, the type is a character type, which means that
515 -- strings are legal aggregates for arrays of components of the type.
517 function Expand_To_Stored_Constraint
519 Constraint : Elist_Id) return Elist_Id;
520 -- Given a constraint (i.e. a list of expressions) on the discriminants of
521 -- Typ, expand it into a constraint on the stored discriminants and return
522 -- the new list of expressions constraining the stored discriminants.
524 function Find_Type_Of_Object
526 Related_Nod : Node_Id) return Entity_Id;
527 -- Get type entity for object referenced by Obj_Def, attaching the
528 -- implicit types generated to Related_Nod
530 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
531 -- Create a new float and apply the constraint to obtain subtype of it
533 function Has_Range_Constraint (N : Node_Id) return Boolean;
534 -- Given an N_Subtype_Indication node N, return True if a range constraint
535 -- is present, either directly, or as part of a digits or delta constraint.
536 -- In addition, a digits constraint in the decimal case returns True, since
537 -- it establishes a default range if no explicit range is present.
539 function Inherit_Components
541 Parent_Base : Entity_Id;
542 Derived_Base : Entity_Id;
544 Inherit_Discr : Boolean;
545 Discs : Elist_Id) return Elist_Id;
546 -- Called from Build_Derived_Record_Type to inherit the components of
547 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
548 -- For more information on derived types and component inheritance please
549 -- consult the comment above the body of Build_Derived_Record_Type.
551 -- N is the original derived type declaration
553 -- Is_Tagged is set if we are dealing with tagged types
555 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
556 -- Parent_Base, otherwise no discriminants are inherited.
558 -- Discs gives the list of constraints that apply to Parent_Base in the
559 -- derived type declaration. If Discs is set to No_Elist, then we have
560 -- the following situation:
562 -- type Parent (D1..Dn : ..) is [tagged] record ...;
563 -- type Derived is new Parent [with ...];
565 -- which gets treated as
567 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
569 -- For untagged types the returned value is an association list. The list
570 -- starts from the association (Parent_Base => Derived_Base), and then it
571 -- contains a sequence of the associations of the form
573 -- (Old_Component => New_Component),
575 -- where Old_Component is the Entity_Id of a component in Parent_Base and
576 -- New_Component is the Entity_Id of the corresponding component in
577 -- Derived_Base. For untagged records, this association list is needed when
578 -- copying the record declaration for the derived base. In the tagged case
579 -- the value returned is irrelevant.
581 function Is_Valid_Constraint_Kind
583 Constraint_Kind : Node_Kind) return Boolean;
584 -- Returns True if it is legal to apply the given kind of constraint to the
585 -- given kind of type (index constraint to an array type, for example).
587 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
588 -- Create new modular type. Verify that modulus is in bounds
590 procedure New_Concatenation_Op (Typ : Entity_Id);
591 -- Create an abbreviated declaration for an operator in order to
592 -- materialize concatenation on array types.
594 procedure Ordinary_Fixed_Point_Type_Declaration
597 -- Create a new ordinary fixed point type, and apply the constraint to
598 -- obtain subtype of it.
600 procedure Prepare_Private_Subtype_Completion
602 Related_Nod : Node_Id);
603 -- Id is a subtype of some private type. Creates the full declaration
604 -- associated with Id whenever possible, i.e. when the full declaration
605 -- of the base type is already known. Records each subtype into
606 -- Private_Dependents of the base type.
608 procedure Process_Incomplete_Dependents
612 -- Process all entities that depend on an incomplete type. There include
613 -- subtypes, subprogram types that mention the incomplete type in their
614 -- profiles, and subprogram with access parameters that designate the
617 -- Inc_T is the defining identifier of an incomplete type declaration, its
618 -- Ekind is E_Incomplete_Type.
620 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
622 -- Full_T is N's defining identifier.
624 -- Subtypes of incomplete types with discriminants are completed when the
625 -- parent type is. This is simpler than private subtypes, because they can
626 -- only appear in the same scope, and there is no need to exchange views.
627 -- Similarly, access_to_subprogram types may have a parameter or a return
628 -- type that is an incomplete type, and that must be replaced with the
631 -- If the full type is tagged, subprogram with access parameters that
632 -- designated the incomplete may be primitive operations of the full type,
633 -- and have to be processed accordingly.
635 procedure Process_Real_Range_Specification (Def : Node_Id);
636 -- Given the type definition for a real type, this procedure processes and
637 -- checks the real range specification of this type definition if one is
638 -- present. If errors are found, error messages are posted, and the
639 -- Real_Range_Specification of Def is reset to Empty.
641 procedure Record_Type_Declaration
645 -- Process a record type declaration (for both untagged and tagged
646 -- records). Parameters T and N are exactly like in procedure
647 -- Derived_Type_Declaration, except that no flag Is_Completion is needed
648 -- for this routine. If this is the completion of an incomplete type
649 -- declaration, Prev is the entity of the incomplete declaration, used for
650 -- cross-referencing. Otherwise Prev = T.
652 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id);
653 -- This routine is used to process the actual record type definition (both
654 -- for untagged and tagged records). Def is a record type definition node.
655 -- This procedure analyzes the components in this record type definition.
656 -- Prev_T is the entity for the enclosing record type. It is provided so
657 -- that its Has_Task flag can be set if any of the component have Has_Task
658 -- set. If the declaration is the completion of an incomplete type
659 -- declaration, Prev_T is the original incomplete type, whose full view is
662 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
663 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
664 -- build a copy of the declaration tree of the parent, and we create
665 -- independently the list of components for the derived type. Semantic
666 -- information uses the component entities, but record representation
667 -- clauses are validated on the declaration tree. This procedure replaces
668 -- discriminants and components in the declaration with those that have
669 -- been created by Inherit_Components.
671 procedure Set_Fixed_Range
676 -- Build a range node with the given bounds and set it as the Scalar_Range
677 -- of the given fixed-point type entity. Loc is the source location used
678 -- for the constructed range. See body for further details.
680 procedure Set_Scalar_Range_For_Subtype
684 -- This routine is used to set the scalar range field for a subtype given
685 -- Def_Id, the entity for the subtype, and R, the range expression for the
686 -- scalar range. Subt provides the parent subtype to be used to analyze,
687 -- resolve, and check the given range.
689 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
690 -- Create a new signed integer entity, and apply the constraint to obtain
691 -- the required first named subtype of this type.
693 procedure Set_Stored_Constraint_From_Discriminant_Constraint
695 -- E is some record type. This routine computes E's Stored_Constraint
696 -- from its Discriminant_Constraint.
698 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id);
699 -- Check that an entity in a list of progenitors is an interface,
700 -- emit error otherwise.
702 -----------------------
703 -- Access_Definition --
704 -----------------------
706 function Access_Definition
707 (Related_Nod : Node_Id;
708 N : Node_Id) return Entity_Id
710 Anon_Type : Entity_Id;
711 Anon_Scope : Entity_Id;
712 Desig_Type : Entity_Id;
713 Enclosing_Prot_Type : Entity_Id := Empty;
716 Check_SPARK_Restriction ("access type is not allowed", N);
718 if Is_Entry (Current_Scope)
719 and then Is_Task_Type (Etype (Scope (Current_Scope)))
721 Error_Msg_N ("task entries cannot have access parameters", N);
725 -- Ada 2005: for an object declaration the corresponding anonymous
726 -- type is declared in the current scope.
728 -- If the access definition is the return type of another access to
729 -- function, scope is the current one, because it is the one of the
730 -- current type declaration, except for the pathological case below.
732 if Nkind_In (Related_Nod, N_Object_Declaration,
733 N_Access_Function_Definition)
735 Anon_Scope := Current_Scope;
737 -- A pathological case: function returning access functions that
738 -- return access functions, etc. Each anonymous access type created
739 -- is in the enclosing scope of the outermost function.
746 while Nkind_In (Par, N_Access_Function_Definition,
752 if Nkind (Par) = N_Function_Specification then
753 Anon_Scope := Scope (Defining_Entity (Par));
757 -- For the anonymous function result case, retrieve the scope of the
758 -- function specification's associated entity rather than using the
759 -- current scope. The current scope will be the function itself if the
760 -- formal part is currently being analyzed, but will be the parent scope
761 -- in the case of a parameterless function, and we always want to use
762 -- the function's parent scope. Finally, if the function is a child
763 -- unit, we must traverse the tree to retrieve the proper entity.
765 elsif Nkind (Related_Nod) = N_Function_Specification
766 and then Nkind (Parent (N)) /= N_Parameter_Specification
768 -- If the current scope is a protected type, the anonymous access
769 -- is associated with one of the protected operations, and must
770 -- be available in the scope that encloses the protected declaration.
771 -- Otherwise the type is in the scope enclosing the subprogram.
773 -- If the function has formals, The return type of a subprogram
774 -- declaration is analyzed in the scope of the subprogram (see
775 -- Process_Formals) and thus the protected type, if present, is
776 -- the scope of the current function scope.
778 if Ekind (Current_Scope) = E_Protected_Type then
779 Enclosing_Prot_Type := Current_Scope;
781 elsif Ekind (Current_Scope) = E_Function
782 and then Ekind (Scope (Current_Scope)) = E_Protected_Type
784 Enclosing_Prot_Type := Scope (Current_Scope);
787 if Present (Enclosing_Prot_Type) then
788 Anon_Scope := Scope (Enclosing_Prot_Type);
791 Anon_Scope := Scope (Defining_Entity (Related_Nod));
794 -- For an access type definition, if the current scope is a child
795 -- unit it is the scope of the type.
797 elsif Is_Compilation_Unit (Current_Scope) then
798 Anon_Scope := Current_Scope;
800 -- For access formals, access components, and access discriminants, the
801 -- scope is that of the enclosing declaration,
804 Anon_Scope := Scope (Current_Scope);
809 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope);
812 and then Ada_Version >= Ada_2005
814 Error_Msg_N ("ALL is not permitted for anonymous access types", N);
817 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call
818 -- the corresponding semantic routine
820 if Present (Access_To_Subprogram_Definition (N)) then
822 -- Compiler runtime units are compiled in Ada 2005 mode when building
823 -- the runtime library but must also be compilable in Ada 95 mode
824 -- (when bootstrapping the compiler).
826 Check_Compiler_Unit (N);
828 Access_Subprogram_Declaration
829 (T_Name => Anon_Type,
830 T_Def => Access_To_Subprogram_Definition (N));
832 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
834 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
837 (Anon_Type, E_Anonymous_Access_Subprogram_Type);
840 Set_Can_Use_Internal_Rep
841 (Anon_Type, not Always_Compatible_Rep_On_Target);
843 -- If the anonymous access is associated with a protected operation,
844 -- create a reference to it after the enclosing protected definition
845 -- because the itype will be used in the subsequent bodies.
847 if Ekind (Current_Scope) = E_Protected_Type then
848 Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
854 Find_Type (Subtype_Mark (N));
855 Desig_Type := Entity (Subtype_Mark (N));
857 Set_Directly_Designated_Type (Anon_Type, Desig_Type);
858 Set_Etype (Anon_Type, Anon_Type);
860 -- Make sure the anonymous access type has size and alignment fields
861 -- set, as required by gigi. This is necessary in the case of the
862 -- Task_Body_Procedure.
864 if not Has_Private_Component (Desig_Type) then
865 Layout_Type (Anon_Type);
868 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
869 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if
870 -- the null value is allowed. In Ada 95 the null value is never allowed.
872 if Ada_Version >= Ada_2005 then
873 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
875 Set_Can_Never_Be_Null (Anon_Type, True);
878 -- The anonymous access type is as public as the discriminated type or
879 -- subprogram that defines it. It is imported (for back-end purposes)
880 -- if the designated type is.
882 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
884 -- Ada 2005 (AI-231): Propagate the access-constant attribute
886 Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
888 -- The context is either a subprogram declaration, object declaration,
889 -- or an access discriminant, in a private or a full type declaration.
890 -- In the case of a subprogram, if the designated type is incomplete,
891 -- the operation will be a primitive operation of the full type, to be
892 -- updated subsequently. If the type is imported through a limited_with
893 -- clause, the subprogram is not a primitive operation of the type
894 -- (which is declared elsewhere in some other scope).
896 if Ekind (Desig_Type) = E_Incomplete_Type
897 and then not From_With_Type (Desig_Type)
898 and then Is_Overloadable (Current_Scope)
900 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
901 Set_Has_Delayed_Freeze (Current_Scope);
904 -- Ada 2005: if the designated type is an interface that may contain
905 -- tasks, create a Master entity for the declaration. This must be done
906 -- before expansion of the full declaration, because the declaration may
907 -- include an expression that is an allocator, whose expansion needs the
908 -- proper Master for the created tasks.
910 if Nkind (Related_Nod) = N_Object_Declaration
911 and then Expander_Active
913 if Is_Interface (Desig_Type)
914 and then Is_Limited_Record (Desig_Type)
916 Build_Class_Wide_Master (Anon_Type);
918 -- Similarly, if the type is an anonymous access that designates
919 -- tasks, create a master entity for it in the current context.
921 elsif Has_Task (Desig_Type)
922 and then Comes_From_Source (Related_Nod)
924 Build_Master_Entity (Defining_Identifier (Related_Nod));
925 Build_Master_Renaming (Anon_Type);
929 -- For a private component of a protected type, it is imperative that
930 -- the back-end elaborate the type immediately after the protected
931 -- declaration, because this type will be used in the declarations
932 -- created for the component within each protected body, so we must
933 -- create an itype reference for it now.
935 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then
936 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
938 -- Similarly, if the access definition is the return result of a
939 -- function, create an itype reference for it because it will be used
940 -- within the function body. For a regular function that is not a
941 -- compilation unit, insert reference after the declaration. For a
942 -- protected operation, insert it after the enclosing protected type
943 -- declaration. In either case, do not create a reference for a type
944 -- obtained through a limited_with clause, because this would introduce
945 -- semantic dependencies.
947 -- Similarly, do not create a reference if the designated type is a
948 -- generic formal, because no use of it will reach the backend.
950 elsif Nkind (Related_Nod) = N_Function_Specification
951 and then not From_With_Type (Desig_Type)
952 and then not Is_Generic_Type (Desig_Type)
954 if Present (Enclosing_Prot_Type) then
955 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
957 elsif Is_List_Member (Parent (Related_Nod))
958 and then Nkind (Parent (N)) /= N_Parameter_Specification
960 Build_Itype_Reference (Anon_Type, Parent (Related_Nod));
963 -- Finally, create an itype reference for an object declaration of an
964 -- anonymous access type. This is strictly necessary only for deferred
965 -- constants, but in any case will avoid out-of-scope problems in the
968 elsif Nkind (Related_Nod) = N_Object_Declaration then
969 Build_Itype_Reference (Anon_Type, Related_Nod);
973 end Access_Definition;
975 -----------------------------------
976 -- Access_Subprogram_Declaration --
977 -----------------------------------
979 procedure Access_Subprogram_Declaration
984 procedure Check_For_Premature_Usage (Def : Node_Id);
985 -- Check that type T_Name is not used, directly or recursively, as a
986 -- parameter or a return type in Def. Def is either a subtype, an
987 -- access_definition, or an access_to_subprogram_definition.
989 -------------------------------
990 -- Check_For_Premature_Usage --
991 -------------------------------
993 procedure Check_For_Premature_Usage (Def : Node_Id) is
997 -- Check for a subtype mark
999 if Nkind (Def) in N_Has_Etype then
1000 if Etype (Def) = T_Name then
1002 ("type& cannot be used before end of its declaration", Def);
1005 -- If this is not a subtype, then this is an access_definition
1007 elsif Nkind (Def) = N_Access_Definition then
1008 if Present (Access_To_Subprogram_Definition (Def)) then
1009 Check_For_Premature_Usage
1010 (Access_To_Subprogram_Definition (Def));
1012 Check_For_Premature_Usage (Subtype_Mark (Def));
1015 -- The only cases left are N_Access_Function_Definition and
1016 -- N_Access_Procedure_Definition.
1019 if Present (Parameter_Specifications (Def)) then
1020 Param := First (Parameter_Specifications (Def));
1021 while Present (Param) loop
1022 Check_For_Premature_Usage (Parameter_Type (Param));
1023 Param := Next (Param);
1027 if Nkind (Def) = N_Access_Function_Definition then
1028 Check_For_Premature_Usage (Result_Definition (Def));
1031 end Check_For_Premature_Usage;
1035 Formals : constant List_Id := Parameter_Specifications (T_Def);
1038 Desig_Type : constant Entity_Id :=
1039 Create_Itype (E_Subprogram_Type, Parent (T_Def));
1041 -- Start of processing for Access_Subprogram_Declaration
1044 Check_SPARK_Restriction ("access type is not allowed", T_Def);
1046 -- Associate the Itype node with the inner full-type declaration or
1047 -- subprogram spec or entry body. This is required to handle nested
1048 -- anonymous declarations. For example:
1051 -- (X : access procedure
1052 -- (Y : access procedure
1055 D_Ityp := Associated_Node_For_Itype (Desig_Type);
1056 while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
1057 N_Private_Type_Declaration,
1058 N_Private_Extension_Declaration,
1059 N_Procedure_Specification,
1060 N_Function_Specification,
1064 Nkind_In (D_Ityp, N_Object_Declaration,
1065 N_Object_Renaming_Declaration,
1066 N_Formal_Object_Declaration,
1067 N_Formal_Type_Declaration,
1068 N_Task_Type_Declaration,
1069 N_Protected_Type_Declaration))
1071 D_Ityp := Parent (D_Ityp);
1072 pragma Assert (D_Ityp /= Empty);
1075 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
1077 if Nkind_In (D_Ityp, N_Procedure_Specification,
1078 N_Function_Specification)
1080 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
1082 elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
1083 N_Object_Declaration,
1084 N_Object_Renaming_Declaration,
1085 N_Formal_Type_Declaration)
1087 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
1090 if Nkind (T_Def) = N_Access_Function_Definition then
1091 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
1093 Acc : constant Node_Id := Result_Definition (T_Def);
1096 if Present (Access_To_Subprogram_Definition (Acc))
1098 Protected_Present (Access_To_Subprogram_Definition (Acc))
1102 Replace_Anonymous_Access_To_Protected_Subprogram
1108 Access_Definition (T_Def, Result_Definition (T_Def)));
1113 Analyze (Result_Definition (T_Def));
1116 Typ : constant Entity_Id := Entity (Result_Definition (T_Def));
1119 -- If a null exclusion is imposed on the result type, then
1120 -- create a null-excluding itype (an access subtype) and use
1121 -- it as the function's Etype.
1123 if Is_Access_Type (Typ)
1124 and then Null_Exclusion_In_Return_Present (T_Def)
1126 Set_Etype (Desig_Type,
1127 Create_Null_Excluding_Itype
1129 Related_Nod => T_Def,
1130 Scope_Id => Current_Scope));
1133 if From_With_Type (Typ) then
1135 -- AI05-151: Incomplete types are allowed in all basic
1136 -- declarations, including access to subprograms.
1138 if Ada_Version >= Ada_2012 then
1143 ("illegal use of incomplete type&",
1144 Result_Definition (T_Def), Typ);
1147 elsif Ekind (Current_Scope) = E_Package
1148 and then In_Private_Part (Current_Scope)
1150 if Ekind (Typ) = E_Incomplete_Type then
1151 Append_Elmt (Desig_Type, Private_Dependents (Typ));
1153 elsif Is_Class_Wide_Type (Typ)
1154 and then Ekind (Etype (Typ)) = E_Incomplete_Type
1157 (Desig_Type, Private_Dependents (Etype (Typ)));
1161 Set_Etype (Desig_Type, Typ);
1166 if not (Is_Type (Etype (Desig_Type))) then
1168 ("expect type in function specification",
1169 Result_Definition (T_Def));
1173 Set_Etype (Desig_Type, Standard_Void_Type);
1176 if Present (Formals) then
1177 Push_Scope (Desig_Type);
1179 -- A bit of a kludge here. These kludges will be removed when Itypes
1180 -- have proper parent pointers to their declarations???
1182 -- Kludge 1) Link defining_identifier of formals. Required by
1183 -- First_Formal to provide its functionality.
1189 F := First (Formals);
1191 -- In ASIS mode, the access_to_subprogram may be analyzed twice,
1192 -- when it is part of an unconstrained type and subtype expansion
1193 -- is disabled. To avoid back-end problems with shared profiles,
1194 -- use previous subprogram type as the designated type.
1197 and then Present (Scope (Defining_Identifier (F)))
1199 Set_Etype (T_Name, T_Name);
1200 Init_Size_Align (T_Name);
1201 Set_Directly_Designated_Type (T_Name,
1202 Scope (Defining_Identifier (F)));
1206 while Present (F) loop
1207 if No (Parent (Defining_Identifier (F))) then
1208 Set_Parent (Defining_Identifier (F), F);
1215 Process_Formals (Formals, Parent (T_Def));
1217 -- Kludge 2) End_Scope requires that the parent pointer be set to
1218 -- something reasonable, but Itypes don't have parent pointers. So
1219 -- we set it and then unset it ???
1221 Set_Parent (Desig_Type, T_Name);
1223 Set_Parent (Desig_Type, Empty);
1226 -- Check for premature usage of the type being defined
1228 Check_For_Premature_Usage (T_Def);
1230 -- The return type and/or any parameter type may be incomplete. Mark
1231 -- the subprogram_type as depending on the incomplete type, so that
1232 -- it can be updated when the full type declaration is seen. This
1233 -- only applies to incomplete types declared in some enclosing scope,
1234 -- not to limited views from other packages.
1236 if Present (Formals) then
1237 Formal := First_Formal (Desig_Type);
1238 while Present (Formal) loop
1239 if Ekind (Formal) /= E_In_Parameter
1240 and then Nkind (T_Def) = N_Access_Function_Definition
1242 Error_Msg_N ("functions can only have IN parameters", Formal);
1245 if Ekind (Etype (Formal)) = E_Incomplete_Type
1246 and then In_Open_Scopes (Scope (Etype (Formal)))
1248 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
1249 Set_Has_Delayed_Freeze (Desig_Type);
1252 Next_Formal (Formal);
1256 -- If the return type is incomplete, this is legal as long as the
1257 -- type is declared in the current scope and will be completed in
1258 -- it (rather than being part of limited view).
1260 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
1261 and then not Has_Delayed_Freeze (Desig_Type)
1262 and then In_Open_Scopes (Scope (Etype (Desig_Type)))
1264 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
1265 Set_Has_Delayed_Freeze (Desig_Type);
1268 Check_Delayed_Subprogram (Desig_Type);
1270 if Protected_Present (T_Def) then
1271 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
1272 Set_Convention (Desig_Type, Convention_Protected);
1274 Set_Ekind (T_Name, E_Access_Subprogram_Type);
1277 Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
1279 Set_Etype (T_Name, T_Name);
1280 Init_Size_Align (T_Name);
1281 Set_Directly_Designated_Type (T_Name, Desig_Type);
1283 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
1285 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
1287 Check_Restriction (No_Access_Subprograms, T_Def);
1288 end Access_Subprogram_Declaration;
1290 ----------------------------
1291 -- Access_Type_Declaration --
1292 ----------------------------
1294 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
1295 P : constant Node_Id := Parent (Def);
1296 S : constant Node_Id := Subtype_Indication (Def);
1298 Full_Desig : Entity_Id;
1301 Check_SPARK_Restriction ("access type is not allowed", Def);
1303 -- Check for permissible use of incomplete type
1305 if Nkind (S) /= N_Subtype_Indication then
1308 if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
1309 Set_Directly_Designated_Type (T, Entity (S));
1311 Set_Directly_Designated_Type (T,
1312 Process_Subtype (S, P, T, 'P'));
1316 Set_Directly_Designated_Type (T,
1317 Process_Subtype (S, P, T, 'P'));
1320 if All_Present (Def) or Constant_Present (Def) then
1321 Set_Ekind (T, E_General_Access_Type);
1323 Set_Ekind (T, E_Access_Type);
1326 Full_Desig := Designated_Type (T);
1328 if Base_Type (Full_Desig) = T then
1329 Error_Msg_N ("access type cannot designate itself", S);
1331 -- In Ada 2005, the type may have a limited view through some unit
1332 -- in its own context, allowing the following circularity that cannot
1333 -- be detected earlier
1335 elsif Is_Class_Wide_Type (Full_Desig)
1336 and then Etype (Full_Desig) = T
1339 ("access type cannot designate its own classwide type", S);
1341 -- Clean up indication of tagged status to prevent cascaded errors
1343 Set_Is_Tagged_Type (T, False);
1348 -- If the type has appeared already in a with_type clause, it is
1349 -- frozen and the pointer size is already set. Else, initialize.
1351 if not From_With_Type (T) then
1352 Init_Size_Align (T);
1355 -- Note that Has_Task is always false, since the access type itself
1356 -- is not a task type. See Einfo for more description on this point.
1357 -- Exactly the same consideration applies to Has_Controlled_Component.
1359 Set_Has_Task (T, False);
1360 Set_Has_Controlled_Component (T, False);
1362 -- Initialize field Finalization_Master explicitly to Empty, to avoid
1363 -- problems where an incomplete view of this entity has been previously
1364 -- established by a limited with and an overlaid version of this field
1365 -- (Stored_Constraint) was initialized for the incomplete view.
1367 -- This reset is performed in most cases except where the access type
1368 -- has been created for the purposes of allocating or deallocating a
1369 -- build-in-place object. Such access types have explicitly set pools
1370 -- and finalization masters.
1372 if No (Associated_Storage_Pool (T)) then
1373 Set_Finalization_Master (T, Empty);
1376 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1379 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def));
1380 Set_Is_Access_Constant (T, Constant_Present (Def));
1381 end Access_Type_Declaration;
1383 ----------------------------------
1384 -- Add_Interface_Tag_Components --
1385 ----------------------------------
1387 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
1388 Loc : constant Source_Ptr := Sloc (N);
1392 procedure Add_Tag (Iface : Entity_Id);
1393 -- Add tag for one of the progenitor interfaces
1399 procedure Add_Tag (Iface : Entity_Id) is
1406 pragma Assert (Is_Tagged_Type (Iface)
1407 and then Is_Interface (Iface));
1409 -- This is a reasonable place to propagate predicates
1411 if Has_Predicates (Iface) then
1412 Set_Has_Predicates (Typ);
1416 Make_Component_Definition (Loc,
1417 Aliased_Present => True,
1418 Subtype_Indication =>
1419 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc));
1421 Tag := Make_Temporary (Loc, 'V');
1424 Make_Component_Declaration (Loc,
1425 Defining_Identifier => Tag,
1426 Component_Definition => Def);
1428 Analyze_Component_Declaration (Decl);
1430 Set_Analyzed (Decl);
1431 Set_Ekind (Tag, E_Component);
1433 Set_Is_Aliased (Tag);
1434 Set_Related_Type (Tag, Iface);
1435 Init_Component_Location (Tag);
1437 pragma Assert (Is_Frozen (Iface));
1439 Set_DT_Entry_Count (Tag,
1440 DT_Entry_Count (First_Entity (Iface)));
1442 if No (Last_Tag) then
1445 Insert_After (Last_Tag, Decl);
1450 -- If the ancestor has discriminants we need to give special support
1451 -- to store the offset_to_top value of the secondary dispatch tables.
1452 -- For this purpose we add a supplementary component just after the
1453 -- field that contains the tag associated with each secondary DT.
1455 if Typ /= Etype (Typ)
1456 and then Has_Discriminants (Etype (Typ))
1459 Make_Component_Definition (Loc,
1460 Subtype_Indication =>
1461 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1463 Offset := Make_Temporary (Loc, 'V');
1466 Make_Component_Declaration (Loc,
1467 Defining_Identifier => Offset,
1468 Component_Definition => Def);
1470 Analyze_Component_Declaration (Decl);
1472 Set_Analyzed (Decl);
1473 Set_Ekind (Offset, E_Component);
1474 Set_Is_Aliased (Offset);
1475 Set_Related_Type (Offset, Iface);
1476 Init_Component_Location (Offset);
1477 Insert_After (Last_Tag, Decl);
1488 -- Start of processing for Add_Interface_Tag_Components
1491 if not RTE_Available (RE_Interface_Tag) then
1493 ("(Ada 2005) interface types not supported by this run-time!",
1498 if Ekind (Typ) /= E_Record_Type
1499 or else (Is_Concurrent_Record_Type (Typ)
1500 and then Is_Empty_List (Abstract_Interface_List (Typ)))
1501 or else (not Is_Concurrent_Record_Type (Typ)
1502 and then No (Interfaces (Typ))
1503 and then Is_Empty_Elmt_List (Interfaces (Typ)))
1508 -- Find the current last tag
1510 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1511 Ext := Record_Extension_Part (Type_Definition (N));
1513 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
1514 Ext := Type_Definition (N);
1519 if not (Present (Component_List (Ext))) then
1520 Set_Null_Present (Ext, False);
1522 Set_Component_List (Ext,
1523 Make_Component_List (Loc,
1524 Component_Items => L,
1525 Null_Present => False));
1527 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1528 L := Component_Items
1530 (Record_Extension_Part
1531 (Type_Definition (N))));
1533 L := Component_Items
1535 (Type_Definition (N)));
1538 -- Find the last tag component
1541 while Present (Comp) loop
1542 if Nkind (Comp) = N_Component_Declaration
1543 and then Is_Tag (Defining_Identifier (Comp))
1552 -- At this point L references the list of components and Last_Tag
1553 -- references the current last tag (if any). Now we add the tag
1554 -- corresponding with all the interfaces that are not implemented
1557 if Present (Interfaces (Typ)) then
1558 Elmt := First_Elmt (Interfaces (Typ));
1559 while Present (Elmt) loop
1560 Add_Tag (Node (Elmt));
1564 end Add_Interface_Tag_Components;
1566 -------------------------------------
1567 -- Add_Internal_Interface_Entities --
1568 -------------------------------------
1570 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
1573 Iface_Elmt : Elmt_Id;
1574 Iface_Prim : Entity_Id;
1575 Ifaces_List : Elist_Id;
1576 New_Subp : Entity_Id := Empty;
1578 Restore_Scope : Boolean := False;
1581 pragma Assert (Ada_Version >= Ada_2005
1582 and then Is_Record_Type (Tagged_Type)
1583 and then Is_Tagged_Type (Tagged_Type)
1584 and then Has_Interfaces (Tagged_Type)
1585 and then not Is_Interface (Tagged_Type));
1587 -- Ensure that the internal entities are added to the scope of the type
1589 if Scope (Tagged_Type) /= Current_Scope then
1590 Push_Scope (Scope (Tagged_Type));
1591 Restore_Scope := True;
1594 Collect_Interfaces (Tagged_Type, Ifaces_List);
1596 Iface_Elmt := First_Elmt (Ifaces_List);
1597 while Present (Iface_Elmt) loop
1598 Iface := Node (Iface_Elmt);
1600 -- Originally we excluded here from this processing interfaces that
1601 -- are parents of Tagged_Type because their primitives are located
1602 -- in the primary dispatch table (and hence no auxiliary internal
1603 -- entities are required to handle secondary dispatch tables in such
1604 -- case). However, these auxiliary entities are also required to
1605 -- handle derivations of interfaces in formals of generics (see
1606 -- Derive_Subprograms).
1608 Elmt := First_Elmt (Primitive_Operations (Iface));
1609 while Present (Elmt) loop
1610 Iface_Prim := Node (Elmt);
1612 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
1614 Find_Primitive_Covering_Interface
1615 (Tagged_Type => Tagged_Type,
1616 Iface_Prim => Iface_Prim);
1618 if No (Prim) and then Serious_Errors_Detected > 0 then
1622 pragma Assert (Present (Prim));
1624 -- Ada 2012 (AI05-0197): If the name of the covering primitive
1625 -- differs from the name of the interface primitive then it is
1626 -- a private primitive inherited from a parent type. In such
1627 -- case, given that Tagged_Type covers the interface, the
1628 -- inherited private primitive becomes visible. For such
1629 -- purpose we add a new entity that renames the inherited
1630 -- private primitive.
1632 if Chars (Prim) /= Chars (Iface_Prim) then
1633 pragma Assert (Has_Suffix (Prim, 'P'));
1635 (New_Subp => New_Subp,
1636 Parent_Subp => Iface_Prim,
1637 Derived_Type => Tagged_Type,
1638 Parent_Type => Iface);
1639 Set_Alias (New_Subp, Prim);
1640 Set_Is_Abstract_Subprogram
1641 (New_Subp, Is_Abstract_Subprogram (Prim));
1645 (New_Subp => New_Subp,
1646 Parent_Subp => Iface_Prim,
1647 Derived_Type => Tagged_Type,
1648 Parent_Type => Iface);
1650 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
1651 -- associated with interface types. These entities are
1652 -- only registered in the list of primitives of its
1653 -- corresponding tagged type because they are only used
1654 -- to fill the contents of the secondary dispatch tables.
1655 -- Therefore they are removed from the homonym chains.
1657 Set_Is_Hidden (New_Subp);
1658 Set_Is_Internal (New_Subp);
1659 Set_Alias (New_Subp, Prim);
1660 Set_Is_Abstract_Subprogram
1661 (New_Subp, Is_Abstract_Subprogram (Prim));
1662 Set_Interface_Alias (New_Subp, Iface_Prim);
1664 -- Internal entities associated with interface types are
1665 -- only registered in the list of primitives of the tagged
1666 -- type. They are only used to fill the contents of the
1667 -- secondary dispatch tables. Therefore they are not needed
1668 -- in the homonym chains.
1670 Remove_Homonym (New_Subp);
1672 -- Hidden entities associated with interfaces must have set
1673 -- the Has_Delay_Freeze attribute to ensure that, in case of
1674 -- locally defined tagged types (or compiling with static
1675 -- dispatch tables generation disabled) the corresponding
1676 -- entry of the secondary dispatch table is filled when
1677 -- such an entity is frozen.
1679 Set_Has_Delayed_Freeze (New_Subp);
1686 Next_Elmt (Iface_Elmt);
1689 if Restore_Scope then
1692 end Add_Internal_Interface_Entities;
1694 -----------------------------------
1695 -- Analyze_Component_Declaration --
1696 -----------------------------------
1698 procedure Analyze_Component_Declaration (N : Node_Id) is
1699 Id : constant Entity_Id := Defining_Identifier (N);
1700 E : constant Node_Id := Expression (N);
1701 Typ : constant Node_Id :=
1702 Subtype_Indication (Component_Definition (N));
1706 function Contains_POC (Constr : Node_Id) return Boolean;
1707 -- Determines whether a constraint uses the discriminant of a record
1708 -- type thus becoming a per-object constraint (POC).
1710 function Is_Known_Limited (Typ : Entity_Id) return Boolean;
1711 -- Typ is the type of the current component, check whether this type is
1712 -- a limited type. Used to validate declaration against that of
1713 -- enclosing record.
1719 function Contains_POC (Constr : Node_Id) return Boolean is
1721 -- Prevent cascaded errors
1723 if Error_Posted (Constr) then
1727 case Nkind (Constr) is
1728 when N_Attribute_Reference =>
1730 Attribute_Name (Constr) = Name_Access
1731 and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
1733 when N_Discriminant_Association =>
1734 return Denotes_Discriminant (Expression (Constr));
1736 when N_Identifier =>
1737 return Denotes_Discriminant (Constr);
1739 when N_Index_Or_Discriminant_Constraint =>
1744 IDC := First (Constraints (Constr));
1745 while Present (IDC) loop
1747 -- One per-object constraint is sufficient
1749 if Contains_POC (IDC) then
1760 return Denotes_Discriminant (Low_Bound (Constr))
1762 Denotes_Discriminant (High_Bound (Constr));
1764 when N_Range_Constraint =>
1765 return Denotes_Discriminant (Range_Expression (Constr));
1773 ----------------------
1774 -- Is_Known_Limited --
1775 ----------------------
1777 function Is_Known_Limited (Typ : Entity_Id) return Boolean is
1778 P : constant Entity_Id := Etype (Typ);
1779 R : constant Entity_Id := Root_Type (Typ);
1782 if Is_Limited_Record (Typ) then
1785 -- If the root type is limited (and not a limited interface)
1786 -- so is the current type
1788 elsif Is_Limited_Record (R)
1790 (not Is_Interface (R)
1791 or else not Is_Limited_Interface (R))
1795 -- Else the type may have a limited interface progenitor, but a
1796 -- limited record parent.
1799 and then Is_Limited_Record (P)
1806 end Is_Known_Limited;
1808 -- Start of processing for Analyze_Component_Declaration
1811 Generate_Definition (Id);
1814 if Present (Typ) then
1815 T := Find_Type_Of_Object
1816 (Subtype_Indication (Component_Definition (N)), N);
1818 if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then
1819 Check_SPARK_Restriction ("subtype mark required", Typ);
1822 -- Ada 2005 (AI-230): Access Definition case
1825 pragma Assert (Present
1826 (Access_Definition (Component_Definition (N))));
1828 T := Access_Definition
1830 N => Access_Definition (Component_Definition (N)));
1831 Set_Is_Local_Anonymous_Access (T);
1833 -- Ada 2005 (AI-254)
1835 if Present (Access_To_Subprogram_Definition
1836 (Access_Definition (Component_Definition (N))))
1837 and then Protected_Present (Access_To_Subprogram_Definition
1839 (Component_Definition (N))))
1841 T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1845 -- If the subtype is a constrained subtype of the enclosing record,
1846 -- (which must have a partial view) the back-end does not properly
1847 -- handle the recursion. Rewrite the component declaration with an
1848 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1849 -- the tree directly because side effects have already been removed from
1850 -- discriminant constraints.
1852 if Ekind (T) = E_Access_Subtype
1853 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
1854 and then Comes_From_Source (T)
1855 and then Nkind (Parent (T)) = N_Subtype_Declaration
1856 and then Etype (Directly_Designated_Type (T)) = Current_Scope
1859 (Subtype_Indication (Component_Definition (N)),
1860 New_Copy_Tree (Subtype_Indication (Parent (T))));
1861 T := Find_Type_Of_Object
1862 (Subtype_Indication (Component_Definition (N)), N);
1865 -- If the component declaration includes a default expression, then we
1866 -- check that the component is not of a limited type (RM 3.7(5)),
1867 -- and do the special preanalysis of the expression (see section on
1868 -- "Handling of Default and Per-Object Expressions" in the spec of
1872 Check_SPARK_Restriction ("default expression is not allowed", E);
1873 Preanalyze_Spec_Expression (E, T);
1874 Check_Initialization (T, E);
1876 if Ada_Version >= Ada_2005
1877 and then Ekind (T) = E_Anonymous_Access_Type
1878 and then Etype (E) /= Any_Type
1880 -- Check RM 3.9.2(9): "if the expected type for an expression is
1881 -- an anonymous access-to-specific tagged type, then the object
1882 -- designated by the expression shall not be dynamically tagged
1883 -- unless it is a controlling operand in a call on a dispatching
1886 if Is_Tagged_Type (Directly_Designated_Type (T))
1888 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
1890 Ekind (Directly_Designated_Type (Etype (E))) =
1894 ("access to specific tagged type required (RM 3.9.2(9))", E);
1897 -- (Ada 2005: AI-230): Accessibility check for anonymous
1900 if Type_Access_Level (Etype (E)) >
1901 Deepest_Type_Access_Level (T)
1904 ("expression has deeper access level than component " &
1905 "(RM 3.10.2 (12.2))", E);
1908 -- The initialization expression is a reference to an access
1909 -- discriminant. The type of the discriminant is always deeper
1910 -- than any access type.
1912 if Ekind (Etype (E)) = E_Anonymous_Access_Type
1913 and then Is_Entity_Name (E)
1914 and then Ekind (Entity (E)) = E_In_Parameter
1915 and then Present (Discriminal_Link (Entity (E)))
1918 ("discriminant has deeper accessibility level than target",
1924 -- The parent type may be a private view with unknown discriminants,
1925 -- and thus unconstrained. Regular components must be constrained.
1927 if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
1928 if Is_Class_Wide_Type (T) then
1930 ("class-wide subtype with unknown discriminants" &
1931 " in component declaration",
1932 Subtype_Indication (Component_Definition (N)));
1935 ("unconstrained subtype in component declaration",
1936 Subtype_Indication (Component_Definition (N)));
1939 -- Components cannot be abstract, except for the special case of
1940 -- the _Parent field (case of extending an abstract tagged type)
1942 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then
1943 Error_Msg_N ("type of a component cannot be abstract", N);
1947 Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
1949 -- The component declaration may have a per-object constraint, set
1950 -- the appropriate flag in the defining identifier of the subtype.
1952 if Present (Subtype_Indication (Component_Definition (N))) then
1954 Sindic : constant Node_Id :=
1955 Subtype_Indication (Component_Definition (N));
1957 if Nkind (Sindic) = N_Subtype_Indication
1958 and then Present (Constraint (Sindic))
1959 and then Contains_POC (Constraint (Sindic))
1961 Set_Has_Per_Object_Constraint (Id);
1966 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1967 -- out some static checks.
1969 if Ada_Version >= Ada_2005
1970 and then Can_Never_Be_Null (T)
1972 Null_Exclusion_Static_Checks (N);
1975 -- If this component is private (or depends on a private type), flag the
1976 -- record type to indicate that some operations are not available.
1978 P := Private_Component (T);
1982 -- Check for circular definitions
1984 if P = Any_Type then
1985 Set_Etype (Id, Any_Type);
1987 -- There is a gap in the visibility of operations only if the
1988 -- component type is not defined in the scope of the record type.
1990 elsif Scope (P) = Scope (Current_Scope) then
1993 elsif Is_Limited_Type (P) then
1994 Set_Is_Limited_Composite (Current_Scope);
1997 Set_Is_Private_Composite (Current_Scope);
2002 and then Is_Limited_Type (T)
2003 and then Chars (Id) /= Name_uParent
2004 and then Is_Tagged_Type (Current_Scope)
2006 if Is_Derived_Type (Current_Scope)
2007 and then not Is_Known_Limited (Current_Scope)
2010 ("extension of nonlimited type cannot have limited components",
2013 if Is_Interface (Root_Type (Current_Scope)) then
2015 ("\limitedness is not inherited from limited interface", N);
2016 Error_Msg_N ("\add LIMITED to type indication", N);
2019 Explain_Limited_Type (T, N);
2020 Set_Etype (Id, Any_Type);
2021 Set_Is_Limited_Composite (Current_Scope, False);
2023 elsif not Is_Derived_Type (Current_Scope)
2024 and then not Is_Limited_Record (Current_Scope)
2025 and then not Is_Concurrent_Type (Current_Scope)
2028 ("nonlimited tagged type cannot have limited components", N);
2029 Explain_Limited_Type (T, N);
2030 Set_Etype (Id, Any_Type);
2031 Set_Is_Limited_Composite (Current_Scope, False);
2035 Set_Original_Record_Component (Id, Id);
2037 if Has_Aspects (N) then
2038 Analyze_Aspect_Specifications (N, Id);
2041 Analyze_Dimension (N);
2042 end Analyze_Component_Declaration;
2044 --------------------------
2045 -- Analyze_Declarations --
2046 --------------------------
2048 procedure Analyze_Declarations (L : List_Id) is
2050 Freeze_From : Entity_Id := Empty;
2051 Next_Node : Node_Id;
2054 -- Adjust D not to include implicit label declarations, since these
2055 -- have strange Sloc values that result in elaboration check problems.
2056 -- (They have the sloc of the label as found in the source, and that
2057 -- is ahead of the current declarative part).
2063 procedure Adjust_D is
2065 while Present (Prev (D))
2066 and then Nkind (D) = N_Implicit_Label_Declaration
2072 -- Start of processing for Analyze_Declarations
2075 if Restriction_Check_Required (SPARK) then
2076 Check_Later_Vs_Basic_Declarations (L, During_Parsing => False);
2080 while Present (D) loop
2082 -- Package spec cannot contain a package declaration in SPARK
2084 if Nkind (D) = N_Package_Declaration
2085 and then Nkind (Parent (L)) = N_Package_Specification
2087 Check_SPARK_Restriction
2088 ("package specification cannot contain a package declaration",
2092 -- Complete analysis of declaration
2095 Next_Node := Next (D);
2097 if No (Freeze_From) then
2098 Freeze_From := First_Entity (Current_Scope);
2101 -- At the end of a declarative part, freeze remaining entities
2102 -- declared in it. The end of the visible declarations of package
2103 -- specification is not the end of a declarative part if private
2104 -- declarations are present. The end of a package declaration is a
2105 -- freezing point only if it a library package. A task definition or
2106 -- protected type definition is not a freeze point either. Finally,
2107 -- we do not freeze entities in generic scopes, because there is no
2108 -- code generated for them and freeze nodes will be generated for
2111 -- The end of a package instantiation is not a freeze point, but
2112 -- for now we make it one, because the generic body is inserted
2113 -- (currently) immediately after. Generic instantiations will not
2114 -- be a freeze point once delayed freezing of bodies is implemented.
2115 -- (This is needed in any case for early instantiations ???).
2117 if No (Next_Node) then
2118 if Nkind_In (Parent (L), N_Component_List,
2120 N_Protected_Definition)
2124 elsif Nkind (Parent (L)) /= N_Package_Specification then
2125 if Nkind (Parent (L)) = N_Package_Body then
2126 Freeze_From := First_Entity (Current_Scope);
2130 Freeze_All (Freeze_From, D);
2131 Freeze_From := Last_Entity (Current_Scope);
2133 elsif Scope (Current_Scope) /= Standard_Standard
2134 and then not Is_Child_Unit (Current_Scope)
2135 and then No (Generic_Parent (Parent (L)))
2139 elsif L /= Visible_Declarations (Parent (L))
2140 or else No (Private_Declarations (Parent (L)))
2141 or else Is_Empty_List (Private_Declarations (Parent (L)))
2144 Freeze_All (Freeze_From, D);
2145 Freeze_From := Last_Entity (Current_Scope);
2148 -- If next node is a body then freeze all types before the body.
2149 -- An exception occurs for some expander-generated bodies. If these
2150 -- are generated at places where in general language rules would not
2151 -- allow a freeze point, then we assume that the expander has
2152 -- explicitly checked that all required types are properly frozen,
2153 -- and we do not cause general freezing here. This special circuit
2154 -- is used when the encountered body is marked as having already
2157 -- In all other cases (bodies that come from source, and expander
2158 -- generated bodies that have not been analyzed yet), freeze all
2159 -- types now. Note that in the latter case, the expander must take
2160 -- care to attach the bodies at a proper place in the tree so as to
2161 -- not cause unwanted freezing at that point.
2163 elsif not Analyzed (Next_Node)
2164 and then (Nkind_In (Next_Node, N_Subprogram_Body,
2170 Nkind (Next_Node) in N_Body_Stub)
2173 Freeze_All (Freeze_From, D);
2174 Freeze_From := Last_Entity (Current_Scope);
2180 -- One more thing to do, we need to scan the declarations to check
2181 -- for any precondition/postcondition pragmas (Pre/Post aspects have
2182 -- by this stage been converted into corresponding pragmas). It is
2183 -- at this point that we analyze the expressions in such pragmas,
2184 -- to implement the delayed visibility requirement.
2194 while Present (Decl) loop
2195 if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
2196 Spec := Specification (Original_Node (Decl));
2197 Sent := Defining_Unit_Name (Spec);
2199 Prag := Spec_PPC_List (Contract (Sent));
2200 while Present (Prag) loop
2201 Analyze_PPC_In_Decl_Part (Prag, Sent);
2202 Prag := Next_Pragma (Prag);
2205 Check_Subprogram_Contract (Sent);
2207 Prag := Spec_TC_List (Contract (Sent));
2208 while Present (Prag) loop
2209 Analyze_TC_In_Decl_Part (Prag, Sent);
2210 Prag := Next_Pragma (Prag);
2217 end Analyze_Declarations;
2219 -----------------------------------
2220 -- Analyze_Full_Type_Declaration --
2221 -----------------------------------
2223 procedure Analyze_Full_Type_Declaration (N : Node_Id) is
2224 Def : constant Node_Id := Type_Definition (N);
2225 Def_Id : constant Entity_Id := Defining_Identifier (N);
2229 Is_Remote : constant Boolean :=
2230 (Is_Remote_Types (Current_Scope)
2231 or else Is_Remote_Call_Interface (Current_Scope))
2232 and then not (In_Private_Part (Current_Scope)
2233 or else In_Package_Body (Current_Scope));
2235 procedure Check_Ops_From_Incomplete_Type;
2236 -- If there is a tagged incomplete partial view of the type, traverse
2237 -- the primitives of the incomplete view and change the type of any
2238 -- controlling formals and result to indicate the full view. The
2239 -- primitives will be added to the full type's primitive operations
2240 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which
2241 -- is called from Process_Incomplete_Dependents).
2243 ------------------------------------
2244 -- Check_Ops_From_Incomplete_Type --
2245 ------------------------------------
2247 procedure Check_Ops_From_Incomplete_Type is
2254 and then Ekind (Prev) = E_Incomplete_Type
2255 and then Is_Tagged_Type (Prev)
2256 and then Is_Tagged_Type (T)
2258 Elmt := First_Elmt (Primitive_Operations (Prev));
2259 while Present (Elmt) loop
2262 Formal := First_Formal (Op);
2263 while Present (Formal) loop
2264 if Etype (Formal) = Prev then
2265 Set_Etype (Formal, T);
2268 Next_Formal (Formal);
2271 if Etype (Op) = Prev then
2278 end Check_Ops_From_Incomplete_Type;
2280 -- Start of processing for Analyze_Full_Type_Declaration
2283 Prev := Find_Type_Name (N);
2285 -- The full view, if present, now points to the current type
2287 -- Ada 2005 (AI-50217): If the type was previously decorated when
2288 -- imported through a LIMITED WITH clause, it appears as incomplete
2289 -- but has no full view.
2291 if Ekind (Prev) = E_Incomplete_Type
2292 and then Present (Full_View (Prev))
2294 T := Full_View (Prev);
2299 Set_Is_Pure (T, Is_Pure (Current_Scope));
2301 -- We set the flag Is_First_Subtype here. It is needed to set the
2302 -- corresponding flag for the Implicit class-wide-type created
2303 -- during tagged types processing.
2305 Set_Is_First_Subtype (T, True);
2307 -- Only composite types other than array types are allowed to have
2312 -- For derived types, the rule will be checked once we've figured
2313 -- out the parent type.
2315 when N_Derived_Type_Definition =>
2318 -- For record types, discriminants are allowed, unless we are in
2321 when N_Record_Definition =>
2322 if Present (Discriminant_Specifications (N)) then
2323 Check_SPARK_Restriction
2324 ("discriminant type is not allowed",
2326 (First (Discriminant_Specifications (N))));
2330 if Present (Discriminant_Specifications (N)) then
2332 ("elementary or array type cannot have discriminants",
2334 (First (Discriminant_Specifications (N))));
2338 -- Elaborate the type definition according to kind, and generate
2339 -- subsidiary (implicit) subtypes where needed. We skip this if it was
2340 -- already done (this happens during the reanalysis that follows a call
2341 -- to the high level optimizer).
2343 if not Analyzed (T) then
2348 when N_Access_To_Subprogram_Definition =>
2349 Access_Subprogram_Declaration (T, Def);
2351 -- If this is a remote access to subprogram, we must create the
2352 -- equivalent fat pointer type, and related subprograms.
2355 Process_Remote_AST_Declaration (N);
2358 -- Validate categorization rule against access type declaration
2359 -- usually a violation in Pure unit, Shared_Passive unit.
2361 Validate_Access_Type_Declaration (T, N);
2363 when N_Access_To_Object_Definition =>
2364 Access_Type_Declaration (T, Def);
2366 -- Validate categorization rule against access type declaration
2367 -- usually a violation in Pure unit, Shared_Passive unit.
2369 Validate_Access_Type_Declaration (T, N);
2371 -- If we are in a Remote_Call_Interface package and define a
2372 -- RACW, then calling stubs and specific stream attributes
2376 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
2378 Add_RACW_Features (Def_Id);
2381 -- Set no strict aliasing flag if config pragma seen
2383 if Opt.No_Strict_Aliasing then
2384 Set_No_Strict_Aliasing (Base_Type (Def_Id));
2387 when N_Array_Type_Definition =>
2388 Array_Type_Declaration (T, Def);
2390 when N_Derived_Type_Definition =>
2391 Derived_Type_Declaration (T, N, T /= Def_Id);
2393 when N_Enumeration_Type_Definition =>
2394 Enumeration_Type_Declaration (T, Def);
2396 when N_Floating_Point_Definition =>
2397 Floating_Point_Type_Declaration (T, Def);
2399 when N_Decimal_Fixed_Point_Definition =>
2400 Decimal_Fixed_Point_Type_Declaration (T, Def);
2402 when N_Ordinary_Fixed_Point_Definition =>
2403 Ordinary_Fixed_Point_Type_Declaration (T, Def);
2405 when N_Signed_Integer_Type_Definition =>
2406 Signed_Integer_Type_Declaration (T, Def);
2408 when N_Modular_Type_Definition =>
2409 Modular_Type_Declaration (T, Def);
2411 when N_Record_Definition =>
2412 Record_Type_Declaration (T, N, Prev);
2414 -- If declaration has a parse error, nothing to elaborate.
2420 raise Program_Error;
2425 if Etype (T) = Any_Type then
2429 -- Controlled type is not allowed in SPARK
2431 if Is_Visibly_Controlled (T) then
2432 Check_SPARK_Restriction ("controlled type is not allowed", N);
2435 -- Some common processing for all types
2437 Set_Depends_On_Private (T, Has_Private_Component (T));
2438 Check_Ops_From_Incomplete_Type;
2440 -- Both the declared entity, and its anonymous base type if one
2441 -- was created, need freeze nodes allocated.
2444 B : constant Entity_Id := Base_Type (T);
2447 -- In the case where the base type differs from the first subtype, we
2448 -- pre-allocate a freeze node, and set the proper link to the first
2449 -- subtype. Freeze_Entity will use this preallocated freeze node when
2450 -- it freezes the entity.
2452 -- This does not apply if the base type is a generic type, whose
2453 -- declaration is independent of the current derived definition.
2455 if B /= T and then not Is_Generic_Type (B) then
2456 Ensure_Freeze_Node (B);
2457 Set_First_Subtype_Link (Freeze_Node (B), T);
2460 -- A type that is imported through a limited_with clause cannot
2461 -- generate any code, and thus need not be frozen. However, an access
2462 -- type with an imported designated type needs a finalization list,
2463 -- which may be referenced in some other package that has non-limited
2464 -- visibility on the designated type. Thus we must create the
2465 -- finalization list at the point the access type is frozen, to
2466 -- prevent unsatisfied references at link time.
2468 if not From_With_Type (T) or else Is_Access_Type (T) then
2469 Set_Has_Delayed_Freeze (T);
2473 -- Case where T is the full declaration of some private type which has
2474 -- been swapped in Defining_Identifier (N).
2476 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2477 Process_Full_View (N, T, Def_Id);
2479 -- Record the reference. The form of this is a little strange, since
2480 -- the full declaration has been swapped in. So the first parameter
2481 -- here represents the entity to which a reference is made which is
2482 -- the "real" entity, i.e. the one swapped in, and the second
2483 -- parameter provides the reference location.
2485 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here
2486 -- since we don't want a complaint about the full type being an
2487 -- unwanted reference to the private type
2490 B : constant Boolean := Has_Pragma_Unreferenced (T);
2492 Set_Has_Pragma_Unreferenced (T, False);
2493 Generate_Reference (T, T, 'c');
2494 Set_Has_Pragma_Unreferenced (T, B);
2497 Set_Completion_Referenced (Def_Id);
2499 -- For completion of incomplete type, process incomplete dependents
2500 -- and always mark the full type as referenced (it is the incomplete
2501 -- type that we get for any real reference).
2503 elsif Ekind (Prev) = E_Incomplete_Type then
2504 Process_Incomplete_Dependents (N, T, Prev);
2505 Generate_Reference (Prev, Def_Id, 'c');
2506 Set_Completion_Referenced (Def_Id);
2508 -- If not private type or incomplete type completion, this is a real
2509 -- definition of a new entity, so record it.
2512 Generate_Definition (Def_Id);
2515 if Chars (Scope (Def_Id)) = Name_System
2516 and then Chars (Def_Id) = Name_Address
2517 and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
2519 Set_Is_Descendent_Of_Address (Def_Id);
2520 Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
2521 Set_Is_Descendent_Of_Address (Prev);
2524 Set_Optimize_Alignment_Flags (Def_Id);
2525 Check_Eliminated (Def_Id);
2527 -- If the declaration is a completion and aspects are present, apply
2528 -- them to the entity for the type which is currently the partial
2529 -- view, but which is the one that will be frozen.
2531 if Has_Aspects (N) then
2532 if Prev /= Def_Id then
2533 Analyze_Aspect_Specifications (N, Prev);
2535 Analyze_Aspect_Specifications (N, Def_Id);
2538 end Analyze_Full_Type_Declaration;
2540 ----------------------------------
2541 -- Analyze_Incomplete_Type_Decl --
2542 ----------------------------------
2544 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
2545 F : constant Boolean := Is_Pure (Current_Scope);
2549 Check_SPARK_Restriction ("incomplete type is not allowed", N);
2551 Generate_Definition (Defining_Identifier (N));
2553 -- Process an incomplete declaration. The identifier must not have been
2554 -- declared already in the scope. However, an incomplete declaration may
2555 -- appear in the private part of a package, for a private type that has
2556 -- already been declared.
2558 -- In this case, the discriminants (if any) must match
2560 T := Find_Type_Name (N);
2562 Set_Ekind (T, E_Incomplete_Type);
2563 Init_Size_Align (T);
2564 Set_Is_First_Subtype (T, True);
2567 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
2568 -- incomplete types.
2570 if Tagged_Present (N) then
2571 Set_Is_Tagged_Type (T);
2572 Make_Class_Wide_Type (T);
2573 Set_Direct_Primitive_Operations (T, New_Elmt_List);
2578 Set_Stored_Constraint (T, No_Elist);
2580 if Present (Discriminant_Specifications (N)) then
2581 Process_Discriminants (N);
2586 -- If the type has discriminants, non-trivial subtypes may be
2587 -- declared before the full view of the type. The full views of those
2588 -- subtypes will be built after the full view of the type.
2590 Set_Private_Dependents (T, New_Elmt_List);
2592 end Analyze_Incomplete_Type_Decl;
2594 -----------------------------------
2595 -- Analyze_Interface_Declaration --
2596 -----------------------------------
2598 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
2599 CW : constant Entity_Id := Class_Wide_Type (T);
2602 Set_Is_Tagged_Type (T);
2604 Set_Is_Limited_Record (T, Limited_Present (Def)
2605 or else Task_Present (Def)
2606 or else Protected_Present (Def)
2607 or else Synchronized_Present (Def));
2609 -- Type is abstract if full declaration carries keyword, or if previous
2610 -- partial view did.
2612 Set_Is_Abstract_Type (T);
2613 Set_Is_Interface (T);
2615 -- Type is a limited interface if it includes the keyword limited, task,
2616 -- protected, or synchronized.
2618 Set_Is_Limited_Interface
2619 (T, Limited_Present (Def)
2620 or else Protected_Present (Def)
2621 or else Synchronized_Present (Def)
2622 or else Task_Present (Def));
2624 Set_Interfaces (T, New_Elmt_List);
2625 Set_Direct_Primitive_Operations (T, New_Elmt_List);
2627 -- Complete the decoration of the class-wide entity if it was already
2628 -- built (i.e. during the creation of the limited view)
2630 if Present (CW) then
2631 Set_Is_Interface (CW);
2632 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T));
2635 -- Check runtime support for synchronized interfaces
2637 if VM_Target = No_VM
2638 and then (Is_Task_Interface (T)
2639 or else Is_Protected_Interface (T)
2640 or else Is_Synchronized_Interface (T))
2641 and then not RTE_Available (RE_Select_Specific_Data)
2643 Error_Msg_CRT ("synchronized interfaces", T);
2645 end Analyze_Interface_Declaration;
2647 -----------------------------
2648 -- Analyze_Itype_Reference --
2649 -----------------------------
2651 -- Nothing to do. This node is placed in the tree only for the benefit of
2652 -- back end processing, and has no effect on the semantic processing.
2654 procedure Analyze_Itype_Reference (N : Node_Id) is
2656 pragma Assert (Is_Itype (Itype (N)));
2658 end Analyze_Itype_Reference;
2660 --------------------------------
2661 -- Analyze_Number_Declaration --
2662 --------------------------------
2664 procedure Analyze_Number_Declaration (N : Node_Id) is
2665 Id : constant Entity_Id := Defining_Identifier (N);
2666 E : constant Node_Id := Expression (N);
2668 Index : Interp_Index;
2672 Generate_Definition (Id);
2675 -- This is an optimization of a common case of an integer literal
2677 if Nkind (E) = N_Integer_Literal then
2678 Set_Is_Static_Expression (E, True);
2679 Set_Etype (E, Universal_Integer);
2681 Set_Etype (Id, Universal_Integer);
2682 Set_Ekind (Id, E_Named_Integer);
2683 Set_Is_Frozen (Id, True);
2687 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2689 -- Process expression, replacing error by integer zero, to avoid
2690 -- cascaded errors or aborts further along in the processing
2692 -- Replace Error by integer zero, which seems least likely to cause
2696 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
2697 Set_Error_Posted (E);
2702 -- Verify that the expression is static and numeric. If
2703 -- the expression is overloaded, we apply the preference
2704 -- rule that favors root numeric types.
2706 if not Is_Overloaded (E) then
2712 Get_First_Interp (E, Index, It);
2713 while Present (It.Typ) loop
2714 if (Is_Integer_Type (It.Typ)
2715 or else Is_Real_Type (It.Typ))
2716 and then (Scope (Base_Type (It.Typ))) = Standard_Standard
2718 if T = Any_Type then
2721 elsif It.Typ = Universal_Real
2722 or else It.Typ = Universal_Integer
2724 -- Choose universal interpretation over any other
2731 Get_Next_Interp (Index, It);
2735 if Is_Integer_Type (T) then
2737 Set_Etype (Id, Universal_Integer);
2738 Set_Ekind (Id, E_Named_Integer);
2740 elsif Is_Real_Type (T) then
2742 -- Because the real value is converted to universal_real, this is a
2743 -- legal context for a universal fixed expression.
2745 if T = Universal_Fixed then
2747 Loc : constant Source_Ptr := Sloc (N);
2748 Conv : constant Node_Id := Make_Type_Conversion (Loc,
2750 New_Occurrence_Of (Universal_Real, Loc),
2751 Expression => Relocate_Node (E));
2758 elsif T = Any_Fixed then
2759 Error_Msg_N ("illegal context for mixed mode operation", E);
2761 -- Expression is of the form : universal_fixed * integer. Try to
2762 -- resolve as universal_real.
2764 T := Universal_Real;
2769 Set_Etype (Id, Universal_Real);
2770 Set_Ekind (Id, E_Named_Real);
2773 Wrong_Type (E, Any_Numeric);
2777 Set_Ekind (Id, E_Constant);
2778 Set_Never_Set_In_Source (Id, True);
2779 Set_Is_True_Constant (Id, True);
2783 if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
2784 Set_Etype (E, Etype (Id));
2787 if not Is_OK_Static_Expression (E) then
2788 Flag_Non_Static_Expr
2789 ("non-static expression used in number declaration!", E);
2790 Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
2791 Set_Etype (E, Any_Type);
2793 end Analyze_Number_Declaration;
2795 --------------------------------
2796 -- Analyze_Object_Declaration --
2797 --------------------------------
2799 procedure Analyze_Object_Declaration (N : Node_Id) is
2800 Loc : constant Source_Ptr := Sloc (N);
2801 Id : constant Entity_Id := Defining_Identifier (N);
2805 E : Node_Id := Expression (N);
2806 -- E is set to Expression (N) throughout this routine. When
2807 -- Expression (N) is modified, E is changed accordingly.
2809 Prev_Entity : Entity_Id := Empty;
2811 function Count_Tasks (T : Entity_Id) return Uint;
2812 -- This function is called when a non-generic library level object of a
2813 -- task type is declared. Its function is to count the static number of
2814 -- tasks declared within the type (it is only called if Has_Tasks is set
2815 -- for T). As a side effect, if an array of tasks with non-static bounds
2816 -- or a variant record type is encountered, Check_Restrictions is called
2817 -- indicating the count is unknown.
2823 function Count_Tasks (T : Entity_Id) return Uint is
2829 if Is_Task_Type (T) then
2832 elsif Is_Record_Type (T) then
2833 if Has_Discriminants (T) then
2834 Check_Restriction (Max_Tasks, N);
2839 C := First_Component (T);
2840 while Present (C) loop
2841 V := V + Count_Tasks (Etype (C));
2848 elsif Is_Array_Type (T) then
2849 X := First_Index (T);
2850 V := Count_Tasks (Component_Type (T));
2851 while Present (X) loop
2854 if not Is_Static_Subtype (C) then
2855 Check_Restriction (Max_Tasks, N);
2858 V := V * (UI_Max (Uint_0,
2859 Expr_Value (Type_High_Bound (C)) -
2860 Expr_Value (Type_Low_Bound (C)) + Uint_1));
2873 -- Start of processing for Analyze_Object_Declaration
2876 -- There are three kinds of implicit types generated by an
2877 -- object declaration:
2879 -- 1. Those generated by the original Object Definition
2881 -- 2. Those generated by the Expression
2883 -- 3. Those used to constrain the Object Definition with the
2884 -- expression constraints when the definition is unconstrained.
2886 -- They must be generated in this order to avoid order of elaboration
2887 -- issues. Thus the first step (after entering the name) is to analyze
2888 -- the object definition.
2890 if Constant_Present (N) then
2891 Prev_Entity := Current_Entity_In_Scope (Id);
2893 if Present (Prev_Entity)
2896 -- If the homograph is an implicit subprogram, it is overridden
2897 -- by the current declaration.
2899 ((Is_Overloadable (Prev_Entity)
2900 and then Is_Inherited_Operation (Prev_Entity))
2902 -- The current object is a discriminal generated for an entry
2903 -- family index. Even though the index is a constant, in this
2904 -- particular context there is no true constant redeclaration.
2905 -- Enter_Name will handle the visibility.
2908 (Is_Discriminal (Id)
2909 and then Ekind (Discriminal_Link (Id)) =
2910 E_Entry_Index_Parameter)
2912 -- The current object is the renaming for a generic declared
2913 -- within the instance.
2916 (Ekind (Prev_Entity) = E_Package
2917 and then Nkind (Parent (Prev_Entity)) =
2918 N_Package_Renaming_Declaration
2919 and then not Comes_From_Source (Prev_Entity)
2920 and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
2922 Prev_Entity := Empty;
2926 if Present (Prev_Entity) then
2927 Constant_Redeclaration (Id, N, T);
2929 Generate_Reference (Prev_Entity, Id, 'c');
2930 Set_Completion_Referenced (Id);
2932 if Error_Posted (N) then
2934 -- Type mismatch or illegal redeclaration, Do not analyze
2935 -- expression to avoid cascaded errors.
2937 T := Find_Type_Of_Object (Object_Definition (N), N);
2939 Set_Ekind (Id, E_Variable);
2943 -- In the normal case, enter identifier at the start to catch premature
2944 -- usage in the initialization expression.
2947 Generate_Definition (Id);
2950 Mark_Coextensions (N, Object_Definition (N));
2952 T := Find_Type_Of_Object (Object_Definition (N), N);
2954 if Nkind (Object_Definition (N)) = N_Access_Definition
2956 (Access_To_Subprogram_Definition (Object_Definition (N)))
2957 and then Protected_Present
2958 (Access_To_Subprogram_Definition (Object_Definition (N)))
2960 T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
2963 if Error_Posted (Id) then
2965 Set_Ekind (Id, E_Variable);
2970 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2971 -- out some static checks
2973 if Ada_Version >= Ada_2005
2974 and then Can_Never_Be_Null (T)
2976 -- In case of aggregates we must also take care of the correct
2977 -- initialization of nested aggregates bug this is done at the
2978 -- point of the analysis of the aggregate (see sem_aggr.adb)
2980 if Present (Expression (N))
2981 and then Nkind (Expression (N)) = N_Aggregate
2987 Save_Typ : constant Entity_Id := Etype (Id);
2989 Set_Etype (Id, T); -- Temp. decoration for static checks
2990 Null_Exclusion_Static_Checks (N);
2991 Set_Etype (Id, Save_Typ);
2996 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2998 -- If deferred constant, make sure context is appropriate. We detect
2999 -- a deferred constant as a constant declaration with no expression.
3000 -- A deferred constant can appear in a package body if its completion
3001 -- is by means of an interface pragma.
3003 if Constant_Present (N)
3006 -- A deferred constant may appear in the declarative part of the
3007 -- following constructs:
3011 -- extended return statements
3014 -- subprogram bodies
3017 -- When declared inside a package spec, a deferred constant must be
3018 -- completed by a full constant declaration or pragma Import. In all
3019 -- other cases, the only proper completion is pragma Import. Extended
3020 -- return statements are flagged as invalid contexts because they do
3021 -- not have a declarative part and so cannot accommodate the pragma.
3023 if Ekind (Current_Scope) = E_Return_Statement then
3025 ("invalid context for deferred constant declaration (RM 7.4)",
3028 ("\declaration requires an initialization expression",
3030 Set_Constant_Present (N, False);
3032 -- In Ada 83, deferred constant must be of private type
3034 elsif not Is_Private_Type (T) then
3035 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3037 ("(Ada 83) deferred constant must be private type", N);
3041 -- If not a deferred constant, then object declaration freezes its type
3044 Check_Fully_Declared (T, N);
3045 Freeze_Before (N, T);
3048 -- If the object was created by a constrained array definition, then
3049 -- set the link in both the anonymous base type and anonymous subtype
3050 -- that are built to represent the array type to point to the object.
3052 if Nkind (Object_Definition (Declaration_Node (Id))) =
3053 N_Constrained_Array_Definition
3055 Set_Related_Array_Object (T, Id);
3056 Set_Related_Array_Object (Base_Type (T), Id);
3059 -- Special checks for protected objects not at library level
3061 if Is_Protected_Type (T)
3062 and then not Is_Library_Level_Entity (Id)
3064 Check_Restriction (No_Local_Protected_Objects, Id);
3066 -- Protected objects with interrupt handlers must be at library level
3068 -- Ada 2005: this test is not needed (and the corresponding clause
3069 -- in the RM is removed) because accessibility checks are sufficient
3070 -- to make handlers not at the library level illegal.
3072 if Has_Interrupt_Handler (T)
3073 and then Ada_Version < Ada_2005
3076 ("interrupt object can only be declared at library level", Id);
3080 -- The actual subtype of the object is the nominal subtype, unless
3081 -- the nominal one is unconstrained and obtained from the expression.
3085 -- These checks should be performed before the initialization expression
3086 -- is considered, so that the Object_Definition node is still the same
3087 -- as in source code.
3089 -- In SPARK, the nominal subtype shall be given by a subtype mark and
3090 -- shall not be unconstrained. (The only exception to this is the
3091 -- admission of declarations of constants of type String.)
3094 Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name)
3096 Check_SPARK_Restriction
3097 ("subtype mark required", Object_Definition (N));
3099 elsif Is_Array_Type (T)
3100 and then not Is_Constrained (T)
3101 and then T /= Standard_String
3103 Check_SPARK_Restriction
3104 ("subtype mark of constrained type expected",
3105 Object_Definition (N));
3108 -- There are no aliased objects in SPARK
3110 if Aliased_Present (N) then
3111 Check_SPARK_Restriction ("aliased object is not allowed", N);
3114 -- Process initialization expression if present and not in error
3116 if Present (E) and then E /= Error then
3118 -- Generate an error in case of CPP class-wide object initialization.
3119 -- Required because otherwise the expansion of the class-wide
3120 -- assignment would try to use 'size to initialize the object
3121 -- (primitive that is not available in CPP tagged types).
3123 if Is_Class_Wide_Type (Act_T)
3125 (Is_CPP_Class (Root_Type (Etype (Act_T)))
3127 (Present (Full_View (Root_Type (Etype (Act_T))))
3129 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
3132 ("predefined assignment not available for 'C'P'P tagged types",
3136 Mark_Coextensions (N, E);
3139 -- In case of errors detected in the analysis of the expression,
3140 -- decorate it with the expected type to avoid cascaded errors
3142 if No (Etype (E)) then
3146 -- If an initialization expression is present, then we set the
3147 -- Is_True_Constant flag. It will be reset if this is a variable
3148 -- and it is indeed modified.
3150 Set_Is_True_Constant (Id, True);
3152 -- If we are analyzing a constant declaration, set its completion
3153 -- flag after analyzing and resolving the expression.
3155 if Constant_Present (N) then
3156 Set_Has_Completion (Id);
3159 -- Set type and resolve (type may be overridden later on)
3164 -- If E is null and has been replaced by an N_Raise_Constraint_Error
3165 -- node (which was marked already-analyzed), we need to set the type
3166 -- to something other than Any_Access in order to keep gigi happy.
3168 if Etype (E) = Any_Access then
3172 -- If the object is an access to variable, the initialization
3173 -- expression cannot be an access to constant.
3175 if Is_Access_Type (T)
3176 and then not Is_Access_Constant (T)
3177 and then Is_Access_Type (Etype (E))
3178 and then Is_Access_Constant (Etype (E))
3181 ("access to variable cannot be initialized "
3182 & "with an access-to-constant expression", E);
3185 if not Assignment_OK (N) then
3186 Check_Initialization (T, E);
3189 Check_Unset_Reference (E);
3191 -- If this is a variable, then set current value. If this is a
3192 -- declared constant of a scalar type with a static expression,
3193 -- indicate that it is always valid.
3195 if not Constant_Present (N) then
3196 if Compile_Time_Known_Value (E) then
3197 Set_Current_Value (Id, E);
3200 elsif Is_Scalar_Type (T)
3201 and then Is_OK_Static_Expression (E)
3203 Set_Is_Known_Valid (Id);
3206 -- Deal with setting of null flags
3208 if Is_Access_Type (T) then
3209 if Known_Non_Null (E) then
3210 Set_Is_Known_Non_Null (Id, True);
3211 elsif Known_Null (E)
3212 and then not Can_Never_Be_Null (Id)
3214 Set_Is_Known_Null (Id, True);
3218 -- Check incorrect use of dynamically tagged expressions.
3220 if Is_Tagged_Type (T) then
3221 Check_Dynamically_Tagged_Expression
3227 Apply_Scalar_Range_Check (E, T);
3228 Apply_Static_Length_Check (E, T);
3230 if Nkind (Original_Node (N)) = N_Object_Declaration
3231 and then Comes_From_Source (Original_Node (N))
3233 -- Only call test if needed
3235 and then Restriction_Check_Required (SPARK)
3236 and then not Is_SPARK_Initialization_Expr (E)
3238 Check_SPARK_Restriction
3239 ("initialization expression is not appropriate", E);
3243 -- If the No_Streams restriction is set, check that the type of the
3244 -- object is not, and does not contain, any subtype derived from
3245 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
3246 -- Has_Stream just for efficiency reasons. There is no point in
3247 -- spending time on a Has_Stream check if the restriction is not set.
3249 if Restriction_Check_Required (No_Streams) then
3250 if Has_Stream (T) then
3251 Check_Restriction (No_Streams, N);
3255 -- Deal with predicate check before we start to do major rewriting.
3256 -- it is OK to initialize and then check the initialized value, since
3257 -- the object goes out of scope if we get a predicate failure. Note
3258 -- that we do this in the analyzer and not the expander because the
3259 -- analyzer does some substantial rewriting in some cases.
3261 -- We need a predicate check if the type has predicates, and if either
3262 -- there is an initializing expression, or for default initialization
3263 -- when we have at least one case of an explicit default initial value.
3265 if not Suppress_Assignment_Checks (N)
3266 and then Present (Predicate_Function (T))
3270 Is_Partially_Initialized_Type (T, Include_Implicit => False))
3273 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
3276 -- Case of unconstrained type
3278 if Is_Indefinite_Subtype (T) then
3280 -- In SPARK, a declaration of unconstrained type is allowed
3281 -- only for constants of type string.
3283 if Is_String_Type (T) and then not Constant_Present (N) then
3284 Check_SPARK_Restriction
3285 ("declaration of object of unconstrained
OSDN Git Service
