1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
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_Dist
; use Exp_Dist
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
38 with Itypes
; use Itypes
;
39 with Layout
; use Layout
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Case
; use Sem_Case
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch6
; use Sem_Ch6
;
52 with Sem_Ch7
; use Sem_Ch7
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch13
; use Sem_Ch13
;
55 with Sem_Disp
; use Sem_Disp
;
56 with Sem_Dist
; use Sem_Dist
;
57 with Sem_Elim
; use Sem_Elim
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Mech
; use Sem_Mech
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Smem
; use Sem_Smem
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Warn
; use Sem_Warn
;
65 with Stand
; use Stand
;
66 with Sinfo
; use Sinfo
;
67 with Snames
; use Snames
;
68 with Targparm
; use Targparm
;
69 with Tbuild
; use Tbuild
;
70 with Ttypes
; use Ttypes
;
71 with Uintp
; use Uintp
;
72 with Urealp
; use Urealp
;
74 package body Sem_Ch3
is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Add_Interface_Tag_Components
81 (N
: Node_Id
; Typ
: Entity_Id
);
82 -- Ada 2005 (AI-251): Add the tag components corresponding to all the
83 -- abstract interface types implemented by a record type or a derived
86 procedure Build_Derived_Type
88 Parent_Type
: Entity_Id
;
89 Derived_Type
: Entity_Id
;
90 Is_Completion
: Boolean;
91 Derive_Subps
: Boolean := True);
92 -- Create and decorate a Derived_Type given the Parent_Type entity. N is
93 -- the N_Full_Type_Declaration node containing the derived type definition.
94 -- Parent_Type is the entity for the parent type in the derived type
95 -- definition and Derived_Type the actual derived type. Is_Completion must
96 -- be set to False if Derived_Type is the N_Defining_Identifier node in N
97 -- (ie Derived_Type = Defining_Identifier (N)). In this case N is not the
98 -- completion of a private type declaration. If Is_Completion is set to
99 -- True, N is the completion of a private type declaration and Derived_Type
100 -- is different from the defining identifier inside N (i.e. Derived_Type /=
101 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent
102 -- subprograms should be derived. The only case where this parameter is
103 -- False is when Build_Derived_Type is recursively called to process an
104 -- implicit derived full type for a type derived from a private type (in
105 -- that case the subprograms must only be derived for the private view of
108 -- ??? These flags need a bit of re-examination and re-documentation:
109 -- ??? are they both necessary (both seem related to the recursion)?
111 procedure Build_Derived_Access_Type
113 Parent_Type
: Entity_Id
;
114 Derived_Type
: Entity_Id
);
115 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
116 -- create an implicit base if the parent type is constrained or if the
117 -- subtype indication has a constraint.
119 procedure Build_Derived_Array_Type
121 Parent_Type
: Entity_Id
;
122 Derived_Type
: Entity_Id
);
123 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
124 -- create an implicit base if the parent type is constrained or if the
125 -- subtype indication has a constraint.
127 procedure Build_Derived_Concurrent_Type
129 Parent_Type
: Entity_Id
;
130 Derived_Type
: Entity_Id
);
131 -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
132 -- tected type, inherit entries and protected subprograms, check legality
133 -- of discriminant constraints if any.
135 procedure Build_Derived_Enumeration_Type
137 Parent_Type
: Entity_Id
;
138 Derived_Type
: Entity_Id
);
139 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
140 -- type, we must create a new list of literals. Types derived from
141 -- Character and Wide_Character are special-cased.
143 procedure Build_Derived_Numeric_Type
145 Parent_Type
: Entity_Id
;
146 Derived_Type
: Entity_Id
);
147 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
148 -- an anonymous base type, and propagate constraint to subtype if needed.
150 procedure Build_Derived_Private_Type
152 Parent_Type
: Entity_Id
;
153 Derived_Type
: Entity_Id
;
154 Is_Completion
: Boolean;
155 Derive_Subps
: Boolean := True);
156 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
157 -- because the parent may or may not have a completion, and the derivation
158 -- may itself be a completion.
160 procedure Build_Derived_Record_Type
162 Parent_Type
: Entity_Id
;
163 Derived_Type
: Entity_Id
;
164 Derive_Subps
: Boolean := True);
165 -- Subsidiary procedure for Build_Derived_Type and
166 -- Analyze_Private_Extension_Declaration used for tagged and untagged
167 -- record types. All parameters are as in Build_Derived_Type except that
168 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
169 -- N_Private_Extension_Declaration node. See the definition of this routine
170 -- for much more info. Derive_Subps indicates whether subprograms should
171 -- be derived from the parent type. The only case where Derive_Subps is
172 -- False is for an implicit derived full type for a type derived from a
173 -- private type (see Build_Derived_Type).
175 procedure Complete_Subprograms_Derivation
176 (Partial_View
: Entity_Id
;
177 Derived_Type
: Entity_Id
);
178 -- Ada 2005 (AI-251): Used to complete type derivation of private tagged
179 -- types implementing interfaces. In this case some interface primitives
180 -- may have been overriden with the partial-view and, instead of
181 -- re-calculating them, they are included in the list of primitive
182 -- operations of the full-view.
184 function Inherit_Components
186 Parent_Base
: Entity_Id
;
187 Derived_Base
: Entity_Id
;
189 Inherit_Discr
: Boolean;
190 Discs
: Elist_Id
) return Elist_Id
;
191 -- Called from Build_Derived_Record_Type to inherit the components of
192 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
193 -- For more information on derived types and component inheritance please
194 -- consult the comment above the body of Build_Derived_Record_Type.
196 -- N is the original derived type declaration
198 -- Is_Tagged is set if we are dealing with tagged types
200 -- If Inherit_Discr is set, Derived_Base inherits its discriminants
201 -- from Parent_Base, otherwise no discriminants are inherited.
203 -- Discs gives the list of constraints that apply to Parent_Base in the
204 -- derived type declaration. If Discs is set to No_Elist, then we have
205 -- the following situation:
207 -- type Parent (D1..Dn : ..) is [tagged] record ...;
208 -- type Derived is new Parent [with ...];
210 -- which gets treated as
212 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
214 -- For untagged types the returned value is an association list. The list
215 -- starts from the association (Parent_Base => Derived_Base), and then it
216 -- contains a sequence of the associations of the form
218 -- (Old_Component => New_Component),
220 -- where Old_Component is the Entity_Id of a component in Parent_Base
221 -- and New_Component is the Entity_Id of the corresponding component
222 -- in Derived_Base. For untagged records, this association list is
223 -- needed when copying the record declaration for the derived base.
224 -- In the tagged case the value returned is irrelevant.
226 procedure Build_Discriminal
(Discrim
: Entity_Id
);
227 -- Create the discriminal corresponding to discriminant Discrim, that is
228 -- the parameter corresponding to Discrim to be used in initialization
229 -- procedures for the type where Discrim is a discriminant. Discriminals
230 -- are not used during semantic analysis, and are not fully defined
231 -- entities until expansion. Thus they are not given a scope until
232 -- initialization procedures are built.
234 function Build_Discriminant_Constraints
237 Derived_Def
: Boolean := False) return Elist_Id
;
238 -- Validate discriminant constraints, and return the list of the
239 -- constraints in order of discriminant declarations. T is the
240 -- discriminated unconstrained type. Def is the N_Subtype_Indication node
241 -- where the discriminants constraints for T are specified. Derived_Def is
242 -- True if we are building the discriminant constraints in a derived type
243 -- definition of the form "type D (...) is new T (xxx)". In this case T is
244 -- the parent type and Def is the constraint "(xxx)" on T and this routine
245 -- sets the Corresponding_Discriminant field of the discriminants in the
246 -- derived type D to point to the corresponding discriminants in the parent
249 procedure Build_Discriminated_Subtype
253 Related_Nod
: Node_Id
;
254 For_Access
: Boolean := False);
255 -- Subsidiary procedure to Constrain_Discriminated_Type and to
256 -- Process_Incomplete_Dependents. Given
258 -- T (a possibly discriminated base type)
259 -- Def_Id (a very partially built subtype for T),
261 -- the call completes Def_Id to be the appropriate E_*_Subtype.
263 -- The Elist is the list of discriminant constraints if any (it is set to
264 -- No_Elist if T is not a discriminated type, and to an empty list if
265 -- T has discriminants but there are no discriminant constraints). The
266 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
267 -- The For_Access says whether or not this subtype is really constraining
268 -- an access type. That is its sole purpose is the designated type of an
269 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
270 -- is built to avoid freezing T when the access subtype is frozen.
272 function Build_Scalar_Bound
275 Der_T
: Entity_Id
) return Node_Id
;
276 -- The bounds of a derived scalar type are conversions of the bounds of
277 -- the parent type. Optimize the representation if the bounds are literals.
278 -- Needs a more complete spec--what are the parameters exactly, and what
279 -- exactly is the returned value, and how is Bound affected???
281 procedure Build_Underlying_Full_View
285 -- If the completion of a private type is itself derived from a private
286 -- type, or if the full view of a private subtype is itself private, the
287 -- back-end has no way to compute the actual size of this type. We build
288 -- an internal subtype declaration of the proper parent type to convey
289 -- this information. This extra mechanism is needed because a full
290 -- view cannot itself have a full view (it would get clobbered during
293 procedure Check_Access_Discriminant_Requires_Limited
296 -- Check the restriction that the type to which an access discriminant
297 -- belongs must be a concurrent type or a descendant of a type with
298 -- the reserved word 'limited' in its declaration.
300 procedure Check_Delta_Expression
(E
: Node_Id
);
301 -- Check that the expression represented by E is suitable for use
302 -- as a delta expression, i.e. it is of real type and is static.
304 procedure Check_Digits_Expression
(E
: Node_Id
);
305 -- Check that the expression represented by E is suitable for use as
306 -- a digits expression, i.e. it is of integer type, positive and static.
308 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
);
309 -- Validate the initialization of an object declaration. T is the
310 -- required type, and Exp is the initialization expression.
312 procedure Check_Or_Process_Discriminants
315 Prev
: Entity_Id
:= Empty
);
316 -- If T is the full declaration of an incomplete or private type, check
317 -- the conformance of the discriminants, otherwise process them. Prev
318 -- is the entity of the partial declaration, if any.
320 procedure Check_Real_Bound
(Bound
: Node_Id
);
321 -- Check given bound for being of real type and static. If not, post an
322 -- appropriate message, and rewrite the bound with the real literal zero.
324 procedure Constant_Redeclaration
328 -- Various checks on legality of full declaration of deferred constant.
329 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
330 -- node. The caller has not yet set any attributes of this entity.
332 procedure Convert_Scalar_Bounds
334 Parent_Type
: Entity_Id
;
335 Derived_Type
: Entity_Id
;
337 -- For derived scalar types, convert the bounds in the type definition
338 -- to the derived type, and complete their analysis. Given a constraint
340 -- .. new T range Lo .. Hi;
341 -- Lo and Hi are analyzed and resolved with T'Base, the parent_type.
342 -- The bounds of the derived type (the anonymous base) are copies of
343 -- Lo and Hi. Finally, the bounds of the derived subtype are conversions
344 -- of those bounds to the derived_type, so that their typing is
347 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
);
348 -- Copies attributes from array base type T2 to array base type T1.
349 -- Copies only attributes that apply to base types, but not subtypes.
351 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
);
352 -- Copies attributes from array subtype T2 to array subtype T1. Copies
353 -- attributes that apply to both subtypes and base types.
355 procedure Create_Constrained_Components
359 Constraints
: Elist_Id
);
360 -- Build the list of entities for a constrained discriminated record
361 -- subtype. If a component depends on a discriminant, replace its subtype
362 -- using the discriminant values in the discriminant constraint.
363 -- Subt is the defining identifier for the subtype whose list of
364 -- constrained entities we will create. Decl_Node is the type declaration
365 -- node where we will attach all the itypes created. Typ is the base
366 -- discriminated type for the subtype Subt. Constraints is the list of
367 -- discriminant constraints for Typ.
369 function Constrain_Component_Type
371 Constrained_Typ
: Entity_Id
;
372 Related_Node
: Node_Id
;
374 Constraints
: Elist_Id
) return Entity_Id
;
375 -- Given a discriminated base type Typ, a list of discriminant constraint
376 -- Constraints for Typ and a component of Typ, with type Compon_Type,
377 -- create and return the type corresponding to Compon_type where all
378 -- discriminant references are replaced with the corresponding
379 -- constraint. If no discriminant references occur in Compon_Typ then
380 -- return it as is. Constrained_Typ is the final constrained subtype to
381 -- which the constrained Compon_Type belongs. Related_Node is the node
382 -- where we will attach all the itypes created.
384 procedure Constrain_Access
385 (Def_Id
: in out Entity_Id
;
387 Related_Nod
: Node_Id
);
388 -- Apply a list of constraints to an access type. If Def_Id is empty, it is
389 -- an anonymous type created for a subtype indication. In that case it is
390 -- created in the procedure and attached to Related_Nod.
392 procedure Constrain_Array
393 (Def_Id
: in out Entity_Id
;
395 Related_Nod
: Node_Id
;
396 Related_Id
: Entity_Id
;
398 -- Apply a list of index constraints to an unconstrained array type. The
399 -- first parameter is the entity for the resulting subtype. A value of
400 -- Empty for Def_Id indicates that an implicit type must be created, but
401 -- creation is delayed (and must be done by this procedure) because other
402 -- subsidiary implicit types must be created first (which is why Def_Id
403 -- is an in/out parameter). The second parameter is a subtype indication
404 -- node for the constrained array to be created (e.g. something of the
405 -- form string (1 .. 10)). Related_Nod gives the place where this type
406 -- has to be inserted in the tree. The Related_Id and Suffix parameters
407 -- are used to build the associated Implicit type name.
409 procedure Constrain_Concurrent
410 (Def_Id
: in out Entity_Id
;
412 Related_Nod
: Node_Id
;
413 Related_Id
: Entity_Id
;
415 -- Apply list of discriminant constraints to an unconstrained concurrent
418 -- SI is the N_Subtype_Indication node containing the constraint and
419 -- the unconstrained type to constrain.
421 -- Def_Id is the entity for the resulting constrained subtype. A value
422 -- of Empty for Def_Id indicates that an implicit type must be created,
423 -- but creation is delayed (and must be done by this procedure) because
424 -- other subsidiary implicit types must be created first (which is why
425 -- Def_Id is an in/out parameter).
427 -- Related_Nod gives the place where this type has to be inserted
430 -- The last two arguments are used to create its external name if needed.
432 function Constrain_Corresponding_Record
433 (Prot_Subt
: Entity_Id
;
434 Corr_Rec
: Entity_Id
;
435 Related_Nod
: Node_Id
;
436 Related_Id
: Entity_Id
) return Entity_Id
;
437 -- When constraining a protected type or task type with discriminants,
438 -- constrain the corresponding record with the same discriminant values.
440 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
);
441 -- Constrain a decimal fixed point type with a digits constraint and/or a
442 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
444 procedure Constrain_Discriminated_Type
447 Related_Nod
: Node_Id
;
448 For_Access
: Boolean := False);
449 -- Process discriminant constraints of composite type. Verify that values
450 -- have been provided for all discriminants, that the original type is
451 -- unconstrained, and that the types of the supplied expressions match
452 -- the discriminant types. The first three parameters are like in routine
453 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
456 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
);
457 -- Constrain an enumeration type with a range constraint. This is identical
458 -- to Constrain_Integer, but for the Ekind of the resulting subtype.
460 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
);
461 -- Constrain a floating point type with either a digits constraint
462 -- and/or a range constraint, building a E_Floating_Point_Subtype.
464 procedure Constrain_Index
467 Related_Nod
: Node_Id
;
468 Related_Id
: Entity_Id
;
471 -- Process an index constraint in a constrained array declaration. The
472 -- constraint can be a subtype name, or a range with or without an
473 -- explicit subtype mark. The index is the corresponding index of the
474 -- unconstrained array. The Related_Id and Suffix parameters are used to
475 -- build the associated Implicit type name.
477 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
);
478 -- Build subtype of a signed or modular integer type
480 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
);
481 -- Constrain an ordinary fixed point type with a range constraint, and
482 -- build an E_Ordinary_Fixed_Point_Subtype entity.
484 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
);
485 -- Copy the Priv entity into the entity of its full declaration
486 -- then swap the two entities in such a manner that the former private
487 -- type is now seen as a full type.
489 procedure Decimal_Fixed_Point_Type_Declaration
492 -- Create a new decimal fixed point type, and apply the constraint to
493 -- obtain a subtype of this new type.
495 procedure Complete_Private_Subtype
498 Full_Base
: Entity_Id
;
499 Related_Nod
: Node_Id
);
500 -- Complete the implicit full view of a private subtype by setting the
501 -- appropriate semantic fields. If the full view of the parent is a record
502 -- type, build constrained components of subtype.
504 procedure Derive_Interface_Subprograms
505 (Derived_Type
: Entity_Id
);
506 -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
507 -- Traverse the list of implemented interfaces and derive all their
510 procedure Derived_Standard_Character
512 Parent_Type
: Entity_Id
;
513 Derived_Type
: Entity_Id
);
514 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
515 -- derivations from types Standard.Character and Standard.Wide_Character.
517 procedure Derived_Type_Declaration
520 Is_Completion
: Boolean);
521 -- Process a derived type declaration. This routine will invoke
522 -- Build_Derived_Type to process the actual derived type definition.
523 -- Parameters N and Is_Completion have the same meaning as in
524 -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
525 -- defined in the N_Full_Type_Declaration node N, that is T is the derived
528 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
529 -- Insert each literal in symbol table, as an overloadable identifier. Each
530 -- enumeration type is mapped into a sequence of integers, and each literal
531 -- is defined as a constant with integer value. If any of the literals are
532 -- character literals, the type is a character type, which means that
533 -- strings are legal aggregates for arrays of components of the type.
535 function Expand_To_Stored_Constraint
537 Constraint
: Elist_Id
) return Elist_Id
;
538 -- Given a Constraint (i.e. a list of expressions) on the discriminants of
539 -- Typ, expand it into a constraint on the stored discriminants and return
540 -- the new list of expressions constraining the stored discriminants.
542 function Find_Type_Of_Object
544 Related_Nod
: Node_Id
) return Entity_Id
;
545 -- Get type entity for object referenced by Obj_Def, attaching the
546 -- implicit types generated to Related_Nod
548 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
549 -- Create a new float, and apply the constraint to obtain subtype of it
551 function Has_Range_Constraint
(N
: Node_Id
) return Boolean;
552 -- Given an N_Subtype_Indication node N, return True if a range constraint
553 -- is present, either directly, or as part of a digits or delta constraint.
554 -- In addition, a digits constraint in the decimal case returns True, since
555 -- it establishes a default range if no explicit range is present.
557 function Is_Valid_Constraint_Kind
559 Constraint_Kind
: Node_Kind
) return Boolean;
560 -- Returns True if it is legal to apply the given kind of constraint to the
561 -- given kind of type (index constraint to an array type, for example).
563 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
564 -- Create new modular type. Verify that modulus is in bounds and is
565 -- a power of two (implementation restriction).
567 procedure New_Concatenation_Op
(Typ
: Entity_Id
);
568 -- Create an abbreviated declaration for an operator in order to
569 -- materialize concatenation on array types.
571 procedure Ordinary_Fixed_Point_Type_Declaration
574 -- Create a new ordinary fixed point type, and apply the constraint to
575 -- obtain subtype of it.
577 procedure Prepare_Private_Subtype_Completion
579 Related_Nod
: Node_Id
);
580 -- Id is a subtype of some private type. Creates the full declaration
581 -- associated with Id whenever possible, i.e. when the full declaration
582 -- of the base type is already known. Records each subtype into
583 -- Private_Dependents of the base type.
585 procedure Process_Incomplete_Dependents
589 -- Process all entities that depend on an incomplete type. There include
590 -- subtypes, subprogram types that mention the incomplete type in their
591 -- profiles, and subprogram with access parameters that designate the
594 -- Inc_T is the defining identifier of an incomplete type declaration, its
595 -- Ekind is E_Incomplete_Type.
597 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
599 -- Full_T is N's defining identifier.
601 -- Subtypes of incomplete types with discriminants are completed when the
602 -- parent type is. This is simpler than private subtypes, because they can
603 -- only appear in the same scope, and there is no need to exchange views.
604 -- Similarly, access_to_subprogram types may have a parameter or a return
605 -- type that is an incomplete type, and that must be replaced with the
608 -- If the full type is tagged, subprogram with access parameters that
609 -- designated the incomplete may be primitive operations of the full type,
610 -- and have to be processed accordingly.
612 procedure Process_Real_Range_Specification
(Def
: Node_Id
);
613 -- Given the type definition for a real type, this procedure processes
614 -- and checks the real range specification of this type definition if
615 -- one is present. If errors are found, error messages are posted, and
616 -- the Real_Range_Specification of Def is reset to Empty.
618 procedure Record_Type_Declaration
622 -- Process a record type declaration (for both untagged and tagged
623 -- records). Parameters T and N are exactly like in procedure
624 -- Derived_Type_Declaration, except that no flag Is_Completion is needed
625 -- for this routine. If this is the completion of an incomplete type
626 -- declaration, Prev is the entity of the incomplete declaration, used for
627 -- cross-referencing. Otherwise Prev = T.
629 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
);
630 -- This routine is used to process the actual record type definition
631 -- (both for untagged and tagged records). Def is a record type
632 -- definition node. This procedure analyzes the components in this
633 -- record type definition. Prev_T is the entity for the enclosing record
634 -- type. It is provided so that its Has_Task flag can be set if any of
635 -- the component have Has_Task set. If the declaration is the completion
636 -- of an incomplete type declaration, Prev_T is the original incomplete
637 -- type, whose full view is the record type.
639 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
);
640 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
641 -- build a copy of the declaration tree of the parent, and we create
642 -- independently the list of components for the derived type. Semantic
643 -- information uses the component entities, but record representation
644 -- clauses are validated on the declaration tree. This procedure replaces
645 -- discriminants and components in the declaration with those that have
646 -- been created by Inherit_Components.
648 procedure Set_Fixed_Range
653 -- Build a range node with the given bounds and set it as the Scalar_Range
654 -- of the given fixed-point type entity. Loc is the source location used
655 -- for the constructed range. See body for further details.
657 procedure Set_Scalar_Range_For_Subtype
661 -- This routine is used to set the scalar range field for a subtype
662 -- given Def_Id, the entity for the subtype, and R, the range expression
663 -- for the scalar range. Subt provides the parent subtype to be used
664 -- to analyze, resolve, and check the given range.
666 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
667 -- Create a new signed integer entity, and apply the constraint to obtain
668 -- the required first named subtype of this type.
670 procedure Set_Stored_Constraint_From_Discriminant_Constraint
672 -- E is some record type. This routine computes E's Stored_Constraint
673 -- from its Discriminant_Constraint.
675 -----------------------
676 -- Access_Definition --
677 -----------------------
679 function Access_Definition
680 (Related_Nod
: Node_Id
;
681 N
: Node_Id
) return Entity_Id
683 Anon_Type
: constant Entity_Id
:=
684 Create_Itype
(E_Anonymous_Access_Type
, Related_Nod
,
685 Scope_Id
=> Scope
(Current_Scope
));
686 Desig_Type
: Entity_Id
;
689 if Is_Entry
(Current_Scope
)
690 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
692 Error_Msg_N
("task entries cannot have access parameters", N
);
695 -- Ada 2005: for an object declaration or function with an anonymous
696 -- access result, the corresponding anonymous type is declared in the
697 -- current scope. For access formals, access components, and access
698 -- discriminants, the scope is that of the enclosing declaration,
699 -- as set above. This special-case handling of resetting the scope
700 -- is awkward, and it might be better to pass in the required scope
701 -- as a parameter. ???
703 if Nkind
(Related_Nod
) = N_Object_Declaration
then
704 Set_Scope
(Anon_Type
, Current_Scope
);
706 -- For the anonymous function result case, retrieve the scope of
707 -- the function specification's associated entity rather than using
708 -- the current scope. The current scope will be the function itself
709 -- if the formal part is currently being analyzed, but will be the
710 -- parent scope in the case of a parameterless function, and we
711 -- always want to use the function's parent scope.
713 elsif Nkind
(Related_Nod
) = N_Function_Specification
714 and then Nkind
(Parent
(N
)) /= N_Parameter_Specification
716 Set_Scope
(Anon_Type
, Scope
(Defining_Unit_Name
(Related_Nod
)));
720 and then Ada_Version
>= Ada_05
722 Error_Msg_N
("ALL is not permitted for anonymous access types", N
);
725 -- Ada 2005 (AI-254): In case of anonymous access to subprograms
726 -- call the corresponding semantic routine
728 if Present
(Access_To_Subprogram_Definition
(N
)) then
729 Access_Subprogram_Declaration
730 (T_Name
=> Anon_Type
,
731 T_Def
=> Access_To_Subprogram_Definition
(N
));
733 if Ekind
(Anon_Type
) = E_Access_Protected_Subprogram_Type
then
735 (Anon_Type
, E_Anonymous_Access_Protected_Subprogram_Type
);
738 (Anon_Type
, E_Anonymous_Access_Subprogram_Type
);
744 Find_Type
(Subtype_Mark
(N
));
745 Desig_Type
:= Entity
(Subtype_Mark
(N
));
747 Set_Directly_Designated_Type
748 (Anon_Type
, Desig_Type
);
749 Set_Etype
(Anon_Type
, Anon_Type
);
750 Init_Size_Align
(Anon_Type
);
751 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
753 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
754 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
755 -- if the null value is allowed. In Ada 95 the null value is never
758 if Ada_Version
>= Ada_05
then
759 Set_Can_Never_Be_Null
(Anon_Type
, Null_Exclusion_Present
(N
));
761 Set_Can_Never_Be_Null
(Anon_Type
, True);
764 -- The anonymous access type is as public as the discriminated type or
765 -- subprogram that defines it. It is imported (for back-end purposes)
766 -- if the designated type is.
768 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
770 -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
771 -- designated type comes from the limited view (for back-end purposes).
773 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
775 -- Ada 2005 (AI-231): Propagate the access-constant attribute
777 Set_Is_Access_Constant
(Anon_Type
, Constant_Present
(N
));
779 -- The context is either a subprogram declaration, object declaration,
780 -- or an access discriminant, in a private or a full type declaration.
781 -- In the case of a subprogram, if the designated type is incomplete,
782 -- the operation will be a primitive operation of the full type, to be
783 -- updated subsequently. If the type is imported through a limited_with
784 -- clause, the subprogram is not a primitive operation of the type
785 -- (which is declared elsewhere in some other scope).
787 if Ekind
(Desig_Type
) = E_Incomplete_Type
788 and then not From_With_Type
(Desig_Type
)
789 and then Is_Overloadable
(Current_Scope
)
791 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
792 Set_Has_Delayed_Freeze
(Current_Scope
);
795 -- Ada 2005: if the designated type is an interface that may contain
796 -- tasks, create a Master entity for the declaration. This must be done
797 -- before expansion of the full declaration, because the declaration
798 -- may include an expression that is an allocator, whose expansion needs
799 -- the proper Master for the created tasks.
801 if Nkind
(Related_Nod
) = N_Object_Declaration
802 and then Expander_Active
803 and then Is_Interface
(Desig_Type
)
804 and then Is_Limited_Record
(Desig_Type
)
806 Build_Class_Wide_Master
(Anon_Type
);
810 end Access_Definition
;
812 -----------------------------------
813 -- Access_Subprogram_Declaration --
814 -----------------------------------
816 procedure Access_Subprogram_Declaration
820 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
824 Desig_Type
: constant Entity_Id
:=
825 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
828 -- Associate the Itype node with the inner full-type declaration
829 -- or subprogram spec. This is required to handle nested anonymous
830 -- declarations. For example:
833 -- (X : access procedure
834 -- (Y : access procedure
837 D_Ityp
:= Associated_Node_For_Itype
(Desig_Type
);
838 while Nkind
(D_Ityp
) /= N_Full_Type_Declaration
839 and then Nkind
(D_Ityp
) /= N_Procedure_Specification
840 and then Nkind
(D_Ityp
) /= N_Function_Specification
841 and then Nkind
(D_Ityp
) /= N_Object_Declaration
842 and then Nkind
(D_Ityp
) /= N_Object_Renaming_Declaration
843 and then Nkind
(D_Ityp
) /= N_Formal_Type_Declaration
845 D_Ityp
:= Parent
(D_Ityp
);
846 pragma Assert
(D_Ityp
/= Empty
);
849 Set_Associated_Node_For_Itype
(Desig_Type
, D_Ityp
);
851 if Nkind
(D_Ityp
) = N_Procedure_Specification
852 or else Nkind
(D_Ityp
) = N_Function_Specification
854 Set_Scope
(Desig_Type
, Scope
(Defining_Unit_Name
(D_Ityp
)));
856 elsif Nkind
(D_Ityp
) = N_Full_Type_Declaration
857 or else Nkind
(D_Ityp
) = N_Object_Declaration
858 or else Nkind
(D_Ityp
) = N_Object_Renaming_Declaration
859 or else Nkind
(D_Ityp
) = N_Formal_Type_Declaration
861 Set_Scope
(Desig_Type
, Scope
(Defining_Identifier
(D_Ityp
)));
864 if Nkind
(T_Def
) = N_Access_Function_Definition
then
865 if Nkind
(Result_Definition
(T_Def
)) = N_Access_Definition
then
868 Access_Definition
(T_Def
, Result_Definition
(T_Def
)));
870 Analyze
(Result_Definition
(T_Def
));
871 Set_Etype
(Desig_Type
, Entity
(Result_Definition
(T_Def
)));
874 if not (Is_Type
(Etype
(Desig_Type
))) then
876 ("expect type in function specification",
877 Result_Definition
(T_Def
));
881 Set_Etype
(Desig_Type
, Standard_Void_Type
);
884 if Present
(Formals
) then
885 New_Scope
(Desig_Type
);
886 Process_Formals
(Formals
, Parent
(T_Def
));
888 -- A bit of a kludge here, End_Scope requires that the parent
889 -- pointer be set to something reasonable, but Itypes don't have
890 -- parent pointers. So we set it and then unset it ??? If and when
891 -- Itypes have proper parent pointers to their declarations, this
892 -- kludge can be removed.
894 Set_Parent
(Desig_Type
, T_Name
);
896 Set_Parent
(Desig_Type
, Empty
);
899 -- The return type and/or any parameter type may be incomplete. Mark
900 -- the subprogram_type as depending on the incomplete type, so that
901 -- it can be updated when the full type declaration is seen.
903 if Present
(Formals
) then
904 Formal
:= First_Formal
(Desig_Type
);
905 while Present
(Formal
) loop
906 if Ekind
(Formal
) /= E_In_Parameter
907 and then Nkind
(T_Def
) = N_Access_Function_Definition
909 Error_Msg_N
("functions can only have IN parameters", Formal
);
912 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
913 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
914 Set_Has_Delayed_Freeze
(Desig_Type
);
917 Next_Formal
(Formal
);
921 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
922 and then not Has_Delayed_Freeze
(Desig_Type
)
924 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
925 Set_Has_Delayed_Freeze
(Desig_Type
);
928 Check_Delayed_Subprogram
(Desig_Type
);
930 if Protected_Present
(T_Def
) then
931 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
932 Set_Convention
(Desig_Type
, Convention_Protected
);
934 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
937 Set_Etype
(T_Name
, T_Name
);
938 Init_Size_Align
(T_Name
);
939 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
941 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
943 Set_Can_Never_Be_Null
(T_Name
, Null_Exclusion_Present
(T_Def
));
945 Check_Restriction
(No_Access_Subprograms
, T_Def
);
946 end Access_Subprogram_Declaration
;
948 ----------------------------
949 -- Access_Type_Declaration --
950 ----------------------------
952 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
953 S
: constant Node_Id
:= Subtype_Indication
(Def
);
954 P
: constant Node_Id
:= Parent
(Def
);
960 -- Check for permissible use of incomplete type
962 if Nkind
(S
) /= N_Subtype_Indication
then
965 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
966 Set_Directly_Designated_Type
(T
, Entity
(S
));
968 Set_Directly_Designated_Type
(T
,
969 Process_Subtype
(S
, P
, T
, 'P'));
973 Set_Directly_Designated_Type
(T
,
974 Process_Subtype
(S
, P
, T
, 'P'));
977 if All_Present
(Def
) or Constant_Present
(Def
) then
978 Set_Ekind
(T
, E_General_Access_Type
);
980 Set_Ekind
(T
, E_Access_Type
);
983 if Base_Type
(Designated_Type
(T
)) = T
then
984 Error_Msg_N
("access type cannot designate itself", S
);
986 -- In Ada 2005, the type may have a limited view through some unit
987 -- in its own context, allowing the following circularity that cannot
988 -- be detected earlier
990 elsif Is_Class_Wide_Type
(Designated_Type
(T
))
991 and then Etype
(Designated_Type
(T
)) = T
994 ("access type cannot designate its own classwide type", S
);
996 -- Clean up indication of tagged status to prevent cascaded errors
998 Set_Is_Tagged_Type
(T
, False);
1003 -- If the type has appeared already in a with_type clause, it is
1004 -- frozen and the pointer size is already set. Else, initialize.
1006 if not From_With_Type
(T
) then
1007 Init_Size_Align
(T
);
1010 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1012 Desig
:= Designated_Type
(T
);
1014 -- If designated type is an imported tagged type, indicate that the
1015 -- access type is also imported, and therefore restricted in its use.
1016 -- The access type may already be imported, so keep setting otherwise.
1018 -- Ada 2005 (AI-50217): If the non-limited view of the designated type
1019 -- is available, use it as the designated type of the access type, so
1020 -- that the back-end gets a usable entity.
1023 N_Desig
: Entity_Id
;
1026 if From_With_Type
(Desig
)
1027 and then Ekind
(Desig
) /= E_Access_Type
1029 Set_From_With_Type
(T
);
1031 if Ekind
(Desig
) = E_Incomplete_Type
then
1032 N_Desig
:= Non_Limited_View
(Desig
);
1034 else pragma Assert
(Ekind
(Desig
) = E_Class_Wide_Type
);
1035 if From_With_Type
(Etype
(Desig
)) then
1036 N_Desig
:= Non_Limited_View
(Etype
(Desig
));
1038 N_Desig
:= Etype
(Desig
);
1042 pragma Assert
(Present
(N_Desig
));
1043 Set_Directly_Designated_Type
(T
, N_Desig
);
1047 -- Note that Has_Task is always false, since the access type itself
1048 -- is not a task type. See Einfo for more description on this point.
1049 -- Exactly the same consideration applies to Has_Controlled_Component.
1051 Set_Has_Task
(T
, False);
1052 Set_Has_Controlled_Component
(T
, False);
1054 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1057 Set_Can_Never_Be_Null
(T
, Null_Exclusion_Present
(Def
));
1058 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1059 end Access_Type_Declaration
;
1061 ----------------------------------
1062 -- Add_Interface_Tag_Components --
1063 ----------------------------------
1065 procedure Add_Interface_Tag_Components
1069 Loc
: constant Source_Ptr
:= Sloc
(N
);
1076 procedure Add_Tag
(Iface
: Entity_Id
);
1077 -- Comment required ???
1083 procedure Add_Tag
(Iface
: Entity_Id
) is
1089 pragma Assert
(Is_Tagged_Type
(Iface
)
1090 and then Is_Interface
(Iface
));
1093 Make_Component_Definition
(Loc
,
1094 Aliased_Present
=> True,
1095 Subtype_Indication
=>
1096 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
));
1098 Tag
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1101 Make_Component_Declaration
(Loc
,
1102 Defining_Identifier
=> Tag
,
1103 Component_Definition
=> Def
);
1105 Analyze_Component_Declaration
(Decl
);
1107 Set_Analyzed
(Decl
);
1108 Set_Ekind
(Tag
, E_Component
);
1109 Set_Is_Limited_Record
(Tag
);
1111 Init_Component_Location
(Tag
);
1113 pragma Assert
(Is_Frozen
(Iface
));
1115 Set_DT_Entry_Count
(Tag
,
1116 DT_Entry_Count
(First_Entity
(Iface
)));
1118 if not Present
(Last_Tag
) then
1121 Insert_After
(Last_Tag
, Decl
);
1127 -- Start of processing for Add_Interface_Tag_Components
1130 if Ekind
(Typ
) /= E_Record_Type
1131 or else not Present
(Abstract_Interfaces
(Typ
))
1132 or else Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
))
1137 if Present
(Abstract_Interfaces
(Typ
)) then
1139 -- Find the current last tag
1141 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1142 Ext
:= Record_Extension_Part
(Type_Definition
(N
));
1144 pragma Assert
(Nkind
(Type_Definition
(N
)) = N_Record_Definition
);
1145 Ext
:= Type_Definition
(N
);
1150 if not (Present
(Component_List
(Ext
))) then
1151 Set_Null_Present
(Ext
, False);
1153 Set_Component_List
(Ext
,
1154 Make_Component_List
(Loc
,
1155 Component_Items
=> L
,
1156 Null_Present
=> False));
1158 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1159 L
:= Component_Items
1161 (Record_Extension_Part
1162 (Type_Definition
(N
))));
1164 L
:= Component_Items
1166 (Type_Definition
(N
)));
1169 -- Find the last tag component
1172 while Present
(Comp
) loop
1173 if Is_Tag
(Defining_Identifier
(Comp
)) then
1181 -- At this point L references the list of components and Last_Tag
1182 -- references the current last tag (if any). Now we add the tag
1183 -- corresponding with all the interfaces that are not implemented
1186 pragma Assert
(Present
1187 (First_Elmt
(Abstract_Interfaces
(Typ
))));
1189 Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1190 while Present
(Elmt
) loop
1191 Add_Tag
(Node
(Elmt
));
1195 end Add_Interface_Tag_Components
;
1197 -----------------------------------
1198 -- Analyze_Component_Declaration --
1199 -----------------------------------
1201 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
1202 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1206 function Contains_POC
(Constr
: Node_Id
) return Boolean;
1207 -- Determines whether a constraint uses the discriminant of a record
1208 -- type thus becoming a per-object constraint (POC).
1214 function Contains_POC
(Constr
: Node_Id
) return Boolean is
1216 case Nkind
(Constr
) is
1217 when N_Attribute_Reference
=>
1218 return Attribute_Name
(Constr
) = Name_Access
1220 Prefix
(Constr
) = Scope
(Entity
(Prefix
(Constr
)));
1222 when N_Discriminant_Association
=>
1223 return Denotes_Discriminant
(Expression
(Constr
));
1225 when N_Identifier
=>
1226 return Denotes_Discriminant
(Constr
);
1228 when N_Index_Or_Discriminant_Constraint
=>
1233 IDC
:= First
(Constraints
(Constr
));
1234 while Present
(IDC
) loop
1236 -- One per-object constraint is sufficient
1238 if Contains_POC
(IDC
) then
1249 return Denotes_Discriminant
(Low_Bound
(Constr
))
1251 Denotes_Discriminant
(High_Bound
(Constr
));
1253 when N_Range_Constraint
=>
1254 return Denotes_Discriminant
(Range_Expression
(Constr
));
1262 -- Start of processing for Analyze_Component_Declaration
1265 Generate_Definition
(Id
);
1268 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1269 T
:= Find_Type_Of_Object
1270 (Subtype_Indication
(Component_Definition
(N
)), N
);
1272 -- Ada 2005 (AI-230): Access Definition case
1275 pragma Assert
(Present
1276 (Access_Definition
(Component_Definition
(N
))));
1278 T
:= Access_Definition
1280 N
=> Access_Definition
(Component_Definition
(N
)));
1281 Set_Is_Local_Anonymous_Access
(T
);
1283 -- Ada 2005 (AI-254)
1285 if Present
(Access_To_Subprogram_Definition
1286 (Access_Definition
(Component_Definition
(N
))))
1287 and then Protected_Present
(Access_To_Subprogram_Definition
1289 (Component_Definition
(N
))))
1291 T
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
, T
);
1295 -- If the subtype is a constrained subtype of the enclosing record,
1296 -- (which must have a partial view) the back-end does not properly
1297 -- handle the recursion. Rewrite the component declaration with an
1298 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1299 -- the tree directly because side effects have already been removed from
1300 -- discriminant constraints.
1302 if Ekind
(T
) = E_Access_Subtype
1303 and then Is_Entity_Name
(Subtype_Indication
(Component_Definition
(N
)))
1304 and then Comes_From_Source
(T
)
1305 and then Nkind
(Parent
(T
)) = N_Subtype_Declaration
1306 and then Etype
(Directly_Designated_Type
(T
)) = Current_Scope
1309 (Subtype_Indication
(Component_Definition
(N
)),
1310 New_Copy_Tree
(Subtype_Indication
(Parent
(T
))));
1311 T
:= Find_Type_Of_Object
1312 (Subtype_Indication
(Component_Definition
(N
)), N
);
1315 -- If the component declaration includes a default expression, then we
1316 -- check that the component is not of a limited type (RM 3.7(5)),
1317 -- and do the special preanalysis of the expression (see section on
1318 -- "Handling of Default and Per-Object Expressions" in the spec of
1321 if Present
(Expression
(N
)) then
1322 Analyze_Per_Use_Expression
(Expression
(N
), T
);
1323 Check_Initialization
(T
, Expression
(N
));
1326 -- The parent type may be a private view with unknown discriminants,
1327 -- and thus unconstrained. Regular components must be constrained.
1329 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
1330 if Is_Class_Wide_Type
(T
) then
1332 ("class-wide subtype with unknown discriminants" &
1333 " in component declaration",
1334 Subtype_Indication
(Component_Definition
(N
)));
1337 ("unconstrained subtype in component declaration",
1338 Subtype_Indication
(Component_Definition
(N
)));
1341 -- Components cannot be abstract, except for the special case of
1342 -- the _Parent field (case of extending an abstract tagged type)
1344 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
1345 Error_Msg_N
("type of a component cannot be abstract", N
);
1349 Set_Is_Aliased
(Id
, Aliased_Present
(Component_Definition
(N
)));
1351 -- The component declaration may have a per-object constraint, set
1352 -- the appropriate flag in the defining identifier of the subtype.
1354 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1356 Sindic
: constant Node_Id
:=
1357 Subtype_Indication
(Component_Definition
(N
));
1360 if Nkind
(Sindic
) = N_Subtype_Indication
1361 and then Present
(Constraint
(Sindic
))
1362 and then Contains_POC
(Constraint
(Sindic
))
1364 Set_Has_Per_Object_Constraint
(Id
);
1369 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1370 -- out some static checks.
1372 if Ada_Version
>= Ada_05
1373 and then Can_Never_Be_Null
(T
)
1375 Null_Exclusion_Static_Checks
(N
);
1378 -- If this component is private (or depends on a private type), flag the
1379 -- record type to indicate that some operations are not available.
1381 P
:= Private_Component
(T
);
1384 -- Check for circular definitions
1386 if P
= Any_Type
then
1387 Set_Etype
(Id
, Any_Type
);
1389 -- There is a gap in the visibility of operations only if the
1390 -- component type is not defined in the scope of the record type.
1392 elsif Scope
(P
) = Scope
(Current_Scope
) then
1395 elsif Is_Limited_Type
(P
) then
1396 Set_Is_Limited_Composite
(Current_Scope
);
1399 Set_Is_Private_Composite
(Current_Scope
);
1404 and then Is_Limited_Type
(T
)
1405 and then Chars
(Id
) /= Name_uParent
1406 and then Is_Tagged_Type
(Current_Scope
)
1408 if Is_Derived_Type
(Current_Scope
)
1409 and then not Is_Limited_Record
(Root_Type
(Current_Scope
))
1412 ("extension of nonlimited type cannot have limited components",
1414 Explain_Limited_Type
(T
, N
);
1415 Set_Etype
(Id
, Any_Type
);
1416 Set_Is_Limited_Composite
(Current_Scope
, False);
1418 elsif not Is_Derived_Type
(Current_Scope
)
1419 and then not Is_Limited_Record
(Current_Scope
)
1420 and then not Is_Concurrent_Type
(Current_Scope
)
1423 ("nonlimited tagged type cannot have limited components", N
);
1424 Explain_Limited_Type
(T
, N
);
1425 Set_Etype
(Id
, Any_Type
);
1426 Set_Is_Limited_Composite
(Current_Scope
, False);
1430 Set_Original_Record_Component
(Id
, Id
);
1431 end Analyze_Component_Declaration
;
1433 --------------------------
1434 -- Analyze_Declarations --
1435 --------------------------
1437 procedure Analyze_Declarations
(L
: List_Id
) is
1439 Next_Node
: Node_Id
;
1440 Freeze_From
: Entity_Id
:= Empty
;
1443 -- Adjust D not to include implicit label declarations, since these
1444 -- have strange Sloc values that result in elaboration check problems.
1445 -- (They have the sloc of the label as found in the source, and that
1446 -- is ahead of the current declarative part).
1452 procedure Adjust_D
is
1454 while Present
(Prev
(D
))
1455 and then Nkind
(D
) = N_Implicit_Label_Declaration
1461 -- Start of processing for Analyze_Declarations
1465 while Present
(D
) loop
1467 -- Complete analysis of declaration
1470 Next_Node
:= Next
(D
);
1472 if No
(Freeze_From
) then
1473 Freeze_From
:= First_Entity
(Current_Scope
);
1476 -- At the end of a declarative part, freeze remaining entities
1477 -- declared in it. The end of the visible declarations of package
1478 -- specification is not the end of a declarative part if private
1479 -- declarations are present. The end of a package declaration is a
1480 -- freezing point only if it a library package. A task definition or
1481 -- protected type definition is not a freeze point either. Finally,
1482 -- we do not freeze entities in generic scopes, because there is no
1483 -- code generated for them and freeze nodes will be generated for
1486 -- The end of a package instantiation is not a freeze point, but
1487 -- for now we make it one, because the generic body is inserted
1488 -- (currently) immediately after. Generic instantiations will not
1489 -- be a freeze point once delayed freezing of bodies is implemented.
1490 -- (This is needed in any case for early instantiations ???).
1492 if No
(Next_Node
) then
1493 if Nkind
(Parent
(L
)) = N_Component_List
1494 or else Nkind
(Parent
(L
)) = N_Task_Definition
1495 or else Nkind
(Parent
(L
)) = N_Protected_Definition
1499 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
1500 if Nkind
(Parent
(L
)) = N_Package_Body
then
1501 Freeze_From
:= First_Entity
(Current_Scope
);
1505 Freeze_All
(Freeze_From
, D
);
1506 Freeze_From
:= Last_Entity
(Current_Scope
);
1508 elsif Scope
(Current_Scope
) /= Standard_Standard
1509 and then not Is_Child_Unit
(Current_Scope
)
1510 and then No
(Generic_Parent
(Parent
(L
)))
1514 elsif L
/= Visible_Declarations
(Parent
(L
))
1515 or else No
(Private_Declarations
(Parent
(L
)))
1516 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1519 Freeze_All
(Freeze_From
, D
);
1520 Freeze_From
:= Last_Entity
(Current_Scope
);
1523 -- If next node is a body then freeze all types before the body.
1524 -- An exception occurs for expander generated bodies, which can
1525 -- be recognized by their already being analyzed. The expander
1526 -- ensures that all types needed by these bodies have been frozen
1527 -- but it is not necessary to freeze all types (and would be wrong
1528 -- since it would not correspond to an RM defined freeze point).
1530 elsif not Analyzed
(Next_Node
)
1531 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1532 or else Nkind
(Next_Node
) = N_Entry_Body
1533 or else Nkind
(Next_Node
) = N_Package_Body
1534 or else Nkind
(Next_Node
) = N_Protected_Body
1535 or else Nkind
(Next_Node
) = N_Task_Body
1536 or else Nkind
(Next_Node
) in N_Body_Stub
)
1539 Freeze_All
(Freeze_From
, D
);
1540 Freeze_From
:= Last_Entity
(Current_Scope
);
1545 end Analyze_Declarations
;
1547 ----------------------------------
1548 -- Analyze_Incomplete_Type_Decl --
1549 ----------------------------------
1551 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1552 F
: constant Boolean := Is_Pure
(Current_Scope
);
1556 Generate_Definition
(Defining_Identifier
(N
));
1558 -- Process an incomplete declaration. The identifier must not have been
1559 -- declared already in the scope. However, an incomplete declaration may
1560 -- appear in the private part of a package, for a private type that has
1561 -- already been declared.
1563 -- In this case, the discriminants (if any) must match
1565 T
:= Find_Type_Name
(N
);
1567 Set_Ekind
(T
, E_Incomplete_Type
);
1568 Init_Size_Align
(T
);
1569 Set_Is_First_Subtype
(T
, True);
1572 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
1573 -- incomplete types.
1575 if Tagged_Present
(N
) then
1576 Set_Is_Tagged_Type
(T
);
1577 Make_Class_Wide_Type
(T
);
1578 Set_Primitive_Operations
(T
, New_Elmt_List
);
1583 Set_Stored_Constraint
(T
, No_Elist
);
1585 if Present
(Discriminant_Specifications
(N
)) then
1586 Process_Discriminants
(N
);
1591 -- If the type has discriminants, non-trivial subtypes may be be
1592 -- declared before the full view of the type. The full views of those
1593 -- subtypes will be built after the full view of the type.
1595 Set_Private_Dependents
(T
, New_Elmt_List
);
1597 end Analyze_Incomplete_Type_Decl
;
1599 -----------------------------------
1600 -- Analyze_Interface_Declaration --
1601 -----------------------------------
1603 procedure Analyze_Interface_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
1605 Set_Is_Tagged_Type
(T
);
1607 Set_Is_Limited_Record
(T
, Limited_Present
(Def
)
1608 or else Task_Present
(Def
)
1609 or else Protected_Present
(Def
)
1610 or else Synchronized_Present
(Def
));
1612 -- Type is abstract if full declaration carries keyword, or if
1613 -- previous partial view did.
1615 Set_Is_Abstract
(T
);
1616 Set_Is_Interface
(T
);
1618 Set_Is_Limited_Interface
(T
, Limited_Present
(Def
));
1619 Set_Is_Protected_Interface
(T
, Protected_Present
(Def
));
1620 Set_Is_Synchronized_Interface
(T
, Synchronized_Present
(Def
));
1621 Set_Is_Task_Interface
(T
, Task_Present
(Def
));
1622 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
1623 Set_Primitive_Operations
(T
, New_Elmt_List
);
1624 end Analyze_Interface_Declaration
;
1626 -----------------------------
1627 -- Analyze_Itype_Reference --
1628 -----------------------------
1630 -- Nothing to do. This node is placed in the tree only for the benefit of
1631 -- back end processing, and has no effect on the semantic processing.
1633 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1635 pragma Assert
(Is_Itype
(Itype
(N
)));
1637 end Analyze_Itype_Reference
;
1639 --------------------------------
1640 -- Analyze_Number_Declaration --
1641 --------------------------------
1643 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1644 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1645 E
: constant Node_Id
:= Expression
(N
);
1647 Index
: Interp_Index
;
1651 Generate_Definition
(Id
);
1654 -- This is an optimization of a common case of an integer literal
1656 if Nkind
(E
) = N_Integer_Literal
then
1657 Set_Is_Static_Expression
(E
, True);
1658 Set_Etype
(E
, Universal_Integer
);
1660 Set_Etype
(Id
, Universal_Integer
);
1661 Set_Ekind
(Id
, E_Named_Integer
);
1662 Set_Is_Frozen
(Id
, True);
1666 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1668 -- Process expression, replacing error by integer zero, to avoid
1669 -- cascaded errors or aborts further along in the processing
1671 -- Replace Error by integer zero, which seems least likely to
1672 -- cause cascaded errors.
1675 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1676 Set_Error_Posted
(E
);
1681 -- Verify that the expression is static and numeric. If
1682 -- the expression is overloaded, we apply the preference
1683 -- rule that favors root numeric types.
1685 if not Is_Overloaded
(E
) then
1691 Get_First_Interp
(E
, Index
, It
);
1692 while Present
(It
.Typ
) loop
1693 if (Is_Integer_Type
(It
.Typ
)
1694 or else Is_Real_Type
(It
.Typ
))
1695 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1697 if T
= Any_Type
then
1700 elsif It
.Typ
= Universal_Real
1701 or else It
.Typ
= Universal_Integer
1703 -- Choose universal interpretation over any other
1710 Get_Next_Interp
(Index
, It
);
1714 if Is_Integer_Type
(T
) then
1716 Set_Etype
(Id
, Universal_Integer
);
1717 Set_Ekind
(Id
, E_Named_Integer
);
1719 elsif Is_Real_Type
(T
) then
1721 -- Because the real value is converted to universal_real, this is a
1722 -- legal context for a universal fixed expression.
1724 if T
= Universal_Fixed
then
1726 Loc
: constant Source_Ptr
:= Sloc
(N
);
1727 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1729 New_Occurrence_Of
(Universal_Real
, Loc
),
1730 Expression
=> Relocate_Node
(E
));
1737 elsif T
= Any_Fixed
then
1738 Error_Msg_N
("illegal context for mixed mode operation", E
);
1740 -- Expression is of the form : universal_fixed * integer. Try to
1741 -- resolve as universal_real.
1743 T
:= Universal_Real
;
1748 Set_Etype
(Id
, Universal_Real
);
1749 Set_Ekind
(Id
, E_Named_Real
);
1752 Wrong_Type
(E
, Any_Numeric
);
1756 Set_Ekind
(Id
, E_Constant
);
1757 Set_Never_Set_In_Source
(Id
, True);
1758 Set_Is_True_Constant
(Id
, True);
1762 if Nkind
(E
) = N_Integer_Literal
1763 or else Nkind
(E
) = N_Real_Literal
1765 Set_Etype
(E
, Etype
(Id
));
1768 if not Is_OK_Static_Expression
(E
) then
1769 Flag_Non_Static_Expr
1770 ("non-static expression used in number declaration!", E
);
1771 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1772 Set_Etype
(E
, Any_Type
);
1774 end Analyze_Number_Declaration
;
1776 --------------------------------
1777 -- Analyze_Object_Declaration --
1778 --------------------------------
1780 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1781 Loc
: constant Source_Ptr
:= Sloc
(N
);
1782 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1786 E
: Node_Id
:= Expression
(N
);
1787 -- E is set to Expression (N) throughout this routine. When
1788 -- Expression (N) is modified, E is changed accordingly.
1790 Prev_Entity
: Entity_Id
:= Empty
;
1792 function Build_Default_Subtype
return Entity_Id
;
1793 -- If the object is limited or aliased, and if the type is unconstrained
1794 -- and there is no expression, the discriminants cannot be modified and
1795 -- the subtype of the object is constrained by the defaults, so it is
1796 -- worthwhile building the corresponding subtype.
1798 function Count_Tasks
(T
: Entity_Id
) return Uint
;
1799 -- This function is called when a library level object of type is
1800 -- declared. It's function is to count the static number of tasks
1801 -- declared within the type (it is only called if Has_Tasks is set for
1802 -- T). As a side effect, if an array of tasks with non-static bounds or
1803 -- a variant record type is encountered, Check_Restrictions is called
1804 -- indicating the count is unknown.
1806 ---------------------------
1807 -- Build_Default_Subtype --
1808 ---------------------------
1810 function Build_Default_Subtype
return Entity_Id
is
1811 Constraints
: constant List_Id
:= New_List
;
1817 Disc
:= First_Discriminant
(T
);
1819 if No
(Discriminant_Default_Value
(Disc
)) then
1820 return T
; -- previous error.
1823 Act
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1824 while Present
(Disc
) loop
1827 Discriminant_Default_Value
(Disc
)), Constraints
);
1828 Next_Discriminant
(Disc
);
1832 Make_Subtype_Declaration
(Loc
,
1833 Defining_Identifier
=> Act
,
1834 Subtype_Indication
=>
1835 Make_Subtype_Indication
(Loc
,
1836 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1838 Make_Index_Or_Discriminant_Constraint
1839 (Loc
, Constraints
)));
1841 Insert_Before
(N
, Decl
);
1844 end Build_Default_Subtype
;
1850 function Count_Tasks
(T
: Entity_Id
) return Uint
is
1856 if Is_Task_Type
(T
) then
1859 elsif Is_Record_Type
(T
) then
1860 if Has_Discriminants
(T
) then
1861 Check_Restriction
(Max_Tasks
, N
);
1866 C
:= First_Component
(T
);
1867 while Present
(C
) loop
1868 V
:= V
+ Count_Tasks
(Etype
(C
));
1875 elsif Is_Array_Type
(T
) then
1876 X
:= First_Index
(T
);
1877 V
:= Count_Tasks
(Component_Type
(T
));
1878 while Present
(X
) loop
1881 if not Is_Static_Subtype
(C
) then
1882 Check_Restriction
(Max_Tasks
, N
);
1885 V
:= V
* (UI_Max
(Uint_0
,
1886 Expr_Value
(Type_High_Bound
(C
)) -
1887 Expr_Value
(Type_Low_Bound
(C
)) + Uint_1
));
1900 -- Start of processing for Analyze_Object_Declaration
1903 -- There are three kinds of implicit types generated by an
1904 -- object declaration:
1906 -- 1. Those for generated by the original Object Definition
1908 -- 2. Those generated by the Expression
1910 -- 3. Those used to constrained the Object Definition with the
1911 -- expression constraints when it is unconstrained
1913 -- They must be generated in this order to avoid order of elaboration
1914 -- issues. Thus the first step (after entering the name) is to analyze
1915 -- the object definition.
1917 if Constant_Present
(N
) then
1918 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
1920 -- If homograph is an implicit subprogram, it is overridden by the
1921 -- current declaration.
1923 if Present
(Prev_Entity
)
1924 and then Is_Overloadable
(Prev_Entity
)
1925 and then Is_Inherited_Operation
(Prev_Entity
)
1927 Prev_Entity
:= Empty
;
1931 if Present
(Prev_Entity
) then
1932 Constant_Redeclaration
(Id
, N
, T
);
1934 Generate_Reference
(Prev_Entity
, Id
, 'c');
1935 Set_Completion_Referenced
(Id
);
1937 if Error_Posted
(N
) then
1939 -- Type mismatch or illegal redeclaration, Do not analyze
1940 -- expression to avoid cascaded errors.
1942 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1944 Set_Ekind
(Id
, E_Variable
);
1948 -- In the normal case, enter identifier at the start to catch premature
1949 -- usage in the initialization expression.
1952 Generate_Definition
(Id
);
1955 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1957 if Error_Posted
(Id
) then
1959 Set_Ekind
(Id
, E_Variable
);
1964 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1965 -- out some static checks
1967 if Ada_Version
>= Ada_05
1968 and then Can_Never_Be_Null
(T
)
1970 -- In case of aggregates we must also take care of the correct
1971 -- initialization of nested aggregates bug this is done at the
1972 -- point of the analysis of the aggregate (see sem_aggr.adb)
1974 if Present
(Expression
(N
))
1975 and then Nkind
(Expression
(N
)) = N_Aggregate
1981 Save_Typ
: constant Entity_Id
:= Etype
(Id
);
1983 Set_Etype
(Id
, T
); -- Temp. decoration for static checks
1984 Null_Exclusion_Static_Checks
(N
);
1985 Set_Etype
(Id
, Save_Typ
);
1990 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1992 -- If deferred constant, make sure context is appropriate. We detect
1993 -- a deferred constant as a constant declaration with no expression.
1994 -- A deferred constant can appear in a package body if its completion
1995 -- is by means of an interface pragma.
1997 if Constant_Present
(N
)
2000 if not Is_Package_Or_Generic_Package
(Current_Scope
) then
2002 ("invalid context for deferred constant declaration ('R'M 7.4)",
2005 ("\declaration requires an initialization expression",
2007 Set_Constant_Present
(N
, False);
2009 -- In Ada 83, deferred constant must be of private type
2011 elsif not Is_Private_Type
(T
) then
2012 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2014 ("(Ada 83) deferred constant must be private type", N
);
2018 -- If not a deferred constant, then object declaration freezes its type
2021 Check_Fully_Declared
(T
, N
);
2022 Freeze_Before
(N
, T
);
2025 -- If the object was created by a constrained array definition, then
2026 -- set the link in both the anonymous base type and anonymous subtype
2027 -- that are built to represent the array type to point to the object.
2029 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
2030 N_Constrained_Array_Definition
2032 Set_Related_Array_Object
(T
, Id
);
2033 Set_Related_Array_Object
(Base_Type
(T
), Id
);
2036 -- Special checks for protected objects not at library level
2038 if Is_Protected_Type
(T
)
2039 and then not Is_Library_Level_Entity
(Id
)
2041 Check_Restriction
(No_Local_Protected_Objects
, Id
);
2043 -- Protected objects with interrupt handlers must be at library level
2045 -- Ada 2005: this test is not needed (and the corresponding clause
2046 -- in the RM is removed) because accessibility checks are sufficient
2047 -- to make handlers not at the library level illegal.
2049 if Has_Interrupt_Handler
(T
)
2050 and then Ada_Version
< Ada_05
2053 ("interrupt object can only be declared at library level", Id
);
2057 -- The actual subtype of the object is the nominal subtype, unless
2058 -- the nominal one is unconstrained and obtained from the expression.
2062 -- Process initialization expression if present and not in error
2064 if Present
(E
) and then E
/= Error
then
2067 -- In case of errors detected in the analysis of the expression,
2068 -- decorate it with the expected type to avoid cascade errors
2070 if not Present
(Etype
(E
)) then
2074 -- If an initialization expression is present, then we set the
2075 -- Is_True_Constant flag. It will be reset if this is a variable
2076 -- and it is indeed modified.
2078 Set_Is_True_Constant
(Id
, True);
2080 -- If we are analyzing a constant declaration, set its completion
2081 -- flag after analyzing the expression.
2083 if Constant_Present
(N
) then
2084 Set_Has_Completion
(Id
);
2087 if not Assignment_OK
(N
) then
2088 Check_Initialization
(T
, E
);
2091 Set_Etype
(Id
, T
); -- may be overridden later on
2093 Check_Unset_Reference
(E
);
2095 if Compile_Time_Known_Value
(E
) then
2096 Set_Current_Value
(Id
, E
);
2099 -- Check incorrect use of dynamically tagged expressions. Note
2100 -- the use of Is_Tagged_Type (T) which seems redundant but is in
2101 -- fact important to avoid spurious errors due to expanded code
2102 -- for dispatching functions over an anonymous access type
2104 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
2105 and then Is_Tagged_Type
(T
)
2106 and then not Is_Class_Wide_Type
(T
)
2108 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
2111 Apply_Scalar_Range_Check
(E
, T
);
2112 Apply_Static_Length_Check
(E
, T
);
2115 -- If the No_Streams restriction is set, check that the type of the
2116 -- object is not, and does not contain, any subtype derived from
2117 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
2118 -- Has_Stream just for efficiency reasons. There is no point in
2119 -- spending time on a Has_Stream check if the restriction is not set.
2121 if Restrictions
.Set
(No_Streams
) then
2122 if Has_Stream
(T
) then
2123 Check_Restriction
(No_Streams
, N
);
2127 -- Abstract type is never permitted for a variable or constant.
2128 -- Note: we inhibit this check for objects that do not come from
2129 -- source because there is at least one case (the expansion of
2130 -- x'class'input where x is abstract) where we legitimately
2131 -- generate an abstract object.
2133 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
2134 Error_Msg_N
("type of object cannot be abstract",
2135 Object_Definition
(N
));
2137 if Is_CPP_Class
(T
) then
2138 Error_Msg_NE
("\} may need a cpp_constructor",
2139 Object_Definition
(N
), T
);
2142 -- Case of unconstrained type
2144 elsif Is_Indefinite_Subtype
(T
) then
2146 -- Nothing to do in deferred constant case
2148 if Constant_Present
(N
) and then No
(E
) then
2151 -- Case of no initialization present
2154 if No_Initialization
(N
) then
2157 elsif Is_Class_Wide_Type
(T
) then
2159 ("initialization required in class-wide declaration ", N
);
2163 ("unconstrained subtype not allowed (need initialization)",
2164 Object_Definition
(N
));
2167 -- Case of initialization present but in error. Set initial
2168 -- expression as absent (but do not make above complaints)
2170 elsif E
= Error
then
2171 Set_Expression
(N
, Empty
);
2174 -- Case of initialization present
2177 -- Not allowed in Ada 83
2179 if not Constant_Present
(N
) then
2180 if Ada_Version
= Ada_83
2181 and then Comes_From_Source
(Object_Definition
(N
))
2184 ("(Ada 83) unconstrained variable not allowed",
2185 Object_Definition
(N
));
2189 -- Now we constrain the variable from the initializing expression
2191 -- If the expression is an aggregate, it has been expanded into
2192 -- individual assignments. Retrieve the actual type from the
2193 -- expanded construct.
2195 if Is_Array_Type
(T
)
2196 and then No_Initialization
(N
)
2197 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2202 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
2203 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2206 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
2208 if Aliased_Present
(N
) then
2209 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2212 Freeze_Before
(N
, Act_T
);
2213 Freeze_Before
(N
, T
);
2216 elsif Is_Array_Type
(T
)
2217 and then No_Initialization
(N
)
2218 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2220 if not Is_Entity_Name
(Object_Definition
(N
)) then
2222 Check_Compile_Time_Size
(Act_T
);
2224 if Aliased_Present
(N
) then
2225 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2229 -- When the given object definition and the aggregate are specified
2230 -- independently, and their lengths might differ do a length check.
2231 -- This cannot happen if the aggregate is of the form (others =>...)
2233 if not Is_Constrained
(T
) then
2236 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
2238 -- Aggregate is statically illegal. Place back in declaration
2240 Set_Expression
(N
, E
);
2241 Set_No_Initialization
(N
, False);
2243 elsif T
= Etype
(E
) then
2246 elsif Nkind
(E
) = N_Aggregate
2247 and then Present
(Component_Associations
(E
))
2248 and then Present
(Choices
(First
(Component_Associations
(E
))))
2249 and then Nkind
(First
2250 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
2255 Apply_Length_Check
(E
, T
);
2258 elsif (Is_Limited_Record
(T
)
2259 or else Is_Concurrent_Type
(T
))
2260 and then not Is_Constrained
(T
)
2261 and then Has_Discriminants
(T
)
2263 Act_T
:= Build_Default_Subtype
;
2264 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
2266 elsif Present
(Underlying_Type
(T
))
2267 and then not Is_Constrained
(Underlying_Type
(T
))
2268 and then Has_Discriminants
(Underlying_Type
(T
))
2269 and then Nkind
(E
) = N_Function_Call
2270 and then Constant_Present
(N
)
2272 -- The back-end has problems with constants of a discriminated type
2273 -- with defaults, if the initial value is a function call. We
2274 -- generate an intermediate temporary for the result of the call.
2275 -- It is unclear why this should make it acceptable to gcc. ???
2277 Remove_Side_Effects
(E
);
2280 if T
= Standard_Wide_Character
or else T
= Standard_Wide_Wide_Character
2281 or else Root_Type
(T
) = Standard_Wide_String
2282 or else Root_Type
(T
) = Standard_Wide_Wide_String
2284 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
2287 -- Now establish the proper kind and type of the object
2289 if Constant_Present
(N
) then
2290 Set_Ekind
(Id
, E_Constant
);
2291 Set_Never_Set_In_Source
(Id
, True);
2292 Set_Is_True_Constant
(Id
, True);
2295 Set_Ekind
(Id
, E_Variable
);
2297 -- A variable is set as shared passive if it appears in a shared
2298 -- passive package, and is at the outer level. This is not done
2299 -- for entities generated during expansion, because those are
2300 -- always manipulated locally.
2302 if Is_Shared_Passive
(Current_Scope
)
2303 and then Is_Library_Level_Entity
(Id
)
2304 and then Comes_From_Source
(Id
)
2306 Set_Is_Shared_Passive
(Id
);
2307 Check_Shared_Var
(Id
, T
, N
);
2310 -- Case of no initializing expression present. If the type is not
2311 -- fully initialized, then we set Never_Set_In_Source, since this
2312 -- is a case of a potentially uninitialized object. Note that we
2313 -- do not consider access variables to be fully initialized for
2314 -- this purpose, since it still seems dubious if someone declares
2316 -- Note that we only do this for source declarations. If the object
2317 -- is declared by a generated declaration, we assume that it is not
2318 -- appropriate to generate warnings in that case.
2321 if (Is_Access_Type
(T
)
2322 or else not Is_Fully_Initialized_Type
(T
))
2323 and then Comes_From_Source
(N
)
2325 Set_Never_Set_In_Source
(Id
);
2330 Init_Alignment
(Id
);
2333 if Aliased_Present
(N
) then
2334 Set_Is_Aliased
(Id
);
2337 and then Is_Record_Type
(T
)
2338 and then not Is_Constrained
(T
)
2339 and then Has_Discriminants
(T
)
2341 Set_Actual_Subtype
(Id
, Build_Default_Subtype
);
2345 Set_Etype
(Id
, Act_T
);
2347 if Has_Controlled_Component
(Etype
(Id
))
2348 or else Is_Controlled
(Etype
(Id
))
2350 if not Is_Library_Level_Entity
(Id
) then
2351 Check_Restriction
(No_Nested_Finalization
, N
);
2353 Validate_Controlled_Object
(Id
);
2356 -- Generate a warning when an initialization causes an obvious ABE
2357 -- violation. If the init expression is a simple aggregate there
2358 -- shouldn't be any initialize/adjust call generated. This will be
2359 -- true as soon as aggregates are built in place when possible.
2361 -- ??? at the moment we do not generate warnings for temporaries
2362 -- created for those aggregates although Program_Error might be
2363 -- generated if compiled with -gnato.
2365 if Is_Controlled
(Etype
(Id
))
2366 and then Comes_From_Source
(Id
)
2369 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
2371 Implicit_Call
: Entity_Id
;
2372 pragma Warnings
(Off
, Implicit_Call
);
2373 -- ??? what is this for (never referenced!)
2375 function Is_Aggr
(N
: Node_Id
) return Boolean;
2376 -- Check that N is an aggregate
2382 function Is_Aggr
(N
: Node_Id
) return Boolean is
2384 case Nkind
(Original_Node
(N
)) is
2385 when N_Aggregate | N_Extension_Aggregate
=>
2388 when N_Qualified_Expression |
2390 N_Unchecked_Type_Conversion
=>
2391 return Is_Aggr
(Expression
(Original_Node
(N
)));
2399 -- If no underlying type, we already are in an error situation.
2400 -- Do not try to add a warning since we do not have access to
2403 if No
(Underlying_Type
(BT
)) then
2404 Implicit_Call
:= Empty
;
2406 -- A generic type does not have usable primitive operators.
2407 -- Initialization calls are built for instances.
2409 elsif Is_Generic_Type
(BT
) then
2410 Implicit_Call
:= Empty
;
2412 -- If the init expression is not an aggregate, an adjust call
2413 -- will be generated
2415 elsif Present
(E
) and then not Is_Aggr
(E
) then
2416 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
2418 -- If no init expression and we are not in the deferred
2419 -- constant case, an Initialize call will be generated
2421 elsif No
(E
) and then not Constant_Present
(N
) then
2422 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
2425 Implicit_Call
:= Empty
;
2431 if Has_Task
(Etype
(Id
)) then
2432 Check_Restriction
(No_Tasking
, N
);
2434 if Is_Library_Level_Entity
(Id
) then
2435 Check_Restriction
(Max_Tasks
, N
, Count_Tasks
(Etype
(Id
)));
2437 Check_Restriction
(Max_Tasks
, N
);
2438 Check_Restriction
(No_Task_Hierarchy
, N
);
2439 Check_Potentially_Blocking_Operation
(N
);
2442 -- A rather specialized test. If we see two tasks being declared
2443 -- of the same type in the same object declaration, and the task
2444 -- has an entry with an address clause, we know that program error
2445 -- will be raised at run-time since we can't have two tasks with
2446 -- entries at the same address.
2448 if Is_Task_Type
(Etype
(Id
)) and then More_Ids
(N
) then
2453 E
:= First_Entity
(Etype
(Id
));
2454 while Present
(E
) loop
2455 if Ekind
(E
) = E_Entry
2456 and then Present
(Get_Attribute_Definition_Clause
2457 (E
, Attribute_Address
))
2460 ("?more than one task with same entry address", N
);
2462 ("\?Program_Error will be raised at run time", N
);
2464 Make_Raise_Program_Error
(Loc
,
2465 Reason
=> PE_Duplicated_Entry_Address
));
2475 -- Some simple constant-propagation: if the expression is a constant
2476 -- string initialized with a literal, share the literal. This avoids
2480 and then Is_Entity_Name
(E
)
2481 and then Ekind
(Entity
(E
)) = E_Constant
2482 and then Base_Type
(Etype
(E
)) = Standard_String
2485 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
2488 and then Nkind
(Val
) = N_String_Literal
2490 Rewrite
(E
, New_Copy
(Val
));
2495 -- Another optimization: if the nominal subtype is unconstrained and
2496 -- the expression is a function call that returns an unconstrained
2497 -- type, rewrite the declaration as a renaming of the result of the
2498 -- call. The exceptions below are cases where the copy is expected,
2499 -- either by the back end (Aliased case) or by the semantics, as for
2500 -- initializing controlled types or copying tags for classwide types.
2503 and then Nkind
(E
) = N_Explicit_Dereference
2504 and then Nkind
(Original_Node
(E
)) = N_Function_Call
2505 and then not Is_Library_Level_Entity
(Id
)
2506 and then not Is_Constrained
(Underlying_Type
(T
))
2507 and then not Is_Aliased
(Id
)
2508 and then not Is_Class_Wide_Type
(T
)
2509 and then not Is_Controlled
(T
)
2510 and then not Has_Controlled_Component
(Base_Type
(T
))
2511 and then Expander_Active
2514 Make_Object_Renaming_Declaration
(Loc
,
2515 Defining_Identifier
=> Id
,
2516 Access_Definition
=> Empty
,
2517 Subtype_Mark
=> New_Occurrence_Of
2518 (Base_Type
(Etype
(Id
)), Loc
),
2521 Set_Renamed_Object
(Id
, E
);
2523 -- Force generation of debugging information for the constant and for
2524 -- the renamed function call.
2526 Set_Needs_Debug_Info
(Id
);
2527 Set_Needs_Debug_Info
(Entity
(Prefix
(E
)));
2530 if Present
(Prev_Entity
)
2531 and then Is_Frozen
(Prev_Entity
)
2532 and then not Error_Posted
(Id
)
2534 Error_Msg_N
("full constant declaration appears too late", N
);
2537 Check_Eliminated
(Id
);
2538 end Analyze_Object_Declaration
;
2540 ---------------------------
2541 -- Analyze_Others_Choice --
2542 ---------------------------
2544 -- Nothing to do for the others choice node itself, the semantic analysis
2545 -- of the others choice will occur as part of the processing of the parent
2547 procedure Analyze_Others_Choice
(N
: Node_Id
) is
2548 pragma Warnings
(Off
, N
);
2551 end Analyze_Others_Choice
;
2553 --------------------------------
2554 -- Analyze_Per_Use_Expression --
2555 --------------------------------
2557 procedure Analyze_Per_Use_Expression
(N
: Node_Id
; T
: Entity_Id
) is
2558 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
2560 In_Default_Expression
:= True;
2561 Pre_Analyze_And_Resolve
(N
, T
);
2562 In_Default_Expression
:= Save_In_Default_Expression
;
2563 end Analyze_Per_Use_Expression
;
2565 -------------------------------------------
2566 -- Analyze_Private_Extension_Declaration --
2567 -------------------------------------------
2569 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
2570 T
: constant Entity_Id
:= Defining_Identifier
(N
);
2571 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
2572 Parent_Type
: Entity_Id
;
2573 Parent_Base
: Entity_Id
;
2576 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
2578 if Is_Non_Empty_List
(Interface_List
(N
)) then
2584 Intf
:= First
(Interface_List
(N
));
2585 while Present
(Intf
) loop
2586 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
2588 if not Is_Interface
(T
) then
2589 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
2597 Generate_Definition
(T
);
2600 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
2601 Parent_Base
:= Base_Type
(Parent_Type
);
2603 if Parent_Type
= Any_Type
2604 or else Etype
(Parent_Type
) = Any_Type
2606 Set_Ekind
(T
, Ekind
(Parent_Type
));
2607 Set_Etype
(T
, Any_Type
);
2610 elsif not Is_Tagged_Type
(Parent_Type
) then
2612 ("parent of type extension must be a tagged type ", Indic
);
2615 elsif Ekind
(Parent_Type
) = E_Void
2616 or else Ekind
(Parent_Type
) = E_Incomplete_Type
2618 Error_Msg_N
("premature derivation of incomplete type", Indic
);
2622 -- Perhaps the parent type should be changed to the class-wide type's
2623 -- specific type in this case to prevent cascading errors ???
2625 if Is_Class_Wide_Type
(Parent_Type
) then
2627 ("parent of type extension must not be a class-wide type", Indic
);
2631 if (not Is_Package_Or_Generic_Package
(Current_Scope
)
2632 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
2633 or else In_Private_Part
(Current_Scope
)
2636 Error_Msg_N
("invalid context for private extension", N
);
2639 -- Set common attributes
2641 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2642 Set_Scope
(T
, Current_Scope
);
2643 Set_Ekind
(T
, E_Record_Type_With_Private
);
2644 Init_Size_Align
(T
);
2646 Set_Etype
(T
, Parent_Base
);
2647 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
2649 Set_Convention
(T
, Convention
(Parent_Type
));
2650 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
2651 Set_Is_First_Subtype
(T
);
2652 Make_Class_Wide_Type
(T
);
2654 if Unknown_Discriminants_Present
(N
) then
2655 Set_Discriminant_Constraint
(T
, No_Elist
);
2658 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
2660 if Limited_Present
(N
) then
2661 Set_Is_Limited_Record
(T
);
2663 if not Is_Limited_Type
(Parent_Type
) then
2664 Error_Msg_NE
("parent type& of limited extension must be limited",
2668 end Analyze_Private_Extension_Declaration
;
2670 ---------------------------------
2671 -- Analyze_Subtype_Declaration --
2672 ---------------------------------
2674 procedure Analyze_Subtype_Declaration
(N
: Node_Id
) is
2675 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2677 R_Checks
: Check_Result
;
2680 Generate_Definition
(Id
);
2681 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2682 Init_Size_Align
(Id
);
2684 -- The following guard condition on Enter_Name is to handle cases where
2685 -- the defining identifier has already been entered into the scope but
2686 -- the declaration as a whole needs to be analyzed.
2688 -- This case in particular happens for derived enumeration types. The
2689 -- derived enumeration type is processed as an inserted enumeration type
2690 -- declaration followed by a rewritten subtype declaration. The defining
2691 -- identifier, however, is entered into the name scope very early in the
2692 -- processing of the original type declaration and therefore needs to be
2693 -- avoided here, when the created subtype declaration is analyzed. (See
2694 -- Build_Derived_Types)
2696 -- This also happens when the full view of a private type is derived
2697 -- type with constraints. In this case the entity has been introduced
2698 -- in the private declaration.
2700 if Present
(Etype
(Id
))
2701 and then (Is_Private_Type
(Etype
(Id
))
2702 or else Is_Task_Type
(Etype
(Id
))
2703 or else Is_Rewrite_Substitution
(N
))
2711 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2713 -- Inherit common attributes
2715 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2716 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2717 Set_Treat_As_Volatile
(Id
, Treat_As_Volatile
(T
));
2718 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2719 Set_Is_Ada_2005
(Id
, Is_Ada_2005
(T
));
2721 -- In the case where there is no constraint given in the subtype
2722 -- indication, Process_Subtype just returns the Subtype_Mark, so its
2723 -- semantic attributes must be established here.
2725 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2726 Set_Etype
(Id
, Base_Type
(T
));
2730 Set_Ekind
(Id
, E_Array_Subtype
);
2731 Copy_Array_Subtype_Attributes
(Id
, T
);
2733 when Decimal_Fixed_Point_Kind
=>
2734 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2735 Set_Digits_Value
(Id
, Digits_Value
(T
));
2736 Set_Delta_Value
(Id
, Delta_Value
(T
));
2737 Set_Scale_Value
(Id
, Scale_Value
(T
));
2738 Set_Small_Value
(Id
, Small_Value
(T
));
2739 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2740 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2741 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2742 Set_RM_Size
(Id
, RM_Size
(T
));
2744 when Enumeration_Kind
=>
2745 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2746 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2747 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2748 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2749 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2750 Set_RM_Size
(Id
, RM_Size
(T
));
2752 when Ordinary_Fixed_Point_Kind
=>
2753 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2754 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2755 Set_Small_Value
(Id
, Small_Value
(T
));
2756 Set_Delta_Value
(Id
, Delta_Value
(T
));
2757 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2758 Set_RM_Size
(Id
, RM_Size
(T
));
2761 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2762 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2763 Set_Digits_Value
(Id
, Digits_Value
(T
));
2764 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2766 when Signed_Integer_Kind
=>
2767 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2768 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2769 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2770 Set_RM_Size
(Id
, RM_Size
(T
));
2772 when Modular_Integer_Kind
=>
2773 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2774 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2775 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2776 Set_RM_Size
(Id
, RM_Size
(T
));
2778 when Class_Wide_Kind
=>
2779 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2780 Set_First_Entity
(Id
, First_Entity
(T
));
2781 Set_Last_Entity
(Id
, Last_Entity
(T
));
2782 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2783 Set_Cloned_Subtype
(Id
, T
);
2784 Set_Is_Tagged_Type
(Id
, True);
2785 Set_Has_Unknown_Discriminants
2788 if Ekind
(T
) = E_Class_Wide_Subtype
then
2789 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
2792 when E_Record_Type | E_Record_Subtype
=>
2793 Set_Ekind
(Id
, E_Record_Subtype
);
2795 if Ekind
(T
) = E_Record_Subtype
2796 and then Present
(Cloned_Subtype
(T
))
2798 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
2800 Set_Cloned_Subtype
(Id
, T
);
2803 Set_First_Entity
(Id
, First_Entity
(T
));
2804 Set_Last_Entity
(Id
, Last_Entity
(T
));
2805 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2806 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2807 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2808 Set_Has_Unknown_Discriminants
2809 (Id
, Has_Unknown_Discriminants
(T
));
2811 if Has_Discriminants
(T
) then
2812 Set_Discriminant_Constraint
2813 (Id
, Discriminant_Constraint
(T
));
2814 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2816 elsif Has_Unknown_Discriminants
(Id
) then
2817 Set_Discriminant_Constraint
(Id
, No_Elist
);
2820 if Is_Tagged_Type
(T
) then
2821 Set_Is_Tagged_Type
(Id
);
2822 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2823 Set_Primitive_Operations
2824 (Id
, Primitive_Operations
(T
));
2825 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2828 when Private_Kind
=>
2829 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2830 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2831 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2832 Set_First_Entity
(Id
, First_Entity
(T
));
2833 Set_Last_Entity
(Id
, Last_Entity
(T
));
2834 Set_Private_Dependents
(Id
, New_Elmt_List
);
2835 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2836 Set_Has_Unknown_Discriminants
2837 (Id
, Has_Unknown_Discriminants
(T
));
2839 if Is_Tagged_Type
(T
) then
2840 Set_Is_Tagged_Type
(Id
);
2841 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2842 Set_Primitive_Operations
2843 (Id
, Primitive_Operations
(T
));
2844 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2847 -- In general the attributes of the subtype of a private type
2848 -- are the attributes of the partial view of parent. However,
2849 -- the full view may be a discriminated type, and the subtype
2850 -- must share the discriminant constraint to generate correct
2851 -- calls to initialization procedures.
2853 if Has_Discriminants
(T
) then
2854 Set_Discriminant_Constraint
2855 (Id
, Discriminant_Constraint
(T
));
2856 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2858 elsif Present
(Full_View
(T
))
2859 and then Has_Discriminants
(Full_View
(T
))
2861 Set_Discriminant_Constraint
2862 (Id
, Discriminant_Constraint
(Full_View
(T
)));
2863 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2865 -- This would seem semantically correct, but apparently
2866 -- confuses the back-end (4412-009). To be explained ???
2868 -- Set_Has_Discriminants (Id);
2871 Prepare_Private_Subtype_Completion
(Id
, N
);
2874 Set_Ekind
(Id
, E_Access_Subtype
);
2875 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2876 Set_Is_Access_Constant
2877 (Id
, Is_Access_Constant
(T
));
2878 Set_Directly_Designated_Type
2879 (Id
, Designated_Type
(T
));
2880 Set_Can_Never_Be_Null
(Id
, Can_Never_Be_Null
(T
));
2882 -- A Pure library_item must not contain the declaration of a
2883 -- named access type, except within a subprogram, generic
2884 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
2886 if Comes_From_Source
(Id
)
2887 and then In_Pure_Unit
2888 and then not In_Subprogram_Task_Protected_Unit
2891 ("named access types not allowed in pure unit", N
);
2894 when Concurrent_Kind
=>
2895 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2896 Set_Corresponding_Record_Type
(Id
,
2897 Corresponding_Record_Type
(T
));
2898 Set_First_Entity
(Id
, First_Entity
(T
));
2899 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
2900 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2901 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2902 Set_Last_Entity
(Id
, Last_Entity
(T
));
2904 if Has_Discriminants
(T
) then
2905 Set_Discriminant_Constraint
(Id
,
2906 Discriminant_Constraint
(T
));
2907 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2910 -- If the subtype name denotes an incomplete type an error was
2911 -- already reported by Process_Subtype.
2913 when E_Incomplete_Type
=>
2914 Set_Etype
(Id
, Any_Type
);
2917 raise Program_Error
;
2921 if Etype
(Id
) = Any_Type
then
2925 -- Some common processing on all types
2927 Set_Size_Info
(Id
, T
);
2928 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
2932 Set_Is_Immediately_Visible
(Id
, True);
2933 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
2935 if Present
(Generic_Parent_Type
(N
))
2938 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
2940 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
2941 /= N_Formal_Private_Type_Definition
)
2943 if Is_Tagged_Type
(Id
) then
2944 if Is_Class_Wide_Type
(Id
) then
2945 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
2947 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
2950 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
2951 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
2955 if Is_Private_Type
(T
)
2956 and then Present
(Full_View
(T
))
2958 Conditional_Delay
(Id
, Full_View
(T
));
2960 -- The subtypes of components or subcomponents of protected types
2961 -- do not need freeze nodes, which would otherwise appear in the
2962 -- wrong scope (before the freeze node for the protected type). The
2963 -- proper subtypes are those of the subcomponents of the corresponding
2966 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
2967 and then Present
(Scope
(Scope
(Id
))) -- error defense!
2968 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
2970 Conditional_Delay
(Id
, T
);
2973 -- Check that constraint_error is raised for a scalar subtype
2974 -- indication when the lower or upper bound of a non-null range
2975 -- lies outside the range of the type mark.
2977 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
2978 if Is_Scalar_Type
(Etype
(Id
))
2979 and then Scalar_Range
(Id
) /=
2980 Scalar_Range
(Etype
(Subtype_Mark
2981 (Subtype_Indication
(N
))))
2985 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
2987 elsif Is_Array_Type
(Etype
(Id
))
2988 and then Present
(First_Index
(Id
))
2990 -- This really should be a subprogram that finds the indications
2993 if ((Nkind
(First_Index
(Id
)) = N_Identifier
2994 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
2995 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
2997 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
3000 Target_Typ
: constant Entity_Id
:=
3003 (Subtype_Mark
(Subtype_Indication
(N
)))));
3007 (Scalar_Range
(Etype
(First_Index
(Id
))),
3009 Etype
(First_Index
(Id
)),
3010 Defining_Identifier
(N
));
3016 Sloc
(Defining_Identifier
(N
)));
3022 Check_Eliminated
(Id
);
3023 end Analyze_Subtype_Declaration
;
3025 --------------------------------
3026 -- Analyze_Subtype_Indication --
3027 --------------------------------
3029 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
3030 T
: constant Entity_Id
:= Subtype_Mark
(N
);
3031 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
3038 Set_Etype
(N
, Etype
(R
));
3040 Set_Error_Posted
(R
);
3041 Set_Error_Posted
(T
);
3043 end Analyze_Subtype_Indication
;
3045 ------------------------------
3046 -- Analyze_Type_Declaration --
3047 ------------------------------
3049 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
3050 Def
: constant Node_Id
:= Type_Definition
(N
);
3051 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3055 Is_Remote
: constant Boolean :=
3056 (Is_Remote_Types
(Current_Scope
)
3057 or else Is_Remote_Call_Interface
(Current_Scope
))
3058 and then not (In_Private_Part
(Current_Scope
)
3060 In_Package_Body
(Current_Scope
));
3062 procedure Check_Ops_From_Incomplete_Type
;
3063 -- If there is a tagged incomplete partial view of the type, transfer
3064 -- its operations to the full view, and indicate that the type of the
3065 -- controlling parameter (s) is this full view.
3067 ------------------------------------
3068 -- Check_Ops_From_Incomplete_Type --
3069 ------------------------------------
3071 procedure Check_Ops_From_Incomplete_Type
is
3078 and then Ekind
(Prev
) = E_Incomplete_Type
3079 and then Is_Tagged_Type
(Prev
)
3080 and then Is_Tagged_Type
(T
)
3082 Elmt
:= First_Elmt
(Primitive_Operations
(Prev
));
3083 while Present
(Elmt
) loop
3085 Prepend_Elmt
(Op
, Primitive_Operations
(T
));
3087 Formal
:= First_Formal
(Op
);
3088 while Present
(Formal
) loop
3089 if Etype
(Formal
) = Prev
then
3090 Set_Etype
(Formal
, T
);
3093 Next_Formal
(Formal
);
3096 if Etype
(Op
) = Prev
then
3103 end Check_Ops_From_Incomplete_Type
;
3105 -- Start of processing for Analyze_Type_Declaration
3108 Prev
:= Find_Type_Name
(N
);
3110 -- The full view, if present, now points to the current type
3112 -- Ada 2005 (AI-50217): If the type was previously decorated when
3113 -- imported through a LIMITED WITH clause, it appears as incomplete
3114 -- but has no full view.
3116 if Ekind
(Prev
) = E_Incomplete_Type
3117 and then Present
(Full_View
(Prev
))
3119 T
:= Full_View
(Prev
);
3124 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
3126 -- We set the flag Is_First_Subtype here. It is needed to set the
3127 -- corresponding flag for the Implicit class-wide-type created
3128 -- during tagged types processing.
3130 Set_Is_First_Subtype
(T
, True);
3132 -- Only composite types other than array types are allowed to have
3137 -- For derived types, the rule will be checked once we've figured
3138 -- out the parent type.
3140 when N_Derived_Type_Definition
=>
3143 -- For record types, discriminants are allowed
3145 when N_Record_Definition
=>
3149 if Present
(Discriminant_Specifications
(N
)) then
3151 ("elementary or array type cannot have discriminants",
3153 (First
(Discriminant_Specifications
(N
))));
3157 -- Elaborate the type definition according to kind, and generate
3158 -- subsidiary (implicit) subtypes where needed. We skip this if
3159 -- it was already done (this happens during the reanalysis that
3160 -- follows a call to the high level optimizer).
3162 if not Analyzed
(T
) then
3167 when N_Access_To_Subprogram_Definition
=>
3168 Access_Subprogram_Declaration
(T
, Def
);
3170 -- If this is a remote access to subprogram, we must create
3171 -- the equivalent fat pointer type, and related subprograms.
3174 Process_Remote_AST_Declaration
(N
);
3177 -- Validate categorization rule against access type declaration
3178 -- usually a violation in Pure unit, Shared_Passive unit.
3180 Validate_Access_Type_Declaration
(T
, N
);
3182 when N_Access_To_Object_Definition
=>
3183 Access_Type_Declaration
(T
, Def
);
3185 -- Validate categorization rule against access type declaration
3186 -- usually a violation in Pure unit, Shared_Passive unit.
3188 Validate_Access_Type_Declaration
(T
, N
);
3190 -- If we are in a Remote_Call_Interface package and define
3191 -- a RACW, Read and Write attribute must be added.
3194 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
3196 Add_RACW_Features
(Def_Id
);
3199 -- Set no strict aliasing flag if config pragma seen
3201 if Opt
.No_Strict_Aliasing
then
3202 Set_No_Strict_Aliasing
(Base_Type
(Def_Id
));
3205 when N_Array_Type_Definition
=>
3206 Array_Type_Declaration
(T
, Def
);
3208 when N_Derived_Type_Definition
=>
3209 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
3211 when N_Enumeration_Type_Definition
=>
3212 Enumeration_Type_Declaration
(T
, Def
);
3214 when N_Floating_Point_Definition
=>
3215 Floating_Point_Type_Declaration
(T
, Def
);
3217 when N_Decimal_Fixed_Point_Definition
=>
3218 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
3220 when N_Ordinary_Fixed_Point_Definition
=>
3221 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
3223 when N_Signed_Integer_Type_Definition
=>
3224 Signed_Integer_Type_Declaration
(T
, Def
);
3226 when N_Modular_Type_Definition
=>
3227 Modular_Type_Declaration
(T
, Def
);
3229 when N_Record_Definition
=>
3230 Record_Type_Declaration
(T
, N
, Prev
);
3233 raise Program_Error
;
3238 if Etype
(T
) = Any_Type
then
3242 -- Some common processing for all types
3244 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
3245 Check_Ops_From_Incomplete_Type
;
3247 -- Both the declared entity, and its anonymous base type if one
3248 -- was created, need freeze nodes allocated.
3251 B
: constant Entity_Id
:= Base_Type
(T
);
3254 -- In the case where the base type is different from the first
3255 -- subtype, we pre-allocate a freeze node, and set the proper link
3256 -- to the first subtype. Freeze_Entity will use this preallocated
3257 -- freeze node when it freezes the entity.
3260 Ensure_Freeze_Node
(B
);
3261 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
3264 if not From_With_Type
(T
) then
3265 Set_Has_Delayed_Freeze
(T
);
3269 -- Case of T is the full declaration of some private type which has
3270 -- been swapped in Defining_Identifier (N).
3272 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
3273 Process_Full_View
(N
, T
, Def_Id
);
3275 -- Record the reference. The form of this is a little strange,
3276 -- since the full declaration has been swapped in. So the first
3277 -- parameter here represents the entity to which a reference is
3278 -- made which is the "real" entity, i.e. the one swapped in,
3279 -- and the second parameter provides the reference location.
3281 Generate_Reference
(T
, T
, 'c');
3282 Set_Completion_Referenced
(Def_Id
);
3284 -- For completion of incomplete type, process incomplete dependents
3285 -- and always mark the full type as referenced (it is the incomplete
3286 -- type that we get for any real reference).
3288 elsif Ekind
(Prev
) = E_Incomplete_Type
then
3289 Process_Incomplete_Dependents
(N
, T
, Prev
);
3290 Generate_Reference
(Prev
, Def_Id
, 'c');
3291 Set_Completion_Referenced
(Def_Id
);
3293 -- If not private type or incomplete type completion, this is a real
3294 -- definition of a new entity, so record it.
3297 Generate_Definition
(Def_Id
);
3300 Check_Eliminated
(Def_Id
);
3301 end Analyze_Type_Declaration
;
3303 --------------------------
3304 -- Analyze_Variant_Part --
3305 --------------------------
3307 procedure Analyze_Variant_Part
(N
: Node_Id
) is
3309 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
3310 -- Error routine invoked by the generic instantiation below when
3311 -- the variant part has a non static choice.
3313 procedure Process_Declarations
(Variant
: Node_Id
);
3314 -- Analyzes all the declarations associated with a Variant.
3315 -- Needed by the generic instantiation below.
3317 package Variant_Choices_Processing
is new
3318 Generic_Choices_Processing
3319 (Get_Alternatives
=> Variants
,
3320 Get_Choices
=> Discrete_Choices
,
3321 Process_Empty_Choice
=> No_OP
,
3322 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
3323 Process_Associated_Node
=> Process_Declarations
);
3324 use Variant_Choices_Processing
;
3325 -- Instantiation of the generic choice processing package
3327 -----------------------------
3328 -- Non_Static_Choice_Error --
3329 -----------------------------
3331 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
3333 Flag_Non_Static_Expr
3334 ("choice given in variant part is not static!", Choice
);
3335 end Non_Static_Choice_Error
;
3337 --------------------------
3338 -- Process_Declarations --
3339 --------------------------
3341 procedure Process_Declarations
(Variant
: Node_Id
) is
3343 if not Null_Present
(Component_List
(Variant
)) then
3344 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
3346 if Present
(Variant_Part
(Component_List
(Variant
))) then
3347 Analyze
(Variant_Part
(Component_List
(Variant
)));
3350 end Process_Declarations
;
3352 -- Variables local to Analyze_Case_Statement
3354 Discr_Name
: Node_Id
;
3355 Discr_Type
: Entity_Id
;
3357 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
3359 Dont_Care
: Boolean;
3360 Others_Present
: Boolean := False;
3362 -- Start of processing for Analyze_Variant_Part
3365 Discr_Name
:= Name
(N
);
3366 Analyze
(Discr_Name
);
3368 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
3369 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
3372 Discr_Type
:= Etype
(Entity
(Discr_Name
));
3374 if not Is_Discrete_Type
(Discr_Type
) then
3376 ("discriminant in a variant part must be of a discrete type",
3381 -- Call the instantiated Analyze_Choices which does the rest of the work
3384 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
3385 end Analyze_Variant_Part
;
3387 ----------------------------
3388 -- Array_Type_Declaration --
3389 ----------------------------
3391 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
3392 Component_Def
: constant Node_Id
:= Component_Definition
(Def
);
3393 Element_Type
: Entity_Id
;
3394 Implicit_Base
: Entity_Id
;
3396 Related_Id
: Entity_Id
:= Empty
;
3398 P
: constant Node_Id
:= Parent
(Def
);
3402 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3403 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
3405 Index
:= First
(Subtype_Marks
(Def
));
3408 -- Find proper names for the implicit types which may be public.
3409 -- in case of anonymous arrays we use the name of the first object
3410 -- of that type as prefix.
3413 Related_Id
:= Defining_Identifier
(P
);
3419 while Present
(Index
) loop
3421 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
3423 Nb_Index
:= Nb_Index
+ 1;
3426 if Present
(Subtype_Indication
(Component_Def
)) then
3427 Element_Type
:= Process_Subtype
(Subtype_Indication
(Component_Def
),
3428 P
, Related_Id
, 'C');
3430 -- Ada 2005 (AI-230): Access Definition case
3432 else pragma Assert
(Present
(Access_Definition
(Component_Def
)));
3433 Element_Type
:= Access_Definition
3434 (Related_Nod
=> Related_Id
,
3435 N
=> Access_Definition
(Component_Def
));
3436 Set_Is_Local_Anonymous_Access
(Element_Type
);
3438 -- Ada 2005 (AI-230): In case of components that are anonymous
3439 -- access types the level of accessibility depends on the enclosing
3442 Set_Scope
(Element_Type
, Current_Scope
); -- Ada 2005 (AI-230)
3444 -- Ada 2005 (AI-254)
3447 CD
: constant Node_Id
:=
3448 Access_To_Subprogram_Definition
3449 (Access_Definition
(Component_Def
));
3451 if Present
(CD
) and then Protected_Present
(CD
) then
3453 Replace_Anonymous_Access_To_Protected_Subprogram
3454 (Def
, Element_Type
);
3459 -- Constrained array case
3462 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
3465 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3467 -- Establish Implicit_Base as unconstrained base type
3469 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
3471 Init_Size_Align
(Implicit_Base
);
3472 Set_Etype
(Implicit_Base
, Implicit_Base
);
3473 Set_Scope
(Implicit_Base
, Current_Scope
);
3474 Set_Has_Delayed_Freeze
(Implicit_Base
);
3476 -- The constrained array type is a subtype of the unconstrained one
3478 Set_Ekind
(T
, E_Array_Subtype
);
3479 Init_Size_Align
(T
);
3480 Set_Etype
(T
, Implicit_Base
);
3481 Set_Scope
(T
, Current_Scope
);
3482 Set_Is_Constrained
(T
, True);
3483 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
3484 Set_Has_Delayed_Freeze
(T
);
3486 -- Complete setup of implicit base type
3488 Set_First_Index
(Implicit_Base
, First_Index
(T
));
3489 Set_Component_Type
(Implicit_Base
, Element_Type
);
3490 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
3491 Set_Component_Size
(Implicit_Base
, Uint_0
);
3492 Set_Has_Controlled_Component
3493 (Implicit_Base
, Has_Controlled_Component
3496 Is_Controlled
(Element_Type
));
3497 Set_Finalize_Storage_Only
3498 (Implicit_Base
, Finalize_Storage_Only
3501 -- Unconstrained array case
3504 Set_Ekind
(T
, E_Array_Type
);
3505 Init_Size_Align
(T
);
3507 Set_Scope
(T
, Current_Scope
);
3508 Set_Component_Size
(T
, Uint_0
);
3509 Set_Is_Constrained
(T
, False);
3510 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
3511 Set_Has_Delayed_Freeze
(T
, True);
3512 Set_Has_Task
(T
, Has_Task
(Element_Type
));
3513 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
3516 Is_Controlled
(Element_Type
));
3517 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
3521 Set_Component_Type
(Base_Type
(T
), Element_Type
);
3523 if Aliased_Present
(Component_Definition
(Def
)) then
3524 Set_Has_Aliased_Components
(Etype
(T
));
3527 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
3528 -- array type to ensure that objects of this type are initialized.
3530 if Ada_Version
>= Ada_05
3531 and then Can_Never_Be_Null
(Element_Type
)
3533 Set_Can_Never_Be_Null
(T
);
3535 if Null_Exclusion_Present
(Component_Definition
(Def
))
3536 and then Can_Never_Be_Null
(Element_Type
)
3538 -- No need to check itypes because in their case this check
3539 -- was done at their point of creation
3541 and then not Is_Itype
(Element_Type
)
3544 ("(Ada 2005) already a null-excluding type",
3545 Subtype_Indication
(Component_Definition
(Def
)));
3549 Priv
:= Private_Component
(Element_Type
);
3551 if Present
(Priv
) then
3553 -- Check for circular definitions
3555 if Priv
= Any_Type
then
3556 Set_Component_Type
(Etype
(T
), Any_Type
);
3558 -- There is a gap in the visibility of operations on the composite
3559 -- type only if the component type is defined in a different scope.
3561 elsif Scope
(Priv
) = Current_Scope
then
3564 elsif Is_Limited_Type
(Priv
) then
3565 Set_Is_Limited_Composite
(Etype
(T
));
3566 Set_Is_Limited_Composite
(T
);
3568 Set_Is_Private_Composite
(Etype
(T
));
3569 Set_Is_Private_Composite
(T
);
3573 -- Create a concatenation operator for the new type. Internal
3574 -- array types created for packed entities do not need such, they
3575 -- are compatible with the user-defined type.
3577 if Number_Dimensions
(T
) = 1
3578 and then not Is_Packed_Array_Type
(T
)
3580 New_Concatenation_Op
(T
);
3583 -- In the case of an unconstrained array the parser has already
3584 -- verified that all the indices are unconstrained but we still
3585 -- need to make sure that the element type is constrained.
3587 if Is_Indefinite_Subtype
(Element_Type
) then
3589 ("unconstrained element type in array declaration",
3590 Subtype_Indication
(Component_Def
));
3592 elsif Is_Abstract
(Element_Type
) then
3594 ("the type of a component cannot be abstract",
3595 Subtype_Indication
(Component_Def
));
3598 end Array_Type_Declaration
;
3600 ------------------------------------------------------
3601 -- Replace_Anonymous_Access_To_Protected_Subprogram --
3602 ------------------------------------------------------
3604 function Replace_Anonymous_Access_To_Protected_Subprogram
3606 Prev_E
: Entity_Id
) return Entity_Id
3608 Loc
: constant Source_Ptr
:= Sloc
(N
);
3610 Curr_Scope
: constant Scope_Stack_Entry
:=
3611 Scope_Stack
.Table
(Scope_Stack
.Last
);
3613 Anon
: constant Entity_Id
:=
3614 Make_Defining_Identifier
(Loc
,
3615 Chars
=> New_Internal_Name
('S'));
3623 Set_Is_Internal
(Anon
);
3626 when N_Component_Declaration |
3627 N_Unconstrained_Array_Definition |
3628 N_Constrained_Array_Definition
=>
3629 Comp
:= Component_Definition
(N
);
3630 Acc
:= Access_Definition
(Component_Definition
(N
));
3632 when N_Discriminant_Specification
=>
3633 Comp
:= Discriminant_Type
(N
);
3634 Acc
:= Discriminant_Type
(N
);
3636 when N_Parameter_Specification
=>
3637 Comp
:= Parameter_Type
(N
);
3638 Acc
:= Parameter_Type
(N
);
3641 raise Program_Error
;
3644 Decl
:= Make_Full_Type_Declaration
(Loc
,
3645 Defining_Identifier
=> Anon
,
3647 Copy_Separate_Tree
(Access_To_Subprogram_Definition
(Acc
)));
3649 Mark_Rewrite_Insertion
(Decl
);
3651 -- Insert the new declaration in the nearest enclosing scope
3654 while Present
(P
) and then not Has_Declarations
(P
) loop
3658 pragma Assert
(Present
(P
));
3660 if Nkind
(P
) = N_Package_Specification
then
3661 Prepend
(Decl
, Visible_Declarations
(P
));
3663 Prepend
(Decl
, Declarations
(P
));
3666 -- Replace the anonymous type with an occurrence of the new declaration.
3667 -- In all cases the rewritten node does not have the null-exclusion
3668 -- attribute because (if present) it was already inherited by the
3669 -- anonymous entity (Anon). Thus, in case of components we do not
3670 -- inherit this attribute.
3672 if Nkind
(N
) = N_Parameter_Specification
then
3673 Rewrite
(Comp
, New_Occurrence_Of
(Anon
, Loc
));
3674 Set_Etype
(Defining_Identifier
(N
), Anon
);
3675 Set_Null_Exclusion_Present
(N
, False);
3678 Make_Component_Definition
(Loc
,
3679 Subtype_Indication
=> New_Occurrence_Of
(Anon
, Loc
)));
3682 Mark_Rewrite_Insertion
(Comp
);
3684 -- Temporarily remove the current scope from the stack to add the new
3685 -- declarations to the enclosing scope
3687 Scope_Stack
.Decrement_Last
;
3689 Scope_Stack
.Append
(Curr_Scope
);
3691 Set_Original_Access_Type
(Anon
, Prev_E
);
3693 end Replace_Anonymous_Access_To_Protected_Subprogram
;
3695 -------------------------------
3696 -- Build_Derived_Access_Type --
3697 -------------------------------
3699 procedure Build_Derived_Access_Type
3701 Parent_Type
: Entity_Id
;
3702 Derived_Type
: Entity_Id
)
3704 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
3706 Desig_Type
: Entity_Id
;
3708 Discr_Con_Elist
: Elist_Id
;
3709 Discr_Con_El
: Elmt_Id
;
3713 -- Set the designated type so it is available in case this is
3714 -- an access to a self-referential type, e.g. a standard list
3715 -- type with a next pointer. Will be reset after subtype is built.
3717 Set_Directly_Designated_Type
3718 (Derived_Type
, Designated_Type
(Parent_Type
));
3720 Subt
:= Process_Subtype
(S
, N
);
3722 if Nkind
(S
) /= N_Subtype_Indication
3723 and then Subt
/= Base_Type
(Subt
)
3725 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
3728 if Ekind
(Derived_Type
) = E_Access_Subtype
then
3730 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3731 Ibase
: constant Entity_Id
:=
3732 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
3733 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
3734 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
3737 Copy_Node
(Pbase
, Ibase
);
3739 Set_Chars
(Ibase
, Svg_Chars
);
3740 Set_Next_Entity
(Ibase
, Svg_Next_E
);
3741 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
3742 Set_Scope
(Ibase
, Scope
(Derived_Type
));
3743 Set_Freeze_Node
(Ibase
, Empty
);
3744 Set_Is_Frozen
(Ibase
, False);
3745 Set_Comes_From_Source
(Ibase
, False);
3746 Set_Is_First_Subtype
(Ibase
, False);
3748 Set_Etype
(Ibase
, Pbase
);
3749 Set_Etype
(Derived_Type
, Ibase
);
3753 Set_Directly_Designated_Type
3754 (Derived_Type
, Designated_Type
(Subt
));
3756 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
3757 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
3758 Set_Size_Info
(Derived_Type
, Parent_Type
);
3759 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
3760 Set_Depends_On_Private
(Derived_Type
,
3761 Has_Private_Component
(Derived_Type
));
3762 Conditional_Delay
(Derived_Type
, Subt
);
3764 -- Ada 2005 (AI-231). Set the null-exclusion attribute
3766 if Null_Exclusion_Present
(Type_Definition
(N
))
3767 or else Can_Never_Be_Null
(Parent_Type
)
3769 Set_Can_Never_Be_Null
(Derived_Type
);
3772 -- Note: we do not copy the Storage_Size_Variable, since
3773 -- we always go to the root type for this information.
3775 -- Apply range checks to discriminants for derived record case
3776 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
3778 Desig_Type
:= Designated_Type
(Derived_Type
);
3779 if Is_Composite_Type
(Desig_Type
)
3780 and then (not Is_Array_Type
(Desig_Type
))
3781 and then Has_Discriminants
(Desig_Type
)
3782 and then Base_Type
(Desig_Type
) /= Desig_Type
3784 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
3785 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
3787 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
3788 while Present
(Discr_Con_El
) loop
3789 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
3790 Next_Elmt
(Discr_Con_El
);
3791 Next_Discriminant
(Discr
);
3794 end Build_Derived_Access_Type
;
3796 ------------------------------
3797 -- Build_Derived_Array_Type --
3798 ------------------------------
3800 procedure Build_Derived_Array_Type
3802 Parent_Type
: Entity_Id
;
3803 Derived_Type
: Entity_Id
)
3805 Loc
: constant Source_Ptr
:= Sloc
(N
);
3806 Tdef
: constant Node_Id
:= Type_Definition
(N
);
3807 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
3808 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3809 Implicit_Base
: Entity_Id
;
3810 New_Indic
: Node_Id
;
3812 procedure Make_Implicit_Base
;
3813 -- If the parent subtype is constrained, the derived type is a
3814 -- subtype of an implicit base type derived from the parent base.
3816 ------------------------
3817 -- Make_Implicit_Base --
3818 ------------------------
3820 procedure Make_Implicit_Base
is
3823 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
3825 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
3826 Set_Etype
(Implicit_Base
, Parent_Base
);
3828 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
3829 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
3831 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
3832 end Make_Implicit_Base
;
3834 -- Start of processing for Build_Derived_Array_Type
3837 if not Is_Constrained
(Parent_Type
) then
3838 if Nkind
(Indic
) /= N_Subtype_Indication
then
3839 Set_Ekind
(Derived_Type
, E_Array_Type
);
3841 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
3842 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
3844 Set_Has_Delayed_Freeze
(Derived_Type
, True);
3848 Set_Etype
(Derived_Type
, Implicit_Base
);
3851 Make_Subtype_Declaration
(Loc
,
3852 Defining_Identifier
=> Derived_Type
,
3853 Subtype_Indication
=>
3854 Make_Subtype_Indication
(Loc
,
3855 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
3856 Constraint
=> Constraint
(Indic
)));
3858 Rewrite
(N
, New_Indic
);
3863 if Nkind
(Indic
) /= N_Subtype_Indication
then
3866 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
3867 Set_Etype
(Derived_Type
, Implicit_Base
);
3868 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
3871 Error_Msg_N
("illegal constraint on constrained type", Indic
);
3875 -- If parent type is not a derived type itself, and is declared in
3876 -- closed scope (e.g. a subprogram), then we must explicitly introduce
3877 -- the new type's concatenation operator since Derive_Subprograms
3878 -- will not inherit the parent's operator. If the parent type is
3879 -- unconstrained, the operator is of the unconstrained base type.
3881 if Number_Dimensions
(Parent_Type
) = 1
3882 and then not Is_Limited_Type
(Parent_Type
)
3883 and then not Is_Derived_Type
(Parent_Type
)
3884 and then not Is_Package_Or_Generic_Package
3885 (Scope
(Base_Type
(Parent_Type
)))
3887 if not Is_Constrained
(Parent_Type
)
3888 and then Is_Constrained
(Derived_Type
)
3890 New_Concatenation_Op
(Implicit_Base
);
3892 New_Concatenation_Op
(Derived_Type
);
3895 end Build_Derived_Array_Type
;
3897 -----------------------------------
3898 -- Build_Derived_Concurrent_Type --
3899 -----------------------------------
3901 procedure Build_Derived_Concurrent_Type
3903 Parent_Type
: Entity_Id
;
3904 Derived_Type
: Entity_Id
)
3906 D_Constraint
: Node_Id
;
3907 Disc_Spec
: Node_Id
;
3908 Old_Disc
: Entity_Id
;
3909 New_Disc
: Entity_Id
;
3911 Constraint_Present
: constant Boolean :=
3912 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3913 = N_Subtype_Indication
;
3916 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
3918 if Is_Task_Type
(Parent_Type
) then
3919 Set_Storage_Size_Variable
(Derived_Type
,
3920 Storage_Size_Variable
(Parent_Type
));
3923 if Present
(Discriminant_Specifications
(N
)) then
3924 New_Scope
(Derived_Type
);
3925 Check_Or_Process_Discriminants
(N
, Derived_Type
);
3928 elsif Constraint_Present
then
3930 -- Build constrained subtype and derive from it
3933 Loc
: constant Source_Ptr
:= Sloc
(N
);
3934 Anon
: constant Entity_Id
:=
3935 Make_Defining_Identifier
(Loc
,
3936 New_External_Name
(Chars
(Derived_Type
), 'T'));
3941 Make_Subtype_Declaration
(Loc
,
3942 Defining_Identifier
=> Anon
,
3943 Subtype_Indication
=>
3944 New_Copy_Tree
(Subtype_Indication
(Type_Definition
(N
))));
3945 Insert_Before
(N
, Decl
);
3946 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
3947 New_Occurrence_Of
(Anon
, Loc
));
3949 Set_Analyzed
(Derived_Type
, False);
3955 -- All attributes are inherited from parent. In particular,
3956 -- entries and the corresponding record type are the same.
3957 -- Discriminants may be renamed, and must be treated separately.
3959 Set_Has_Discriminants
3960 (Derived_Type
, Has_Discriminants
(Parent_Type
));
3961 Set_Corresponding_Record_Type
3962 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
3964 if Constraint_Present
then
3965 if not Has_Discriminants
(Parent_Type
) then
3966 Error_Msg_N
("untagged parent must have discriminants", N
);
3968 elsif Present
(Discriminant_Specifications
(N
)) then
3970 -- Verify that new discriminants are used to constrain old ones
3975 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
3977 Old_Disc
:= First_Discriminant
(Parent_Type
);
3978 New_Disc
:= First_Discriminant
(Derived_Type
);
3979 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
3980 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
3981 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
3984 Analyze
(Discriminant_Type
(Disc_Spec
));
3986 if not Subtypes_Statically_Compatible
(
3987 Etype
(Discriminant_Type
(Disc_Spec
)),
3991 ("not statically compatible with parent discriminant",
3992 Discriminant_Type
(Disc_Spec
));
3996 if Nkind
(D_Constraint
) = N_Identifier
3997 and then Chars
(D_Constraint
) /=
3998 Chars
(Defining_Identifier
(Disc_Spec
))
4000 Error_Msg_N
("new discriminants must constrain old ones",
4003 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
4006 Next_Discriminant
(Old_Disc
);
4007 Next_Discriminant
(New_Disc
);
4011 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
4012 Error_Msg_N
("discriminant mismatch in derivation", N
);
4017 elsif Present
(Discriminant_Specifications
(N
)) then
4019 ("missing discriminant constraint in untagged derivation",
4023 if Present
(Discriminant_Specifications
(N
)) then
4024 Old_Disc
:= First_Discriminant
(Parent_Type
);
4025 while Present
(Old_Disc
) loop
4027 if No
(Next_Entity
(Old_Disc
))
4028 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
4030 Set_Next_Entity
(Last_Entity
(Derived_Type
),
4031 Next_Entity
(Old_Disc
));
4035 Next_Discriminant
(Old_Disc
);
4039 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
4040 if Has_Discriminants
(Parent_Type
) then
4041 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4042 Set_Discriminant_Constraint
(
4043 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
4047 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
4049 Set_Has_Completion
(Derived_Type
);
4050 end Build_Derived_Concurrent_Type
;
4052 ------------------------------------
4053 -- Build_Derived_Enumeration_Type --
4054 ------------------------------------
4056 procedure Build_Derived_Enumeration_Type
4058 Parent_Type
: Entity_Id
;
4059 Derived_Type
: Entity_Id
)
4061 Loc
: constant Source_Ptr
:= Sloc
(N
);
4062 Def
: constant Node_Id
:= Type_Definition
(N
);
4063 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
4064 Implicit_Base
: Entity_Id
;
4065 Literal
: Entity_Id
;
4066 New_Lit
: Entity_Id
;
4067 Literals_List
: List_Id
;
4068 Type_Decl
: Node_Id
;
4070 Rang_Expr
: Node_Id
;
4073 -- Since types Standard.Character and Standard.Wide_Character do
4074 -- not have explicit literals lists we need to process types derived
4075 -- from them specially. This is handled by Derived_Standard_Character.
4076 -- If the parent type is a generic type, there are no literals either,
4077 -- and we construct the same skeletal representation as for the generic
4080 if Root_Type
(Parent_Type
) = Standard_Character
4081 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
4082 or else Root_Type
(Parent_Type
) = Standard_Wide_Wide_Character
4084 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
4086 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
4093 Make_Attribute_Reference
(Loc
,
4094 Attribute_Name
=> Name_First
,
4095 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4096 Set_Etype
(Lo
, Derived_Type
);
4099 Make_Attribute_Reference
(Loc
,
4100 Attribute_Name
=> Name_Last
,
4101 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4102 Set_Etype
(Hi
, Derived_Type
);
4104 Set_Scalar_Range
(Derived_Type
,
4111 -- If a constraint is present, analyze the bounds to catch
4112 -- premature usage of the derived literals.
4114 if Nkind
(Indic
) = N_Subtype_Indication
4115 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
4117 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
4118 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
4121 -- Introduce an implicit base type for the derived type even
4122 -- if there is no constraint attached to it, since this seems
4123 -- closer to the Ada semantics. Build a full type declaration
4124 -- tree for the derived type using the implicit base type as
4125 -- the defining identifier. The build a subtype declaration
4126 -- tree which applies the constraint (if any) have it replace
4127 -- the derived type declaration.
4129 Literal
:= First_Literal
(Parent_Type
);
4130 Literals_List
:= New_List
;
4131 while Present
(Literal
)
4132 and then Ekind
(Literal
) = E_Enumeration_Literal
4134 -- Literals of the derived type have the same representation as
4135 -- those of the parent type, but this representation can be
4136 -- overridden by an explicit representation clause. Indicate
4137 -- that there is no explicit representation given yet. These
4138 -- derived literals are implicit operations of the new type,
4139 -- and can be overridden by explicit ones.
4141 if Nkind
(Literal
) = N_Defining_Character_Literal
then
4143 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
4145 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
4148 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
4149 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
4150 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
4151 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
4152 Set_Alias
(New_Lit
, Literal
);
4153 Set_Is_Known_Valid
(New_Lit
, True);
4155 Append
(New_Lit
, Literals_List
);
4156 Next_Literal
(Literal
);
4160 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4161 New_External_Name
(Chars
(Derived_Type
), 'B'));
4163 -- Indicate the proper nature of the derived type. This must
4164 -- be done before analysis of the literals, to recognize cases
4165 -- when a literal may be hidden by a previous explicit function
4166 -- definition (cf. c83031a).
4168 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
4169 Set_Etype
(Derived_Type
, Implicit_Base
);
4172 Make_Full_Type_Declaration
(Loc
,
4173 Defining_Identifier
=> Implicit_Base
,
4174 Discriminant_Specifications
=> No_List
,
4176 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
4178 Mark_Rewrite_Insertion
(Type_Decl
);
4179 Insert_Before
(N
, Type_Decl
);
4180 Analyze
(Type_Decl
);
4182 -- After the implicit base is analyzed its Etype needs to be changed
4183 -- to reflect the fact that it is derived from the parent type which
4184 -- was ignored during analysis. We also set the size at this point.
4186 Set_Etype
(Implicit_Base
, Parent_Type
);
4188 Set_Size_Info
(Implicit_Base
, Parent_Type
);
4189 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
4190 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
4192 Set_Has_Non_Standard_Rep
4193 (Implicit_Base
, Has_Non_Standard_Rep
4195 Set_Has_Delayed_Freeze
(Implicit_Base
);
4197 -- Process the subtype indication including a validation check
4198 -- on the constraint, if any. If a constraint is given, its bounds
4199 -- must be implicitly converted to the new type.
4201 if Nkind
(Indic
) = N_Subtype_Indication
then
4203 R
: constant Node_Id
:=
4204 Range_Expression
(Constraint
(Indic
));
4207 if Nkind
(R
) = N_Range
then
4208 Hi
:= Build_Scalar_Bound
4209 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
4210 Lo
:= Build_Scalar_Bound
4211 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
4214 -- Constraint is a Range attribute. Replace with the
4215 -- explicit mention of the bounds of the prefix, which must
4218 Analyze
(Prefix
(R
));
4220 Convert_To
(Implicit_Base
,
4221 Make_Attribute_Reference
(Loc
,
4222 Attribute_Name
=> Name_Last
,
4224 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4227 Convert_To
(Implicit_Base
,
4228 Make_Attribute_Reference
(Loc
,
4229 Attribute_Name
=> Name_First
,
4231 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4238 (Type_High_Bound
(Parent_Type
),
4239 Parent_Type
, Implicit_Base
);
4242 (Type_Low_Bound
(Parent_Type
),
4243 Parent_Type
, Implicit_Base
);
4251 -- If we constructed a default range for the case where no range
4252 -- was given, then the expressions in the range must not freeze
4253 -- since they do not correspond to expressions in the source.
4255 if Nkind
(Indic
) /= N_Subtype_Indication
then
4256 Set_Must_Not_Freeze
(Lo
);
4257 Set_Must_Not_Freeze
(Hi
);
4258 Set_Must_Not_Freeze
(Rang_Expr
);
4262 Make_Subtype_Declaration
(Loc
,
4263 Defining_Identifier
=> Derived_Type
,
4264 Subtype_Indication
=>
4265 Make_Subtype_Indication
(Loc
,
4266 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
4268 Make_Range_Constraint
(Loc
,
4269 Range_Expression
=> Rang_Expr
))));
4273 -- If pragma Discard_Names applies on the first subtype of the
4274 -- parent type, then it must be applied on this subtype as well.
4276 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
4277 Set_Discard_Names
(Derived_Type
);
4280 -- Apply a range check. Since this range expression doesn't have an
4281 -- Etype, we have to specifically pass the Source_Typ parameter. Is
4284 if Nkind
(Indic
) = N_Subtype_Indication
then
4285 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
4287 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
4290 end Build_Derived_Enumeration_Type
;
4292 --------------------------------
4293 -- Build_Derived_Numeric_Type --
4294 --------------------------------
4296 procedure Build_Derived_Numeric_Type
4298 Parent_Type
: Entity_Id
;
4299 Derived_Type
: Entity_Id
)
4301 Loc
: constant Source_Ptr
:= Sloc
(N
);
4302 Tdef
: constant Node_Id
:= Type_Definition
(N
);
4303 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
4304 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4305 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
4306 N_Subtype_Indication
;
4307 Implicit_Base
: Entity_Id
;
4313 -- Process the subtype indication including a validation check on
4314 -- the constraint if any.
4316 Discard_Node
(Process_Subtype
(Indic
, N
));
4318 -- Introduce an implicit base type for the derived type even if there
4319 -- is no constraint attached to it, since this seems closer to the Ada
4323 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
4325 Set_Etype
(Implicit_Base
, Parent_Base
);
4326 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
4327 Set_Size_Info
(Implicit_Base
, Parent_Base
);
4328 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4329 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
4330 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
4332 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
4333 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4336 Set_Has_Delayed_Freeze
(Implicit_Base
);
4338 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
4339 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
4341 Set_Scalar_Range
(Implicit_Base
,
4346 if Has_Infinities
(Parent_Base
) then
4347 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
4350 -- The Derived_Type, which is the entity of the declaration, is a
4351 -- subtype of the implicit base. Its Ekind is a subtype, even in the
4352 -- absence of an explicit constraint.
4354 Set_Etype
(Derived_Type
, Implicit_Base
);
4356 -- If we did not have a constraint, then the Ekind is set from the
4357 -- parent type (otherwise Process_Subtype has set the bounds)
4359 if No_Constraint
then
4360 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
4363 -- If we did not have a range constraint, then set the range from the
4364 -- parent type. Otherwise, the call to Process_Subtype has set the
4368 or else not Has_Range_Constraint
(Indic
)
4370 Set_Scalar_Range
(Derived_Type
,
4372 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
4373 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
4374 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4376 if Has_Infinities
(Parent_Type
) then
4377 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
4381 -- Set remaining type-specific fields, depending on numeric type
4383 if Is_Modular_Integer_Type
(Parent_Type
) then
4384 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
4386 Set_Non_Binary_Modulus
4387 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
4389 elsif Is_Floating_Point_Type
(Parent_Type
) then
4391 -- Digits of base type is always copied from the digits value of
4392 -- the parent base type, but the digits of the derived type will
4393 -- already have been set if there was a constraint present.
4395 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4396 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
4398 if No_Constraint
then
4399 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
4402 elsif Is_Fixed_Point_Type
(Parent_Type
) then
4404 -- Small of base type and derived type are always copied from the
4405 -- parent base type, since smalls never change. The delta of the
4406 -- base type is also copied from the parent base type. However the
4407 -- delta of the derived type will have been set already if a
4408 -- constraint was present.
4410 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
4411 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
4412 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
4414 if No_Constraint
then
4415 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
4418 -- The scale and machine radix in the decimal case are always
4419 -- copied from the parent base type.
4421 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
4422 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
4423 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
4425 Set_Machine_Radix_10
4426 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
4427 Set_Machine_Radix_10
4428 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
4430 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4432 if No_Constraint
then
4433 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
4436 -- the analysis of the subtype_indication sets the
4437 -- digits value of the derived type.
4444 -- The type of the bounds is that of the parent type, and they
4445 -- must be converted to the derived type.
4447 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
4449 -- The implicit_base should be frozen when the derived type is frozen,
4450 -- but note that it is used in the conversions of the bounds. For fixed
4451 -- types we delay the determination of the bounds until the proper
4452 -- freezing point. For other numeric types this is rejected by GCC, for
4453 -- reasons that are currently unclear (???), so we choose to freeze the
4454 -- implicit base now. In the case of integers and floating point types
4455 -- this is harmless because subsequent representation clauses cannot
4456 -- affect anything, but it is still baffling that we cannot use the
4457 -- same mechanism for all derived numeric types.
4459 if Is_Fixed_Point_Type
(Parent_Type
) then
4460 Conditional_Delay
(Implicit_Base
, Parent_Type
);
4462 Freeze_Before
(N
, Implicit_Base
);
4464 end Build_Derived_Numeric_Type
;
4466 --------------------------------
4467 -- Build_Derived_Private_Type --
4468 --------------------------------
4470 procedure Build_Derived_Private_Type
4472 Parent_Type
: Entity_Id
;
4473 Derived_Type
: Entity_Id
;
4474 Is_Completion
: Boolean;
4475 Derive_Subps
: Boolean := True)
4477 Der_Base
: Entity_Id
;
4479 Full_Decl
: Node_Id
:= Empty
;
4480 Full_Der
: Entity_Id
;
4482 Last_Discr
: Entity_Id
;
4483 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
4484 Swapped
: Boolean := False;
4486 procedure Copy_And_Build
;
4487 -- Copy derived type declaration, replace parent with its full view,
4488 -- and analyze new declaration.
4490 --------------------
4491 -- Copy_And_Build --
4492 --------------------
4494 procedure Copy_And_Build
is
4498 if Ekind
(Parent_Type
) in Record_Kind
4500 (Ekind
(Parent_Type
) in Enumeration_Kind
4501 and then Root_Type
(Parent_Type
) /= Standard_Character
4502 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
4503 and then Root_Type
(Parent_Type
) /= Standard_Wide_Wide_Character
4504 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
4506 Full_N
:= New_Copy_Tree
(N
);
4507 Insert_After
(N
, Full_N
);
4508 Build_Derived_Type
(
4509 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4512 Build_Derived_Type
(
4513 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4517 -- Start of processing for Build_Derived_Private_Type
4520 if Is_Tagged_Type
(Parent_Type
) then
4521 Build_Derived_Record_Type
4522 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4525 elsif Has_Discriminants
(Parent_Type
) then
4526 if Present
(Full_View
(Parent_Type
)) then
4527 if not Is_Completion
then
4529 -- Copy declaration for subsequent analysis, to provide a
4530 -- completion for what is a private declaration. Indicate that
4531 -- the full type is internally generated.
4533 Full_Decl
:= New_Copy_Tree
(N
);
4534 Full_Der
:= New_Copy
(Derived_Type
);
4535 Set_Comes_From_Source
(Full_Decl
, False);
4536 Set_Comes_From_Source
(Full_Der
, False);
4538 Insert_After
(N
, Full_Decl
);
4541 -- If this is a completion, the full view being built is
4542 -- itself private. We build a subtype of the parent with
4543 -- the same constraints as this full view, to convey to the
4544 -- back end the constrained components and the size of this
4545 -- subtype. If the parent is constrained, its full view can
4546 -- serve as the underlying full view of the derived type.
4548 if No
(Discriminant_Specifications
(N
)) then
4549 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4550 N_Subtype_Indication
4552 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
4554 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
4555 Set_Underlying_Full_View
(Derived_Type
,
4556 Full_View
(Parent_Type
));
4560 -- If there are new discriminants, the parent subtype is
4561 -- constrained by them, but it is not clear how to build
4562 -- the underlying_full_view in this case ???
4569 -- Build partial view of derived type from partial view of parent
4571 Build_Derived_Record_Type
4572 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4574 if Present
(Full_View
(Parent_Type
))
4575 and then not Is_Completion
4577 if not In_Open_Scopes
(Par_Scope
)
4578 or else not In_Same_Source_Unit
(N
, Parent_Type
)
4580 -- Swap partial and full views temporarily
4582 Install_Private_Declarations
(Par_Scope
);
4583 Install_Visible_Declarations
(Par_Scope
);
4587 -- Build full view of derived type from full view of parent which
4588 -- is now installed. Subprograms have been derived on the partial
4589 -- view, the completion does not derive them anew.
4591 if not Is_Tagged_Type
(Parent_Type
) then
4593 -- If the parent is itself derived from another private type,
4594 -- installing the private declarations has not affected its
4595 -- privacy status, so use its own full view explicitly.
4597 if Is_Private_Type
(Parent_Type
) then
4598 Build_Derived_Record_Type
4599 (Full_Decl
, Full_View
(Parent_Type
), Full_Der
, False);
4601 Build_Derived_Record_Type
4602 (Full_Decl
, Parent_Type
, Full_Der
, False);
4606 -- If full view of parent is tagged, the completion
4607 -- inherits the proper primitive operations.
4609 Set_Defining_Identifier
(Full_Decl
, Full_Der
);
4610 Build_Derived_Record_Type
4611 (Full_Decl
, Parent_Type
, Full_Der
, Derive_Subps
);
4612 Set_Analyzed
(Full_Decl
);
4616 Uninstall_Declarations
(Par_Scope
);
4618 if In_Open_Scopes
(Par_Scope
) then
4619 Install_Visible_Declarations
(Par_Scope
);
4623 Der_Base
:= Base_Type
(Derived_Type
);
4624 Set_Full_View
(Derived_Type
, Full_Der
);
4625 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
4627 -- Copy the discriminant list from full view to the partial views
4628 -- (base type and its subtype). Gigi requires that the partial
4629 -- and full views have the same discriminants.
4631 -- Note that since the partial view is pointing to discriminants
4632 -- in the full view, their scope will be that of the full view.
4633 -- This might cause some front end problems and need
4636 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
4637 Set_First_Entity
(Der_Base
, Discr
);
4640 Last_Discr
:= Discr
;
4641 Next_Discriminant
(Discr
);
4642 exit when No
(Discr
);
4645 Set_Last_Entity
(Der_Base
, Last_Discr
);
4647 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
4648 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
4649 Set_Stored_Constraint
(Full_Der
, Stored_Constraint
(Derived_Type
));
4652 -- If this is a completion, the derived type stays private
4653 -- and there is no need to create a further full view, except
4654 -- in the unusual case when the derivation is nested within a
4655 -- child unit, see below.
4660 elsif Present
(Full_View
(Parent_Type
))
4661 and then Has_Discriminants
(Full_View
(Parent_Type
))
4663 if Has_Unknown_Discriminants
(Parent_Type
)
4664 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4665 = N_Subtype_Indication
4668 ("cannot constrain type with unknown discriminants",
4669 Subtype_Indication
(Type_Definition
(N
)));
4673 -- If full view of parent is a record type, Build full view as
4674 -- a derivation from the parent's full view. Partial view remains
4675 -- private. For code generation and linking, the full view must
4676 -- have the same public status as the partial one. This full view
4677 -- is only needed if the parent type is in an enclosing scope, so
4678 -- that the full view may actually become visible, e.g. in a child
4679 -- unit. This is both more efficient, and avoids order of freezing
4680 -- problems with the added entities.
4682 if not Is_Private_Type
(Full_View
(Parent_Type
))
4683 and then (In_Open_Scopes
(Scope
(Parent_Type
)))
4685 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
4686 Chars
(Derived_Type
));
4687 Set_Is_Itype
(Full_Der
);
4688 Set_Has_Private_Declaration
(Full_Der
);
4689 Set_Has_Private_Declaration
(Derived_Type
);
4690 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4691 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4692 Set_Full_View
(Derived_Type
, Full_Der
);
4693 Set_Is_Public
(Full_Der
, Is_Public
(Derived_Type
));
4694 Full_P
:= Full_View
(Parent_Type
);
4695 Exchange_Declarations
(Parent_Type
);
4697 Exchange_Declarations
(Full_P
);
4700 Build_Derived_Record_Type
4701 (N
, Full_View
(Parent_Type
), Derived_Type
,
4702 Derive_Subps
=> False);
4705 -- In any case, the primitive operations are inherited from
4706 -- the parent type, not from the internal full view.
4708 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
4710 if Derive_Subps
then
4711 Derive_Subprograms
(Parent_Type
, Derived_Type
);
4715 -- Untagged type, No discriminants on either view
4717 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4718 N_Subtype_Indication
4721 ("illegal constraint on type without discriminants", N
);
4724 if Present
(Discriminant_Specifications
(N
))
4725 and then Present
(Full_View
(Parent_Type
))
4726 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4729 ("cannot add discriminants to untagged type", N
);
4732 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
4733 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4734 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
4735 Set_Has_Controlled_Component
4736 (Derived_Type
, Has_Controlled_Component
4739 -- Direct controlled types do not inherit Finalize_Storage_Only flag
4741 if not Is_Controlled
(Parent_Type
) then
4742 Set_Finalize_Storage_Only
4743 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
4746 -- Construct the implicit full view by deriving from full view of
4747 -- the parent type. In order to get proper visibility, we install
4748 -- the parent scope and its declarations.
4750 -- ??? if the parent is untagged private and its completion is
4751 -- tagged, this mechanism will not work because we cannot derive
4752 -- from the tagged full view unless we have an extension
4754 if Present
(Full_View
(Parent_Type
))
4755 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4756 and then not Is_Completion
4759 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4760 Chars
=> Chars
(Derived_Type
));
4761 Set_Is_Itype
(Full_Der
);
4762 Set_Has_Private_Declaration
(Full_Der
);
4763 Set_Has_Private_Declaration
(Derived_Type
);
4764 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4765 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4766 Set_Full_View
(Derived_Type
, Full_Der
);
4768 if not In_Open_Scopes
(Par_Scope
) then
4769 Install_Private_Declarations
(Par_Scope
);
4770 Install_Visible_Declarations
(Par_Scope
);
4772 Uninstall_Declarations
(Par_Scope
);
4774 -- If parent scope is open and in another unit, and parent has a
4775 -- completion, then the derivation is taking place in the visible
4776 -- part of a child unit. In that case retrieve the full view of
4777 -- the parent momentarily.
4779 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
4780 Full_P
:= Full_View
(Parent_Type
);
4781 Exchange_Declarations
(Parent_Type
);
4783 Exchange_Declarations
(Full_P
);
4785 -- Otherwise it is a local derivation
4791 Set_Scope
(Full_Der
, Current_Scope
);
4792 Set_Is_First_Subtype
(Full_Der
,
4793 Is_First_Subtype
(Derived_Type
));
4794 Set_Has_Size_Clause
(Full_Der
, False);
4795 Set_Has_Alignment_Clause
(Full_Der
, False);
4796 Set_Next_Entity
(Full_Der
, Empty
);
4797 Set_Has_Delayed_Freeze
(Full_Der
);
4798 Set_Is_Frozen
(Full_Der
, False);
4799 Set_Freeze_Node
(Full_Der
, Empty
);
4800 Set_Depends_On_Private
(Full_Der
,
4801 Has_Private_Component
(Full_Der
));
4802 Set_Public_Status
(Full_Der
);
4806 Set_Has_Unknown_Discriminants
(Derived_Type
,
4807 Has_Unknown_Discriminants
(Parent_Type
));
4809 if Is_Private_Type
(Derived_Type
) then
4810 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
4813 if Is_Private_Type
(Parent_Type
)
4814 and then Base_Type
(Parent_Type
) = Parent_Type
4815 and then In_Open_Scopes
(Scope
(Parent_Type
))
4817 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
4819 if Is_Child_Unit
(Scope
(Current_Scope
))
4820 and then Is_Completion
4821 and then In_Private_Part
(Current_Scope
)
4822 and then Scope
(Parent_Type
) /= Current_Scope
4824 -- This is the unusual case where a type completed by a private
4825 -- derivation occurs within a package nested in a child unit,
4826 -- and the parent is declared in an ancestor. In this case, the
4827 -- full view of the parent type will become visible in the body
4828 -- of the enclosing child, and only then will the current type
4829 -- be possibly non-private. We build a underlying full view that
4830 -- will be installed when the enclosing child body is compiled.
4833 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
4837 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4838 Chars
(Derived_Type
));
4839 Set_Is_Itype
(Full_Der
);
4840 Set_Itype
(IR
, Full_Der
);
4841 Insert_After
(N
, IR
);
4843 -- The full view will be used to swap entities on entry/exit
4844 -- to the body, and must appear in the entity list for the
4847 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
4848 Set_Has_Private_Declaration
(Full_Der
);
4849 Set_Has_Private_Declaration
(Derived_Type
);
4850 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4851 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4852 Full_P
:= Full_View
(Parent_Type
);
4853 Exchange_Declarations
(Parent_Type
);
4855 Exchange_Declarations
(Full_P
);
4856 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
4860 end Build_Derived_Private_Type
;
4862 -------------------------------
4863 -- Build_Derived_Record_Type --
4864 -------------------------------
4868 -- Ideally we would like to use the same model of type derivation for
4869 -- tagged and untagged record types. Unfortunately this is not quite
4870 -- possible because the semantics of representation clauses is different
4871 -- for tagged and untagged records under inheritance. Consider the
4874 -- type R (...) is [tagged] record ... end record;
4875 -- type T (...) is new R (...) [with ...];
4877 -- The representation clauses of T can specify a completely different
4878 -- record layout from R's. Hence the same component can be placed in
4879 -- two very different positions in objects of type T and R. If R and T
4880 -- are tagged types, representation clauses for T can only specify the
4881 -- layout of non inherited components, thus components that are common
4882 -- in R and T have the same position in objects of type R and T.
4884 -- This has two implications. The first is that the entire tree for R's
4885 -- declaration needs to be copied for T in the untagged case, so that T
4886 -- can be viewed as a record type of its own with its own representation
4887 -- clauses. The second implication is the way we handle discriminants.
4888 -- Specifically, in the untagged case we need a way to communicate to Gigi
4889 -- what are the real discriminants in the record, while for the semantics
4890 -- we need to consider those introduced by the user to rename the
4891 -- discriminants in the parent type. This is handled by introducing the
4892 -- notion of stored discriminants. See below for more.
4894 -- Fortunately the way regular components are inherited can be handled in
4895 -- the same way in tagged and untagged types.
4897 -- To complicate things a bit more the private view of a private extension
4898 -- cannot be handled in the same way as the full view (for one thing the
4899 -- semantic rules are somewhat different). We will explain what differs
4902 -- 2. DISCRIMINANTS UNDER INHERITANCE
4904 -- The semantic rules governing the discriminants of derived types are
4907 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
4908 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
4910 -- If parent type has discriminants, then the discriminants that are
4911 -- declared in the derived type are [3.4 (11)]:
4913 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
4916 -- o Otherwise, each discriminant of the parent type (implicitly declared
4917 -- in the same order with the same specifications). In this case, the
4918 -- discriminants are said to be "inherited", or if unknown in the parent
4919 -- are also unknown in the derived type.
4921 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
4923 -- o The parent subtype shall be constrained;
4925 -- o If the parent type is not a tagged type, then each discriminant of
4926 -- the derived type shall be used in the constraint defining a parent
4927 -- subtype [Implementation note: this ensures that the new discriminant
4928 -- can share storage with an existing discriminant.].
4930 -- For the derived type each discriminant of the parent type is either
4931 -- inherited, constrained to equal some new discriminant of the derived
4932 -- type, or constrained to the value of an expression.
4934 -- When inherited or constrained to equal some new discriminant, the
4935 -- parent discriminant and the discriminant of the derived type are said
4938 -- If a discriminant of the parent type is constrained to a specific value
4939 -- in the derived type definition, then the discriminant is said to be
4940 -- "specified" by that derived type definition.
4942 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
4944 -- We have spoken about stored discriminants in point 1 (introduction)
4945 -- above. There are two sort of stored discriminants: implicit and
4946 -- explicit. As long as the derived type inherits the same discriminants as
4947 -- the root record type, stored discriminants are the same as regular
4948 -- discriminants, and are said to be implicit. However, if any discriminant
4949 -- in the root type was renamed in the derived type, then the derived
4950 -- type will contain explicit stored discriminants. Explicit stored
4951 -- discriminants are discriminants in addition to the semantically visible
4952 -- discriminants defined for the derived type. Stored discriminants are
4953 -- used by Gigi to figure out what are the physical discriminants in
4954 -- objects of the derived type (see precise definition in einfo.ads).
4955 -- As an example, consider the following:
4957 -- type R (D1, D2, D3 : Int) is record ... end record;
4958 -- type T1 is new R;
4959 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
4960 -- type T3 is new T2;
4961 -- type T4 (Y : Int) is new T3 (Y, 99);
4963 -- The following table summarizes the discriminants and stored
4964 -- discriminants in R and T1 through T4.
4966 -- Type Discrim Stored Discrim Comment
4967 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
4968 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
4969 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
4970 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
4971 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
4973 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
4974 -- find the corresponding discriminant in the parent type, while
4975 -- Original_Record_Component (abbreviated ORC below), the actual physical
4976 -- component that is renamed. Finally the field Is_Completely_Hidden
4977 -- (abbreviated ICH below) is set for all explicit stored discriminants
4978 -- (see einfo.ads for more info). For the above example this gives:
4980 -- Discrim CD ORC ICH
4981 -- ^^^^^^^ ^^ ^^^ ^^^
4982 -- D1 in R empty itself no
4983 -- D2 in R empty itself no
4984 -- D3 in R empty itself no
4986 -- D1 in T1 D1 in R itself no
4987 -- D2 in T1 D2 in R itself no
4988 -- D3 in T1 D3 in R itself no
4990 -- X1 in T2 D3 in T1 D3 in T2 no
4991 -- X2 in T2 D1 in T1 D1 in T2 no
4992 -- D1 in T2 empty itself yes
4993 -- D2 in T2 empty itself yes
4994 -- D3 in T2 empty itself yes
4996 -- X1 in T3 X1 in T2 D3 in T3 no
4997 -- X2 in T3 X2 in T2 D1 in T3 no
4998 -- D1 in T3 empty itself yes
4999 -- D2 in T3 empty itself yes
5000 -- D3 in T3 empty itself yes
5002 -- Y in T4 X1 in T3 D3 in T3 no
5003 -- D1 in T3 empty itself yes
5004 -- D2 in T3 empty itself yes
5005 -- D3 in T3 empty itself yes
5007 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
5009 -- Type derivation for tagged types is fairly straightforward. if no
5010 -- discriminants are specified by the derived type, these are inherited
5011 -- from the parent. No explicit stored discriminants are ever necessary.
5012 -- The only manipulation that is done to the tree is that of adding a
5013 -- _parent field with parent type and constrained to the same constraint
5014 -- specified for the parent in the derived type definition. For instance:
5016 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
5017 -- type T1 is new R with null record;
5018 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
5020 -- are changed into:
5022 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
5023 -- _parent : R (D1, D2, D3);
5026 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
5027 -- _parent : T1 (X2, 88, X1);
5030 -- The discriminants actually present in R, T1 and T2 as well as their CD,
5031 -- ORC and ICH fields are:
5033 -- Discrim CD ORC ICH
5034 -- ^^^^^^^ ^^ ^^^ ^^^
5035 -- D1 in R empty itself no
5036 -- D2 in R empty itself no
5037 -- D3 in R empty itself no
5039 -- D1 in T1 D1 in R D1 in R no
5040 -- D2 in T1 D2 in R D2 in R no
5041 -- D3 in T1 D3 in R D3 in R no
5043 -- X1 in T2 D3 in T1 D3 in R no
5044 -- X2 in T2 D1 in T1 D1 in R no
5046 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
5048 -- Regardless of whether we dealing with a tagged or untagged type
5049 -- we will transform all derived type declarations of the form
5051 -- type T is new R (...) [with ...];
5053 -- subtype S is R (...);
5054 -- type T is new S [with ...];
5056 -- type BT is new R [with ...];
5057 -- subtype T is BT (...);
5059 -- That is, the base derived type is constrained only if it has no
5060 -- discriminants. The reason for doing this is that GNAT's semantic model
5061 -- assumes that a base type with discriminants is unconstrained.
5063 -- Note that, strictly speaking, the above transformation is not always
5064 -- correct. Consider for instance the following excerpt from ACVC b34011a:
5066 -- procedure B34011A is
5067 -- type REC (D : integer := 0) is record
5072 -- type T6 is new Rec;
5073 -- function F return T6;
5078 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
5081 -- The definition of Q6.U is illegal. However transforming Q6.U into
5083 -- type BaseU is new T6;
5084 -- subtype U is BaseU (Q6.F.I)
5086 -- turns U into a legal subtype, which is incorrect. To avoid this problem
5087 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
5088 -- the transformation described above.
5090 -- There is another instance where the above transformation is incorrect.
5094 -- type Base (D : Integer) is tagged null record;
5095 -- procedure P (X : Base);
5097 -- type Der is new Base (2) with null record;
5098 -- procedure P (X : Der);
5101 -- Then the above transformation turns this into
5103 -- type Der_Base is new Base with null record;
5104 -- -- procedure P (X : Base) is implicitly inherited here
5105 -- -- as procedure P (X : Der_Base).
5107 -- subtype Der is Der_Base (2);
5108 -- procedure P (X : Der);
5109 -- -- The overriding of P (X : Der_Base) is illegal since we
5110 -- -- have a parameter conformance problem.
5112 -- To get around this problem, after having semantically processed Der_Base
5113 -- and the rewritten subtype declaration for Der, we copy Der_Base field
5114 -- Discriminant_Constraint from Der so that when parameter conformance is
5115 -- checked when P is overridden, no semantic errors are flagged.
5117 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
5119 -- Regardless of whether we are dealing with a tagged or untagged type
5120 -- we will transform all derived type declarations of the form
5122 -- type R (D1, .., Dn : ...) is [tagged] record ...;
5123 -- type T is new R [with ...];
5125 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
5127 -- The reason for such transformation is that it allows us to implement a
5128 -- very clean form of component inheritance as explained below.
5130 -- Note that this transformation is not achieved by direct tree rewriting
5131 -- and manipulation, but rather by redoing the semantic actions that the
5132 -- above transformation will entail. This is done directly in routine
5133 -- Inherit_Components.
5135 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
5137 -- In both tagged and untagged derived types, regular non discriminant
5138 -- components are inherited in the derived type from the parent type. In
5139 -- the absence of discriminants component, inheritance is straightforward
5140 -- as components can simply be copied from the parent.
5142 -- If the parent has discriminants, inheriting components constrained with
5143 -- these discriminants requires caution. Consider the following example:
5145 -- type R (D1, D2 : Positive) is [tagged] record
5146 -- S : String (D1 .. D2);
5149 -- type T1 is new R [with null record];
5150 -- type T2 (X : positive) is new R (1, X) [with null record];
5152 -- As explained in 6. above, T1 is rewritten as
5153 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
5154 -- which makes the treatment for T1 and T2 identical.
5156 -- What we want when inheriting S, is that references to D1 and D2 in R are
5157 -- replaced with references to their correct constraints, ie D1 and D2 in
5158 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
5159 -- with either discriminant references in the derived type or expressions.
5160 -- This replacement is achieved as follows: before inheriting R's
5161 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
5162 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
5163 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
5164 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
5165 -- by String (1 .. X).
5167 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
5169 -- We explain here the rules governing private type extensions relevant to
5170 -- type derivation. These rules are explained on the following example:
5172 -- type D [(...)] is new A [(...)] with private; <-- partial view
5173 -- type D [(...)] is new P [(...)] with null record; <-- full view
5175 -- Type A is called the ancestor subtype of the private extension.
5176 -- Type P is the parent type of the full view of the private extension. It
5177 -- must be A or a type derived from A.
5179 -- The rules concerning the discriminants of private type extensions are
5182 -- o If a private extension inherits known discriminants from the ancestor
5183 -- subtype, then the full view shall also inherit its discriminants from
5184 -- the ancestor subtype and the parent subtype of the full view shall be
5185 -- constrained if and only if the ancestor subtype is constrained.
5187 -- o If a partial view has unknown discriminants, then the full view may
5188 -- define a definite or an indefinite subtype, with or without
5191 -- o If a partial view has neither known nor unknown discriminants, then
5192 -- the full view shall define a definite subtype.
5194 -- o If the ancestor subtype of a private extension has constrained
5195 -- discriminants, then the parent subtype of the full view shall impose a
5196 -- statically matching constraint on those discriminants.
5198 -- This means that only the following forms of private extensions are
5201 -- type D is new A with private; <-- partial view
5202 -- type D is new P with null record; <-- full view
5204 -- If A has no discriminants than P has no discriminants, otherwise P must
5205 -- inherit A's discriminants.
5207 -- type D is new A (...) with private; <-- partial view
5208 -- type D is new P (:::) with null record; <-- full view
5210 -- P must inherit A's discriminants and (...) and (:::) must statically
5213 -- subtype A is R (...);
5214 -- type D is new A with private; <-- partial view
5215 -- type D is new P with null record; <-- full view
5217 -- P must have inherited R's discriminants and must be derived from A or
5218 -- any of its subtypes.
5220 -- type D (..) is new A with private; <-- partial view
5221 -- type D (..) is new P [(:::)] with null record; <-- full view
5223 -- No specific constraints on P's discriminants or constraint (:::).
5224 -- Note that A can be unconstrained, but the parent subtype P must either
5225 -- be constrained or (:::) must be present.
5227 -- type D (..) is new A [(...)] with private; <-- partial view
5228 -- type D (..) is new P [(:::)] with null record; <-- full view
5230 -- P's constraints on A's discriminants must statically match those
5231 -- imposed by (...).
5233 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
5235 -- The full view of a private extension is handled exactly as described
5236 -- above. The model chose for the private view of a private extension is
5237 -- the same for what concerns discriminants (ie they receive the same
5238 -- treatment as in the tagged case). However, the private view of the
5239 -- private extension always inherits the components of the parent base,
5240 -- without replacing any discriminant reference. Strictly speaking this is
5241 -- incorrect. However, Gigi never uses this view to generate code so this
5242 -- is a purely semantic issue. In theory, a set of transformations similar
5243 -- to those given in 5. and 6. above could be applied to private views of
5244 -- private extensions to have the same model of component inheritance as
5245 -- for non private extensions. However, this is not done because it would
5246 -- further complicate private type processing. Semantically speaking, this
5247 -- leaves us in an uncomfortable situation. As an example consider:
5250 -- type R (D : integer) is tagged record
5251 -- S : String (1 .. D);
5253 -- procedure P (X : R);
5254 -- type T is new R (1) with private;
5256 -- type T is new R (1) with null record;
5259 -- This is transformed into:
5262 -- type R (D : integer) is tagged record
5263 -- S : String (1 .. D);
5265 -- procedure P (X : R);
5266 -- type T is new R (1) with private;
5268 -- type BaseT is new R with null record;
5269 -- subtype T is BaseT (1);
5272 -- (strictly speaking the above is incorrect Ada)
5274 -- From the semantic standpoint the private view of private extension T
5275 -- should be flagged as constrained since one can clearly have
5279 -- in a unit withing Pack. However, when deriving subprograms for the
5280 -- private view of private extension T, T must be seen as unconstrained
5281 -- since T has discriminants (this is a constraint of the current
5282 -- subprogram derivation model). Thus, when processing the private view of
5283 -- a private extension such as T, we first mark T as unconstrained, we
5284 -- process it, we perform program derivation and just before returning from
5285 -- Build_Derived_Record_Type we mark T as constrained.
5287 -- ??? Are there are other uncomfortable cases that we will have to
5290 -- 10. RECORD_TYPE_WITH_PRIVATE complications
5292 -- Types that are derived from a visible record type and have a private
5293 -- extension present other peculiarities. They behave mostly like private
5294 -- types, but if they have primitive operations defined, these will not
5295 -- have the proper signatures for further inheritance, because other
5296 -- primitive operations will use the implicit base that we define for
5297 -- private derivations below. This affect subprogram inheritance (see
5298 -- Derive_Subprograms for details). We also derive the implicit base from
5299 -- the base type of the full view, so that the implicit base is a record
5300 -- type and not another private type, This avoids infinite loops.
5302 procedure Build_Derived_Record_Type
5304 Parent_Type
: Entity_Id
;
5305 Derived_Type
: Entity_Id
;
5306 Derive_Subps
: Boolean := True)
5308 Loc
: constant Source_Ptr
:= Sloc
(N
);
5309 Parent_Base
: Entity_Id
;
5312 Discrim
: Entity_Id
;
5313 Last_Discrim
: Entity_Id
;
5316 Discs
: Elist_Id
:= New_Elmt_List
;
5317 -- An empty Discs list means that there were no constraints in the
5318 -- subtype indication or that there was an error processing it.
5320 Assoc_List
: Elist_Id
;
5321 New_Discrs
: Elist_Id
;
5322 New_Base
: Entity_Id
;
5324 New_Indic
: Node_Id
;
5326 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
5327 Discriminant_Specs
: constant Boolean :=
5328 Present
(Discriminant_Specifications
(N
));
5329 Private_Extension
: constant Boolean :=
5330 (Nkind
(N
) = N_Private_Extension_Declaration
);
5332 Constraint_Present
: Boolean;
5333 Has_Interfaces
: Boolean := False;
5334 Inherit_Discrims
: Boolean := False;
5335 Last_Inherited_Prim_Op
: Elmt_Id
;
5336 Tagged_Partial_View
: Entity_Id
;
5337 Save_Etype
: Entity_Id
;
5338 Save_Discr_Constr
: Elist_Id
;
5339 Save_Next_Entity
: Entity_Id
;
5342 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
5343 and then Present
(Full_View
(Parent_Type
))
5344 and then Has_Discriminants
(Parent_Type
)
5346 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
5348 Parent_Base
:= Base_Type
(Parent_Type
);
5351 -- Before we start the previously documented transformations, here is
5352 -- a little fix for size and alignment of tagged types. Normally when
5353 -- we derive type D from type P, we copy the size and alignment of P
5354 -- as the default for D, and in the absence of explicit representation
5355 -- clauses for D, the size and alignment are indeed the same as the
5358 -- But this is wrong for tagged types, since fields may be added,
5359 -- and the default size may need to be larger, and the default
5360 -- alignment may need to be larger.
5362 -- We therefore reset the size and alignment fields in the tagged
5363 -- case. Note that the size and alignment will in any case be at
5364 -- least as large as the parent type (since the derived type has
5365 -- a copy of the parent type in the _parent field)
5368 Init_Size_Align
(Derived_Type
);
5371 -- STEP 0a: figure out what kind of derived type declaration we have
5373 if Private_Extension
then
5375 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
5378 Type_Def
:= Type_Definition
(N
);
5380 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
5381 -- Parent_Base can be a private type or private extension. However,
5382 -- for tagged types with an extension the newly added fields are
5383 -- visible and hence the Derived_Type is always an E_Record_Type.
5384 -- (except that the parent may have its own private fields).
5385 -- For untagged types we preserve the Ekind of the Parent_Base.
5387 if Present
(Record_Extension_Part
(Type_Def
)) then
5388 Set_Ekind
(Derived_Type
, E_Record_Type
);
5390 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5394 -- Indic can either be an N_Identifier if the subtype indication
5395 -- contains no constraint or an N_Subtype_Indication if the subtype
5396 -- indication has a constraint.
5398 Indic
:= Subtype_Indication
(Type_Def
);
5399 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
5401 -- Check that the type has visible discriminants. The type may be
5402 -- a private type with unknown discriminants whose full view has
5403 -- discriminants which are invisible.
5405 if Constraint_Present
then
5406 if not Has_Discriminants
(Parent_Base
)
5408 (Has_Unknown_Discriminants
(Parent_Base
)
5409 and then Is_Private_Type
(Parent_Base
))
5412 ("invalid constraint: type has no discriminant",
5413 Constraint
(Indic
));
5415 Constraint_Present
:= False;
5416 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5418 elsif Is_Constrained
(Parent_Type
) then
5420 ("invalid constraint: parent type is already constrained",
5421 Constraint
(Indic
));
5423 Constraint_Present
:= False;
5424 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5428 -- STEP 0b: If needed, apply transformation given in point 5. above
5430 if not Private_Extension
5431 and then Has_Discriminants
(Parent_Type
)
5432 and then not Discriminant_Specs
5433 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
5435 -- First, we must analyze the constraint (see comment in point 5.)
5437 if Constraint_Present
then
5438 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5440 if Has_Discriminants
(Derived_Type
)
5441 and then Has_Private_Declaration
(Derived_Type
)
5442 and then Present
(Discriminant_Constraint
(Derived_Type
))
5444 -- Verify that constraints of the full view conform to those
5445 -- given in partial view.
5451 C1
:= First_Elmt
(New_Discrs
);
5452 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
5453 while Present
(C1
) and then Present
(C2
) loop
5455 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5458 "constraint not conformant to previous declaration",
5469 -- Insert and analyze the declaration for the unconstrained base type
5471 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
5474 Make_Full_Type_Declaration
(Loc
,
5475 Defining_Identifier
=> New_Base
,
5477 Make_Derived_Type_Definition
(Loc
,
5478 Abstract_Present
=> Abstract_Present
(Type_Def
),
5479 Subtype_Indication
=>
5480 New_Occurrence_Of
(Parent_Base
, Loc
),
5481 Record_Extension_Part
=>
5482 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
5484 Set_Parent
(New_Decl
, Parent
(N
));
5485 Mark_Rewrite_Insertion
(New_Decl
);
5486 Insert_Before
(N
, New_Decl
);
5488 -- Note that this call passes False for the Derive_Subps parameter
5489 -- because subprogram derivation is deferred until after creating
5490 -- the subtype (see below).
5493 (New_Decl
, Parent_Base
, New_Base
,
5494 Is_Completion
=> True, Derive_Subps
=> False);
5496 -- ??? This needs re-examination to determine whether the
5497 -- above call can simply be replaced by a call to Analyze.
5499 Set_Analyzed
(New_Decl
);
5501 -- Insert and analyze the declaration for the constrained subtype
5503 if Constraint_Present
then
5505 Make_Subtype_Indication
(Loc
,
5506 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5507 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
5511 Constr_List
: constant List_Id
:= New_List
;
5516 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
5517 while Present
(C
) loop
5520 -- It is safe here to call New_Copy_Tree since
5521 -- Force_Evaluation was called on each constraint in
5522 -- Build_Discriminant_Constraints.
5524 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
5530 Make_Subtype_Indication
(Loc
,
5531 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5533 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
5538 Make_Subtype_Declaration
(Loc
,
5539 Defining_Identifier
=> Derived_Type
,
5540 Subtype_Indication
=> New_Indic
));
5544 -- Derivation of subprograms must be delayed until the full subtype
5545 -- has been established to ensure proper overriding of subprograms
5546 -- inherited by full types. If the derivations occurred as part of
5547 -- the call to Build_Derived_Type above, then the check for type
5548 -- conformance would fail because earlier primitive subprograms
5549 -- could still refer to the full type prior the change to the new
5550 -- subtype and hence would not match the new base type created here.
5552 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5554 -- For tagged types the Discriminant_Constraint of the new base itype
5555 -- is inherited from the first subtype so that no subtype conformance
5556 -- problem arise when the first subtype overrides primitive
5557 -- operations inherited by the implicit base type.
5560 Set_Discriminant_Constraint
5561 (New_Base
, Discriminant_Constraint
(Derived_Type
));
5567 -- If we get here Derived_Type will have no discriminants or it will be
5568 -- a discriminated unconstrained base type.
5570 -- STEP 1a: perform preliminary actions/checks for derived tagged types
5574 -- The parent type is frozen for non-private extensions (RM 13.14(7))
5576 if not Private_Extension
then
5577 Freeze_Before
(N
, Parent_Type
);
5580 -- In Ada 2005 (AI-344), the restriction that a derived tagged type
5581 -- cannot be declared at a deeper level than its parent type is
5582 -- removed. The check on derivation within a generic body is also
5583 -- relaxed, but there's a restriction that a derived tagged type
5584 -- cannot be declared in a generic body if it's derived directly
5585 -- or indirectly from a formal type of that generic.
5587 if Ada_Version
>= Ada_05
then
5588 if Present
(Enclosing_Generic_Body
(Derived_Type
)) then
5590 Ancestor_Type
: Entity_Id
;
5593 -- Check to see if any ancestor of the derived type is a
5596 Ancestor_Type
:= Parent_Type
;
5597 while not Is_Generic_Type
(Ancestor_Type
)
5598 and then Etype
(Ancestor_Type
) /= Ancestor_Type
5600 Ancestor_Type
:= Etype
(Ancestor_Type
);
5603 -- If the derived type does have a formal type as an
5604 -- ancestor, then it's an error if the derived type is
5605 -- declared within the body of the generic unit that
5606 -- declares the formal type in its generic formal part. It's
5607 -- sufficient to check whether the ancestor type is declared
5608 -- inside the same generic body as the derived type (such as
5609 -- within a nested generic spec), in which case the
5610 -- derivation is legal. If the formal type is declared
5611 -- outside of that generic body, then it's guaranteed that
5612 -- the derived type is declared within the generic body of
5613 -- the generic unit declaring the formal type.
5615 if Is_Generic_Type
(Ancestor_Type
)
5616 and then Enclosing_Generic_Body
(Ancestor_Type
) /=
5617 Enclosing_Generic_Body
(Derived_Type
)
5620 ("parent type of& must not be descendant of formal type"
5621 & " of an enclosing generic body",
5622 Indic
, Derived_Type
);
5627 elsif Type_Access_Level
(Derived_Type
) /=
5628 Type_Access_Level
(Parent_Type
)
5629 and then not Is_Generic_Type
(Derived_Type
)
5631 if Is_Controlled
(Parent_Type
) then
5633 ("controlled type must be declared at the library level",
5637 ("type extension at deeper accessibility level than parent",
5643 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
5647 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
5650 ("parent type of& must not be outside generic body"
5651 & " ('R'M 3.9.1(4))",
5652 Indic
, Derived_Type
);
5658 -- Ada 2005 (AI-251)
5660 if Ada_Version
= Ada_05
5664 -- "The declaration of a specific descendant of an interface type
5665 -- freezes the interface type" (RM 13.14).
5670 if Is_Non_Empty_List
(Interface_List
(Type_Def
)) then
5671 Iface
:= First
(Interface_List
(Type_Def
));
5672 while Present
(Iface
) loop
5673 Freeze_Before
(N
, Etype
(Iface
));
5680 -- STEP 1b : preliminary cleanup of the full view of private types
5682 -- If the type is already marked as having discriminants, then it's the
5683 -- completion of a private type or private extension and we need to
5684 -- retain the discriminants from the partial view if the current
5685 -- declaration has Discriminant_Specifications so that we can verify
5686 -- conformance. However, we must remove any existing components that
5687 -- were inherited from the parent (and attached in Copy_And_Swap)
5688 -- because the full type inherits all appropriate components anyway, and
5689 -- we do not want the partial view's components interfering.
5691 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
5692 Discrim
:= First_Discriminant
(Derived_Type
);
5694 Last_Discrim
:= Discrim
;
5695 Next_Discriminant
(Discrim
);
5696 exit when No
(Discrim
);
5699 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
5701 -- In all other cases wipe out the list of inherited components (even
5702 -- inherited discriminants), it will be properly rebuilt here.
5705 Set_First_Entity
(Derived_Type
, Empty
);
5706 Set_Last_Entity
(Derived_Type
, Empty
);
5709 -- STEP 1c: Initialize some flags for the Derived_Type
5711 -- The following flags must be initialized here so that
5712 -- Process_Discriminants can check that discriminants of tagged types
5713 -- do not have a default initial value and that access discriminants
5714 -- are only specified for limited records. For completeness, these
5715 -- flags are also initialized along with all the other flags below.
5717 -- AI-419: limitedness is not inherited from an interface parent
5719 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
5720 Set_Is_Limited_Record
(Derived_Type
,
5721 Is_Limited_Record
(Parent_Type
)
5722 and then not Is_Interface
(Parent_Type
));
5724 -- STEP 2a: process discriminants of derived type if any
5726 New_Scope
(Derived_Type
);
5728 if Discriminant_Specs
then
5729 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
5731 -- The following call initializes fields Has_Discriminants and
5732 -- Discriminant_Constraint, unless we are processing the completion
5733 -- of a private type declaration.
5735 Check_Or_Process_Discriminants
(N
, Derived_Type
);
5737 -- For non-tagged types the constraint on the Parent_Type must be
5738 -- present and is used to rename the discriminants.
5740 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
5741 Error_Msg_N
("untagged parent must have discriminants", Indic
);
5743 elsif not Is_Tagged
and then not Constraint_Present
then
5745 ("discriminant constraint needed for derived untagged records",
5748 -- Otherwise the parent subtype must be constrained unless we have a
5749 -- private extension.
5751 elsif not Constraint_Present
5752 and then not Private_Extension
5753 and then not Is_Constrained
(Parent_Type
)
5756 ("unconstrained type not allowed in this context", Indic
);
5758 elsif Constraint_Present
then
5759 -- The following call sets the field Corresponding_Discriminant
5760 -- for the discriminants in the Derived_Type.
5762 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
5764 -- For untagged types all new discriminants must rename
5765 -- discriminants in the parent. For private extensions new
5766 -- discriminants cannot rename old ones (implied by [7.3(13)]).
5768 Discrim
:= First_Discriminant
(Derived_Type
);
5769 while Present
(Discrim
) loop
5771 and then not Present
(Corresponding_Discriminant
(Discrim
))
5774 ("new discriminants must constrain old ones", Discrim
);
5776 elsif Private_Extension
5777 and then Present
(Corresponding_Discriminant
(Discrim
))
5780 ("only static constraints allowed for parent"
5781 & " discriminants in the partial view", Indic
);
5785 -- If a new discriminant is used in the constraint, then its
5786 -- subtype must be statically compatible with the parent
5787 -- discriminant's subtype (3.7(15)).
5789 if Present
(Corresponding_Discriminant
(Discrim
))
5791 not Subtypes_Statically_Compatible
5793 Etype
(Corresponding_Discriminant
(Discrim
)))
5796 ("subtype must be compatible with parent discriminant",
5800 Next_Discriminant
(Discrim
);
5803 -- Check whether the constraints of the full view statically
5804 -- match those imposed by the parent subtype [7.3(13)].
5806 if Present
(Stored_Constraint
(Derived_Type
)) then
5811 C1
:= First_Elmt
(Discs
);
5812 C2
:= First_Elmt
(Stored_Constraint
(Derived_Type
));
5813 while Present
(C1
) and then Present
(C2
) loop
5815 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5818 "not conformant with previous declaration",
5829 -- STEP 2b: No new discriminants, inherit discriminants if any
5832 if Private_Extension
then
5833 Set_Has_Unknown_Discriminants
5835 Has_Unknown_Discriminants
(Parent_Type
)
5836 or else Unknown_Discriminants_Present
(N
));
5838 -- The partial view of the parent may have unknown discriminants,
5839 -- but if the full view has discriminants and the parent type is
5840 -- in scope they must be inherited.
5842 elsif Has_Unknown_Discriminants
(Parent_Type
)
5844 (not Has_Discriminants
(Parent_Type
)
5845 or else not In_Open_Scopes
(Scope
(Parent_Type
)))
5847 Set_Has_Unknown_Discriminants
(Derived_Type
);
5850 if not Has_Unknown_Discriminants
(Derived_Type
)
5851 and then not Has_Unknown_Discriminants
(Parent_Base
)
5852 and then Has_Discriminants
(Parent_Type
)
5854 Inherit_Discrims
:= True;
5855 Set_Has_Discriminants
5856 (Derived_Type
, True);
5857 Set_Discriminant_Constraint
5858 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
5861 -- The following test is true for private types (remember
5862 -- transformation 5. is not applied to those) and in an error
5865 if Constraint_Present
then
5866 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5869 -- For now mark a new derived type as constrained only if it has no
5870 -- discriminants. At the end of Build_Derived_Record_Type we properly
5871 -- set this flag in the case of private extensions. See comments in
5872 -- point 9. just before body of Build_Derived_Record_Type.
5876 not (Inherit_Discrims
5877 or else Has_Unknown_Discriminants
(Derived_Type
)));
5880 -- STEP 3: initialize fields of derived type
5882 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
5883 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
5885 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
5886 -- but cannot be interfaces
5888 if not Private_Extension
5889 and then Ekind
(Derived_Type
) /= E_Private_Type
5890 and then Ekind
(Derived_Type
) /= E_Limited_Private_Type
5892 Set_Is_Interface
(Derived_Type
, Interface_Present
(Type_Def
));
5893 Set_Abstract_Interfaces
(Derived_Type
, No_Elist
);
5896 -- Fields inherited from the Parent_Type
5899 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
5900 Set_Has_Specified_Layout
5901 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
5902 Set_Is_Limited_Composite
5903 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
5904 Set_Is_Limited_Record
5906 Is_Limited_Record
(Parent_Type
)
5907 and then not Is_Interface
(Parent_Type
));
5908 Set_Is_Private_Composite
5909 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
5911 -- Fields inherited from the Parent_Base
5913 Set_Has_Controlled_Component
5914 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
5915 Set_Has_Non_Standard_Rep
5916 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
5917 Set_Has_Primitive_Operations
5918 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
5920 -- Direct controlled types do not inherit Finalize_Storage_Only flag
5922 if not Is_Controlled
(Parent_Type
) then
5923 Set_Finalize_Storage_Only
5924 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
5927 -- Set fields for private derived types
5929 if Is_Private_Type
(Derived_Type
) then
5930 Set_Depends_On_Private
(Derived_Type
, True);
5931 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
5933 -- Inherit fields from non private record types. If this is the
5934 -- completion of a derivation from a private type, the parent itself
5935 -- is private, and the attributes come from its full view, which must
5939 if Is_Private_Type
(Parent_Base
)
5940 and then not Is_Record_Type
(Parent_Base
)
5942 Set_Component_Alignment
5943 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
5945 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
5947 Set_Component_Alignment
5948 (Derived_Type
, Component_Alignment
(Parent_Base
));
5951 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
5955 -- Set fields for tagged types
5958 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
5960 -- All tagged types defined in Ada.Finalization are controlled
5962 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
5963 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
5964 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
5966 Set_Is_Controlled
(Derived_Type
);
5968 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
5971 Make_Class_Wide_Type
(Derived_Type
);
5972 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
5974 if Has_Discriminants
(Derived_Type
)
5975 and then Constraint_Present
5977 Set_Stored_Constraint
5978 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Base
, Discs
));
5981 -- Ada 2005 (AI-251): Look for the partial view of tagged types
5982 -- declared in the private part. This will be used 1) to check that
5983 -- the set of interfaces in both views is equal, and 2) to complete
5984 -- the derivation of subprograms covering interfaces.
5986 Tagged_Partial_View
:= Empty
;
5988 if Has_Private_Declaration
(Derived_Type
) then
5989 Tagged_Partial_View
:= Next_Entity
(Derived_Type
);
5991 exit when Has_Private_Declaration
(Tagged_Partial_View
)
5992 and then Full_View
(Tagged_Partial_View
) = Derived_Type
;
5994 Next_Entity
(Tagged_Partial_View
);
5998 -- Ada 2005 (AI-251): Collect the whole list of implemented
6001 if Ada_Version
>= Ada_05
then
6002 Set_Abstract_Interfaces
(Derived_Type
, New_Elmt_List
);
6004 if Nkind
(N
) = N_Private_Extension_Declaration
then
6005 Collect_Interfaces
(N
, Derived_Type
);
6007 Collect_Interfaces
(Type_Definition
(N
), Derived_Type
);
6010 -- Ada 2005 (AI-251): The progenitor types specified in a private
6011 -- extension declaration and the progenitor types specified in the
6012 -- corresponding declaration of a record extension given in the
6013 -- private part need not be the same; the only requirement is that
6014 -- the private extension must be descended from each interface
6015 -- from which the record extension is descended (AARM 7.3, 20.1/2)
6017 if Has_Private_Declaration
(Derived_Type
) then
6019 N_Partial
: constant Node_Id
:= Parent
(Tagged_Partial_View
);
6020 Iface_Partial
: Entity_Id
;
6023 if Nkind
(N_Partial
) = N_Private_Extension_Declaration
6024 and then not Is_Empty_List
(Interface_List
(N_Partial
))
6026 Iface_Partial
:= First
(Interface_List
(N_Partial
));
6028 while Present
(Iface_Partial
) loop
6029 if not Interface_Present_In_Ancestor
6030 (Derived_Type
, Etype
(Iface_Partial
))
6033 ("(Ada 2005) full type and private extension must"
6034 & " have the same progenitors", Derived_Type
);
6038 Next
(Iface_Partial
);
6046 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
6047 Set_Has_Non_Standard_Rep
6048 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6051 -- STEP 4: Inherit components from the parent base and constrain them.
6052 -- Apply the second transformation described in point 6. above.
6054 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
6055 or else not Has_Discriminants
(Parent_Type
)
6056 or else not Is_Constrained
(Parent_Type
)
6060 Constrs
:= Discriminant_Constraint
(Parent_Type
);
6063 Assoc_List
:= Inherit_Components
(N
,
6064 Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
6066 -- STEP 5a: Copy the parent record declaration for untagged types
6068 if not Is_Tagged
then
6070 -- Discriminant_Constraint (Derived_Type) has been properly
6071 -- constructed. Save it and temporarily set it to Empty because we
6072 -- do not want the call to New_Copy_Tree below to mess this list.
6074 if Has_Discriminants
(Derived_Type
) then
6075 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
6076 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
6078 Save_Discr_Constr
:= No_Elist
;
6081 -- Save the Etype field of Derived_Type. It is correctly set now,
6082 -- but the call to New_Copy tree may remap it to point to itself,
6083 -- which is not what we want. Ditto for the Next_Entity field.
6085 Save_Etype
:= Etype
(Derived_Type
);
6086 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
6088 -- Assoc_List maps all stored discriminants in the Parent_Base to
6089 -- stored discriminants in the Derived_Type. It is fundamental that
6090 -- no types or itypes with discriminants other than the stored
6091 -- discriminants appear in the entities declared inside
6092 -- Derived_Type, since the back end cannot deal with it.
6096 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
6098 -- Restore the fields saved prior to the New_Copy_Tree call
6099 -- and compute the stored constraint.
6101 Set_Etype
(Derived_Type
, Save_Etype
);
6102 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
6104 if Has_Discriminants
(Derived_Type
) then
6105 Set_Discriminant_Constraint
6106 (Derived_Type
, Save_Discr_Constr
);
6107 Set_Stored_Constraint
6108 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Type
, Discs
));
6109 Replace_Components
(Derived_Type
, New_Decl
);
6112 -- Insert the new derived type declaration
6114 Rewrite
(N
, New_Decl
);
6116 -- STEP 5b: Complete the processing for record extensions in generics
6118 -- There is no completion for record extensions declared in the
6119 -- parameter part of a generic, so we need to complete processing for
6120 -- these generic record extensions here. The Record_Type_Definition call
6121 -- will change the Ekind of the components from E_Void to E_Component.
6123 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
6124 Record_Type_Definition
(Empty
, Derived_Type
);
6126 -- STEP 5c: Process the record extension for non private tagged types
6128 elsif not Private_Extension
then
6130 -- Add the _parent field in the derived type
6132 Expand_Record_Extension
(Derived_Type
, Type_Def
);
6134 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
6135 -- implemented interfaces if we are in expansion mode
6137 if Expander_Active
then
6138 Add_Interface_Tag_Components
(N
, Derived_Type
);
6141 -- Analyze the record extension
6143 Record_Type_Definition
6144 (Record_Extension_Part
(Type_Def
), Derived_Type
);
6149 if Etype
(Derived_Type
) = Any_Type
then
6153 -- Set delayed freeze and then derive subprograms, we need to do
6154 -- this in this order so that derived subprograms inherit the
6155 -- derived freeze if necessary.
6157 Set_Has_Delayed_Freeze
(Derived_Type
);
6159 if Derive_Subps
then
6161 -- Ada 2005 (AI-251): Check if this tagged type implements abstract
6164 Has_Interfaces
:= False;
6166 if Is_Tagged_Type
(Derived_Type
) then
6171 -- Handle private types
6173 if Present
(Full_View
(Derived_Type
)) then
6174 E
:= Full_View
(Derived_Type
);
6181 or else (Present
(Abstract_Interfaces
(E
))
6183 not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
)))
6185 Has_Interfaces
:= True;
6189 exit when Etype
(E
) = E
6191 -- Handle private types
6193 or else (Present
(Full_View
(Etype
(E
)))
6194 and then Full_View
(Etype
(E
)) = E
)
6196 -- Protect the frontend against wrong source
6198 or else Etype
(E
) = Derived_Type
;
6200 -- Climb to the ancestor type handling private types
6202 if Present
(Full_View
(Etype
(E
))) then
6203 E
:= Full_View
(Etype
(E
));
6211 -- Ada 2005 (AI-251): Keep separate the management of tagged types
6212 -- implementing interfaces
6214 if not Is_Tagged_Type
(Derived_Type
)
6215 or else not Has_Interfaces
6217 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6220 -- Ada 2005 (AI-251): Complete the decoration of tagged private
6221 -- types that implement interfaces
6223 if Present
(Tagged_Partial_View
) then
6225 (Parent_Type
, Derived_Type
);
6227 Complete_Subprograms_Derivation
6228 (Partial_View
=> Tagged_Partial_View
,
6229 Derived_Type
=> Derived_Type
);
6231 -- Ada 2005 (AI-251): Derive the interface subprograms of all the
6232 -- implemented interfaces and check if some of the subprograms
6233 -- inherited from the ancestor cover some interface subprogram.
6236 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6239 Subp_Elmt
: Elmt_Id
;
6240 First_Iface_Elmt
: Elmt_Id
;
6241 Iface_Subp_Elmt
: Elmt_Id
;
6243 Iface_Subp
: Entity_Id
;
6244 Is_Interface_Subp
: Boolean;
6247 -- Ada 2005 (AI-251): Remember the entity corresponding to
6248 -- the last inherited primitive operation. This is required
6249 -- to check if some of the inherited subprograms covers some
6250 -- of the new interfaces.
6252 Last_Inherited_Prim_Op
:= No_Elmt
;
6255 First_Elmt
(Primitive_Operations
(Derived_Type
));
6256 while Present
(Subp_Elmt
) loop
6257 Last_Inherited_Prim_Op
:= Subp_Elmt
;
6258 Next_Elmt
(Subp_Elmt
);
6261 -- Ada 2005 (AI-251): Derive subprograms in abstract
6264 Derive_Interface_Subprograms
(Derived_Type
);
6266 -- Ada 2005 (AI-251): Check if some of the inherited
6267 -- subprograms cover some of the new interfaces.
6269 if Present
(Last_Inherited_Prim_Op
) then
6270 First_Iface_Elmt
:= Next_Elmt
(Last_Inherited_Prim_Op
);
6271 Iface_Subp_Elmt
:= First_Iface_Elmt
;
6272 while Present
(Iface_Subp_Elmt
) loop
6273 Subp_Elmt
:= First_Elmt
(Primitive_Operations
6275 while Subp_Elmt
/= First_Iface_Elmt
loop
6276 Subp
:= Node
(Subp_Elmt
);
6277 Iface_Subp
:= Node
(Iface_Subp_Elmt
);
6279 Is_Interface_Subp
:=
6280 Present
(Alias
(Subp
))
6281 and then Present
(DTC_Entity
(Alias
(Subp
)))
6282 and then Is_Interface
(Scope
6286 if Chars
(Subp
) = Chars
(Iface_Subp
)
6287 and then not Is_Interface_Subp
6288 and then not Is_Abstract
(Subp
)
6289 and then Type_Conformant
(Iface_Subp
, Subp
)
6291 Check_Dispatching_Operation
6293 Old_Subp
=> Iface_Subp
);
6295 -- Traverse the list of aliased subprograms
6302 while Present
(Alias
(E
)) loop
6306 Set_Alias
(Subp
, E
);
6309 Set_Has_Delayed_Freeze
(Subp
);
6313 Next_Elmt
(Subp_Elmt
);
6316 Next_Elmt
(Iface_Subp_Elmt
);
6324 -- If we have a private extension which defines a constrained derived
6325 -- type mark as constrained here after we have derived subprograms. See
6326 -- comment on point 9. just above the body of Build_Derived_Record_Type.
6328 if Private_Extension
and then Inherit_Discrims
then
6329 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
6330 Set_Is_Constrained
(Derived_Type
, True);
6331 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
6333 elsif Is_Constrained
(Parent_Type
) then
6335 (Derived_Type
, True);
6336 Set_Discriminant_Constraint
6337 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
6341 -- Update the class_wide type, which shares the now-completed
6342 -- entity list with its specific type.
6346 (Class_Wide_Type
(Derived_Type
), First_Entity
(Derived_Type
));
6348 (Class_Wide_Type
(Derived_Type
), Last_Entity
(Derived_Type
));
6351 end Build_Derived_Record_Type
;
6353 ------------------------
6354 -- Build_Derived_Type --
6355 ------------------------
6357 procedure Build_Derived_Type
6359 Parent_Type
: Entity_Id
;
6360 Derived_Type
: Entity_Id
;
6361 Is_Completion
: Boolean;
6362 Derive_Subps
: Boolean := True)
6364 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
6367 -- Set common attributes
6369 Set_Scope
(Derived_Type
, Current_Scope
);
6371 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
6372 Set_Etype
(Derived_Type
, Parent_Base
);
6373 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
6375 Set_Size_Info
(Derived_Type
, Parent_Type
);
6376 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
6377 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
6378 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
6380 -- The derived type inherits the representation clauses of the parent.
6381 -- However, for a private type that is completed by a derivation, there
6382 -- may be operation attributes that have been specified already (stream
6383 -- attributes and External_Tag) and those must be provided. Finally,
6384 -- if the partial view is a private extension, the representation items
6385 -- of the parent have been inherited already, and should not be chained
6386 -- twice to the derived type.
6388 if Is_Tagged_Type
(Parent_Type
)
6389 and then Present
(First_Rep_Item
(Derived_Type
))
6391 -- The existing items are either operational items or items inherited
6392 -- from a private extension declaration.
6396 Found
: Boolean := False;
6399 Rep
:= First_Rep_Item
(Derived_Type
);
6400 while Present
(Rep
) loop
6401 if Rep
= First_Rep_Item
(Parent_Type
) then
6405 Rep
:= Next_Rep_Item
(Rep
);
6411 (First_Rep_Item
(Derived_Type
), First_Rep_Item
(Parent_Type
));
6416 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
6419 case Ekind
(Parent_Type
) is
6420 when Numeric_Kind
=>
6421 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
6424 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
6428 | Class_Wide_Kind
=>
6429 Build_Derived_Record_Type
6430 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
6433 when Enumeration_Kind
=>
6434 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
6437 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
6439 when Incomplete_Or_Private_Kind
=>
6440 Build_Derived_Private_Type
6441 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
6443 -- For discriminated types, the derivation includes deriving
6444 -- primitive operations. For others it is done below.
6446 if Is_Tagged_Type
(Parent_Type
)
6447 or else Has_Discriminants
(Parent_Type
)
6448 or else (Present
(Full_View
(Parent_Type
))
6449 and then Has_Discriminants
(Full_View
(Parent_Type
)))
6454 when Concurrent_Kind
=>
6455 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
6458 raise Program_Error
;
6461 if Etype
(Derived_Type
) = Any_Type
then
6465 -- Set delayed freeze and then derive subprograms, we need to do this
6466 -- in this order so that derived subprograms inherit the derived freeze
6469 Set_Has_Delayed_Freeze
(Derived_Type
);
6470 if Derive_Subps
then
6471 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6474 Set_Has_Primitive_Operations
6475 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
6476 end Build_Derived_Type
;
6478 -----------------------
6479 -- Build_Discriminal --
6480 -----------------------
6482 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
6483 D_Minal
: Entity_Id
;
6484 CR_Disc
: Entity_Id
;
6487 -- A discriminal has the same name as the discriminant
6490 Make_Defining_Identifier
(Sloc
(Discrim
),
6491 Chars
=> Chars
(Discrim
));
6493 Set_Ekind
(D_Minal
, E_In_Parameter
);
6494 Set_Mechanism
(D_Minal
, Default_Mechanism
);
6495 Set_Etype
(D_Minal
, Etype
(Discrim
));
6497 Set_Discriminal
(Discrim
, D_Minal
);
6498 Set_Discriminal_Link
(D_Minal
, Discrim
);
6500 -- For task types, build at once the discriminants of the corresponding
6501 -- record, which are needed if discriminants are used in entry defaults
6502 -- and in family bounds.
6504 if Is_Concurrent_Type
(Current_Scope
)
6505 or else Is_Limited_Type
(Current_Scope
)
6507 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
6509 Set_Ekind
(CR_Disc
, E_In_Parameter
);
6510 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
6511 Set_Etype
(CR_Disc
, Etype
(Discrim
));
6512 Set_Discriminal_Link
(CR_Disc
, Discrim
);
6513 Set_CR_Discriminant
(Discrim
, CR_Disc
);
6515 end Build_Discriminal
;
6517 ------------------------------------
6518 -- Build_Discriminant_Constraints --
6519 ------------------------------------
6521 function Build_Discriminant_Constraints
6524 Derived_Def
: Boolean := False) return Elist_Id
6526 C
: constant Node_Id
:= Constraint
(Def
);
6527 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
6529 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
6530 -- Saves the expression corresponding to a given discriminant in T
6532 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
6533 -- Return the Position number within array Discr_Expr of a discriminant
6534 -- D within the discriminant list of the discriminated type T.
6540 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
6544 Disc
:= First_Discriminant
(T
);
6545 for J
in Discr_Expr
'Range loop
6550 Next_Discriminant
(Disc
);
6553 -- Note: Since this function is called on discriminants that are
6554 -- known to belong to the discriminated type, falling through the
6555 -- loop with no match signals an internal compiler error.
6557 raise Program_Error
;
6560 -- Declarations local to Build_Discriminant_Constraints
6564 Elist
: constant Elist_Id
:= New_Elmt_List
;
6572 Discrim_Present
: Boolean := False;
6574 -- Start of processing for Build_Discriminant_Constraints
6577 -- The following loop will process positional associations only.
6578 -- For a positional association, the (single) discriminant is
6579 -- implicitly specified by position, in textual order (RM 3.7.2).
6581 Discr
:= First_Discriminant
(T
);
6582 Constr
:= First
(Constraints
(C
));
6584 for D
in Discr_Expr
'Range loop
6585 exit when Nkind
(Constr
) = N_Discriminant_Association
;
6588 Error_Msg_N
("too few discriminants given in constraint", C
);
6589 return New_Elmt_List
;
6591 elsif Nkind
(Constr
) = N_Range
6592 or else (Nkind
(Constr
) = N_Attribute_Reference
6594 Attribute_Name
(Constr
) = Name_Range
)
6597 ("a range is not a valid discriminant constraint", Constr
);
6598 Discr_Expr
(D
) := Error
;
6601 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
6602 Discr_Expr
(D
) := Constr
;
6605 Next_Discriminant
(Discr
);
6609 if No
(Discr
) and then Present
(Constr
) then
6610 Error_Msg_N
("too many discriminants given in constraint", Constr
);
6611 return New_Elmt_List
;
6614 -- Named associations can be given in any order, but if both positional
6615 -- and named associations are used in the same discriminant constraint,
6616 -- then positional associations must occur first, at their normal
6617 -- position. Hence once a named association is used, the rest of the
6618 -- discriminant constraint must use only named associations.
6620 while Present
(Constr
) loop
6622 -- Positional association forbidden after a named association
6624 if Nkind
(Constr
) /= N_Discriminant_Association
then
6625 Error_Msg_N
("positional association follows named one", Constr
);
6626 return New_Elmt_List
;
6628 -- Otherwise it is a named association
6631 -- E records the type of the discriminants in the named
6632 -- association. All the discriminants specified in the same name
6633 -- association must have the same type.
6637 -- Search the list of discriminants in T to see if the simple name
6638 -- given in the constraint matches any of them.
6640 Id
:= First
(Selector_Names
(Constr
));
6641 while Present
(Id
) loop
6644 -- If Original_Discriminant is present, we are processing a
6645 -- generic instantiation and this is an instance node. We need
6646 -- to find the name of the corresponding discriminant in the
6647 -- actual record type T and not the name of the discriminant in
6648 -- the generic formal. Example:
6651 -- type G (D : int) is private;
6653 -- subtype W is G (D => 1);
6655 -- type Rec (X : int) is record ... end record;
6656 -- package Q is new P (G => Rec);
6658 -- At the point of the instantiation, formal type G is Rec
6659 -- and therefore when reanalyzing "subtype W is G (D => 1);"
6660 -- which really looks like "subtype W is Rec (D => 1);" at
6661 -- the point of instantiation, we want to find the discriminant
6662 -- that corresponds to D in Rec, ie X.
6664 if Present
(Original_Discriminant
(Id
)) then
6665 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
6669 Discr
:= First_Discriminant
(T
);
6670 while Present
(Discr
) loop
6671 if Chars
(Discr
) = Chars
(Id
) then
6676 Next_Discriminant
(Discr
);
6680 Error_Msg_N
("& does not match any discriminant", Id
);
6681 return New_Elmt_List
;
6683 -- The following is only useful for the benefit of generic
6684 -- instances but it does not interfere with other
6685 -- processing for the non-generic case so we do it in all
6686 -- cases (for generics this statement is executed when
6687 -- processing the generic definition, see comment at the
6688 -- beginning of this if statement).
6691 Set_Original_Discriminant
(Id
, Discr
);
6695 Position
:= Pos_Of_Discr
(T
, Discr
);
6697 if Present
(Discr_Expr
(Position
)) then
6698 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
6701 -- Each discriminant specified in the same named association
6702 -- must be associated with a separate copy of the
6703 -- corresponding expression.
6705 if Present
(Next
(Id
)) then
6706 Expr
:= New_Copy_Tree
(Expression
(Constr
));
6707 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
6709 Expr
:= Expression
(Constr
);
6712 Discr_Expr
(Position
) := Expr
;
6713 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
6716 -- A discriminant association with more than one discriminant
6717 -- name is only allowed if the named discriminants are all of
6718 -- the same type (RM 3.7.1(8)).
6721 E
:= Base_Type
(Etype
(Discr
));
6723 elsif Base_Type
(Etype
(Discr
)) /= E
then
6725 ("all discriminants in an association " &
6726 "must have the same type", Id
);
6736 -- A discriminant constraint must provide exactly one value for each
6737 -- discriminant of the type (RM 3.7.1(8)).
6739 for J
in Discr_Expr
'Range loop
6740 if No
(Discr_Expr
(J
)) then
6741 Error_Msg_N
("too few discriminants given in constraint", C
);
6742 return New_Elmt_List
;
6746 -- Determine if there are discriminant expressions in the constraint
6748 for J
in Discr_Expr
'Range loop
6749 if Denotes_Discriminant
(Discr_Expr
(J
), Check_Protected
=> True) then
6750 Discrim_Present
:= True;
6754 -- Build an element list consisting of the expressions given in the
6755 -- discriminant constraint and apply the appropriate checks. The list
6756 -- is constructed after resolving any named discriminant associations
6757 -- and therefore the expressions appear in the textual order of the
6760 Discr
:= First_Discriminant
(T
);
6761 for J
in Discr_Expr
'Range loop
6762 if Discr_Expr
(J
) /= Error
then
6764 Append_Elmt
(Discr_Expr
(J
), Elist
);
6766 -- If any of the discriminant constraints is given by a
6767 -- discriminant and we are in a derived type declaration we
6768 -- have a discriminant renaming. Establish link between new
6769 -- and old discriminant.
6771 if Denotes_Discriminant
(Discr_Expr
(J
)) then
6773 Set_Corresponding_Discriminant
6774 (Entity
(Discr_Expr
(J
)), Discr
);
6777 -- Force the evaluation of non-discriminant expressions.
6778 -- If we have found a discriminant in the constraint 3.4(26)
6779 -- and 3.8(18) demand that no range checks are performed are
6780 -- after evaluation. If the constraint is for a component
6781 -- definition that has a per-object constraint, expressions are
6782 -- evaluated but not checked either. In all other cases perform
6786 if Discrim_Present
then
6789 elsif Nkind
(Parent
(Parent
(Def
))) = N_Component_Declaration
6791 Has_Per_Object_Constraint
6792 (Defining_Identifier
(Parent
(Parent
(Def
))))
6796 elsif Is_Access_Type
(Etype
(Discr
)) then
6797 Apply_Constraint_Check
(Discr_Expr
(J
), Etype
(Discr
));
6800 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
6803 Force_Evaluation
(Discr_Expr
(J
));
6806 -- Check that the designated type of an access discriminant's
6807 -- expression is not a class-wide type unless the discriminant's
6808 -- designated type is also class-wide.
6810 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
6811 and then not Is_Class_Wide_Type
6812 (Designated_Type
(Etype
(Discr
)))
6813 and then Etype
(Discr_Expr
(J
)) /= Any_Type
6814 and then Is_Class_Wide_Type
6815 (Designated_Type
(Etype
(Discr_Expr
(J
))))
6817 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
6821 Next_Discriminant
(Discr
);
6825 end Build_Discriminant_Constraints
;
6827 ---------------------------------
6828 -- Build_Discriminated_Subtype --
6829 ---------------------------------
6831 procedure Build_Discriminated_Subtype
6835 Related_Nod
: Node_Id
;
6836 For_Access
: Boolean := False)
6838 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
6839 Constrained
: constant Boolean
6841 and then not Is_Empty_Elmt_List
(Elist
)
6842 and then not Is_Class_Wide_Type
(T
))
6843 or else Is_Constrained
(T
);
6846 if Ekind
(T
) = E_Record_Type
then
6848 Set_Ekind
(Def_Id
, E_Private_Subtype
);
6849 Set_Is_For_Access_Subtype
(Def_Id
, True);
6851 Set_Ekind
(Def_Id
, E_Record_Subtype
);
6854 elsif Ekind
(T
) = E_Task_Type
then
6855 Set_Ekind
(Def_Id
, E_Task_Subtype
);
6857 elsif Ekind
(T
) = E_Protected_Type
then
6858 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
6860 elsif Is_Private_Type
(T
) then
6861 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
6863 elsif Is_Class_Wide_Type
(T
) then
6864 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
6867 -- Incomplete type. attach subtype to list of dependents, to be
6868 -- completed with full view of parent type, unless is it the
6869 -- designated subtype of a record component within an init_proc.
6870 -- This last case arises for a component of an access type whose
6871 -- designated type is incomplete (e.g. a Taft Amendment type).
6872 -- The designated subtype is within an inner scope, and needs no
6873 -- elaboration, because only the access type is needed in the
6874 -- initialization procedure.
6876 Set_Ekind
(Def_Id
, Ekind
(T
));
6878 if For_Access
and then Within_Init_Proc
then
6881 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
6885 Set_Etype
(Def_Id
, T
);
6886 Init_Size_Align
(Def_Id
);
6887 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
6888 Set_Is_Constrained
(Def_Id
, Constrained
);
6890 Set_First_Entity
(Def_Id
, First_Entity
(T
));
6891 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
6892 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
6894 if Is_Tagged_Type
(T
) then
6895 Set_Is_Tagged_Type
(Def_Id
);
6896 Make_Class_Wide_Type
(Def_Id
);
6899 Set_Stored_Constraint
(Def_Id
, No_Elist
);
6902 Set_Discriminant_Constraint
(Def_Id
, Elist
);
6903 Set_Stored_Constraint_From_Discriminant_Constraint
(Def_Id
);
6906 if Is_Tagged_Type
(T
) then
6907 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
6908 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
6911 -- Subtypes introduced by component declarations do not need to be
6912 -- marked as delayed, and do not get freeze nodes, because the semantics
6913 -- verifies that the parents of the subtypes are frozen before the
6914 -- enclosing record is frozen.
6916 if not Is_Type
(Scope
(Def_Id
)) then
6917 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
6919 if Is_Private_Type
(T
)
6920 and then Present
(Full_View
(T
))
6922 Conditional_Delay
(Def_Id
, Full_View
(T
));
6924 Conditional_Delay
(Def_Id
, T
);
6928 if Is_Record_Type
(T
) then
6929 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
6932 and then not Is_Empty_Elmt_List
(Elist
)
6933 and then not For_Access
6935 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
6936 elsif not For_Access
then
6937 Set_Cloned_Subtype
(Def_Id
, T
);
6941 end Build_Discriminated_Subtype
;
6943 ------------------------
6944 -- Build_Scalar_Bound --
6945 ------------------------
6947 function Build_Scalar_Bound
6950 Der_T
: Entity_Id
) return Node_Id
6952 New_Bound
: Entity_Id
;
6955 -- Note: not clear why this is needed, how can the original bound
6956 -- be unanalyzed at this point? and if it is, what business do we
6957 -- have messing around with it? and why is the base type of the
6958 -- parent type the right type for the resolution. It probably is
6959 -- not! It is OK for the new bound we are creating, but not for
6960 -- the old one??? Still if it never happens, no problem!
6962 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
6964 if Nkind
(Bound
) = N_Integer_Literal
6965 or else Nkind
(Bound
) = N_Real_Literal
6967 New_Bound
:= New_Copy
(Bound
);
6968 Set_Etype
(New_Bound
, Der_T
);
6969 Set_Analyzed
(New_Bound
);
6971 elsif Is_Entity_Name
(Bound
) then
6972 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
6974 -- The following is almost certainly wrong. What business do we have
6975 -- relocating a node (Bound) that is presumably still attached to
6976 -- the tree elsewhere???
6979 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
6982 Set_Etype
(New_Bound
, Der_T
);
6984 end Build_Scalar_Bound
;
6986 --------------------------------
6987 -- Build_Underlying_Full_View --
6988 --------------------------------
6990 procedure Build_Underlying_Full_View
6995 Loc
: constant Source_Ptr
:= Sloc
(N
);
6996 Subt
: constant Entity_Id
:=
6997 Make_Defining_Identifier
6998 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
7005 procedure Set_Discriminant_Name
(Id
: Node_Id
);
7006 -- If the derived type has discriminants, they may rename discriminants
7007 -- of the parent. When building the full view of the parent, we need to
7008 -- recover the names of the original discriminants if the constraint is
7009 -- given by named associations.
7011 ---------------------------
7012 -- Set_Discriminant_Name --
7013 ---------------------------
7015 procedure Set_Discriminant_Name
(Id
: Node_Id
) is
7019 Set_Original_Discriminant
(Id
, Empty
);
7021 if Has_Discriminants
(Typ
) then
7022 Disc
:= First_Discriminant
(Typ
);
7023 while Present
(Disc
) loop
7024 if Chars
(Disc
) = Chars
(Id
)
7025 and then Present
(Corresponding_Discriminant
(Disc
))
7027 Set_Chars
(Id
, Chars
(Corresponding_Discriminant
(Disc
)));
7029 Next_Discriminant
(Disc
);
7032 end Set_Discriminant_Name
;
7034 -- Start of processing for Build_Underlying_Full_View
7037 if Nkind
(N
) = N_Full_Type_Declaration
then
7038 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
7040 elsif Nkind
(N
) = N_Subtype_Declaration
then
7041 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
7043 elsif Nkind
(N
) = N_Component_Declaration
then
7046 (Constraint
(Subtype_Indication
(Component_Definition
(N
))));
7049 raise Program_Error
;
7052 C
:= First
(Constraints
(Constr
));
7053 while Present
(C
) loop
7054 if Nkind
(C
) = N_Discriminant_Association
then
7055 Id
:= First
(Selector_Names
(C
));
7056 while Present
(Id
) loop
7057 Set_Discriminant_Name
(Id
);
7066 Make_Subtype_Declaration
(Loc
,
7067 Defining_Identifier
=> Subt
,
7068 Subtype_Indication
=>
7069 Make_Subtype_Indication
(Loc
,
7070 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
7071 Constraint
=> New_Copy_Tree
(Constr
)));
7073 -- If this is a component subtype for an outer itype, it is not
7074 -- a list member, so simply set the parent link for analysis: if
7075 -- the enclosing type does not need to be in a declarative list,
7076 -- neither do the components.
7078 if Is_List_Member
(N
)
7079 and then Nkind
(N
) /= N_Component_Declaration
7081 Insert_Before
(N
, Indic
);
7083 Set_Parent
(Indic
, Parent
(N
));
7087 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
7088 end Build_Underlying_Full_View
;
7090 -------------------------------
7091 -- Check_Abstract_Overriding --
7092 -------------------------------
7094 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
7101 Op_List
:= Primitive_Operations
(T
);
7103 -- Loop to check primitive operations
7105 Elmt
:= First_Elmt
(Op_List
);
7106 while Present
(Elmt
) loop
7107 Subp
:= Node
(Elmt
);
7109 -- Special exception, do not complain about failure to override the
7110 -- stream routines _Input and _Output, as well as the primitive
7111 -- operations used in dispatching selects since we always provide
7112 -- automatic overridings for these subprograms.
7114 if Is_Abstract
(Subp
)
7115 and then not Is_TSS
(Subp
, TSS_Stream_Input
)
7116 and then not Is_TSS
(Subp
, TSS_Stream_Output
)
7117 and then not Is_Abstract
(T
)
7118 and then Chars
(Subp
) /= Name_uDisp_Asynchronous_Select
7119 and then Chars
(Subp
) /= Name_uDisp_Conditional_Select
7120 and then Chars
(Subp
) /= Name_uDisp_Get_Prim_Op_Kind
7121 and then Chars
(Subp
) /= Name_uDisp_Timed_Select
7123 if Present
(Alias
(Subp
)) then
7125 -- Only perform the check for a derived subprogram when
7126 -- the type has an explicit record extension. This avoids
7127 -- incorrectly flagging abstract subprograms for the case
7128 -- of a type without an extension derived from a formal type
7129 -- with a tagged actual (can occur within a private part).
7131 Type_Def
:= Type_Definition
(Parent
(T
));
7132 if Nkind
(Type_Def
) = N_Derived_Type_Definition
7133 and then Present
(Record_Extension_Part
(Type_Def
))
7136 ("type must be declared abstract or & overridden",
7139 -- Traverse the whole chain of aliased subprograms to
7140 -- complete the error notification. This is useful for
7141 -- traceability of the chain of entities when the subprogram
7142 -- corresponds with interface subprogram (that may be
7143 -- defined in another package)
7145 if Ada_Version
>= Ada_05
7146 and then Present
(Alias
(Subp
))
7153 while Present
(Alias
(E
)) loop
7154 Error_Msg_Sloc
:= Sloc
(E
);
7155 Error_Msg_NE
("\& has been inherited #", T
, Subp
);
7159 Error_Msg_Sloc
:= Sloc
(E
);
7161 ("\& has been inherited from subprogram #", T
, Subp
);
7165 -- Ada 2005 (AI-345): Protected or task type implementing
7166 -- abstract interfaces.
7168 elsif Is_Concurrent_Record_Type
(T
)
7169 and then Present
(Abstract_Interfaces
(T
))
7172 ("interface subprogram & must be overridden",
7177 ("abstract subprogram not allowed for type&",
7180 ("nonabstract type has abstract subprogram&",
7187 end Check_Abstract_Overriding
;
7189 ------------------------------------------------
7190 -- Check_Access_Discriminant_Requires_Limited --
7191 ------------------------------------------------
7193 procedure Check_Access_Discriminant_Requires_Limited
7198 -- A discriminant_specification for an access discriminant shall appear
7199 -- only in the declaration for a task or protected type, or for a type
7200 -- with the reserved word 'limited' in its definition or in one of its
7201 -- ancestors. (RM 3.7(10))
7203 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
7204 and then not Is_Concurrent_Type
(Current_Scope
)
7205 and then not Is_Concurrent_Record_Type
(Current_Scope
)
7206 and then not Is_Limited_Record
(Current_Scope
)
7207 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
7210 ("access discriminants allowed only for limited types", Loc
);
7212 end Check_Access_Discriminant_Requires_Limited
;
7214 -----------------------------------
7215 -- Check_Aliased_Component_Types --
7216 -----------------------------------
7218 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
7222 -- ??? Also need to check components of record extensions, but not
7223 -- components of protected types (which are always limited).
7225 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
7226 -- types to be unconstrained. This is safe because it is illegal to
7227 -- create access subtypes to such types with explicit discriminant
7230 if not Is_Limited_Type
(T
) then
7231 if Ekind
(T
) = E_Record_Type
then
7232 C
:= First_Component
(T
);
7233 while Present
(C
) loop
7235 and then Has_Discriminants
(Etype
(C
))
7236 and then not Is_Constrained
(Etype
(C
))
7237 and then not In_Instance_Body
7238 and then Ada_Version
< Ada_05
7241 ("aliased component must be constrained ('R'M 3.6(11))",
7248 elsif Ekind
(T
) = E_Array_Type
then
7249 if Has_Aliased_Components
(T
)
7250 and then Has_Discriminants
(Component_Type
(T
))
7251 and then not Is_Constrained
(Component_Type
(T
))
7252 and then not In_Instance_Body
7253 and then Ada_Version
< Ada_05
7256 ("aliased component type must be constrained ('R'M 3.6(11))",
7261 end Check_Aliased_Component_Types
;
7263 ----------------------
7264 -- Check_Completion --
7265 ----------------------
7267 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
7270 procedure Post_Error
;
7271 -- Post error message for lack of completion for entity E
7277 procedure Post_Error
is
7279 if not Comes_From_Source
(E
) then
7281 if Ekind
(E
) = E_Task_Type
7282 or else Ekind
(E
) = E_Protected_Type
7284 -- It may be an anonymous protected type created for a
7285 -- single variable. Post error on variable, if present.
7291 Var
:= First_Entity
(Current_Scope
);
7292 while Present
(Var
) loop
7293 exit when Etype
(Var
) = E
7294 and then Comes_From_Source
(Var
);
7299 if Present
(Var
) then
7306 -- If a generated entity has no completion, then either previous
7307 -- semantic errors have disabled the expansion phase, or else we had
7308 -- missing subunits, or else we are compiling without expan- sion,
7309 -- or else something is very wrong.
7311 if not Comes_From_Source
(E
) then
7313 (Serious_Errors_Detected
> 0
7314 or else Configurable_Run_Time_Violations
> 0
7315 or else Subunits_Missing
7316 or else not Expander_Active
);
7319 -- Here for source entity
7322 -- Here if no body to post the error message, so we post the error
7323 -- on the declaration that has no completion. This is not really
7324 -- the right place to post it, think about this later ???
7326 if No
(Body_Id
) then
7329 ("missing full declaration for }", Parent
(E
), E
);
7332 ("missing body for &", Parent
(E
), E
);
7335 -- Package body has no completion for a declaration that appears
7336 -- in the corresponding spec. Post error on the body, with a
7337 -- reference to the non-completed declaration.
7340 Error_Msg_Sloc
:= Sloc
(E
);
7344 ("missing full declaration for }!", Body_Id
, E
);
7346 elsif Is_Overloadable
(E
)
7347 and then Current_Entity_In_Scope
(E
) /= E
7349 -- It may be that the completion is mistyped and appears
7350 -- as a distinct overloading of the entity.
7353 Candidate
: constant Entity_Id
:=
7354 Current_Entity_In_Scope
(E
);
7355 Decl
: constant Node_Id
:=
7356 Unit_Declaration_Node
(Candidate
);
7359 if Is_Overloadable
(Candidate
)
7360 and then Ekind
(Candidate
) = Ekind
(E
)
7361 and then Nkind
(Decl
) = N_Subprogram_Body
7362 and then Acts_As_Spec
(Decl
)
7364 Check_Type_Conformant
(Candidate
, E
);
7367 Error_Msg_NE
("missing body for & declared#!",
7372 Error_Msg_NE
("missing body for & declared#!",
7379 -- Start processing for Check_Completion
7382 E
:= First_Entity
(Current_Scope
);
7383 while Present
(E
) loop
7384 if Is_Intrinsic_Subprogram
(E
) then
7387 -- The following situation requires special handling: a child
7388 -- unit that appears in the context clause of the body of its
7391 -- procedure Parent.Child (...);
7393 -- with Parent.Child;
7394 -- package body Parent is
7396 -- Here Parent.Child appears as a local entity, but should not
7397 -- be flagged as requiring completion, because it is a
7398 -- compilation unit.
7400 elsif Ekind
(E
) = E_Function
7401 or else Ekind
(E
) = E_Procedure
7402 or else Ekind
(E
) = E_Generic_Function
7403 or else Ekind
(E
) = E_Generic_Procedure
7405 if not Has_Completion
(E
)
7406 and then not Is_Abstract
(E
)
7407 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7409 and then Chars
(E
) /= Name_uSize
7414 elsif Is_Entry
(E
) then
7415 if not Has_Completion
(E
) and then
7416 (Ekind
(Scope
(E
)) = E_Protected_Object
7417 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
7422 elsif Is_Package_Or_Generic_Package
(E
) then
7423 if Unit_Requires_Body
(E
) then
7424 if not Has_Completion
(E
)
7425 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7431 elsif not Is_Child_Unit
(E
) then
7432 May_Need_Implicit_Body
(E
);
7435 elsif Ekind
(E
) = E_Incomplete_Type
7436 and then No
(Underlying_Type
(E
))
7440 elsif (Ekind
(E
) = E_Task_Type
or else
7441 Ekind
(E
) = E_Protected_Type
)
7442 and then not Has_Completion
(E
)
7446 -- A single task declared in the current scope is a constant, verify
7447 -- that the body of its anonymous type is in the same scope. If the
7448 -- task is defined elsewhere, this may be a renaming declaration for
7449 -- which no completion is needed.
7451 elsif Ekind
(E
) = E_Constant
7452 and then Ekind
(Etype
(E
)) = E_Task_Type
7453 and then not Has_Completion
(Etype
(E
))
7454 and then Scope
(Etype
(E
)) = Current_Scope
7458 elsif Ekind
(E
) = E_Protected_Object
7459 and then not Has_Completion
(Etype
(E
))
7463 elsif Ekind
(E
) = E_Record_Type
then
7464 if Is_Tagged_Type
(E
) then
7465 Check_Abstract_Overriding
(E
);
7468 Check_Aliased_Component_Types
(E
);
7470 elsif Ekind
(E
) = E_Array_Type
then
7471 Check_Aliased_Component_Types
(E
);
7477 end Check_Completion
;
7479 ----------------------------
7480 -- Check_Delta_Expression --
7481 ----------------------------
7483 procedure Check_Delta_Expression
(E
: Node_Id
) is
7485 if not (Is_Real_Type
(Etype
(E
))) then
7486 Wrong_Type
(E
, Any_Real
);
7488 elsif not Is_OK_Static_Expression
(E
) then
7489 Flag_Non_Static_Expr
7490 ("non-static expression used for delta value!", E
);
7492 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
7493 Error_Msg_N
("delta expression must be positive", E
);
7499 -- If any of above errors occurred, then replace the incorrect
7500 -- expression by the real 0.1, which should prevent further errors.
7503 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
7504 Analyze_And_Resolve
(E
, Standard_Float
);
7505 end Check_Delta_Expression
;
7507 -----------------------------
7508 -- Check_Digits_Expression --
7509 -----------------------------
7511 procedure Check_Digits_Expression
(E
: Node_Id
) is
7513 if not (Is_Integer_Type
(Etype
(E
))) then
7514 Wrong_Type
(E
, Any_Integer
);
7516 elsif not Is_OK_Static_Expression
(E
) then
7517 Flag_Non_Static_Expr
7518 ("non-static expression used for digits value!", E
);
7520 elsif Expr_Value
(E
) <= 0 then
7521 Error_Msg_N
("digits value must be greater than zero", E
);
7527 -- If any of above errors occurred, then replace the incorrect
7528 -- expression by the integer 1, which should prevent further errors.
7530 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
7531 Analyze_And_Resolve
(E
, Standard_Integer
);
7533 end Check_Digits_Expression
;
7535 --------------------------
7536 -- Check_Initialization --
7537 --------------------------
7539 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
7541 if (Is_Limited_Type
(T
)
7542 or else Is_Limited_Composite
(T
))
7543 and then not In_Instance
7544 and then not In_Inlined_Body
7546 -- Ada 2005 (AI-287): Relax the strictness of the front-end in
7547 -- case of limited aggregates and extension aggregates.
7549 if Ada_Version
>= Ada_05
7550 and then (Nkind
(Exp
) = N_Aggregate
7551 or else Nkind
(Exp
) = N_Extension_Aggregate
)
7556 ("cannot initialize entities of limited type", Exp
);
7557 Explain_Limited_Type
(T
, Exp
);
7560 end Check_Initialization
;
7562 ------------------------------------
7563 -- Check_Or_Process_Discriminants --
7564 ------------------------------------
7566 -- If an incomplete or private type declaration was already given for the
7567 -- type, the discriminants may have already been processed if they were
7568 -- present on the incomplete declaration. In this case a full conformance
7569 -- check is performed otherwise just process them.
7571 procedure Check_Or_Process_Discriminants
7574 Prev
: Entity_Id
:= Empty
)
7577 if Has_Discriminants
(T
) then
7579 -- Make the discriminants visible to component declarations
7586 D
:= First_Discriminant
(T
);
7587 while Present
(D
) loop
7588 Prev
:= Current_Entity
(D
);
7589 Set_Current_Entity
(D
);
7590 Set_Is_Immediately_Visible
(D
);
7591 Set_Homonym
(D
, Prev
);
7593 -- Ada 2005 (AI-230): Access discriminant allowed in
7594 -- non-limited record types.
7596 if Ada_Version
< Ada_05
then
7598 -- This restriction gets applied to the full type here. It
7599 -- has already been applied earlier to the partial view.
7601 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
7604 Next_Discriminant
(D
);
7608 elsif Present
(Discriminant_Specifications
(N
)) then
7609 Process_Discriminants
(N
, Prev
);
7611 end Check_Or_Process_Discriminants
;
7613 ----------------------
7614 -- Check_Real_Bound --
7615 ----------------------
7617 procedure Check_Real_Bound
(Bound
: Node_Id
) is
7619 if not Is_Real_Type
(Etype
(Bound
)) then
7621 ("bound in real type definition must be of real type", Bound
);
7623 elsif not Is_OK_Static_Expression
(Bound
) then
7624 Flag_Non_Static_Expr
7625 ("non-static expression used for real type bound!", Bound
);
7632 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
7634 Resolve
(Bound
, Standard_Float
);
7635 end Check_Real_Bound
;
7637 ------------------------
7638 -- Collect_Interfaces --
7639 ------------------------
7641 procedure Collect_Interfaces
(N
: Node_Id
; Derived_Type
: Entity_Id
) is
7644 procedure Add_Interface
(Iface
: Entity_Id
);
7645 -- Add one interface
7651 procedure Add_Interface
(Iface
: Entity_Id
) is
7655 Elmt
:= First_Elmt
(Abstract_Interfaces
(Derived_Type
));
7656 while Present
(Elmt
) and then Node
(Elmt
) /= Iface
loop
7660 if not Present
(Elmt
) then
7661 Append_Elmt
(Node
=> Iface
,
7662 To
=> Abstract_Interfaces
(Derived_Type
));
7666 -- Start of processing for Collect_Interfaces
7669 pragma Assert
(False
7670 or else Nkind
(N
) = N_Derived_Type_Definition
7671 or else Nkind
(N
) = N_Record_Definition
7672 or else Nkind
(N
) = N_Private_Extension_Declaration
);
7674 -- Traverse the graph of ancestor interfaces
7676 if Is_Non_Empty_List
(Interface_List
(N
)) then
7677 Intf
:= First
(Interface_List
(N
));
7678 while Present
(Intf
) loop
7680 -- Protect against wrong uses. For example:
7681 -- type I is interface;
7682 -- type O is tagged null record;
7683 -- type Wrong is new I and O with null record; -- ERROR
7685 if Is_Interface
(Etype
(Intf
)) then
7687 -- Do not add the interface when the derived type already
7688 -- implements this interface
7690 if not Interface_Present_In_Ancestor
(Derived_Type
,
7694 (Type_Definition
(Parent
(Etype
(Intf
))),
7696 Add_Interface
(Etype
(Intf
));
7703 end Collect_Interfaces
;
7705 ------------------------------
7706 -- Complete_Private_Subtype --
7707 ------------------------------
7709 procedure Complete_Private_Subtype
7712 Full_Base
: Entity_Id
;
7713 Related_Nod
: Node_Id
)
7715 Save_Next_Entity
: Entity_Id
;
7716 Save_Homonym
: Entity_Id
;
7719 -- Set semantic attributes for (implicit) private subtype completion.
7720 -- If the full type has no discriminants, then it is a copy of the full
7721 -- view of the base. Otherwise, it is a subtype of the base with a
7722 -- possible discriminant constraint. Save and restore the original
7723 -- Next_Entity field of full to ensure that the calls to Copy_Node
7724 -- do not corrupt the entity chain.
7726 -- Note that the type of the full view is the same entity as the type of
7727 -- the partial view. In this fashion, the subtype has access to the
7728 -- correct view of the parent.
7730 Save_Next_Entity
:= Next_Entity
(Full
);
7731 Save_Homonym
:= Homonym
(Priv
);
7733 case Ekind
(Full_Base
) is
7734 when E_Record_Type |
7740 Copy_Node
(Priv
, Full
);
7742 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
7743 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
7744 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
7747 Copy_Node
(Full_Base
, Full
);
7748 Set_Chars
(Full
, Chars
(Priv
));
7749 Conditional_Delay
(Full
, Priv
);
7750 Set_Sloc
(Full
, Sloc
(Priv
));
7753 Set_Next_Entity
(Full
, Save_Next_Entity
);
7754 Set_Homonym
(Full
, Save_Homonym
);
7755 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
7757 -- Set common attributes for all subtypes
7759 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
7761 -- The Etype of the full view is inconsistent. Gigi needs to see the
7762 -- structural full view, which is what the current scheme gives:
7763 -- the Etype of the full view is the etype of the full base. However,
7764 -- if the full base is a derived type, the full view then looks like
7765 -- a subtype of the parent, not a subtype of the full base. If instead
7768 -- Set_Etype (Full, Full_Base);
7770 -- then we get inconsistencies in the front-end (confusion between
7771 -- views). Several outstanding bugs are related to this ???
7773 Set_Is_First_Subtype
(Full
, False);
7774 Set_Scope
(Full
, Scope
(Priv
));
7775 Set_Size_Info
(Full
, Full_Base
);
7776 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
7777 Set_Is_Itype
(Full
);
7779 -- A subtype of a private-type-without-discriminants, whose full-view
7780 -- has discriminants with default expressions, is not constrained!
7782 if not Has_Discriminants
(Priv
) then
7783 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
7785 if Has_Discriminants
(Full_Base
) then
7786 Set_Discriminant_Constraint
7787 (Full
, Discriminant_Constraint
(Full_Base
));
7789 -- The partial view may have been indefinite, the full view
7792 Set_Has_Unknown_Discriminants
7793 (Full
, Has_Unknown_Discriminants
(Full_Base
));
7797 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
7798 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
7800 -- Freeze the private subtype entity if its parent is delayed, and not
7801 -- already frozen. We skip this processing if the type is an anonymous
7802 -- subtype of a record component, or is the corresponding record of a
7803 -- protected type, since ???
7805 if not Is_Type
(Scope
(Full
)) then
7806 Set_Has_Delayed_Freeze
(Full
,
7807 Has_Delayed_Freeze
(Full_Base
)
7808 and then (not Is_Frozen
(Full_Base
)));
7811 Set_Freeze_Node
(Full
, Empty
);
7812 Set_Is_Frozen
(Full
, False);
7813 Set_Full_View
(Priv
, Full
);
7815 if Has_Discriminants
(Full
) then
7816 Set_Stored_Constraint_From_Discriminant_Constraint
(Full
);
7817 Set_Stored_Constraint
(Priv
, Stored_Constraint
(Full
));
7819 if Has_Unknown_Discriminants
(Full
) then
7820 Set_Discriminant_Constraint
(Full
, No_Elist
);
7824 if Ekind
(Full_Base
) = E_Record_Type
7825 and then Has_Discriminants
(Full_Base
)
7826 and then Has_Discriminants
(Priv
) -- might not, if errors
7827 and then not Has_Unknown_Discriminants
(Priv
)
7828 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
7830 Create_Constrained_Components
7831 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
7833 -- If the full base is itself derived from private, build a congruent
7834 -- subtype of its underlying type, for use by the back end. For a
7835 -- constrained record component, the declaration cannot be placed on
7836 -- the component list, but it must nevertheless be built an analyzed, to
7837 -- supply enough information for Gigi to compute the size of component.
7839 elsif Ekind
(Full_Base
) in Private_Kind
7840 and then Is_Derived_Type
(Full_Base
)
7841 and then Has_Discriminants
(Full_Base
)
7842 and then (Ekind
(Current_Scope
) /= E_Record_Subtype
)
7844 if not Is_Itype
(Priv
)
7846 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
7848 Build_Underlying_Full_View
7849 (Parent
(Priv
), Full
, Etype
(Full_Base
));
7851 elsif Nkind
(Related_Nod
) = N_Component_Declaration
then
7852 Build_Underlying_Full_View
(Related_Nod
, Full
, Etype
(Full_Base
));
7855 elsif Is_Record_Type
(Full_Base
) then
7857 -- Show Full is simply a renaming of Full_Base
7859 Set_Cloned_Subtype
(Full
, Full_Base
);
7862 -- It is unsafe to share to bounds of a scalar type, because the Itype
7863 -- is elaborated on demand, and if a bound is non-static then different
7864 -- orders of elaboration in different units will lead to different
7865 -- external symbols.
7867 if Is_Scalar_Type
(Full_Base
) then
7868 Set_Scalar_Range
(Full
,
7869 Make_Range
(Sloc
(Related_Nod
),
7871 Duplicate_Subexpr_No_Checks
(Type_Low_Bound
(Full_Base
)),
7873 Duplicate_Subexpr_No_Checks
(Type_High_Bound
(Full_Base
))));
7875 -- This completion inherits the bounds of the full parent, but if
7876 -- the parent is an unconstrained floating point type, so is the
7879 if Is_Floating_Point_Type
(Full_Base
) then
7880 Set_Includes_Infinities
7881 (Scalar_Range
(Full
), Has_Infinities
(Full_Base
));
7885 -- ??? It seems that a lot of fields are missing that should be copied
7886 -- from Full_Base to Full. Here are some that are introduced in a
7887 -- non-disruptive way but a cleanup is necessary.
7889 if Is_Tagged_Type
(Full_Base
) then
7890 Set_Is_Tagged_Type
(Full
);
7891 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
7892 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Full_Base
));
7894 -- If this is a subtype of a protected or task type, constrain its
7895 -- corresponding record, unless this is a subtype without constraints,
7896 -- i.e. a simple renaming as with an actual subtype in an instance.
7898 elsif Is_Concurrent_Type
(Full_Base
) then
7899 if Has_Discriminants
(Full
)
7900 and then Present
(Corresponding_Record_Type
(Full_Base
))
7902 not Is_Empty_Elmt_List
(Discriminant_Constraint
(Full
))
7904 Set_Corresponding_Record_Type
(Full
,
7905 Constrain_Corresponding_Record
7906 (Full
, Corresponding_Record_Type
(Full_Base
),
7907 Related_Nod
, Full_Base
));
7910 Set_Corresponding_Record_Type
(Full
,
7911 Corresponding_Record_Type
(Full_Base
));
7914 end Complete_Private_Subtype
;
7916 -------------------------------------
7917 -- Complete_Subprograms_Derivation --
7918 -------------------------------------
7920 procedure Complete_Subprograms_Derivation
7921 (Partial_View
: Entity_Id
;
7922 Derived_Type
: Entity_Id
)
7924 Result
: constant Elist_Id
:= New_Elmt_List
;
7928 Prim_Op
: Entity_Id
;
7932 -- Handle the case in which the full-view is a transitive
7933 -- derivation of the ancestor of the partial view.
7935 -- type I is interface;
7936 -- type T is new I with ...
7939 -- type DT is new I with private;
7941 -- type DT is new T with ...
7944 if Etype
(Partial_View
) /= Etype
(Derived_Type
)
7945 and then Is_Interface
(Etype
(Partial_View
))
7946 and then Is_Ancestor
(Etype
(Partial_View
), Etype
(Derived_Type
))
7951 if Is_Tagged_Type
(Partial_View
) then
7952 Elmt_P
:= First_Elmt
(Primitive_Operations
(Partial_View
));
7957 -- Inherit primitives declared with the partial-view
7959 while Present
(Elmt_P
) loop
7960 Prim_Op
:= Node
(Elmt_P
);
7962 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
7963 while Present
(Elmt_D
) loop
7964 if Node
(Elmt_D
) = Prim_Op
then
7973 Append_Elmt
(Prim_Op
, Result
);
7975 -- Search for entries associated with abstract interfaces that
7976 -- have been covered by this primitive
7978 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
7979 while Present
(Elmt_D
) loop
7982 if Chars
(E
) = Chars
(Prim_Op
)
7983 and then Is_Abstract
(E
)
7984 and then Present
(Alias
(E
))
7985 and then Present
(DTC_Entity
(Alias
(E
)))
7986 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(E
))))
7988 Remove_Elmt
(Primitive_Operations
(Derived_Type
), Elmt_D
);
7998 -- Append the entities of the full-view to the list of primitives
8001 Elmt_D
:= First_Elmt
(Result
);
8002 while Present
(Elmt_D
) loop
8003 Append_Elmt
(Node
(Elmt_D
), Primitive_Operations
(Derived_Type
));
8006 end Complete_Subprograms_Derivation
;
8008 ----------------------------
8009 -- Constant_Redeclaration --
8010 ----------------------------
8012 procedure Constant_Redeclaration
8017 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
8018 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
8021 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
8022 -- If deferred constant is an access type initialized with an allocator,
8023 -- check whether there is an illegal recursion in the definition,
8024 -- through a default value of some record subcomponent. This is normally
8025 -- detected when generating init procs, but requires this additional
8026 -- mechanism when expansion is disabled.
8028 ---------------------------------
8029 -- Check_Recursive_Declaration --
8030 ---------------------------------
8032 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
8036 if Is_Record_Type
(Typ
) then
8037 Comp
:= First_Component
(Typ
);
8038 while Present
(Comp
) loop
8039 if Comes_From_Source
(Comp
) then
8040 if Present
(Expression
(Parent
(Comp
)))
8041 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
8042 and then Entity
(Expression
(Parent
(Comp
))) = Prev
8044 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
8046 ("illegal circularity with declaration for&#",
8050 elsif Is_Record_Type
(Etype
(Comp
)) then
8051 Check_Recursive_Declaration
(Etype
(Comp
));
8055 Next_Component
(Comp
);
8058 end Check_Recursive_Declaration
;
8060 -- Start of processing for Constant_Redeclaration
8063 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
8064 if Nkind
(Object_Definition
8065 (Parent
(Prev
))) = N_Subtype_Indication
8067 -- Find type of new declaration. The constraints of the two
8068 -- views must match statically, but there is no point in
8069 -- creating an itype for the full view.
8071 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
8072 Find_Type
(Subtype_Mark
(Obj_Def
));
8073 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
8076 Find_Type
(Obj_Def
);
8077 New_T
:= Entity
(Obj_Def
);
8083 -- The full view may impose a constraint, even if the partial
8084 -- view does not, so construct the subtype.
8086 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
8091 -- Current declaration is illegal, diagnosed below in Enter_Name
8097 -- If previous full declaration exists, or if a homograph is present,
8098 -- let Enter_Name handle it, either with an error, or with the removal
8099 -- of an overridden implicit subprogram.
8101 if Ekind
(Prev
) /= E_Constant
8102 or else Present
(Expression
(Parent
(Prev
)))
8103 or else Present
(Full_View
(Prev
))
8107 -- Verify that types of both declarations match, or else that both types
8108 -- are anonymous access types whose designated subtypes statically match
8109 -- (as allowed in Ada 2005 by AI-385).
8111 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
)
8113 (Ekind
(Etype
(Prev
)) /= E_Anonymous_Access_Type
8114 or else Ekind
(Etype
(New_T
)) /= E_Anonymous_Access_Type
8115 or else not Subtypes_Statically_Match
8116 (Designated_Type
(Etype
(Prev
)),
8117 Designated_Type
(Etype
(New_T
))))
8119 Error_Msg_Sloc
:= Sloc
(Prev
);
8120 Error_Msg_N
("type does not match declaration#", N
);
8121 Set_Full_View
(Prev
, Id
);
8122 Set_Etype
(Id
, Any_Type
);
8124 -- If so, process the full constant declaration
8127 Set_Full_View
(Prev
, Id
);
8128 Set_Is_Public
(Id
, Is_Public
(Prev
));
8129 Set_Is_Internal
(Id
);
8130 Append_Entity
(Id
, Current_Scope
);
8132 -- Check ALIASED present if present before (RM 7.4(7))
8134 if Is_Aliased
(Prev
)
8135 and then not Aliased_Present
(N
)
8137 Error_Msg_Sloc
:= Sloc
(Prev
);
8138 Error_Msg_N
("ALIASED required (see declaration#)", N
);
8141 -- Check that placement is in private part and that the incomplete
8142 -- declaration appeared in the visible part.
8144 if Ekind
(Current_Scope
) = E_Package
8145 and then not In_Private_Part
(Current_Scope
)
8147 Error_Msg_Sloc
:= Sloc
(Prev
);
8148 Error_Msg_N
("full constant for declaration#"
8149 & " must be in private part", N
);
8151 elsif Ekind
(Current_Scope
) = E_Package
8152 and then List_Containing
(Parent
(Prev
))
8153 /= Visible_Declarations
8154 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
8157 ("deferred constant must be declared in visible part",
8161 if Is_Access_Type
(T
)
8162 and then Nkind
(Expression
(N
)) = N_Allocator
8164 Check_Recursive_Declaration
(Designated_Type
(T
));
8167 end Constant_Redeclaration
;
8169 ----------------------
8170 -- Constrain_Access --
8171 ----------------------
8173 procedure Constrain_Access
8174 (Def_Id
: in out Entity_Id
;
8176 Related_Nod
: Node_Id
)
8178 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8179 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
8180 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
8181 Constraint_OK
: Boolean := True;
8183 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean;
8184 -- Simple predicate to test for defaulted discriminants
8185 -- Shouldn't this be in sem_util???
8187 ---------------------------------
8188 -- Has_Defaulted_Discriminants --
8189 ---------------------------------
8191 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean is
8193 return Has_Discriminants
(Typ
)
8194 and then Present
(First_Discriminant
(Typ
))
8196 (Discriminant_Default_Value
(First_Discriminant
(Typ
)));
8197 end Has_Defaulted_Discriminants
;
8199 -- Start of processing for Constrain_Access
8202 if Is_Array_Type
(Desig_Type
) then
8203 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
8205 elsif (Is_Record_Type
(Desig_Type
)
8206 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
8207 and then not Is_Constrained
(Desig_Type
)
8209 -- ??? The following code is a temporary kludge to ignore a
8210 -- discriminant constraint on access type if it is constraining
8211 -- the current record. Avoid creating the implicit subtype of the
8212 -- record we are currently compiling since right now, we cannot
8213 -- handle these. For now, just return the access type itself.
8215 if Desig_Type
= Current_Scope
8216 and then No
(Def_Id
)
8218 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
8219 Def_Id
:= Entity
(Subtype_Mark
(S
));
8221 -- This call added to ensure that the constraint is analyzed
8222 -- (needed for a B test). Note that we still return early from
8223 -- this procedure to avoid recursive processing. ???
8225 Constrain_Discriminated_Type
8226 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
8230 if Ekind
(T
) = E_General_Access_Type
8231 and then Has_Private_Declaration
(Desig_Type
)
8232 and then In_Open_Scopes
(Scope
(Desig_Type
))
8234 -- Enforce rule that the constraint is illegal if there is
8235 -- an unconstrained view of the designated type. This means
8236 -- that the partial view (either a private type declaration or
8237 -- a derivation from a private type) has no discriminants.
8238 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
8239 -- by ACATS B371001).
8240 -- Rule updated for Ada 2005: the private type is said to have
8241 -- a constrained partial view, given that objects of the type
8245 Pack
: constant Node_Id
:=
8246 Unit_Declaration_Node
(Scope
(Desig_Type
));
8251 if Nkind
(Pack
) = N_Package_Declaration
then
8252 Decls
:= Visible_Declarations
(Specification
(Pack
));
8253 Decl
:= First
(Decls
);
8254 while Present
(Decl
) loop
8255 if (Nkind
(Decl
) = N_Private_Type_Declaration
8257 Chars
(Defining_Identifier
(Decl
)) =
8261 (Nkind
(Decl
) = N_Full_Type_Declaration
8263 Chars
(Defining_Identifier
(Decl
)) =
8265 and then Is_Derived_Type
(Desig_Type
)
8267 Has_Private_Declaration
(Etype
(Desig_Type
)))
8269 if No
(Discriminant_Specifications
(Decl
)) then
8271 ("cannot constrain general access type if " &
8272 "designated type has constrained partial view",
8285 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
8286 For_Access
=> True);
8288 elsif (Is_Task_Type
(Desig_Type
)
8289 or else Is_Protected_Type
(Desig_Type
))
8290 and then not Is_Constrained
(Desig_Type
)
8292 Constrain_Concurrent
8293 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
8296 Error_Msg_N
("invalid constraint on access type", S
);
8297 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
8298 Constraint_OK
:= False;
8302 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
8304 Set_Ekind
(Def_Id
, E_Access_Subtype
);
8307 if Constraint_OK
then
8308 Set_Etype
(Def_Id
, Base_Type
(T
));
8310 if Is_Private_Type
(Desig_Type
) then
8311 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
8314 Set_Etype
(Def_Id
, Any_Type
);
8317 Set_Size_Info
(Def_Id
, T
);
8318 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
8319 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
8320 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8321 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
8323 Conditional_Delay
(Def_Id
, T
);
8325 -- AI-363 : Subtypes of general access types whose designated types have
8326 -- default discriminants are disallowed. In instances, the rule has to
8327 -- be checked against the actual, of which T is the subtype. In a
8328 -- generic body, the rule is checked assuming that the actual type has
8329 -- defaulted discriminants.
8331 if Ada_Version
>= Ada_05
then
8332 if Ekind
(Base_Type
(T
)) = E_General_Access_Type
8333 and then Has_Defaulted_Discriminants
(Desig_Type
)
8336 ("access subype of general access type not allowed", S
);
8337 Error_Msg_N
("\ when discriminants have defaults", S
);
8339 elsif Is_Access_Type
(T
)
8340 and then Is_Generic_Type
(Desig_Type
)
8341 and then Has_Discriminants
(Desig_Type
)
8342 and then In_Package_Body
(Current_Scope
)
8344 Error_Msg_N
("access subtype not allowed in generic body", S
);
8346 ("\ wben designated type is a discriminated formal", S
);
8349 end Constrain_Access
;
8351 ---------------------
8352 -- Constrain_Array --
8353 ---------------------
8355 procedure Constrain_Array
8356 (Def_Id
: in out Entity_Id
;
8358 Related_Nod
: Node_Id
;
8359 Related_Id
: Entity_Id
;
8362 C
: constant Node_Id
:= Constraint
(SI
);
8363 Number_Of_Constraints
: Nat
:= 0;
8366 Constraint_OK
: Boolean := True;
8369 T
:= Entity
(Subtype_Mark
(SI
));
8371 if Ekind
(T
) in Access_Kind
then
8372 T
:= Designated_Type
(T
);
8375 -- If an index constraint follows a subtype mark in a subtype indication
8376 -- then the type or subtype denoted by the subtype mark must not already
8377 -- impose an index constraint. The subtype mark must denote either an
8378 -- unconstrained array type or an access type whose designated type
8379 -- is such an array type... (RM 3.6.1)
8381 if Is_Constrained
(T
) then
8383 ("array type is already constrained", Subtype_Mark
(SI
));
8384 Constraint_OK
:= False;
8387 S
:= First
(Constraints
(C
));
8388 while Present
(S
) loop
8389 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
8393 -- In either case, the index constraint must provide a discrete
8394 -- range for each index of the array type and the type of each
8395 -- discrete range must be the same as that of the corresponding
8396 -- index. (RM 3.6.1)
8398 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
8399 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
8400 Constraint_OK
:= False;
8403 S
:= First
(Constraints
(C
));
8404 Index
:= First_Index
(T
);
8407 -- Apply constraints to each index type
8409 for J
in 1 .. Number_Of_Constraints
loop
8410 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
8420 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
8421 Set_Parent
(Def_Id
, Related_Nod
);
8424 Set_Ekind
(Def_Id
, E_Array_Subtype
);
8427 Set_Size_Info
(Def_Id
, (T
));
8428 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8429 Set_Etype
(Def_Id
, Base_Type
(T
));
8431 if Constraint_OK
then
8432 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
8434 Set_First_Index
(Def_Id
, First_Index
(T
));
8437 Set_Is_Constrained
(Def_Id
, True);
8438 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
8439 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8441 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
8442 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
8444 -- Build a freeze node if parent still needs one. Also, make sure
8445 -- that the Depends_On_Private status is set (explanation ???)
8446 -- and also that a conditional delay is set.
8448 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
8449 Conditional_Delay
(Def_Id
, T
);
8451 end Constrain_Array
;
8453 ------------------------------
8454 -- Constrain_Component_Type --
8455 ------------------------------
8457 function Constrain_Component_Type
8459 Constrained_Typ
: Entity_Id
;
8460 Related_Node
: Node_Id
;
8462 Constraints
: Elist_Id
) return Entity_Id
8464 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
8465 Compon_Type
: constant Entity_Id
:= Etype
(Comp
);
8467 function Build_Constrained_Array_Type
8468 (Old_Type
: Entity_Id
) return Entity_Id
;
8469 -- If Old_Type is an array type, one of whose indices is constrained
8470 -- by a discriminant, build an Itype whose constraint replaces the
8471 -- discriminant with its value in the constraint.
8473 function Build_Constrained_Discriminated_Type
8474 (Old_Type
: Entity_Id
) return Entity_Id
;
8475 -- Ditto for record components
8477 function Build_Constrained_Access_Type
8478 (Old_Type
: Entity_Id
) return Entity_Id
;
8479 -- Ditto for access types. Makes use of previous two functions, to
8480 -- constrain designated type.
8482 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
8483 -- T is an array or discriminated type, C is a list of constraints
8484 -- that apply to T. This routine builds the constrained subtype.
8486 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
8487 -- Returns True if Expr is a discriminant
8489 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
8490 -- Find the value of discriminant Discrim in Constraint
8492 -----------------------------------
8493 -- Build_Constrained_Access_Type --
8494 -----------------------------------
8496 function Build_Constrained_Access_Type
8497 (Old_Type
: Entity_Id
) return Entity_Id
8499 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
8501 Desig_Subtype
: Entity_Id
;
8505 -- if the original access type was not embedded in the enclosing
8506 -- type definition, there is no need to produce a new access
8507 -- subtype. In fact every access type with an explicit constraint
8508 -- generates an itype whose scope is the enclosing record.
8510 if not Is_Type
(Scope
(Old_Type
)) then
8513 elsif Is_Array_Type
(Desig_Type
) then
8514 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
8516 elsif Has_Discriminants
(Desig_Type
) then
8518 -- This may be an access type to an enclosing record type for
8519 -- which we are constructing the constrained components. Return
8520 -- the enclosing record subtype. This is not always correct,
8521 -- but avoids infinite recursion. ???
8523 Desig_Subtype
:= Any_Type
;
8525 for J
in reverse 0 .. Scope_Stack
.Last
loop
8526 Scop
:= Scope_Stack
.Table
(J
).Entity
;
8529 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
8531 Desig_Subtype
:= Scop
;
8534 exit when not Is_Type
(Scop
);
8537 if Desig_Subtype
= Any_Type
then
8539 Build_Constrained_Discriminated_Type
(Desig_Type
);
8546 if Desig_Subtype
/= Desig_Type
then
8548 -- The Related_Node better be here or else we won't be able
8549 -- to attach new itypes to a node in the tree.
8551 pragma Assert
(Present
(Related_Node
));
8553 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
8555 Set_Etype
(Itype
, Base_Type
(Old_Type
));
8556 Set_Size_Info
(Itype
, (Old_Type
));
8557 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
8558 Set_Depends_On_Private
(Itype
, Has_Private_Component
8560 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
8563 -- The new itype needs freezing when it depends on a not frozen
8564 -- type and the enclosing subtype needs freezing.
8566 if Has_Delayed_Freeze
(Constrained_Typ
)
8567 and then not Is_Frozen
(Constrained_Typ
)
8569 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
8577 end Build_Constrained_Access_Type
;
8579 ----------------------------------
8580 -- Build_Constrained_Array_Type --
8581 ----------------------------------
8583 function Build_Constrained_Array_Type
8584 (Old_Type
: Entity_Id
) return Entity_Id
8588 Old_Index
: Node_Id
;
8589 Range_Node
: Node_Id
;
8590 Constr_List
: List_Id
;
8592 Need_To_Create_Itype
: Boolean := False;
8595 Old_Index
:= First_Index
(Old_Type
);
8596 while Present
(Old_Index
) loop
8597 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8599 if Is_Discriminant
(Lo_Expr
)
8600 or else Is_Discriminant
(Hi_Expr
)
8602 Need_To_Create_Itype
:= True;
8605 Next_Index
(Old_Index
);
8608 if Need_To_Create_Itype
then
8609 Constr_List
:= New_List
;
8611 Old_Index
:= First_Index
(Old_Type
);
8612 while Present
(Old_Index
) loop
8613 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8615 if Is_Discriminant
(Lo_Expr
) then
8616 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
8619 if Is_Discriminant
(Hi_Expr
) then
8620 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
8625 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
8627 Append
(Range_Node
, To
=> Constr_List
);
8629 Next_Index
(Old_Index
);
8632 return Build_Subtype
(Old_Type
, Constr_List
);
8637 end Build_Constrained_Array_Type
;
8639 ------------------------------------------
8640 -- Build_Constrained_Discriminated_Type --
8641 ------------------------------------------
8643 function Build_Constrained_Discriminated_Type
8644 (Old_Type
: Entity_Id
) return Entity_Id
8647 Constr_List
: List_Id
;
8648 Old_Constraint
: Elmt_Id
;
8650 Need_To_Create_Itype
: Boolean := False;
8653 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8654 while Present
(Old_Constraint
) loop
8655 Expr
:= Node
(Old_Constraint
);
8657 if Is_Discriminant
(Expr
) then
8658 Need_To_Create_Itype
:= True;
8661 Next_Elmt
(Old_Constraint
);
8664 if Need_To_Create_Itype
then
8665 Constr_List
:= New_List
;
8667 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8668 while Present
(Old_Constraint
) loop
8669 Expr
:= Node
(Old_Constraint
);
8671 if Is_Discriminant
(Expr
) then
8672 Expr
:= Get_Discr_Value
(Expr
);
8675 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
8677 Next_Elmt
(Old_Constraint
);
8680 return Build_Subtype
(Old_Type
, Constr_List
);
8685 end Build_Constrained_Discriminated_Type
;
8691 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
8693 Subtyp_Decl
: Node_Id
;
8695 Btyp
: Entity_Id
:= Base_Type
(T
);
8698 -- The Related_Node better be here or else we won't be able to
8699 -- attach new itypes to a node in the tree.
8701 pragma Assert
(Present
(Related_Node
));
8703 -- If the view of the component's type is incomplete or private
8704 -- with unknown discriminants, then the constraint must be applied
8705 -- to the full type.
8707 if Has_Unknown_Discriminants
(Btyp
)
8708 and then Present
(Underlying_Type
(Btyp
))
8710 Btyp
:= Underlying_Type
(Btyp
);
8714 Make_Subtype_Indication
(Loc
,
8715 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
8716 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
8718 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
8721 Make_Subtype_Declaration
(Loc
,
8722 Defining_Identifier
=> Def_Id
,
8723 Subtype_Indication
=> Indic
);
8725 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
8727 -- Itypes must be analyzed with checks off (see package Itypes)
8729 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
8734 ---------------------
8735 -- Get_Discr_Value --
8736 ---------------------
8738 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
8744 -- The discriminant may be declared for the type, in which case we
8745 -- find it by iterating over the list of discriminants. If the
8746 -- discriminant is inherited from a parent type, it appears as the
8747 -- corresponding discriminant of the current type. This will be the
8748 -- case when constraining an inherited component whose constraint is
8749 -- given by a discriminant of the parent.
8751 D
:= First_Discriminant
(Typ
);
8752 E
:= First_Elmt
(Constraints
);
8753 while Present
(D
) loop
8754 if D
= Entity
(Discrim
)
8755 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
8760 Next_Discriminant
(D
);
8764 -- The corresponding_Discriminant mechanism is incomplete, because
8765 -- the correspondence between new and old discriminants is not one
8766 -- to one: one new discriminant can constrain several old ones. In
8767 -- that case, scan sequentially the stored_constraint, the list of
8768 -- discriminants of the parents, and the constraints.
8770 if Is_Derived_Type
(Typ
)
8771 and then Present
(Stored_Constraint
(Typ
))
8772 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
8774 D
:= First_Discriminant
(Etype
(Typ
));
8775 E
:= First_Elmt
(Constraints
);
8776 G
:= First_Elmt
(Stored_Constraint
(Typ
));
8777 while Present
(D
) loop
8778 if D
= Entity
(Discrim
) then
8782 Next_Discriminant
(D
);
8788 -- Something is wrong if we did not find the value
8790 raise Program_Error
;
8791 end Get_Discr_Value
;
8793 ---------------------
8794 -- Is_Discriminant --
8795 ---------------------
8797 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
8798 Discrim_Scope
: Entity_Id
;
8801 if Denotes_Discriminant
(Expr
) then
8802 Discrim_Scope
:= Scope
(Entity
(Expr
));
8804 -- Either we have a reference to one of Typ's discriminants,
8806 pragma Assert
(Discrim_Scope
= Typ
8808 -- or to the discriminants of the parent type, in the case
8809 -- of a derivation of a tagged type with variants.
8811 or else Discrim_Scope
= Etype
(Typ
)
8812 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
8814 -- or same as above for the case where the discriminants
8815 -- were declared in Typ's private view.
8817 or else (Is_Private_Type
(Discrim_Scope
)
8818 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8820 -- or else we are deriving from the full view and the
8821 -- discriminant is declared in the private entity.
8823 or else (Is_Private_Type
(Typ
)
8824 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8826 -- or we have a class-wide type, in which case make sure the
8827 -- discriminant found belongs to the root type.
8829 or else (Is_Class_Wide_Type
(Typ
)
8830 and then Etype
(Typ
) = Discrim_Scope
));
8835 -- In all other cases we have something wrong
8838 end Is_Discriminant
;
8840 -- Start of processing for Constrain_Component_Type
8843 if Nkind
(Parent
(Comp
)) = N_Component_Declaration
8844 and then Comes_From_Source
(Parent
(Comp
))
8845 and then Comes_From_Source
8846 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8849 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8853 elsif Is_Array_Type
(Compon_Type
) then
8854 return Build_Constrained_Array_Type
(Compon_Type
);
8856 elsif Has_Discriminants
(Compon_Type
) then
8857 return Build_Constrained_Discriminated_Type
(Compon_Type
);
8859 elsif Is_Access_Type
(Compon_Type
) then
8860 return Build_Constrained_Access_Type
(Compon_Type
);
8865 end Constrain_Component_Type
;
8867 --------------------------
8868 -- Constrain_Concurrent --
8869 --------------------------
8871 -- For concurrent types, the associated record value type carries the same
8872 -- discriminants, so when we constrain a concurrent type, we must constrain
8873 -- the corresponding record type as well.
8875 procedure Constrain_Concurrent
8876 (Def_Id
: in out Entity_Id
;
8878 Related_Nod
: Node_Id
;
8879 Related_Id
: Entity_Id
;
8882 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
8886 if Ekind
(T_Ent
) in Access_Kind
then
8887 T_Ent
:= Designated_Type
(T_Ent
);
8890 T_Val
:= Corresponding_Record_Type
(T_Ent
);
8892 if Present
(T_Val
) then
8895 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8898 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8900 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8901 Set_Corresponding_Record_Type
(Def_Id
,
8902 Constrain_Corresponding_Record
8903 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
8906 -- If there is no associated record, expansion is disabled and this
8907 -- is a generic context. Create a subtype in any case, so that
8908 -- semantic analysis can proceed.
8911 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8914 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8916 end Constrain_Concurrent
;
8918 ------------------------------------
8919 -- Constrain_Corresponding_Record --
8920 ------------------------------------
8922 function Constrain_Corresponding_Record
8923 (Prot_Subt
: Entity_Id
;
8924 Corr_Rec
: Entity_Id
;
8925 Related_Nod
: Node_Id
;
8926 Related_Id
: Entity_Id
) return Entity_Id
8928 T_Sub
: constant Entity_Id
:=
8929 Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
8932 Set_Etype
(T_Sub
, Corr_Rec
);
8933 Init_Size_Align
(T_Sub
);
8934 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
8935 Set_Is_Constrained
(T_Sub
, True);
8936 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
8937 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
8939 Conditional_Delay
(T_Sub
, Corr_Rec
);
8941 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
8942 Set_Discriminant_Constraint
8943 (T_Sub
, Discriminant_Constraint
(Prot_Subt
));
8944 Set_Stored_Constraint_From_Discriminant_Constraint
(T_Sub
);
8945 Create_Constrained_Components
8946 (T_Sub
, Related_Nod
, Corr_Rec
, Discriminant_Constraint
(T_Sub
));
8949 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
8952 end Constrain_Corresponding_Record
;
8954 -----------------------
8955 -- Constrain_Decimal --
8956 -----------------------
8958 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
8959 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8960 C
: constant Node_Id
:= Constraint
(S
);
8961 Loc
: constant Source_Ptr
:= Sloc
(C
);
8962 Range_Expr
: Node_Id
;
8963 Digits_Expr
: Node_Id
;
8968 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
8970 if Nkind
(C
) = N_Range_Constraint
then
8971 Range_Expr
:= Range_Expression
(C
);
8972 Digits_Val
:= Digits_Value
(T
);
8975 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
8976 Digits_Expr
:= Digits_Expression
(C
);
8977 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
8979 Check_Digits_Expression
(Digits_Expr
);
8980 Digits_Val
:= Expr_Value
(Digits_Expr
);
8982 if Digits_Val
> Digits_Value
(T
) then
8984 ("digits expression is incompatible with subtype", C
);
8985 Digits_Val
:= Digits_Value
(T
);
8988 if Present
(Range_Constraint
(C
)) then
8989 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
8991 Range_Expr
:= Empty
;
8995 Set_Etype
(Def_Id
, Base_Type
(T
));
8996 Set_Size_Info
(Def_Id
, (T
));
8997 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8998 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
8999 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
9000 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9001 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
9002 Set_Digits_Value
(Def_Id
, Digits_Val
);
9004 -- Manufacture range from given digits value if no range present
9006 if No
(Range_Expr
) then
9007 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
9011 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
9013 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
9016 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
9017 Set_Discrete_RM_Size
(Def_Id
);
9019 -- Unconditionally delay the freeze, since we cannot set size
9020 -- information in all cases correctly until the freeze point.
9022 Set_Has_Delayed_Freeze
(Def_Id
);
9023 end Constrain_Decimal
;
9025 ----------------------------------
9026 -- Constrain_Discriminated_Type --
9027 ----------------------------------
9029 procedure Constrain_Discriminated_Type
9030 (Def_Id
: Entity_Id
;
9032 Related_Nod
: Node_Id
;
9033 For_Access
: Boolean := False)
9035 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9038 Elist
: Elist_Id
:= New_Elmt_List
;
9040 procedure Fixup_Bad_Constraint
;
9041 -- This is called after finding a bad constraint, and after having
9042 -- posted an appropriate error message. The mission is to leave the
9043 -- entity T in as reasonable state as possible!
9045 --------------------------
9046 -- Fixup_Bad_Constraint --
9047 --------------------------
9049 procedure Fixup_Bad_Constraint
is
9051 -- Set a reasonable Ekind for the entity. For an incomplete type,
9052 -- we can't do much, but for other types, we can set the proper
9053 -- corresponding subtype kind.
9055 if Ekind
(T
) = E_Incomplete_Type
then
9056 Set_Ekind
(Def_Id
, Ekind
(T
));
9058 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
9061 Set_Etype
(Def_Id
, Any_Type
);
9062 Set_Error_Posted
(Def_Id
);
9063 end Fixup_Bad_Constraint
;
9065 -- Start of processing for Constrain_Discriminated_Type
9068 C
:= Constraint
(S
);
9070 -- A discriminant constraint is only allowed in a subtype indication,
9071 -- after a subtype mark. This subtype mark must denote either a type
9072 -- with discriminants, or an access type whose designated type is a
9073 -- type with discriminants. A discriminant constraint specifies the
9074 -- values of these discriminants (RM 3.7.2(5)).
9076 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
9078 if Ekind
(T
) in Access_Kind
then
9079 T
:= Designated_Type
(T
);
9082 -- Check that the type has visible discriminants. The type may be
9083 -- a private type with unknown discriminants whose full view has
9084 -- discriminants which are invisible.
9086 if not Has_Discriminants
(T
)
9088 (Has_Unknown_Discriminants
(T
)
9089 and then Is_Private_Type
(T
))
9091 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
9092 Fixup_Bad_Constraint
;
9095 elsif Is_Constrained
(E
)
9096 or else (Ekind
(E
) = E_Class_Wide_Subtype
9097 and then Present
(Discriminant_Constraint
(E
)))
9099 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
9100 Fixup_Bad_Constraint
;
9104 -- T may be an unconstrained subtype (e.g. a generic actual).
9105 -- Constraint applies to the base type.
9109 Elist
:= Build_Discriminant_Constraints
(T
, S
);
9111 -- If the list returned was empty we had an error in building the
9112 -- discriminant constraint. We have also already signalled an error
9113 -- in the incomplete type case
9115 if Is_Empty_Elmt_List
(Elist
) then
9116 Fixup_Bad_Constraint
;
9120 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
9121 end Constrain_Discriminated_Type
;
9123 ---------------------------
9124 -- Constrain_Enumeration --
9125 ---------------------------
9127 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
9128 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9129 C
: constant Node_Id
:= Constraint
(S
);
9132 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9134 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
9136 Set_Etype
(Def_Id
, Base_Type
(T
));
9137 Set_Size_Info
(Def_Id
, (T
));
9138 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9139 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9141 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9143 Set_Discrete_RM_Size
(Def_Id
);
9144 end Constrain_Enumeration
;
9146 ----------------------
9147 -- Constrain_Float --
9148 ----------------------
9150 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
9151 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9157 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
9159 Set_Etype
(Def_Id
, Base_Type
(T
));
9160 Set_Size_Info
(Def_Id
, (T
));
9161 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9163 -- Process the constraint
9165 C
:= Constraint
(S
);
9167 -- Digits constraint present
9169 if Nkind
(C
) = N_Digits_Constraint
then
9170 Check_Restriction
(No_Obsolescent_Features
, C
);
9172 if Warn_On_Obsolescent_Feature
then
9174 ("subtype digits constraint is an " &
9175 "obsolescent feature ('R'M 'J.3(8))?", C
);
9178 D
:= Digits_Expression
(C
);
9179 Analyze_And_Resolve
(D
, Any_Integer
);
9180 Check_Digits_Expression
(D
);
9181 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
9183 -- Check that digits value is in range. Obviously we can do this
9184 -- at compile time, but it is strictly a runtime check, and of
9185 -- course there is an ACVC test that checks this!
9187 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
9188 Error_Msg_Uint_1
:= Digits_Value
(T
);
9189 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
9191 Make_Raise_Constraint_Error
(Sloc
(D
),
9192 Reason
=> CE_Range_Check_Failed
);
9193 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9196 C
:= Range_Constraint
(C
);
9198 -- No digits constraint present
9201 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
9204 -- Range constraint present
9206 if Nkind
(C
) = N_Range_Constraint
then
9207 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9209 -- No range constraint present
9212 pragma Assert
(No
(C
));
9213 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9216 Set_Is_Constrained
(Def_Id
);
9217 end Constrain_Float
;
9219 ---------------------
9220 -- Constrain_Index --
9221 ---------------------
9223 procedure Constrain_Index
9226 Related_Nod
: Node_Id
;
9227 Related_Id
: Entity_Id
;
9232 R
: Node_Id
:= Empty
;
9233 T
: constant Entity_Id
:= Etype
(Index
);
9236 if Nkind
(S
) = N_Range
9238 (Nkind
(S
) = N_Attribute_Reference
9239 and then Attribute_Name
(S
) = Name_Range
)
9241 -- A Range attribute will transformed into N_Range by Resolve
9247 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
);
9249 if not Error_Posted
(S
)
9251 (Nkind
(S
) /= N_Range
9252 or else not Covers
(T
, (Etype
(Low_Bound
(S
))))
9253 or else not Covers
(T
, (Etype
(High_Bound
(S
)))))
9255 if Base_Type
(T
) /= Any_Type
9256 and then Etype
(Low_Bound
(S
)) /= Any_Type
9257 and then Etype
(High_Bound
(S
)) /= Any_Type
9259 Error_Msg_N
("range expected", S
);
9263 elsif Nkind
(S
) = N_Subtype_Indication
then
9265 -- The parser has verified that this is a discrete indication
9267 Resolve_Discrete_Subtype_Indication
(S
, T
);
9268 R
:= Range_Expression
(Constraint
(S
));
9270 elsif Nkind
(S
) = N_Discriminant_Association
then
9272 -- Syntactically valid in subtype indication
9274 Error_Msg_N
("invalid index constraint", S
);
9275 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9278 -- Subtype_Mark case, no anonymous subtypes to construct
9283 if Is_Entity_Name
(S
) then
9284 if not Is_Type
(Entity
(S
)) then
9285 Error_Msg_N
("expect subtype mark for index constraint", S
);
9287 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
9288 Wrong_Type
(S
, Base_Type
(T
));
9294 Error_Msg_N
("invalid index constraint", S
);
9295 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9301 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
9303 Set_Etype
(Def_Id
, Base_Type
(T
));
9305 if Is_Modular_Integer_Type
(T
) then
9306 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9308 elsif Is_Integer_Type
(T
) then
9309 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9312 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9313 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9316 Set_Size_Info
(Def_Id
, (T
));
9317 Set_RM_Size
(Def_Id
, RM_Size
(T
));
9318 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9320 Set_Scalar_Range
(Def_Id
, R
);
9322 Set_Etype
(S
, Def_Id
);
9323 Set_Discrete_RM_Size
(Def_Id
);
9324 end Constrain_Index
;
9326 -----------------------
9327 -- Constrain_Integer --
9328 -----------------------
9330 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
9331 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9332 C
: constant Node_Id
:= Constraint
(S
);
9335 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9337 if Is_Modular_Integer_Type
(T
) then
9338 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9340 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9343 Set_Etype
(Def_Id
, Base_Type
(T
));
9344 Set_Size_Info
(Def_Id
, (T
));
9345 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9346 Set_Discrete_RM_Size
(Def_Id
);
9347 end Constrain_Integer
;
9349 ------------------------------
9350 -- Constrain_Ordinary_Fixed --
9351 ------------------------------
9353 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
9354 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9360 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
9361 Set_Etype
(Def_Id
, Base_Type
(T
));
9362 Set_Size_Info
(Def_Id
, (T
));
9363 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9364 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9366 -- Process the constraint
9368 C
:= Constraint
(S
);
9370 -- Delta constraint present
9372 if Nkind
(C
) = N_Delta_Constraint
then
9373 Check_Restriction
(No_Obsolescent_Features
, C
);
9375 if Warn_On_Obsolescent_Feature
then
9377 ("subtype delta constraint is an " &
9378 "obsolescent feature ('R'M 'J.3(7))?");
9381 D
:= Delta_Expression
(C
);
9382 Analyze_And_Resolve
(D
, Any_Real
);
9383 Check_Delta_Expression
(D
);
9384 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
9386 -- Check that delta value is in range. Obviously we can do this
9387 -- at compile time, but it is strictly a runtime check, and of
9388 -- course there is an ACVC test that checks this!
9390 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
9391 Error_Msg_N
("?delta value is too small", D
);
9393 Make_Raise_Constraint_Error
(Sloc
(D
),
9394 Reason
=> CE_Range_Check_Failed
);
9395 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9398 C
:= Range_Constraint
(C
);
9400 -- No delta constraint present
9403 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9406 -- Range constraint present
9408 if Nkind
(C
) = N_Range_Constraint
then
9409 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9411 -- No range constraint present
9414 pragma Assert
(No
(C
));
9415 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9419 Set_Discrete_RM_Size
(Def_Id
);
9421 -- Unconditionally delay the freeze, since we cannot set size
9422 -- information in all cases correctly until the freeze point.
9424 Set_Has_Delayed_Freeze
(Def_Id
);
9425 end Constrain_Ordinary_Fixed
;
9427 ---------------------------
9428 -- Convert_Scalar_Bounds --
9429 ---------------------------
9431 procedure Convert_Scalar_Bounds
9433 Parent_Type
: Entity_Id
;
9434 Derived_Type
: Entity_Id
;
9437 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
9444 Lo
:= Build_Scalar_Bound
9445 (Type_Low_Bound
(Derived_Type
),
9446 Parent_Type
, Implicit_Base
);
9448 Hi
:= Build_Scalar_Bound
9449 (Type_High_Bound
(Derived_Type
),
9450 Parent_Type
, Implicit_Base
);
9457 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
9459 Set_Parent
(Rng
, N
);
9460 Set_Scalar_Range
(Derived_Type
, Rng
);
9462 -- Analyze the bounds
9464 Analyze_And_Resolve
(Lo
, Implicit_Base
);
9465 Analyze_And_Resolve
(Hi
, Implicit_Base
);
9467 -- Analyze the range itself, except that we do not analyze it if
9468 -- the bounds are real literals, and we have a fixed-point type.
9469 -- The reason for this is that we delay setting the bounds in this
9470 -- case till we know the final Small and Size values (see circuit
9471 -- in Freeze.Freeze_Fixed_Point_Type for further details).
9473 if Is_Fixed_Point_Type
(Parent_Type
)
9474 and then Nkind
(Lo
) = N_Real_Literal
9475 and then Nkind
(Hi
) = N_Real_Literal
9479 -- Here we do the analysis of the range
9481 -- Note: we do this manually, since if we do a normal Analyze and
9482 -- Resolve call, there are problems with the conversions used for
9483 -- the derived type range.
9486 Set_Etype
(Rng
, Implicit_Base
);
9487 Set_Analyzed
(Rng
, True);
9489 end Convert_Scalar_Bounds
;
9495 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
) is
9497 -- Initialize new full declaration entity by copying the pertinent
9498 -- fields of the corresponding private declaration entity.
9500 -- We temporarily set Ekind to a value appropriate for a type to
9501 -- avoid assert failures in Einfo from checking for setting type
9502 -- attributes on something that is not a type. Ekind (Priv) is an
9503 -- appropriate choice, since it allowed the attributes to be set
9504 -- in the first place. This Ekind value will be modified later.
9506 Set_Ekind
(Full
, Ekind
(Priv
));
9508 -- Also set Etype temporarily to Any_Type, again, in the absence
9509 -- of errors, it will be properly reset, and if there are errors,
9510 -- then we want a value of Any_Type to remain.
9512 Set_Etype
(Full
, Any_Type
);
9514 -- Now start copying attributes
9516 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
9518 if Has_Discriminants
(Full
) then
9519 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
9520 Set_Stored_Constraint
(Full
, Stored_Constraint
(Priv
));
9523 Set_First_Rep_Item
(Full
, First_Rep_Item
(Priv
));
9524 Set_Homonym
(Full
, Homonym
(Priv
));
9525 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
9526 Set_Is_Public
(Full
, Is_Public
(Priv
));
9527 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
9528 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
9530 Conditional_Delay
(Full
, Priv
);
9532 if Is_Tagged_Type
(Full
) then
9533 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
9535 if Priv
= Base_Type
(Priv
) then
9536 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
9540 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
9541 Set_Treat_As_Volatile
(Full
, Treat_As_Volatile
(Priv
));
9542 Set_Scope
(Full
, Scope
(Priv
));
9543 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
9544 Set_First_Entity
(Full
, First_Entity
(Priv
));
9545 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
9547 -- If access types have been recorded for later handling, keep them in
9548 -- the full view so that they get handled when the full view freeze
9549 -- node is expanded.
9551 if Present
(Freeze_Node
(Priv
))
9552 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
9554 Ensure_Freeze_Node
(Full
);
9555 Set_Access_Types_To_Process
9556 (Freeze_Node
(Full
),
9557 Access_Types_To_Process
(Freeze_Node
(Priv
)));
9560 -- Swap the two entities. Now Privat is the full type entity and
9561 -- Full is the private one. They will be swapped back at the end
9562 -- of the private part. This swapping ensures that the entity that
9563 -- is visible in the private part is the full declaration.
9565 Exchange_Entities
(Priv
, Full
);
9566 Append_Entity
(Full
, Scope
(Full
));
9569 -------------------------------------
9570 -- Copy_Array_Base_Type_Attributes --
9571 -------------------------------------
9573 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
9575 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
9576 Set_Component_Type
(T1
, Component_Type
(T2
));
9577 Set_Component_Size
(T1
, Component_Size
(T2
));
9578 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
9579 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
9580 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
9581 Set_Has_Task
(T1
, Has_Task
(T2
));
9582 Set_Is_Packed
(T1
, Is_Packed
(T2
));
9583 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
9584 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
9585 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
9586 end Copy_Array_Base_Type_Attributes
;
9588 -----------------------------------
9589 -- Copy_Array_Subtype_Attributes --
9590 -----------------------------------
9592 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
9594 Set_Size_Info
(T1
, T2
);
9596 Set_First_Index
(T1
, First_Index
(T2
));
9597 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
9598 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
9599 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
9600 Set_Treat_As_Volatile
(T1
, Treat_As_Volatile
(T2
));
9601 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
9602 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
9603 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
9604 Set_Convention
(T1
, Convention
(T2
));
9605 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
9606 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
9607 end Copy_Array_Subtype_Attributes
;
9609 -----------------------------------
9610 -- Create_Constrained_Components --
9611 -----------------------------------
9613 procedure Create_Constrained_Components
9615 Decl_Node
: Node_Id
;
9617 Constraints
: Elist_Id
)
9619 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
9620 Comp_List
: constant Elist_Id
:= New_Elmt_List
;
9621 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
9622 Assoc_List
: constant List_Id
:= New_List
;
9623 Discr_Val
: Elmt_Id
;
9627 Is_Static
: Boolean := True;
9629 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
9630 -- Collect parent type components that do not appear in a variant part
9632 procedure Create_All_Components
;
9633 -- Iterate over Comp_List to create the components of the subtype
9635 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
9636 -- Creates a new component from Old_Compon, copying all the fields from
9637 -- it, including its Etype, inserts the new component in the Subt entity
9638 -- chain and returns the new component.
9640 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
9641 -- If true, and discriminants are static, collect only components from
9642 -- variants selected by discriminant values.
9644 ------------------------------
9645 -- Collect_Fixed_Components --
9646 ------------------------------
9648 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
9650 -- Build association list for discriminants, and find components of the
9651 -- variant part selected by the values of the discriminants.
9653 Old_C
:= First_Discriminant
(Typ
);
9654 Discr_Val
:= First_Elmt
(Constraints
);
9655 while Present
(Old_C
) loop
9656 Append_To
(Assoc_List
,
9657 Make_Component_Association
(Loc
,
9658 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
9659 Expression
=> New_Copy
(Node
(Discr_Val
))));
9661 Next_Elmt
(Discr_Val
);
9662 Next_Discriminant
(Old_C
);
9665 -- The tag, and the possible parent and controller components
9666 -- are unconditionally in the subtype.
9668 if Is_Tagged_Type
(Typ
)
9669 or else Has_Controlled_Component
(Typ
)
9671 Old_C
:= First_Component
(Typ
);
9672 while Present
(Old_C
) loop
9673 if Chars
((Old_C
)) = Name_uTag
9674 or else Chars
((Old_C
)) = Name_uParent
9675 or else Chars
((Old_C
)) = Name_uController
9677 Append_Elmt
(Old_C
, Comp_List
);
9680 Next_Component
(Old_C
);
9683 end Collect_Fixed_Components
;
9685 ---------------------------
9686 -- Create_All_Components --
9687 ---------------------------
9689 procedure Create_All_Components
is
9693 Comp
:= First_Elmt
(Comp_List
);
9694 while Present
(Comp
) loop
9695 Old_C
:= Node
(Comp
);
9696 New_C
:= Create_Component
(Old_C
);
9700 Constrain_Component_Type
9701 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9702 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9706 end Create_All_Components
;
9708 ----------------------
9709 -- Create_Component --
9710 ----------------------
9712 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
9713 New_Compon
: constant Entity_Id
:= New_Copy
(Old_Compon
);
9716 -- Set the parent so we have a proper link for freezing etc. This is
9717 -- not a real parent pointer, since of course our parent does not own
9718 -- up to us and reference us, we are an illegitimate child of the
9721 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
9723 -- If the old component's Esize was already determined and is a
9724 -- static value, then the new component simply inherits it. Otherwise
9725 -- the old component's size may require run-time determination, but
9726 -- the new component's size still might be statically determinable
9727 -- (if, for example it has a static constraint). In that case we want
9728 -- Layout_Type to recompute the component's size, so we reset its
9729 -- size and positional fields.
9731 if Frontend_Layout_On_Target
9732 and then not Known_Static_Esize
(Old_Compon
)
9734 Set_Esize
(New_Compon
, Uint_0
);
9735 Init_Normalized_First_Bit
(New_Compon
);
9736 Init_Normalized_Position
(New_Compon
);
9737 Init_Normalized_Position_Max
(New_Compon
);
9740 -- We do not want this node marked as Comes_From_Source, since
9741 -- otherwise it would get first class status and a separate cross-
9742 -- reference line would be generated. Illegitimate children do not
9743 -- rate such recognition.
9745 Set_Comes_From_Source
(New_Compon
, False);
9747 -- But it is a real entity, and a birth certificate must be properly
9748 -- registered by entering it into the entity list.
9750 Enter_Name
(New_Compon
);
9753 end Create_Component
;
9755 -----------------------
9756 -- Is_Variant_Record --
9757 -----------------------
9759 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
9761 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
9762 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
9763 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
9765 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
9766 end Is_Variant_Record
;
9768 -- Start of processing for Create_Constrained_Components
9771 pragma Assert
(Subt
/= Base_Type
(Subt
));
9772 pragma Assert
(Typ
= Base_Type
(Typ
));
9774 Set_First_Entity
(Subt
, Empty
);
9775 Set_Last_Entity
(Subt
, Empty
);
9777 -- Check whether constraint is fully static, in which case we can
9778 -- optimize the list of components.
9780 Discr_Val
:= First_Elmt
(Constraints
);
9781 while Present
(Discr_Val
) loop
9782 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
9787 Next_Elmt
(Discr_Val
);
9792 -- Inherit the discriminants of the parent type
9794 Old_C
:= First_Discriminant
(Typ
);
9795 while Present
(Old_C
) loop
9796 New_C
:= Create_Component
(Old_C
);
9797 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9798 Next_Discriminant
(Old_C
);
9802 and then Is_Variant_Record
(Typ
)
9804 Collect_Fixed_Components
(Typ
);
9808 Component_List
(Type_Definition
(Parent
(Typ
))),
9809 Governed_By
=> Assoc_List
,
9811 Report_Errors
=> Errors
);
9812 pragma Assert
(not Errors
);
9814 Create_All_Components
;
9816 -- If the subtype declaration is created for a tagged type derivation
9817 -- with constraints, we retrieve the record definition of the parent
9818 -- type to select the components of the proper variant.
9821 and then Is_Tagged_Type
(Typ
)
9822 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
9824 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
9825 and then Is_Variant_Record
(Parent_Type
)
9827 Collect_Fixed_Components
(Typ
);
9831 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
9832 Governed_By
=> Assoc_List
,
9834 Report_Errors
=> Errors
);
9835 pragma Assert
(not Errors
);
9837 -- If the tagged derivation has a type extension, collect all the
9838 -- new components therein.
9841 (Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
9843 Old_C
:= First_Component
(Typ
);
9844 while Present
(Old_C
) loop
9845 if Original_Record_Component
(Old_C
) = Old_C
9846 and then Chars
(Old_C
) /= Name_uTag
9847 and then Chars
(Old_C
) /= Name_uParent
9848 and then Chars
(Old_C
) /= Name_uController
9850 Append_Elmt
(Old_C
, Comp_List
);
9853 Next_Component
(Old_C
);
9857 Create_All_Components
;
9860 -- If discriminants are not static, or if this is a multi-level type
9861 -- extension, we have to include all components of the parent type.
9863 Old_C
:= First_Component
(Typ
);
9864 while Present
(Old_C
) loop
9865 New_C
:= Create_Component
(Old_C
);
9869 Constrain_Component_Type
9870 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9871 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9873 Next_Component
(Old_C
);
9878 end Create_Constrained_Components
;
9880 ------------------------------------------
9881 -- Decimal_Fixed_Point_Type_Declaration --
9882 ------------------------------------------
9884 procedure Decimal_Fixed_Point_Type_Declaration
9888 Loc
: constant Source_Ptr
:= Sloc
(Def
);
9889 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
9890 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
9891 Implicit_Base
: Entity_Id
;
9897 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
9900 Check_Restriction
(No_Fixed_Point
, Def
);
9902 -- Create implicit base type
9905 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
9906 Set_Etype
(Implicit_Base
, Implicit_Base
);
9908 -- Analyze and process delta expression
9910 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
9912 Check_Delta_Expression
(Delta_Expr
);
9913 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
9915 -- Check delta is power of 10, and determine scale value from it
9921 Scale_Val
:= Uint_0
;
9924 if Val
< Ureal_1
then
9925 while Val
< Ureal_1
loop
9926 Val
:= Val
* Ureal_10
;
9927 Scale_Val
:= Scale_Val
+ 1;
9930 if Scale_Val
> 18 then
9931 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
9932 Scale_Val
:= UI_From_Int
(+18);
9936 while Val
> Ureal_1
loop
9937 Val
:= Val
/ Ureal_10
;
9938 Scale_Val
:= Scale_Val
- 1;
9941 if Scale_Val
< -18 then
9942 Error_Msg_N
("scale is less than minimum value of -18", Def
);
9943 Scale_Val
:= UI_From_Int
(-18);
9947 if Val
/= Ureal_1
then
9948 Error_Msg_N
("delta expression must be a power of 10", Def
);
9949 Delta_Val
:= Ureal_10
** (-Scale_Val
);
9953 -- Set delta, scale and small (small = delta for decimal type)
9955 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
9956 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
9957 Set_Small_Value
(Implicit_Base
, Delta_Val
);
9959 -- Analyze and process digits expression
9961 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
9962 Check_Digits_Expression
(Digs_Expr
);
9963 Digs_Val
:= Expr_Value
(Digs_Expr
);
9965 if Digs_Val
> 18 then
9966 Digs_Val
:= UI_From_Int
(+18);
9967 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
9970 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
9971 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
9973 -- Set range of base type from digits value for now. This will be
9974 -- expanded to represent the true underlying base range by Freeze.
9976 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
9978 -- Set size to zero for now, size will be set at freeze time. We have
9979 -- to do this for ordinary fixed-point, because the size depends on
9980 -- the specified small, and we might as well do the same for decimal
9983 Init_Size_Align
(Implicit_Base
);
9985 -- If there are bounds given in the declaration use them as the
9986 -- bounds of the first named subtype.
9988 if Present
(Real_Range_Specification
(Def
)) then
9990 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
9991 Low
: constant Node_Id
:= Low_Bound
(RRS
);
9992 High
: constant Node_Id
:= High_Bound
(RRS
);
9997 Analyze_And_Resolve
(Low
, Any_Real
);
9998 Analyze_And_Resolve
(High
, Any_Real
);
9999 Check_Real_Bound
(Low
);
10000 Check_Real_Bound
(High
);
10001 Low_Val
:= Expr_Value_R
(Low
);
10002 High_Val
:= Expr_Value_R
(High
);
10004 if Low_Val
< (-Bound_Val
) then
10006 ("range low bound too small for digits value", Low
);
10007 Low_Val
:= -Bound_Val
;
10010 if High_Val
> Bound_Val
then
10012 ("range high bound too large for digits value", High
);
10013 High_Val
:= Bound_Val
;
10016 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
10019 -- If no explicit range, use range that corresponds to given
10020 -- digits value. This will end up as the final range for the
10024 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
10027 -- Complete entity for first subtype
10029 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
10030 Set_Etype
(T
, Implicit_Base
);
10031 Set_Size_Info
(T
, Implicit_Base
);
10032 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
10033 Set_Digits_Value
(T
, Digs_Val
);
10034 Set_Delta_Value
(T
, Delta_Val
);
10035 Set_Small_Value
(T
, Delta_Val
);
10036 Set_Scale_Value
(T
, Scale_Val
);
10037 Set_Is_Constrained
(T
);
10038 end Decimal_Fixed_Point_Type_Declaration
;
10040 ---------------------------------
10041 -- Derive_Interface_Subprogram --
10042 ---------------------------------
10044 procedure Derive_Interface_Subprograms
(Derived_Type
: Entity_Id
) is
10046 procedure Do_Derivation
(T
: Entity_Id
);
10047 -- This inner subprograms is used to climb to the ancestors.
10048 -- It is needed to add the derivations to the Derived_Type.
10050 procedure Do_Derivation
(T
: Entity_Id
) is
10051 Etyp
: constant Entity_Id
:= Etype
(T
);
10056 and then Is_Interface
(Etyp
)
10058 Do_Derivation
(Etyp
);
10061 if Present
(Abstract_Interfaces
(T
))
10062 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(T
))
10064 AI
:= First_Elmt
(Abstract_Interfaces
(T
));
10065 while Present
(AI
) loop
10066 if not Is_Ancestor
(Node
(AI
), Derived_Type
) then
10068 (Parent_Type
=> Node
(AI
),
10069 Derived_Type
=> Derived_Type
,
10070 No_Predefined_Prims
=> True);
10079 Do_Derivation
(Derived_Type
);
10081 -- At this point the list of primitive operations of Derived_Type
10082 -- contains the entities corresponding to all the subprograms of all the
10083 -- implemented interfaces. If N interfaces have subprograms with the
10084 -- same profile we have N entities in this list because each one must be
10085 -- allocated in its corresponding virtual table.
10087 -- Its alias attribute references its original interface subprogram.
10088 -- When overridden, the alias attribute is later saved in the
10089 -- Abstract_Interface_Alias attribute.
10091 end Derive_Interface_Subprograms
;
10093 -----------------------
10094 -- Derive_Subprogram --
10095 -----------------------
10097 procedure Derive_Subprogram
10098 (New_Subp
: in out Entity_Id
;
10099 Parent_Subp
: Entity_Id
;
10100 Derived_Type
: Entity_Id
;
10101 Parent_Type
: Entity_Id
;
10102 Actual_Subp
: Entity_Id
:= Empty
)
10104 Formal
: Entity_Id
;
10105 New_Formal
: Entity_Id
;
10106 Visible_Subp
: Entity_Id
:= Parent_Subp
;
10108 function Is_Private_Overriding
return Boolean;
10109 -- If Subp is a private overriding of a visible operation, the in-
10110 -- herited operation derives from the overridden op (even though
10111 -- its body is the overriding one) and the inherited operation is
10112 -- visible now. See sem_disp to see the details of the handling of
10113 -- the overridden subprogram, which is removed from the list of
10114 -- primitive operations of the type. The overridden subprogram is
10115 -- saved locally in Visible_Subp, and used to diagnose abstract
10116 -- operations that need overriding in the derived type.
10118 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
10119 -- When the type is an anonymous access type, create a new access type
10120 -- designating the derived type.
10122 procedure Set_Derived_Name
;
10123 -- This procedure sets the appropriate Chars name for New_Subp. This
10124 -- is normally just a copy of the parent name. An exception arises for
10125 -- type support subprograms, where the name is changed to reflect the
10126 -- name of the derived type, e.g. if type foo is derived from type bar,
10127 -- then a procedure barDA is derived with a name fooDA.
10129 ---------------------------
10130 -- Is_Private_Overriding --
10131 ---------------------------
10133 function Is_Private_Overriding
return Boolean is
10137 -- The visible operation that is overridden is a homonym of the
10138 -- parent subprogram. We scan the homonym chain to find the one
10139 -- whose alias is the subprogram we are deriving.
10141 Prev
:= Current_Entity
(Parent_Subp
);
10142 while Present
(Prev
) loop
10143 if Is_Dispatching_Operation
(Parent_Subp
)
10144 and then Present
(Prev
)
10145 and then Ekind
(Prev
) = Ekind
(Parent_Subp
)
10146 and then Alias
(Prev
) = Parent_Subp
10147 and then Scope
(Parent_Subp
) = Scope
(Prev
)
10149 (not Is_Hidden
(Prev
)
10152 -- Ada 2005 (AI-251): Entities associated with overridden
10153 -- interface subprograms are always marked as hidden; in
10154 -- this case the field abstract_interface_alias references
10155 -- the original entity (cf. override_dispatching_operation).
10157 (Atree
.Present
(Abstract_Interface_Alias
(Prev
))
10158 and then not Is_Hidden
(Abstract_Interface_Alias
(Prev
))))
10160 Visible_Subp
:= Prev
;
10164 Prev
:= Homonym
(Prev
);
10168 end Is_Private_Overriding
;
10174 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
10175 Acc_Type
: Entity_Id
;
10177 Par
: constant Node_Id
:= Parent
(Derived_Type
);
10180 -- When the type is an anonymous access type, create a new access
10181 -- type designating the derived type. This itype must be elaborated
10182 -- at the point of the derivation, not on subsequent calls that may
10183 -- be out of the proper scope for Gigi, so we insert a reference to
10184 -- it after the derivation.
10186 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
10188 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
10191 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
10192 and then Present
(Full_View
(Desig_Typ
))
10193 and then not Is_Private_Type
(Parent_Type
)
10195 Desig_Typ
:= Full_View
(Desig_Typ
);
10198 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
) then
10199 Acc_Type
:= New_Copy
(Etype
(Id
));
10200 Set_Etype
(Acc_Type
, Acc_Type
);
10201 Set_Scope
(Acc_Type
, New_Subp
);
10203 -- Compute size of anonymous access type
10205 if Is_Array_Type
(Desig_Typ
)
10206 and then not Is_Constrained
(Desig_Typ
)
10208 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
10210 Init_Size
(Acc_Type
, System_Address_Size
);
10213 Init_Alignment
(Acc_Type
);
10214 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
10216 Set_Etype
(New_Id
, Acc_Type
);
10217 Set_Scope
(New_Id
, New_Subp
);
10219 -- Create a reference to it
10221 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
10222 Set_Itype
(IR
, Acc_Type
);
10223 Insert_After
(Parent
(Derived_Type
), IR
);
10226 Set_Etype
(New_Id
, Etype
(Id
));
10230 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
10232 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
10233 and then Present
(Full_View
(Etype
(Id
)))
10235 Base_Type
(Full_View
(Etype
(Id
))) = Base_Type
(Parent_Type
))
10237 -- Constraint checks on formals are generated during expansion,
10238 -- based on the signature of the original subprogram. The bounds
10239 -- of the derived type are not relevant, and thus we can use
10240 -- the base type for the formals. However, the return type may be
10241 -- used in a context that requires that the proper static bounds
10242 -- be used (a case statement, for example) and for those cases
10243 -- we must use the derived type (first subtype), not its base.
10245 -- If the derived_type_definition has no constraints, we know that
10246 -- the derived type has the same constraints as the first subtype
10247 -- of the parent, and we can also use it rather than its base,
10248 -- which can lead to more efficient code.
10250 if Etype
(Id
) = Parent_Type
then
10251 if Is_Scalar_Type
(Parent_Type
)
10253 Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
)
10255 Set_Etype
(New_Id
, Derived_Type
);
10257 elsif Nkind
(Par
) = N_Full_Type_Declaration
10259 Nkind
(Type_Definition
(Par
)) = N_Derived_Type_Definition
10262 (Subtype_Indication
(Type_Definition
(Par
)))
10264 Set_Etype
(New_Id
, Derived_Type
);
10267 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10271 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10275 Set_Etype
(New_Id
, Etype
(Id
));
10279 ----------------------
10280 -- Set_Derived_Name --
10281 ----------------------
10283 procedure Set_Derived_Name
is
10284 Nm
: constant TSS_Name_Type
:= Get_TSS_Name
(Parent_Subp
);
10286 if Nm
= TSS_Null
then
10287 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
10289 Set_Chars
(New_Subp
, Make_TSS_Name
(Base_Type
(Derived_Type
), Nm
));
10291 end Set_Derived_Name
;
10293 -- Start of processing for Derive_Subprogram
10297 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
10298 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
10300 -- Check whether the inherited subprogram is a private operation that
10301 -- should be inherited but not yet made visible. Such subprograms can
10302 -- become visible at a later point (e.g., the private part of a public
10303 -- child unit) via Declare_Inherited_Private_Subprograms. If the
10304 -- following predicate is true, then this is not such a private
10305 -- operation and the subprogram simply inherits the name of the parent
10306 -- subprogram. Note the special check for the names of controlled
10307 -- operations, which are currently exempted from being inherited with
10308 -- a hidden name because they must be findable for generation of
10309 -- implicit run-time calls.
10311 if not Is_Hidden
(Parent_Subp
)
10312 or else Is_Internal
(Parent_Subp
)
10313 or else Is_Private_Overriding
10314 or else Is_Internal_Name
(Chars
(Parent_Subp
))
10315 or else Chars
(Parent_Subp
) = Name_Initialize
10316 or else Chars
(Parent_Subp
) = Name_Adjust
10317 or else Chars
(Parent_Subp
) = Name_Finalize
10321 -- If parent is hidden, this can be a regular derivation if the
10322 -- parent is immediately visible in a non-instantiating context,
10323 -- or if we are in the private part of an instance. This test
10324 -- should still be refined ???
10326 -- The test for In_Instance_Not_Visible avoids inheriting the derived
10327 -- operation as a non-visible operation in cases where the parent
10328 -- subprogram might not be visible now, but was visible within the
10329 -- original generic, so it would be wrong to make the inherited
10330 -- subprogram non-visible now. (Not clear if this test is fully
10331 -- correct; are there any cases where we should declare the inherited
10332 -- operation as not visible to avoid it being overridden, e.g., when
10333 -- the parent type is a generic actual with private primitives ???)
10335 -- (they should be treated the same as other private inherited
10336 -- subprograms, but it's not clear how to do this cleanly). ???
10338 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
10339 and then Is_Immediately_Visible
(Parent_Subp
)
10340 and then not In_Instance
)
10341 or else In_Instance_Not_Visible
10345 -- The type is inheriting a private operation, so enter
10346 -- it with a special name so it can't be overridden.
10349 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
10352 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
10353 Replace_Type
(Parent_Subp
, New_Subp
);
10354 Conditional_Delay
(New_Subp
, Parent_Subp
);
10356 Formal
:= First_Formal
(Parent_Subp
);
10357 while Present
(Formal
) loop
10358 New_Formal
:= New_Copy
(Formal
);
10360 -- Normally we do not go copying parents, but in the case of
10361 -- formals, we need to link up to the declaration (which is the
10362 -- parameter specification), and it is fine to link up to the
10363 -- original formal's parameter specification in this case.
10365 Set_Parent
(New_Formal
, Parent
(Formal
));
10367 Append_Entity
(New_Formal
, New_Subp
);
10369 Replace_Type
(Formal
, New_Formal
);
10370 Next_Formal
(Formal
);
10373 -- If this derivation corresponds to a tagged generic actual, then
10374 -- primitive operations rename those of the actual. Otherwise the
10375 -- primitive operations rename those of the parent type, If the
10376 -- parent renames an intrinsic operator, so does the new subprogram.
10377 -- We except concatenation, which is always properly typed, and does
10378 -- not get expanded as other intrinsic operations.
10380 if No
(Actual_Subp
) then
10381 if Is_Intrinsic_Subprogram
(Parent_Subp
) then
10382 Set_Is_Intrinsic_Subprogram
(New_Subp
);
10384 if Present
(Alias
(Parent_Subp
))
10385 and then Chars
(Parent_Subp
) /= Name_Op_Concat
10387 Set_Alias
(New_Subp
, Alias
(Parent_Subp
));
10389 Set_Alias
(New_Subp
, Parent_Subp
);
10393 Set_Alias
(New_Subp
, Parent_Subp
);
10397 Set_Alias
(New_Subp
, Actual_Subp
);
10400 -- Derived subprograms of a tagged type must inherit the convention
10401 -- of the parent subprogram (a requirement of AI-117). Derived
10402 -- subprograms of untagged types simply get convention Ada by default.
10404 if Is_Tagged_Type
(Derived_Type
) then
10405 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
10408 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
10409 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
10411 if Ekind
(Parent_Subp
) = E_Procedure
then
10412 Set_Is_Valued_Procedure
10413 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
10416 -- A derived function with a controlling result is abstract. If the
10417 -- Derived_Type is a nonabstract formal generic derived type, then
10418 -- inherited operations are not abstract: the required check is done at
10419 -- instantiation time. If the derivation is for a generic actual, the
10420 -- function is not abstract unless the actual is.
10422 if Is_Generic_Type
(Derived_Type
)
10423 and then not Is_Abstract
(Derived_Type
)
10427 elsif Is_Abstract
(Alias
(New_Subp
))
10428 or else (Is_Tagged_Type
(Derived_Type
)
10429 and then Etype
(New_Subp
) = Derived_Type
10430 and then No
(Actual_Subp
))
10432 Set_Is_Abstract
(New_Subp
);
10434 -- Finally, if the parent type is abstract we must verify that all
10435 -- inherited operations are either non-abstract or overridden, or
10436 -- that the derived type itself is abstract (this check is performed
10437 -- at the end of a package declaration, in Check_Abstract_Overriding).
10438 -- A private overriding in the parent type will not be visible in the
10439 -- derivation if we are not in an inner package or in a child unit of
10440 -- the parent type, in which case the abstractness of the inherited
10441 -- operation is carried to the new subprogram.
10443 elsif Is_Abstract
(Parent_Type
)
10444 and then not In_Open_Scopes
(Scope
(Parent_Type
))
10445 and then Is_Private_Overriding
10446 and then Is_Abstract
(Visible_Subp
)
10448 Set_Alias
(New_Subp
, Visible_Subp
);
10449 Set_Is_Abstract
(New_Subp
);
10452 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
10454 -- Check for case of a derived subprogram for the instantiation of a
10455 -- formal derived tagged type, if so mark the subprogram as dispatching
10456 -- and inherit the dispatching attributes of the parent subprogram. The
10457 -- derived subprogram is effectively renaming of the actual subprogram,
10458 -- so it needs to have the same attributes as the actual.
10460 if Present
(Actual_Subp
)
10461 and then Is_Dispatching_Operation
(Parent_Subp
)
10463 Set_Is_Dispatching_Operation
(New_Subp
);
10464 if Present
(DTC_Entity
(Parent_Subp
)) then
10465 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
10466 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
10470 -- Indicate that a derived subprogram does not require a body and that
10471 -- it does not require processing of default expressions.
10473 Set_Has_Completion
(New_Subp
);
10474 Set_Default_Expressions_Processed
(New_Subp
);
10476 if Ekind
(New_Subp
) = E_Function
then
10477 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
10479 end Derive_Subprogram
;
10481 ------------------------
10482 -- Derive_Subprograms --
10483 ------------------------
10485 procedure Derive_Subprograms
10486 (Parent_Type
: Entity_Id
;
10487 Derived_Type
: Entity_Id
;
10488 Generic_Actual
: Entity_Id
:= Empty
;
10489 No_Predefined_Prims
: Boolean := False)
10491 Op_List
: constant Elist_Id
:=
10492 Collect_Primitive_Operations
(Parent_Type
);
10493 Act_List
: Elist_Id
;
10494 Act_Elmt
: Elmt_Id
;
10496 Is_Predef
: Boolean;
10498 New_Subp
: Entity_Id
:= Empty
;
10499 Parent_Base
: Entity_Id
;
10502 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
10503 and then Has_Discriminants
(Parent_Type
)
10504 and then Present
(Full_View
(Parent_Type
))
10506 Parent_Base
:= Full_View
(Parent_Type
);
10508 Parent_Base
:= Parent_Type
;
10511 if Present
(Generic_Actual
) then
10512 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
10513 Act_Elmt
:= First_Elmt
(Act_List
);
10515 Act_Elmt
:= No_Elmt
;
10518 -- Literals are derived earlier in the process of building the derived
10519 -- type, and are skipped here.
10521 Elmt
:= First_Elmt
(Op_List
);
10522 while Present
(Elmt
) loop
10523 Subp
:= Node
(Elmt
);
10525 if Ekind
(Subp
) /= E_Enumeration_Literal
then
10527 Is_Dispatching_Operation
(Subp
)
10528 and then Is_Predefined_Dispatching_Operation
(Subp
);
10530 if No_Predefined_Prims
and then Is_Predef
then
10533 -- We don't need to derive alias entities associated with
10534 -- abstract interfaces
10536 elsif Is_Dispatching_Operation
(Subp
)
10537 and then Present
(Alias
(Subp
))
10538 and then Present
(Abstract_Interface_Alias
(Subp
))
10542 elsif No
(Generic_Actual
) then
10544 (New_Subp
, Subp
, Derived_Type
, Parent_Base
);
10547 Derive_Subprogram
(New_Subp
, Subp
,
10548 Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
10549 Next_Elmt
(Act_Elmt
);
10555 end Derive_Subprograms
;
10557 --------------------------------
10558 -- Derived_Standard_Character --
10559 --------------------------------
10561 procedure Derived_Standard_Character
10563 Parent_Type
: Entity_Id
;
10564 Derived_Type
: Entity_Id
)
10566 Loc
: constant Source_Ptr
:= Sloc
(N
);
10567 Def
: constant Node_Id
:= Type_Definition
(N
);
10568 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10569 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
10570 Implicit_Base
: constant Entity_Id
:=
10572 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
10578 Discard_Node
(Process_Subtype
(Indic
, N
));
10580 Set_Etype
(Implicit_Base
, Parent_Base
);
10581 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
10582 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
10584 Set_Is_Character_Type
(Implicit_Base
, True);
10585 Set_Has_Delayed_Freeze
(Implicit_Base
);
10587 -- The bounds of the implicit base are the bounds of the parent base.
10588 -- Note that their type is the parent base.
10590 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
10591 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
10593 Set_Scalar_Range
(Implicit_Base
,
10596 High_Bound
=> Hi
));
10598 Conditional_Delay
(Derived_Type
, Parent_Type
);
10600 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
10601 Set_Etype
(Derived_Type
, Implicit_Base
);
10602 Set_Size_Info
(Derived_Type
, Parent_Type
);
10604 if Unknown_RM_Size
(Derived_Type
) then
10605 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
10608 Set_Is_Character_Type
(Derived_Type
, True);
10610 if Nkind
(Indic
) /= N_Subtype_Indication
then
10612 -- If no explicit constraint, the bounds are those
10613 -- of the parent type.
10615 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
10616 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
10617 Set_Scalar_Range
(Derived_Type
, Make_Range
(Loc
, Lo
, Hi
));
10620 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
10622 -- Because the implicit base is used in the conversion of the bounds,
10623 -- we have to freeze it now. This is similar to what is done for
10624 -- numeric types, and it equally suspicious, but otherwise a non-
10625 -- static bound will have a reference to an unfrozen type, which is
10626 -- rejected by Gigi (???).
10628 Freeze_Before
(N
, Implicit_Base
);
10629 end Derived_Standard_Character
;
10631 ------------------------------
10632 -- Derived_Type_Declaration --
10633 ------------------------------
10635 procedure Derived_Type_Declaration
10638 Is_Completion
: Boolean)
10640 Def
: constant Node_Id
:= Type_Definition
(N
);
10641 Iface_Def
: Node_Id
;
10642 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10643 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
10644 Parent_Type
: Entity_Id
;
10645 Parent_Scope
: Entity_Id
;
10648 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean;
10649 -- Check whether the parent type is a generic formal, or derives
10650 -- directly or indirectly from one.
10652 ------------------------
10653 -- Comes_From_Generic --
10654 ------------------------
10656 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean is
10658 if Is_Generic_Type
(Typ
) then
10661 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
10664 elsif Is_Private_Type
(Typ
)
10665 and then Present
(Full_View
(Typ
))
10666 and then Is_Generic_Type
(Root_Type
(Full_View
(Typ
)))
10670 elsif Is_Generic_Actual_Type
(Typ
) then
10676 end Comes_From_Generic
;
10678 -- Start of processing for Derived_Type_Declaration
10681 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
10683 -- Ada 2005 (AI-251): In case of interface derivation check that the
10684 -- parent is also an interface.
10686 if Interface_Present
(Def
) then
10687 if not Is_Interface
(Parent_Type
) then
10688 Error_Msg_NE
("(Ada 2005) & must be an interface",
10689 Indic
, Parent_Type
);
10692 Iface_Def
:= Type_Definition
(Parent
(Parent_Type
));
10694 -- Ada 2005 (AI-251): Limited interfaces can only inherit from
10695 -- other limited interfaces.
10697 if Limited_Present
(Def
) then
10698 if Limited_Present
(Iface_Def
) then
10701 elsif Protected_Present
(Iface_Def
) then
10702 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10703 " inherit from protected interface", Indic
);
10705 elsif Synchronized_Present
(Iface_Def
) then
10706 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10707 " inherit from synchronized interface", Indic
);
10709 elsif Task_Present
(Iface_Def
) then
10710 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10711 " inherit from task interface", Indic
);
10714 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10715 " inherit from non-limited interface", Indic
);
10718 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
10719 -- from non-limited or limited interfaces.
10721 elsif not Protected_Present
(Def
)
10722 and then not Synchronized_Present
(Def
)
10723 and then not Task_Present
(Def
)
10725 if Limited_Present
(Iface_Def
) then
10728 elsif Protected_Present
(Iface_Def
) then
10729 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10730 " inherit from protected interface", Indic
);
10732 elsif Synchronized_Present
(Iface_Def
) then
10733 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10734 " inherit from synchronized interface", Indic
);
10736 elsif Task_Present
(Iface_Def
) then
10737 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10738 " inherit from task interface", Indic
);
10747 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
10750 if Is_Tagged_Type
(Parent_Type
)
10751 and then Is_Non_Empty_List
(Interface_List
(Def
))
10758 Intf
:= First
(Interface_List
(Def
));
10759 while Present
(Intf
) loop
10760 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
10762 if not Is_Interface
(T
) then
10763 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
10765 elsif Limited_Present
(Def
)
10766 and then not Is_Limited_Interface
(T
)
10769 ("progenitor interface& of limited type must be limited",
10778 if Parent_Type
= Any_Type
10779 or else Etype
(Parent_Type
) = Any_Type
10780 or else (Is_Class_Wide_Type
(Parent_Type
)
10781 and then Etype
(Parent_Type
) = T
)
10783 -- If Parent_Type is undefined or illegal, make new type into a
10784 -- subtype of Any_Type, and set a few attributes to prevent cascaded
10785 -- errors. If this is a self-definition, emit error now.
10788 or else T
= Etype
(Parent_Type
)
10790 Error_Msg_N
("type cannot be used in its own definition", Indic
);
10793 Set_Ekind
(T
, Ekind
(Parent_Type
));
10794 Set_Etype
(T
, Any_Type
);
10795 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
10797 if Is_Tagged_Type
(T
) then
10798 Set_Primitive_Operations
(T
, New_Elmt_List
);
10804 -- Ada 2005 (AI-251): The case in which the parent of the full-view is
10805 -- an interface is special because the list of interfaces in the full
10806 -- view can be given in any order. For example:
10808 -- type A is interface;
10809 -- type B is interface and A;
10810 -- type D is new B with private;
10812 -- type D is new A and B with null record; -- 1 --
10814 -- In this case we perform the following transformation of -1-:
10816 -- type D is new B and A with null record;
10818 -- If the parent of the full-view covers the parent of the partial-view
10819 -- we have two possible cases:
10821 -- 1) They have the same parent
10822 -- 2) The parent of the full-view implements some further interfaces
10824 -- In both cases we do not need to perform the transformation. In the
10825 -- first case the source program is correct and the transformation is
10826 -- not needed; in the second case the source program does not fulfill
10827 -- the no-hidden interfaces rule (AI-396) and the error will be reported
10830 -- This transformation not only simplifies the rest of the analysis of
10831 -- this type declaration but also simplifies the correct generation of
10832 -- the object layout to the expander.
10834 if In_Private_Part
(Current_Scope
)
10835 and then Is_Interface
(Parent_Type
)
10839 Partial_View
: Entity_Id
;
10840 Partial_View_Parent
: Entity_Id
;
10841 New_Iface
: Node_Id
;
10844 -- Look for the associated private type declaration
10846 Partial_View
:= First_Entity
(Current_Scope
);
10848 exit when not Present
(Partial_View
)
10849 or else (Has_Private_Declaration
(Partial_View
)
10850 and then Full_View
(Partial_View
) = T
);
10852 Next_Entity
(Partial_View
);
10855 -- If the partial view was not found then the source code has
10856 -- errors and the transformation is not needed.
10858 if Present
(Partial_View
) then
10859 Partial_View_Parent
:= Etype
(Partial_View
);
10861 -- If the parent of the full-view covers the parent of the
10862 -- partial-view we have nothing else to do.
10864 if Interface_Present_In_Ancestor
10865 (Parent_Type
, Partial_View_Parent
)
10869 -- Traverse the list of interfaces of the full-view to look
10870 -- for the parent of the partial-view and perform the tree
10874 Iface
:= First
(Interface_List
(Def
));
10875 while Present
(Iface
) loop
10876 if Etype
(Iface
) = Etype
(Partial_View
) then
10877 Rewrite
(Subtype_Indication
(Def
),
10878 New_Copy
(Subtype_Indication
10879 (Parent
(Partial_View
))));
10881 New_Iface
:= Make_Identifier
(Sloc
(N
),
10882 Chars
(Parent_Type
));
10883 Append
(New_Iface
, Interface_List
(Def
));
10885 -- Analyze the transformed code
10887 Derived_Type_Declaration
(T
, N
, Is_Completion
);
10898 -- Only composite types other than array types are allowed to have
10901 if Present
(Discriminant_Specifications
(N
))
10902 and then (Is_Elementary_Type
(Parent_Type
)
10903 or else Is_Array_Type
(Parent_Type
))
10904 and then not Error_Posted
(N
)
10907 ("elementary or array type cannot have discriminants",
10908 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
10909 Set_Has_Discriminants
(T
, False);
10912 -- In Ada 83, a derived type defined in a package specification cannot
10913 -- be used for further derivation until the end of its visible part.
10914 -- Note that derivation in the private part of the package is allowed.
10916 if Ada_Version
= Ada_83
10917 and then Is_Derived_Type
(Parent_Type
)
10918 and then In_Visible_Part
(Scope
(Parent_Type
))
10920 if Ada_Version
= Ada_83
and then Comes_From_Source
(Indic
) then
10922 ("(Ada 83): premature use of type for derivation", Indic
);
10926 -- Check for early use of incomplete or private type
10928 if Ekind
(Parent_Type
) = E_Void
10929 or else Ekind
(Parent_Type
) = E_Incomplete_Type
10931 Error_Msg_N
("premature derivation of incomplete type", Indic
);
10934 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
10935 and then not Comes_From_Generic
(Parent_Type
))
10936 or else Has_Private_Component
(Parent_Type
)
10938 -- The ancestor type of a formal type can be incomplete, in which
10939 -- case only the operations of the partial view are available in
10940 -- the generic. Subsequent checks may be required when the full
10941 -- view is analyzed, to verify that derivation from a tagged type
10942 -- has an extension.
10944 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
10947 elsif No
(Underlying_Type
(Parent_Type
))
10948 or else Has_Private_Component
(Parent_Type
)
10951 ("premature derivation of derived or private type", Indic
);
10953 -- Flag the type itself as being in error, this prevents some
10954 -- nasty problems with subsequent uses of the malformed type.
10956 Set_Error_Posted
(T
);
10958 -- Check that within the immediate scope of an untagged partial
10959 -- view it's illegal to derive from the partial view if the
10960 -- full view is tagged. (7.3(7))
10962 -- We verify that the Parent_Type is a partial view by checking
10963 -- that it is not a Full_Type_Declaration (i.e. a private type or
10964 -- private extension declaration), to distinguish a partial view
10965 -- from a derivation from a private type which also appears as
10968 elsif Present
(Full_View
(Parent_Type
))
10969 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
10970 and then not Is_Tagged_Type
(Parent_Type
)
10971 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
10973 Parent_Scope
:= Scope
(T
);
10974 while Present
(Parent_Scope
)
10975 and then Parent_Scope
/= Standard_Standard
10977 if Parent_Scope
= Scope
(Parent_Type
) then
10979 ("premature derivation from type with tagged full view",
10983 Parent_Scope
:= Scope
(Parent_Scope
);
10988 -- Check that form of derivation is appropriate
10990 Taggd
:= Is_Tagged_Type
(Parent_Type
);
10992 -- Perhaps the parent type should be changed to the class-wide type's
10993 -- specific type in this case to prevent cascading errors ???
10995 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
10996 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
11000 if Present
(Extension
) and then not Taggd
then
11002 ("type derived from untagged type cannot have extension", Indic
);
11004 elsif No
(Extension
) and then Taggd
then
11006 -- If this declaration is within a private part (or body) of a
11007 -- generic instantiation then the derivation is allowed (the parent
11008 -- type can only appear tagged in this case if it's a generic actual
11009 -- type, since it would otherwise have been rejected in the analysis
11010 -- of the generic template).
11012 if not Is_Generic_Actual_Type
(Parent_Type
)
11013 or else In_Visible_Part
(Scope
(Parent_Type
))
11016 ("type derived from tagged type must have extension", Indic
);
11020 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
11022 -- AI-419: the parent type of an explicitly limited derived type must
11023 -- be limited. Interface progenitors were checked earlier.
11025 if Limited_Present
(Def
) then
11026 Set_Is_Limited_Record
(T
);
11028 if not Is_Limited_Type
(Parent_Type
)
11029 and then not Is_Interface
(Parent_Type
)
11031 Error_Msg_NE
("parent type& of limited type must be limited",
11035 end Derived_Type_Declaration
;
11037 ----------------------------------
11038 -- Enumeration_Type_Declaration --
11039 ----------------------------------
11041 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11048 -- Create identifier node representing lower bound
11050 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11051 L
:= First
(Literals
(Def
));
11052 Set_Chars
(B_Node
, Chars
(L
));
11053 Set_Entity
(B_Node
, L
);
11054 Set_Etype
(B_Node
, T
);
11055 Set_Is_Static_Expression
(B_Node
, True);
11057 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
11058 Set_Low_Bound
(R_Node
, B_Node
);
11060 Set_Ekind
(T
, E_Enumeration_Type
);
11061 Set_First_Literal
(T
, L
);
11063 Set_Is_Constrained
(T
);
11067 -- Loop through literals of enumeration type setting pos and rep values
11068 -- except that if the Ekind is already set, then it means that the
11069 -- literal was already constructed (case of a derived type declaration
11070 -- and we should not disturb the Pos and Rep values.
11072 while Present
(L
) loop
11073 if Ekind
(L
) /= E_Enumeration_Literal
then
11074 Set_Ekind
(L
, E_Enumeration_Literal
);
11075 Set_Enumeration_Pos
(L
, Ev
);
11076 Set_Enumeration_Rep
(L
, Ev
);
11077 Set_Is_Known_Valid
(L
, True);
11081 New_Overloaded_Entity
(L
);
11082 Generate_Definition
(L
);
11083 Set_Convention
(L
, Convention_Intrinsic
);
11085 if Nkind
(L
) = N_Defining_Character_Literal
then
11086 Set_Is_Character_Type
(T
, True);
11093 -- Now create a node representing upper bound
11095 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11096 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
11097 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
11098 Set_Etype
(B_Node
, T
);
11099 Set_Is_Static_Expression
(B_Node
, True);
11101 Set_High_Bound
(R_Node
, B_Node
);
11102 Set_Scalar_Range
(T
, R_Node
);
11103 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
11104 Set_Enum_Esize
(T
);
11106 -- Set Discard_Names if configuration pragma set, or if there is
11107 -- a parameterless pragma in the current declarative region
11109 if Global_Discard_Names
11110 or else Discard_Names
(Scope
(T
))
11112 Set_Discard_Names
(T
);
11115 -- Process end label if there is one
11117 if Present
(Def
) then
11118 Process_End_Label
(Def
, 'e', T
);
11120 end Enumeration_Type_Declaration
;
11122 ---------------------------------
11123 -- Expand_To_Stored_Constraint --
11124 ---------------------------------
11126 function Expand_To_Stored_Constraint
11128 Constraint
: Elist_Id
) return Elist_Id
11130 Explicitly_Discriminated_Type
: Entity_Id
;
11131 Expansion
: Elist_Id
;
11132 Discriminant
: Entity_Id
;
11134 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
11135 -- Find the nearest type that actually specifies discriminants
11137 ---------------------------------
11138 -- Type_With_Explicit_Discrims --
11139 ---------------------------------
11141 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
11142 Typ
: constant E
:= Base_Type
(Id
);
11145 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
11146 if Present
(Full_View
(Typ
)) then
11147 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
11151 if Has_Discriminants
(Typ
) then
11156 if Etype
(Typ
) = Typ
then
11158 elsif Has_Discriminants
(Typ
) then
11161 return Type_With_Explicit_Discrims
(Etype
(Typ
));
11164 end Type_With_Explicit_Discrims
;
11166 -- Start of processing for Expand_To_Stored_Constraint
11170 or else Is_Empty_Elmt_List
(Constraint
)
11175 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
11177 if No
(Explicitly_Discriminated_Type
) then
11181 Expansion
:= New_Elmt_List
;
11184 First_Stored_Discriminant
(Explicitly_Discriminated_Type
);
11185 while Present
(Discriminant
) loop
11187 Get_Discriminant_Value
(
11188 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
11190 Next_Stored_Discriminant
(Discriminant
);
11194 end Expand_To_Stored_Constraint
;
11196 --------------------
11197 -- Find_Type_Name --
11198 --------------------
11200 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
11201 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
11203 New_Id
: Entity_Id
;
11204 Prev_Par
: Node_Id
;
11207 -- Find incomplete declaration, if one was given
11209 Prev
:= Current_Entity_In_Scope
(Id
);
11211 if Present
(Prev
) then
11213 -- Previous declaration exists. Error if not incomplete/private case
11214 -- except if previous declaration is implicit, etc. Enter_Name will
11215 -- emit error if appropriate.
11217 Prev_Par
:= Parent
(Prev
);
11219 if not Is_Incomplete_Or_Private_Type
(Prev
) then
11223 elsif Nkind
(N
) /= N_Full_Type_Declaration
11224 and then Nkind
(N
) /= N_Task_Type_Declaration
11225 and then Nkind
(N
) /= N_Protected_Type_Declaration
11227 -- Completion must be a full type declarations (RM 7.3(4))
11229 Error_Msg_Sloc
:= Sloc
(Prev
);
11230 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
11232 -- Set scope of Id to avoid cascaded errors. Entity is never
11233 -- examined again, except when saving globals in generics.
11235 Set_Scope
(Id
, Current_Scope
);
11238 -- Case of full declaration of incomplete type
11240 elsif Ekind
(Prev
) = E_Incomplete_Type
then
11242 -- Indicate that the incomplete declaration has a matching full
11243 -- declaration. The defining occurrence of the incomplete
11244 -- declaration remains the visible one, and the procedure
11245 -- Get_Full_View dereferences it whenever the type is used.
11247 if Present
(Full_View
(Prev
)) then
11248 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11251 Set_Full_View
(Prev
, Id
);
11252 Append_Entity
(Id
, Current_Scope
);
11253 Set_Is_Public
(Id
, Is_Public
(Prev
));
11254 Set_Is_Internal
(Id
);
11257 -- Case of full declaration of private type
11260 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
11261 if Etype
(Prev
) /= Prev
then
11263 -- Prev is a private subtype or a derived type, and needs
11266 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11269 elsif Ekind
(Prev
) = E_Private_Type
11271 (Nkind
(N
) = N_Task_Type_Declaration
11272 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11275 ("completion of nonlimited type cannot be limited", N
);
11278 -- Ada 2005 (AI-251): Private extension declaration of a
11279 -- task type. This case arises with tasks implementing interfaces
11281 elsif Nkind
(N
) = N_Task_Type_Declaration
11282 or else Nkind
(N
) = N_Protected_Type_Declaration
11286 elsif Nkind
(N
) /= N_Full_Type_Declaration
11287 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
11290 ("full view of private extension must be an extension", N
);
11292 elsif not (Abstract_Present
(Parent
(Prev
)))
11293 and then Abstract_Present
(Type_Definition
(N
))
11296 ("full view of non-abstract extension cannot be abstract", N
);
11299 if not In_Private_Part
(Current_Scope
) then
11301 ("declaration of full view must appear in private part", N
);
11304 Copy_And_Swap
(Prev
, Id
);
11305 Set_Has_Private_Declaration
(Prev
);
11306 Set_Has_Private_Declaration
(Id
);
11308 -- If no error, propagate freeze_node from private to full view.
11309 -- It may have been generated for an early operational item.
11311 if Present
(Freeze_Node
(Id
))
11312 and then Serious_Errors_Detected
= 0
11313 and then No
(Full_View
(Id
))
11315 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
11316 Set_Freeze_Node
(Id
, Empty
);
11317 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
11320 Set_Full_View
(Id
, Prev
);
11324 -- Verify that full declaration conforms to incomplete one
11326 if Is_Incomplete_Or_Private_Type
(Prev
)
11327 and then Present
(Discriminant_Specifications
(Prev_Par
))
11329 if Present
(Discriminant_Specifications
(N
)) then
11330 if Ekind
(Prev
) = E_Incomplete_Type
then
11331 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
11333 Check_Discriminant_Conformance
(N
, Prev
, Id
);
11338 ("missing discriminants in full type declaration", N
);
11340 -- To avoid cascaded errors on subsequent use, share the
11341 -- discriminants of the partial view.
11343 Set_Discriminant_Specifications
(N
,
11344 Discriminant_Specifications
(Prev_Par
));
11348 -- A prior untagged private type can have an associated class-wide
11349 -- type due to use of the class attribute, and in this case also the
11350 -- full type is required to be tagged.
11353 and then (Is_Tagged_Type
(Prev
)
11354 or else Present
(Class_Wide_Type
(Prev
)))
11355 and then (Nkind
(N
) /= N_Task_Type_Declaration
11356 and then Nkind
(N
) /= N_Protected_Type_Declaration
)
11358 -- The full declaration is either a tagged record or an
11359 -- extension otherwise this is an error
11361 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
11362 if not Tagged_Present
(Type_Definition
(N
)) then
11364 ("full declaration of } must be tagged", Prev
, Id
);
11365 Set_Is_Tagged_Type
(Id
);
11366 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11369 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
11370 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
11372 "full declaration of } must be a record extension",
11374 Set_Is_Tagged_Type
(Id
);
11375 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11380 ("full declaration of } must be a tagged type", Prev
, Id
);
11388 -- New type declaration
11393 end Find_Type_Name
;
11395 -------------------------
11396 -- Find_Type_Of_Object --
11397 -------------------------
11399 function Find_Type_Of_Object
11400 (Obj_Def
: Node_Id
;
11401 Related_Nod
: Node_Id
) return Entity_Id
11403 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
11404 P
: Node_Id
:= Parent
(Obj_Def
);
11409 -- If the parent is a component_definition node we climb to the
11410 -- component_declaration node
11412 if Nkind
(P
) = N_Component_Definition
then
11416 -- Case of an anonymous array subtype
11418 if Def_Kind
= N_Constrained_Array_Definition
11419 or else Def_Kind
= N_Unconstrained_Array_Definition
11422 Array_Type_Declaration
(T
, Obj_Def
);
11424 -- Create an explicit subtype whenever possible
11426 elsif Nkind
(P
) /= N_Component_Declaration
11427 and then Def_Kind
= N_Subtype_Indication
11429 -- Base name of subtype on object name, which will be unique in
11430 -- the current scope.
11432 -- If this is a duplicate declaration, return base type, to avoid
11433 -- generating duplicate anonymous types.
11435 if Error_Posted
(P
) then
11436 Analyze
(Subtype_Mark
(Obj_Def
));
11437 return Entity
(Subtype_Mark
(Obj_Def
));
11442 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
11444 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
11446 Insert_Action
(Obj_Def
,
11447 Make_Subtype_Declaration
(Sloc
(P
),
11448 Defining_Identifier
=> T
,
11449 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
11451 -- This subtype may need freezing, and this will not be done
11452 -- automatically if the object declaration is not in declarative
11453 -- part. Since this is an object declaration, the type cannot always
11454 -- be frozen here. Deferred constants do not freeze their type
11455 -- (which often enough will be private).
11457 if Nkind
(P
) = N_Object_Declaration
11458 and then Constant_Present
(P
)
11459 and then No
(Expression
(P
))
11463 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
11466 -- Ada 2005 AI-406: the object definition in an object declaration
11467 -- can be an access definition.
11469 elsif Def_Kind
= N_Access_Definition
then
11470 T
:= Access_Definition
(Related_Nod
, Obj_Def
);
11471 Set_Is_Local_Anonymous_Access
(T
);
11473 -- comment here, what cases ???
11476 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
11480 end Find_Type_Of_Object
;
11482 --------------------------------
11483 -- Find_Type_Of_Subtype_Indic --
11484 --------------------------------
11486 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
11490 -- Case of subtype mark with a constraint
11492 if Nkind
(S
) = N_Subtype_Indication
then
11493 Find_Type
(Subtype_Mark
(S
));
11494 Typ
:= Entity
(Subtype_Mark
(S
));
11497 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
11500 ("incorrect constraint for this kind of type", Constraint
(S
));
11501 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11504 -- Otherwise we have a subtype mark without a constraint
11506 elsif Error_Posted
(S
) then
11507 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
11515 if Typ
= Standard_Wide_Character
11516 or else Typ
= Standard_Wide_Wide_Character
11517 or else Typ
= Standard_Wide_String
11518 or else Typ
= Standard_Wide_Wide_String
11520 Check_Restriction
(No_Wide_Characters
, S
);
11524 end Find_Type_Of_Subtype_Indic
;
11526 -------------------------------------
11527 -- Floating_Point_Type_Declaration --
11528 -------------------------------------
11530 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11531 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
11533 Base_Typ
: Entity_Id
;
11534 Implicit_Base
: Entity_Id
;
11537 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
11538 -- Find if given digits value allows derivation from specified type
11540 ---------------------
11541 -- Can_Derive_From --
11542 ---------------------
11544 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
11545 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
11548 if Digs_Val
> Digits_Value
(E
) then
11552 if Present
(Spec
) then
11553 if Expr_Value_R
(Type_Low_Bound
(E
)) >
11554 Expr_Value_R
(Low_Bound
(Spec
))
11559 if Expr_Value_R
(Type_High_Bound
(E
)) <
11560 Expr_Value_R
(High_Bound
(Spec
))
11567 end Can_Derive_From
;
11569 -- Start of processing for Floating_Point_Type_Declaration
11572 Check_Restriction
(No_Floating_Point
, Def
);
11574 -- Create an implicit base type
11577 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
11579 -- Analyze and verify digits value
11581 Analyze_And_Resolve
(Digs
, Any_Integer
);
11582 Check_Digits_Expression
(Digs
);
11583 Digs_Val
:= Expr_Value
(Digs
);
11585 -- Process possible range spec and find correct type to derive from
11587 Process_Real_Range_Specification
(Def
);
11589 if Can_Derive_From
(Standard_Short_Float
) then
11590 Base_Typ
:= Standard_Short_Float
;
11591 elsif Can_Derive_From
(Standard_Float
) then
11592 Base_Typ
:= Standard_Float
;
11593 elsif Can_Derive_From
(Standard_Long_Float
) then
11594 Base_Typ
:= Standard_Long_Float
;
11595 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
11596 Base_Typ
:= Standard_Long_Long_Float
;
11598 -- If we can't derive from any existing type, use long_long_float
11599 -- and give appropriate message explaining the problem.
11602 Base_Typ
:= Standard_Long_Long_Float
;
11604 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
11605 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
11606 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
11610 ("range too large for any predefined type",
11611 Real_Range_Specification
(Def
));
11615 -- If there are bounds given in the declaration use them as the bounds
11616 -- of the type, otherwise use the bounds of the predefined base type
11617 -- that was chosen based on the Digits value.
11619 if Present
(Real_Range_Specification
(Def
)) then
11620 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
11621 Set_Is_Constrained
(T
);
11623 -- The bounds of this range must be converted to machine numbers
11624 -- in accordance with RM 4.9(38).
11626 Bound
:= Type_Low_Bound
(T
);
11628 if Nkind
(Bound
) = N_Real_Literal
then
11630 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11631 Set_Is_Machine_Number
(Bound
);
11634 Bound
:= Type_High_Bound
(T
);
11636 if Nkind
(Bound
) = N_Real_Literal
then
11638 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11639 Set_Is_Machine_Number
(Bound
);
11643 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
11646 -- Complete definition of implicit base and declared first subtype
11648 Set_Etype
(Implicit_Base
, Base_Typ
);
11650 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
11651 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
11652 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
11653 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
11654 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
11655 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
11657 Set_Ekind
(T
, E_Floating_Point_Subtype
);
11658 Set_Etype
(T
, Implicit_Base
);
11660 Set_Size_Info
(T
, (Implicit_Base
));
11661 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
11662 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
11663 Set_Digits_Value
(T
, Digs_Val
);
11664 end Floating_Point_Type_Declaration
;
11666 ----------------------------
11667 -- Get_Discriminant_Value --
11668 ----------------------------
11670 -- This is the situation:
11672 -- There is a non-derived type
11674 -- type T0 (Dx, Dy, Dz...)
11676 -- There are zero or more levels of derivation, with each derivation
11677 -- either purely inheriting the discriminants, or defining its own.
11679 -- type Ti is new Ti-1
11681 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
11683 -- subtype Ti is ...
11685 -- The subtype issue is avoided by the use of Original_Record_Component,
11686 -- and the fact that derived subtypes also derive the constraints.
11688 -- This chain leads back from
11690 -- Typ_For_Constraint
11692 -- Typ_For_Constraint has discriminants, and the value for each
11693 -- discriminant is given by its corresponding Elmt of Constraints.
11695 -- Discriminant is some discriminant in this hierarchy
11697 -- We need to return its value
11699 -- We do this by recursively searching each level, and looking for
11700 -- Discriminant. Once we get to the bottom, we start backing up
11701 -- returning the value for it which may in turn be a discriminant
11702 -- further up, so on the backup we continue the substitution.
11704 function Get_Discriminant_Value
11705 (Discriminant
: Entity_Id
;
11706 Typ_For_Constraint
: Entity_Id
;
11707 Constraint
: Elist_Id
) return Node_Id
11709 function Search_Derivation_Levels
11711 Discrim_Values
: Elist_Id
;
11712 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
;
11713 -- This is the routine that performs the recursive search of levels
11714 -- as described above.
11716 ------------------------------
11717 -- Search_Derivation_Levels --
11718 ------------------------------
11720 function Search_Derivation_Levels
11722 Discrim_Values
: Elist_Id
;
11723 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
11727 Result
: Node_Or_Entity_Id
;
11728 Result_Entity
: Node_Id
;
11731 -- If inappropriate type, return Error, this happens only in
11732 -- cascaded error situations, and we want to avoid a blow up.
11734 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
11738 -- Look deeper if possible. Use Stored_Constraints only for
11739 -- untagged types. For tagged types use the given constraint.
11740 -- This asymmetry needs explanation???
11742 if not Stored_Discrim_Values
11743 and then Present
(Stored_Constraint
(Ti
))
11744 and then not Is_Tagged_Type
(Ti
)
11747 Search_Derivation_Levels
(Ti
, Stored_Constraint
(Ti
), True);
11750 Td
: constant Entity_Id
:= Etype
(Ti
);
11754 Result
:= Discriminant
;
11757 if Present
(Stored_Constraint
(Ti
)) then
11759 Search_Derivation_Levels
11760 (Td
, Stored_Constraint
(Ti
), True);
11763 Search_Derivation_Levels
11764 (Td
, Discrim_Values
, Stored_Discrim_Values
);
11770 -- Extra underlying places to search, if not found above. For
11771 -- concurrent types, the relevant discriminant appears in the
11772 -- corresponding record. For a type derived from a private type
11773 -- without discriminant, the full view inherits the discriminants
11774 -- of the full view of the parent.
11776 if Result
= Discriminant
then
11777 if Is_Concurrent_Type
(Ti
)
11778 and then Present
(Corresponding_Record_Type
(Ti
))
11781 Search_Derivation_Levels
(
11782 Corresponding_Record_Type
(Ti
),
11784 Stored_Discrim_Values
);
11786 elsif Is_Private_Type
(Ti
)
11787 and then not Has_Discriminants
(Ti
)
11788 and then Present
(Full_View
(Ti
))
11789 and then Etype
(Full_View
(Ti
)) /= Ti
11792 Search_Derivation_Levels
(
11795 Stored_Discrim_Values
);
11799 -- If Result is not a (reference to a) discriminant, return it,
11800 -- otherwise set Result_Entity to the discriminant.
11802 if Nkind
(Result
) = N_Defining_Identifier
then
11803 pragma Assert
(Result
= Discriminant
);
11804 Result_Entity
:= Result
;
11807 if not Denotes_Discriminant
(Result
) then
11811 Result_Entity
:= Entity
(Result
);
11814 -- See if this level of derivation actually has discriminants
11815 -- because tagged derivations can add them, hence the lower
11816 -- levels need not have any.
11818 if not Has_Discriminants
(Ti
) then
11822 -- Scan Ti's discriminants for Result_Entity,
11823 -- and return its corresponding value, if any.
11825 Result_Entity
:= Original_Record_Component
(Result_Entity
);
11827 Assoc
:= First_Elmt
(Discrim_Values
);
11829 if Stored_Discrim_Values
then
11830 Disc
:= First_Stored_Discriminant
(Ti
);
11832 Disc
:= First_Discriminant
(Ti
);
11835 while Present
(Disc
) loop
11836 pragma Assert
(Present
(Assoc
));
11838 if Original_Record_Component
(Disc
) = Result_Entity
then
11839 return Node
(Assoc
);
11844 if Stored_Discrim_Values
then
11845 Next_Stored_Discriminant
(Disc
);
11847 Next_Discriminant
(Disc
);
11851 -- Could not find it
11854 end Search_Derivation_Levels
;
11856 Result
: Node_Or_Entity_Id
;
11858 -- Start of processing for Get_Discriminant_Value
11861 -- ??? This routine is a gigantic mess and will be deleted. For the
11862 -- time being just test for the trivial case before calling recurse.
11864 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
11870 D
:= First_Discriminant
(Typ_For_Constraint
);
11871 E
:= First_Elmt
(Constraint
);
11872 while Present
(D
) loop
11873 if Chars
(D
) = Chars
(Discriminant
) then
11877 Next_Discriminant
(D
);
11883 Result
:= Search_Derivation_Levels
11884 (Typ_For_Constraint
, Constraint
, False);
11886 -- ??? hack to disappear when this routine is gone
11888 if Nkind
(Result
) = N_Defining_Identifier
then
11894 D
:= First_Discriminant
(Typ_For_Constraint
);
11895 E
:= First_Elmt
(Constraint
);
11896 while Present
(D
) loop
11897 if Corresponding_Discriminant
(D
) = Discriminant
then
11901 Next_Discriminant
(D
);
11907 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
11909 end Get_Discriminant_Value
;
11911 --------------------------
11912 -- Has_Range_Constraint --
11913 --------------------------
11915 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
11916 C
: constant Node_Id
:= Constraint
(N
);
11919 if Nkind
(C
) = N_Range_Constraint
then
11922 elsif Nkind
(C
) = N_Digits_Constraint
then
11924 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
11926 Present
(Range_Constraint
(C
));
11928 elsif Nkind
(C
) = N_Delta_Constraint
then
11929 return Present
(Range_Constraint
(C
));
11934 end Has_Range_Constraint
;
11936 ------------------------
11937 -- Inherit_Components --
11938 ------------------------
11940 function Inherit_Components
11942 Parent_Base
: Entity_Id
;
11943 Derived_Base
: Entity_Id
;
11944 Is_Tagged
: Boolean;
11945 Inherit_Discr
: Boolean;
11946 Discs
: Elist_Id
) return Elist_Id
11948 Assoc_List
: constant Elist_Id
:= New_Elmt_List
;
11950 procedure Inherit_Component
11951 (Old_C
: Entity_Id
;
11952 Plain_Discrim
: Boolean := False;
11953 Stored_Discrim
: Boolean := False);
11954 -- Inherits component Old_C from Parent_Base to the Derived_Base. If
11955 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
11956 -- True, Old_C is a stored discriminant. If they are both false then
11957 -- Old_C is a regular component.
11959 -----------------------
11960 -- Inherit_Component --
11961 -----------------------
11963 procedure Inherit_Component
11964 (Old_C
: Entity_Id
;
11965 Plain_Discrim
: Boolean := False;
11966 Stored_Discrim
: Boolean := False)
11968 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
11970 Discrim
: Entity_Id
;
11971 Corr_Discrim
: Entity_Id
;
11974 pragma Assert
(not Is_Tagged
or else not Stored_Discrim
);
11976 Set_Parent
(New_C
, Parent
(Old_C
));
11978 -- Regular discriminants and components must be inserted
11979 -- in the scope of the Derived_Base. Do it here.
11981 if not Stored_Discrim
then
11982 Enter_Name
(New_C
);
11985 -- For tagged types the Original_Record_Component must point to
11986 -- whatever this field was pointing to in the parent type. This has
11987 -- already been achieved by the call to New_Copy above.
11989 if not Is_Tagged
then
11990 Set_Original_Record_Component
(New_C
, New_C
);
11993 -- If we have inherited a component then see if its Etype contains
11994 -- references to Parent_Base discriminants. In this case, replace
11995 -- these references with the constraints given in Discs. We do not
11996 -- do this for the partial view of private types because this is
11997 -- not needed (only the components of the full view will be used
11998 -- for code generation) and cause problem. We also avoid this
11999 -- transformation in some error situations.
12001 if Ekind
(New_C
) = E_Component
then
12002 if (Is_Private_Type
(Derived_Base
)
12003 and then not Is_Generic_Type
(Derived_Base
))
12004 or else (Is_Empty_Elmt_List
(Discs
)
12005 and then not Expander_Active
)
12007 Set_Etype
(New_C
, Etype
(Old_C
));
12011 Constrain_Component_Type
12012 (Old_C
, Derived_Base
, N
, Parent_Base
, Discs
));
12016 -- In derived tagged types it is illegal to reference a non
12017 -- discriminant component in the parent type. To catch this, mark
12018 -- these components with an Ekind of E_Void. This will be reset in
12019 -- Record_Type_Definition after processing the record extension of
12020 -- the derived type.
12022 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
12023 Set_Ekind
(New_C
, E_Void
);
12026 if Plain_Discrim
then
12027 Set_Corresponding_Discriminant
(New_C
, Old_C
);
12028 Build_Discriminal
(New_C
);
12030 -- If we are explicitly inheriting a stored discriminant it will be
12031 -- completely hidden.
12033 elsif Stored_Discrim
then
12034 Set_Corresponding_Discriminant
(New_C
, Empty
);
12035 Set_Discriminal
(New_C
, Empty
);
12036 Set_Is_Completely_Hidden
(New_C
);
12038 -- Set the Original_Record_Component of each discriminant in the
12039 -- derived base to point to the corresponding stored that we just
12042 Discrim
:= First_Discriminant
(Derived_Base
);
12043 while Present
(Discrim
) loop
12044 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
12046 -- Corr_Discrim could be missing in an error situation
12048 if Present
(Corr_Discrim
)
12049 and then Original_Record_Component
(Corr_Discrim
) = Old_C
12051 Set_Original_Record_Component
(Discrim
, New_C
);
12054 Next_Discriminant
(Discrim
);
12057 Append_Entity
(New_C
, Derived_Base
);
12060 if not Is_Tagged
then
12061 Append_Elmt
(Old_C
, Assoc_List
);
12062 Append_Elmt
(New_C
, Assoc_List
);
12064 end Inherit_Component
;
12066 -- Variables local to Inherit_Component
12068 Loc
: constant Source_Ptr
:= Sloc
(N
);
12070 Parent_Discrim
: Entity_Id
;
12071 Stored_Discrim
: Entity_Id
;
12073 Component
: Entity_Id
;
12075 -- Start of processing for Inherit_Components
12078 if not Is_Tagged
then
12079 Append_Elmt
(Parent_Base
, Assoc_List
);
12080 Append_Elmt
(Derived_Base
, Assoc_List
);
12083 -- Inherit parent discriminants if needed
12085 if Inherit_Discr
then
12086 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
12087 while Present
(Parent_Discrim
) loop
12088 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
12089 Next_Discriminant
(Parent_Discrim
);
12093 -- Create explicit stored discrims for untagged types when necessary
12095 if not Has_Unknown_Discriminants
(Derived_Base
)
12096 and then Has_Discriminants
(Parent_Base
)
12097 and then not Is_Tagged
12100 or else First_Discriminant
(Parent_Base
) /=
12101 First_Stored_Discriminant
(Parent_Base
))
12103 Stored_Discrim
:= First_Stored_Discriminant
(Parent_Base
);
12104 while Present
(Stored_Discrim
) loop
12105 Inherit_Component
(Stored_Discrim
, Stored_Discrim
=> True);
12106 Next_Stored_Discriminant
(Stored_Discrim
);
12110 -- See if we can apply the second transformation for derived types, as
12111 -- explained in point 6. in the comments above Build_Derived_Record_Type
12112 -- This is achieved by appending Derived_Base discriminants into Discs,
12113 -- which has the side effect of returning a non empty Discs list to the
12114 -- caller of Inherit_Components, which is what we want. This must be
12115 -- done for private derived types if there are explicit stored
12116 -- discriminants, to ensure that we can retrieve the values of the
12117 -- constraints provided in the ancestors.
12120 and then Is_Empty_Elmt_List
(Discs
)
12121 and then Present
(First_Discriminant
(Derived_Base
))
12123 (not Is_Private_Type
(Derived_Base
)
12124 or else Is_Completely_Hidden
12125 (First_Stored_Discriminant
(Derived_Base
))
12126 or else Is_Generic_Type
(Derived_Base
))
12128 D
:= First_Discriminant
(Derived_Base
);
12129 while Present
(D
) loop
12130 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
12131 Next_Discriminant
(D
);
12135 -- Finally, inherit non-discriminant components unless they are not
12136 -- visible because defined or inherited from the full view of the
12137 -- parent. Don't inherit the _parent field of the parent type.
12139 Component
:= First_Entity
(Parent_Base
);
12140 while Present
(Component
) loop
12142 -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
12143 -- interfaces of the parent
12145 if Ekind
(Component
) = E_Component
12146 and then Is_Tag
(Component
)
12147 and then Etype
(Component
) = RTE
(RE_Interface_Tag
)
12151 elsif Ekind
(Component
) /= E_Component
12152 or else Chars
(Component
) = Name_uParent
12156 -- If the derived type is within the parent type's declarative
12157 -- region, then the components can still be inherited even though
12158 -- they aren't visible at this point. This can occur for cases
12159 -- such as within public child units where the components must
12160 -- become visible upon entering the child unit's private part.
12162 elsif not Is_Visible_Component
(Component
)
12163 and then not In_Open_Scopes
(Scope
(Parent_Base
))
12167 elsif Ekind
(Derived_Base
) = E_Private_Type
12168 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
12173 Inherit_Component
(Component
);
12176 Next_Entity
(Component
);
12179 -- For tagged derived types, inherited discriminants cannot be used in
12180 -- component declarations of the record extension part. To achieve this
12181 -- we mark the inherited discriminants as not visible.
12183 if Is_Tagged
and then Inherit_Discr
then
12184 D
:= First_Discriminant
(Derived_Base
);
12185 while Present
(D
) loop
12186 Set_Is_Immediately_Visible
(D
, False);
12187 Next_Discriminant
(D
);
12192 end Inherit_Components
;
12194 ------------------------------
12195 -- Is_Valid_Constraint_Kind --
12196 ------------------------------
12198 function Is_Valid_Constraint_Kind
12199 (T_Kind
: Type_Kind
;
12200 Constraint_Kind
: Node_Kind
) return Boolean
12204 when Enumeration_Kind |
12206 return Constraint_Kind
= N_Range_Constraint
;
12208 when Decimal_Fixed_Point_Kind
=>
12210 Constraint_Kind
= N_Digits_Constraint
12212 Constraint_Kind
= N_Range_Constraint
;
12214 when Ordinary_Fixed_Point_Kind
=>
12216 Constraint_Kind
= N_Delta_Constraint
12218 Constraint_Kind
= N_Range_Constraint
;
12222 Constraint_Kind
= N_Digits_Constraint
12224 Constraint_Kind
= N_Range_Constraint
;
12231 E_Incomplete_Type |
12234 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
12237 return True; -- Error will be detected later
12239 end Is_Valid_Constraint_Kind
;
12241 --------------------------
12242 -- Is_Visible_Component --
12243 --------------------------
12245 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
12246 Original_Comp
: Entity_Id
:= Empty
;
12247 Original_Scope
: Entity_Id
;
12248 Type_Scope
: Entity_Id
;
12250 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean;
12251 -- Check whether parent type of inherited component is declared locally,
12252 -- possibly within a nested package or instance. The current scope is
12253 -- the derived record itself.
12255 -------------------
12256 -- Is_Local_Type --
12257 -------------------
12259 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean is
12263 Scop
:= Scope
(Typ
);
12264 while Present
(Scop
)
12265 and then Scop
/= Standard_Standard
12267 if Scop
= Scope
(Current_Scope
) then
12271 Scop
:= Scope
(Scop
);
12277 -- Start of processing for Is_Visible_Component
12280 if Ekind
(C
) = E_Component
12281 or else Ekind
(C
) = E_Discriminant
12283 Original_Comp
:= Original_Record_Component
(C
);
12286 if No
(Original_Comp
) then
12288 -- Premature usage, or previous error
12293 Original_Scope
:= Scope
(Original_Comp
);
12294 Type_Scope
:= Scope
(Base_Type
(Scope
(C
)));
12297 -- This test only concerns tagged types
12299 if not Is_Tagged_Type
(Original_Scope
) then
12302 -- If it is _Parent or _Tag, there is no visibility issue
12304 elsif not Comes_From_Source
(Original_Comp
) then
12307 -- If we are in the body of an instantiation, the component is visible
12308 -- even when the parent type (possibly defined in an enclosing unit or
12309 -- in a parent unit) might not.
12311 elsif In_Instance_Body
then
12314 -- Discriminants are always visible
12316 elsif Ekind
(Original_Comp
) = E_Discriminant
12317 and then not Has_Unknown_Discriminants
(Original_Scope
)
12321 -- If the component has been declared in an ancestor which is currently
12322 -- a private type, then it is not visible. The same applies if the
12323 -- component's containing type is not in an open scope and the original
12324 -- component's enclosing type is a visible full type of a private type
12325 -- (which can occur in cases where an attempt is being made to reference
12326 -- a component in a sibling package that is inherited from a visible
12327 -- component of a type in an ancestor package; the component in the
12328 -- sibling package should not be visible even though the component it
12329 -- inherited from is visible). This does not apply however in the case
12330 -- where the scope of the type is a private child unit, or when the
12331 -- parent comes from a local package in which the ancestor is currently
12332 -- visible. The latter suppression of visibility is needed for cases
12333 -- that are tested in B730006.
12335 elsif Is_Private_Type
(Original_Scope
)
12337 (not Is_Private_Descendant
(Type_Scope
)
12338 and then not In_Open_Scopes
(Type_Scope
)
12339 and then Has_Private_Declaration
(Original_Scope
))
12341 -- If the type derives from an entity in a formal package, there
12342 -- are no additional visible components.
12344 if Nkind
(Original_Node
(Unit_Declaration_Node
(Type_Scope
))) =
12345 N_Formal_Package_Declaration
12349 -- if we are not in the private part of the current package, there
12350 -- are no additional visible components.
12352 elsif Ekind
(Scope
(Current_Scope
)) = E_Package
12353 and then not In_Private_Part
(Scope
(Current_Scope
))
12358 Is_Child_Unit
(Cunit_Entity
(Current_Sem_Unit
))
12359 and then Is_Local_Type
(Type_Scope
);
12362 -- There is another weird way in which a component may be invisible
12363 -- when the private and the full view are not derived from the same
12364 -- ancestor. Here is an example :
12366 -- type A1 is tagged record F1 : integer; end record;
12367 -- type A2 is new A1 with record F2 : integer; end record;
12368 -- type T is new A1 with private;
12370 -- type T is new A2 with null record;
12372 -- In this case, the full view of T inherits F1 and F2 but the private
12373 -- view inherits only F1
12377 Ancestor
: Entity_Id
:= Scope
(C
);
12381 if Ancestor
= Original_Scope
then
12383 elsif Ancestor
= Etype
(Ancestor
) then
12387 Ancestor
:= Etype
(Ancestor
);
12393 end Is_Visible_Component
;
12395 --------------------------
12396 -- Make_Class_Wide_Type --
12397 --------------------------
12399 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
12400 CW_Type
: Entity_Id
;
12402 Next_E
: Entity_Id
;
12405 -- The class wide type can have been defined by the partial view in
12406 -- which case everything is already done
12408 if Present
(Class_Wide_Type
(T
)) then
12413 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
12415 -- Inherit root type characteristics
12417 CW_Name
:= Chars
(CW_Type
);
12418 Next_E
:= Next_Entity
(CW_Type
);
12419 Copy_Node
(T
, CW_Type
);
12420 Set_Comes_From_Source
(CW_Type
, False);
12421 Set_Chars
(CW_Type
, CW_Name
);
12422 Set_Parent
(CW_Type
, Parent
(T
));
12423 Set_Next_Entity
(CW_Type
, Next_E
);
12424 Set_Has_Delayed_Freeze
(CW_Type
);
12426 -- Customize the class-wide type: It has no prim. op., it cannot be
12427 -- abstract and its Etype points back to the specific root type.
12429 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
12430 Set_Is_Tagged_Type
(CW_Type
, True);
12431 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
12432 Set_Is_Abstract
(CW_Type
, False);
12433 Set_Is_Constrained
(CW_Type
, False);
12434 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
12435 Init_Size_Align
(CW_Type
);
12437 if Ekind
(T
) = E_Class_Wide_Subtype
then
12438 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
12440 Set_Etype
(CW_Type
, T
);
12443 -- If this is the class_wide type of a constrained subtype, it does
12444 -- not have discriminants.
12446 Set_Has_Discriminants
(CW_Type
,
12447 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
12449 Set_Has_Unknown_Discriminants
(CW_Type
, True);
12450 Set_Class_Wide_Type
(T
, CW_Type
);
12451 Set_Equivalent_Type
(CW_Type
, Empty
);
12453 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
12455 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
12456 end Make_Class_Wide_Type
;
12462 procedure Make_Index
12464 Related_Nod
: Node_Id
;
12465 Related_Id
: Entity_Id
:= Empty
;
12466 Suffix_Index
: Nat
:= 1)
12470 Def_Id
: Entity_Id
:= Empty
;
12471 Found
: Boolean := False;
12474 -- For a discrete range used in a constrained array definition and
12475 -- defined by a range, an implicit conversion to the predefined type
12476 -- INTEGER is assumed if each bound is either a numeric literal, a named
12477 -- number, or an attribute, and the type of both bounds (prior to the
12478 -- implicit conversion) is the type universal_integer. Otherwise, both
12479 -- bounds must be of the same discrete type, other than universal
12480 -- integer; this type must be determinable independently of the
12481 -- context, but using the fact that the type must be discrete and that
12482 -- both bounds must have the same type.
12484 -- Character literals also have a universal type in the absence of
12485 -- of additional context, and are resolved to Standard_Character.
12487 if Nkind
(I
) = N_Range
then
12489 -- The index is given by a range constraint. The bounds are known
12490 -- to be of a consistent type.
12492 if not Is_Overloaded
(I
) then
12495 -- If the bounds are universal, choose the specific predefined
12498 if T
= Universal_Integer
then
12499 T
:= Standard_Integer
;
12501 elsif T
= Any_Character
then
12503 if Ada_Version
>= Ada_95
then
12505 ("ambiguous character literals (could be Wide_Character)",
12509 T
:= Standard_Character
;
12516 Ind
: Interp_Index
;
12520 Get_First_Interp
(I
, Ind
, It
);
12521 while Present
(It
.Typ
) loop
12522 if Is_Discrete_Type
(It
.Typ
) then
12525 and then not Covers
(It
.Typ
, T
)
12526 and then not Covers
(T
, It
.Typ
)
12528 Error_Msg_N
("ambiguous bounds in discrete range", I
);
12536 Get_Next_Interp
(Ind
, It
);
12539 if T
= Any_Type
then
12540 Error_Msg_N
("discrete type required for range", I
);
12541 Set_Etype
(I
, Any_Type
);
12544 elsif T
= Universal_Integer
then
12545 T
:= Standard_Integer
;
12550 if not Is_Discrete_Type
(T
) then
12551 Error_Msg_N
("discrete type required for range", I
);
12552 Set_Etype
(I
, Any_Type
);
12556 if Nkind
(Low_Bound
(I
)) = N_Attribute_Reference
12557 and then Attribute_Name
(Low_Bound
(I
)) = Name_First
12558 and then Is_Entity_Name
(Prefix
(Low_Bound
(I
)))
12559 and then Is_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12560 and then Is_Discrete_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12562 -- The type of the index will be the type of the prefix, as long
12563 -- as the upper bound is 'Last of the same type.
12565 Def_Id
:= Entity
(Prefix
(Low_Bound
(I
)));
12567 if Nkind
(High_Bound
(I
)) /= N_Attribute_Reference
12568 or else Attribute_Name
(High_Bound
(I
)) /= Name_Last
12569 or else not Is_Entity_Name
(Prefix
(High_Bound
(I
)))
12570 or else Entity
(Prefix
(High_Bound
(I
))) /= Def_Id
12577 Process_Range_Expr_In_Decl
(R
, T
);
12579 elsif Nkind
(I
) = N_Subtype_Indication
then
12581 -- The index is given by a subtype with a range constraint
12583 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
12585 if not Is_Discrete_Type
(T
) then
12586 Error_Msg_N
("discrete type required for range", I
);
12587 Set_Etype
(I
, Any_Type
);
12591 R
:= Range_Expression
(Constraint
(I
));
12594 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
12596 elsif Nkind
(I
) = N_Attribute_Reference
then
12598 -- The parser guarantees that the attribute is a RANGE attribute
12600 -- If the node denotes the range of a type mark, that is also the
12601 -- resulting type, and we do no need to create an Itype for it.
12603 if Is_Entity_Name
(Prefix
(I
))
12604 and then Comes_From_Source
(I
)
12605 and then Is_Type
(Entity
(Prefix
(I
)))
12606 and then Is_Discrete_Type
(Entity
(Prefix
(I
)))
12608 Def_Id
:= Entity
(Prefix
(I
));
12611 Analyze_And_Resolve
(I
);
12615 -- If none of the above, must be a subtype. We convert this to a
12616 -- range attribute reference because in the case of declared first
12617 -- named subtypes, the types in the range reference can be different
12618 -- from the type of the entity. A range attribute normalizes the
12619 -- reference and obtains the correct types for the bounds.
12621 -- This transformation is in the nature of an expansion, is only
12622 -- done if expansion is active. In particular, it is not done on
12623 -- formal generic types, because we need to retain the name of the
12624 -- original index for instantiation purposes.
12627 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
12628 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
12629 Set_Etype
(I
, Any_Integer
);
12633 -- The type mark may be that of an incomplete type. It is only
12634 -- now that we can get the full view, previous analysis does
12635 -- not look specifically for a type mark.
12637 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
12638 Set_Etype
(I
, Entity
(I
));
12639 Def_Id
:= Entity
(I
);
12641 if not Is_Discrete_Type
(Def_Id
) then
12642 Error_Msg_N
("discrete type required for index", I
);
12643 Set_Etype
(I
, Any_Type
);
12648 if Expander_Active
then
12650 Make_Attribute_Reference
(Sloc
(I
),
12651 Attribute_Name
=> Name_Range
,
12652 Prefix
=> Relocate_Node
(I
)));
12654 -- The original was a subtype mark that does not freeze. This
12655 -- means that the rewritten version must not freeze either.
12657 Set_Must_Not_Freeze
(I
);
12658 Set_Must_Not_Freeze
(Prefix
(I
));
12660 -- Is order critical??? if so, document why, if not
12661 -- use Analyze_And_Resolve
12668 -- If expander is inactive, type is legal, nothing else to construct
12675 if not Is_Discrete_Type
(T
) then
12676 Error_Msg_N
("discrete type required for range", I
);
12677 Set_Etype
(I
, Any_Type
);
12680 elsif T
= Any_Type
then
12681 Set_Etype
(I
, Any_Type
);
12685 -- We will now create the appropriate Itype to describe the range, but
12686 -- first a check. If we originally had a subtype, then we just label
12687 -- the range with this subtype. Not only is there no need to construct
12688 -- a new subtype, but it is wrong to do so for two reasons:
12690 -- 1. A legality concern, if we have a subtype, it must not freeze,
12691 -- and the Itype would cause freezing incorrectly
12693 -- 2. An efficiency concern, if we created an Itype, it would not be
12694 -- recognized as the same type for the purposes of eliminating
12695 -- checks in some circumstances.
12697 -- We signal this case by setting the subtype entity in Def_Id
12699 if No
(Def_Id
) then
12701 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
12702 Set_Etype
(Def_Id
, Base_Type
(T
));
12704 if Is_Signed_Integer_Type
(T
) then
12705 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
12707 elsif Is_Modular_Integer_Type
(T
) then
12708 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
12711 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
12712 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
12713 Set_First_Literal
(Def_Id
, First_Literal
(T
));
12716 Set_Size_Info
(Def_Id
, (T
));
12717 Set_RM_Size
(Def_Id
, RM_Size
(T
));
12718 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
12720 Set_Scalar_Range
(Def_Id
, R
);
12721 Conditional_Delay
(Def_Id
, T
);
12723 -- In the subtype indication case, if the immediate parent of the
12724 -- new subtype is non-static, then the subtype we create is non-
12725 -- static, even if its bounds are static.
12727 if Nkind
(I
) = N_Subtype_Indication
12728 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
12730 Set_Is_Non_Static_Subtype
(Def_Id
);
12734 -- Final step is to label the index with this constructed type
12736 Set_Etype
(I
, Def_Id
);
12739 ------------------------------
12740 -- Modular_Type_Declaration --
12741 ------------------------------
12743 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
12744 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
12747 procedure Set_Modular_Size
(Bits
: Int
);
12748 -- Sets RM_Size to Bits, and Esize to normal word size above this
12750 ----------------------
12751 -- Set_Modular_Size --
12752 ----------------------
12754 procedure Set_Modular_Size
(Bits
: Int
) is
12756 Set_RM_Size
(T
, UI_From_Int
(Bits
));
12761 elsif Bits
<= 16 then
12762 Init_Esize
(T
, 16);
12764 elsif Bits
<= 32 then
12765 Init_Esize
(T
, 32);
12768 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
12770 end Set_Modular_Size
;
12772 -- Start of processing for Modular_Type_Declaration
12775 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
12777 Set_Ekind
(T
, E_Modular_Integer_Type
);
12778 Init_Alignment
(T
);
12779 Set_Is_Constrained
(T
);
12781 if not Is_OK_Static_Expression
(Mod_Expr
) then
12782 Flag_Non_Static_Expr
12783 ("non-static expression used for modular type bound!", Mod_Expr
);
12784 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
12786 M_Val
:= Expr_Value
(Mod_Expr
);
12790 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
12791 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
12794 Set_Modulus
(T
, M_Val
);
12796 -- Create bounds for the modular type based on the modulus given in
12797 -- the type declaration and then analyze and resolve those bounds.
12799 Set_Scalar_Range
(T
,
12800 Make_Range
(Sloc
(Mod_Expr
),
12802 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
12804 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
12806 -- Properly analyze the literals for the range. We do this manually
12807 -- because we can't go calling Resolve, since we are resolving these
12808 -- bounds with the type, and this type is certainly not complete yet!
12810 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
12811 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
12812 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
12813 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
12815 -- Loop through powers of two to find number of bits required
12817 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
12821 if M_Val
= 2 ** Bits
then
12822 Set_Modular_Size
(Bits
);
12827 elsif M_Val
< 2 ** Bits
then
12828 Set_Non_Binary_Modulus
(T
);
12830 if Bits
> System_Max_Nonbinary_Modulus_Power
then
12831 Error_Msg_Uint_1
:=
12832 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
12834 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
12835 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
12839 -- In the non-binary case, set size as per RM 13.3(55)
12841 Set_Modular_Size
(Bits
);
12848 -- If we fall through, then the size exceed System.Max_Binary_Modulus
12849 -- so we just signal an error and set the maximum size.
12851 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
12852 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
12854 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
12855 Init_Alignment
(T
);
12857 end Modular_Type_Declaration
;
12859 --------------------------
12860 -- New_Concatenation_Op --
12861 --------------------------
12863 procedure New_Concatenation_Op
(Typ
: Entity_Id
) is
12864 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
12867 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
12868 -- Create abbreviated declaration for the formal of a predefined
12869 -- Operator 'Op' of type 'Typ'
12871 --------------------
12872 -- Make_Op_Formal --
12873 --------------------
12875 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
12876 Formal
: Entity_Id
;
12878 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
12879 Set_Etype
(Formal
, Typ
);
12880 Set_Mechanism
(Formal
, Default_Mechanism
);
12882 end Make_Op_Formal
;
12884 -- Start of processing for New_Concatenation_Op
12887 Op
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Concat
);
12889 Set_Ekind
(Op
, E_Operator
);
12890 Set_Scope
(Op
, Current_Scope
);
12891 Set_Etype
(Op
, Typ
);
12892 Set_Homonym
(Op
, Get_Name_Entity_Id
(Name_Op_Concat
));
12893 Set_Is_Immediately_Visible
(Op
);
12894 Set_Is_Intrinsic_Subprogram
(Op
);
12895 Set_Has_Completion
(Op
);
12896 Append_Entity
(Op
, Current_Scope
);
12898 Set_Name_Entity_Id
(Name_Op_Concat
, Op
);
12900 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
12901 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
12902 end New_Concatenation_Op
;
12904 -------------------------------------------
12905 -- Ordinary_Fixed_Point_Type_Declaration --
12906 -------------------------------------------
12908 procedure Ordinary_Fixed_Point_Type_Declaration
12912 Loc
: constant Source_Ptr
:= Sloc
(Def
);
12913 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
12914 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
12915 Implicit_Base
: Entity_Id
;
12922 Check_Restriction
(No_Fixed_Point
, Def
);
12924 -- Create implicit base type
12927 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
12928 Set_Etype
(Implicit_Base
, Implicit_Base
);
12930 -- Analyze and process delta expression
12932 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
12934 Check_Delta_Expression
(Delta_Expr
);
12935 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
12937 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
12939 -- Compute default small from given delta, which is the largest power
12940 -- of two that does not exceed the given delta value.
12950 if Delta_Val
< Ureal_1
then
12951 while Delta_Val
< Tmp
loop
12952 Tmp
:= Tmp
/ Ureal_2
;
12953 Scale
:= Scale
+ 1;
12958 Tmp
:= Tmp
* Ureal_2
;
12959 exit when Tmp
> Delta_Val
;
12960 Scale
:= Scale
- 1;
12964 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
12967 Set_Small_Value
(Implicit_Base
, Small_Val
);
12969 -- If no range was given, set a dummy range
12971 if RRS
<= Empty_Or_Error
then
12972 Low_Val
:= -Small_Val
;
12973 High_Val
:= Small_Val
;
12975 -- Otherwise analyze and process given range
12979 Low
: constant Node_Id
:= Low_Bound
(RRS
);
12980 High
: constant Node_Id
:= High_Bound
(RRS
);
12983 Analyze_And_Resolve
(Low
, Any_Real
);
12984 Analyze_And_Resolve
(High
, Any_Real
);
12985 Check_Real_Bound
(Low
);
12986 Check_Real_Bound
(High
);
12988 -- Obtain and set the range
12990 Low_Val
:= Expr_Value_R
(Low
);
12991 High_Val
:= Expr_Value_R
(High
);
12993 if Low_Val
> High_Val
then
12994 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
12999 -- The range for both the implicit base and the declared first subtype
13000 -- cannot be set yet, so we use the special routine Set_Fixed_Range to
13001 -- set a temporary range in place. Note that the bounds of the base
13002 -- type will be widened to be symmetrical and to fill the available
13003 -- bits when the type is frozen.
13005 -- We could do this with all discrete types, and probably should, but
13006 -- we absolutely have to do it for fixed-point, since the end-points
13007 -- of the range and the size are determined by the small value, which
13008 -- could be reset before the freeze point.
13010 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
13011 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
13013 Init_Size_Align
(Implicit_Base
);
13015 -- Complete definition of first subtype
13017 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
13018 Set_Etype
(T
, Implicit_Base
);
13019 Init_Size_Align
(T
);
13020 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
13021 Set_Small_Value
(T
, Small_Val
);
13022 Set_Delta_Value
(T
, Delta_Val
);
13023 Set_Is_Constrained
(T
);
13025 end Ordinary_Fixed_Point_Type_Declaration
;
13027 ----------------------------------------
13028 -- Prepare_Private_Subtype_Completion --
13029 ----------------------------------------
13031 procedure Prepare_Private_Subtype_Completion
13033 Related_Nod
: Node_Id
)
13035 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
13036 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
13040 if Present
(Full_B
) then
13042 -- The Base_Type is already completed, we can complete the subtype
13043 -- now. We have to create a new entity with the same name, Thus we
13044 -- can't use Create_Itype.
13046 -- This is messy, should be fixed ???
13048 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
13049 Set_Is_Itype
(Full
);
13050 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
13051 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
13054 -- The parent subtype may be private, but the base might not, in some
13055 -- nested instances. In that case, the subtype does not need to be
13056 -- exchanged. It would still be nice to make private subtypes and their
13057 -- bases consistent at all times ???
13059 if Is_Private_Type
(Id_B
) then
13060 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
13063 end Prepare_Private_Subtype_Completion
;
13065 ---------------------------
13066 -- Process_Discriminants --
13067 ---------------------------
13069 procedure Process_Discriminants
13071 Prev
: Entity_Id
:= Empty
)
13073 Elist
: constant Elist_Id
:= New_Elmt_List
;
13076 Discr_Number
: Uint
;
13077 Discr_Type
: Entity_Id
;
13078 Default_Present
: Boolean := False;
13079 Default_Not_Present
: Boolean := False;
13082 -- A composite type other than an array type can have discriminants.
13083 -- Discriminants of non-limited types must have a discrete type.
13084 -- On entry, the current scope is the composite type.
13086 -- The discriminants are initially entered into the scope of the type
13087 -- via Enter_Name with the default Ekind of E_Void to prevent premature
13088 -- use, as explained at the end of this procedure.
13090 Discr
:= First
(Discriminant_Specifications
(N
));
13091 while Present
(Discr
) loop
13092 Enter_Name
(Defining_Identifier
(Discr
));
13094 -- For navigation purposes we add a reference to the discriminant
13095 -- in the entity for the type. If the current declaration is a
13096 -- completion, place references on the partial view. Otherwise the
13097 -- type is the current scope.
13099 if Present
(Prev
) then
13101 -- The references go on the partial view, if present. If the
13102 -- partial view has discriminants, the references have been
13103 -- generated already.
13105 if not Has_Discriminants
(Prev
) then
13106 Generate_Reference
(Prev
, Defining_Identifier
(Discr
), 'd');
13110 (Current_Scope
, Defining_Identifier
(Discr
), 'd');
13113 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
13114 Discr_Type
:= Access_Definition
(N
, Discriminant_Type
(Discr
));
13116 -- Ada 2005 (AI-230): Access discriminants are now allowed for
13117 -- nonlimited types, and are treated like other components of
13118 -- anonymous access types in terms of accessibility.
13120 if not Is_Concurrent_Type
(Current_Scope
)
13121 and then not Is_Concurrent_Record_Type
(Current_Scope
)
13122 and then not Is_Limited_Record
(Current_Scope
)
13123 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
13125 Set_Is_Local_Anonymous_Access
(Discr_Type
);
13128 -- Ada 2005 (AI-254)
13130 if Present
(Access_To_Subprogram_Definition
13131 (Discriminant_Type
(Discr
)))
13132 and then Protected_Present
(Access_To_Subprogram_Definition
13133 (Discriminant_Type
(Discr
)))
13136 Replace_Anonymous_Access_To_Protected_Subprogram
13137 (Discr
, Discr_Type
);
13141 Find_Type
(Discriminant_Type
(Discr
));
13142 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
13144 if Error_Posted
(Discriminant_Type
(Discr
)) then
13145 Discr_Type
:= Any_Type
;
13149 if Is_Access_Type
(Discr_Type
) then
13151 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
13154 if Ada_Version
< Ada_05
then
13155 Check_Access_Discriminant_Requires_Limited
13156 (Discr
, Discriminant_Type
(Discr
));
13159 if Ada_Version
= Ada_83
and then Comes_From_Source
(Discr
) then
13161 ("(Ada 83) access discriminant not allowed", Discr
);
13164 elsif not Is_Discrete_Type
(Discr_Type
) then
13165 Error_Msg_N
("discriminants must have a discrete or access type",
13166 Discriminant_Type
(Discr
));
13169 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
13171 -- If a discriminant specification includes the assignment compound
13172 -- delimiter followed by an expression, the expression is the default
13173 -- expression of the discriminant; the default expression must be of
13174 -- the type of the discriminant. (RM 3.7.1) Since this expression is
13175 -- a default expression, we do the special preanalysis, since this
13176 -- expression does not freeze (see "Handling of Default and Per-
13177 -- Object Expressions" in spec of package Sem).
13179 if Present
(Expression
(Discr
)) then
13180 Analyze_Per_Use_Expression
(Expression
(Discr
), Discr_Type
);
13182 if Nkind
(N
) = N_Formal_Type_Declaration
then
13184 ("discriminant defaults not allowed for formal type",
13185 Expression
(Discr
));
13187 -- Tagged types cannot have defaulted discriminants, but a
13188 -- non-tagged private type with defaulted discriminants
13189 -- can have a tagged completion.
13191 elsif Is_Tagged_Type
(Current_Scope
)
13192 and then Comes_From_Source
(N
)
13195 ("discriminants of tagged type cannot have defaults",
13196 Expression
(Discr
));
13199 Default_Present
:= True;
13200 Append_Elmt
(Expression
(Discr
), Elist
);
13202 -- Tag the defining identifiers for the discriminants with
13203 -- their corresponding default expressions from the tree.
13205 Set_Discriminant_Default_Value
13206 (Defining_Identifier
(Discr
), Expression
(Discr
));
13210 Default_Not_Present
:= True;
13213 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
13214 -- Discr_Type but with the null-exclusion attribute
13216 if Ada_Version
>= Ada_05
then
13218 -- Ada 2005 (AI-231): Static checks
13220 if Can_Never_Be_Null
(Discr_Type
) then
13221 Null_Exclusion_Static_Checks
(Discr
);
13223 elsif Is_Access_Type
(Discr_Type
)
13224 and then Null_Exclusion_Present
(Discr
)
13226 -- No need to check itypes because in their case this check
13227 -- was done at their point of creation
13229 and then not Is_Itype
(Discr_Type
)
13231 if Can_Never_Be_Null
(Discr_Type
) then
13233 ("(Ada 2005) already a null-excluding type", Discr
);
13236 Set_Etype
(Defining_Identifier
(Discr
),
13237 Create_Null_Excluding_Itype
13239 Related_Nod
=> Discr
));
13247 -- An element list consisting of the default expressions of the
13248 -- discriminants is constructed in the above loop and used to set
13249 -- the Discriminant_Constraint attribute for the type. If an object
13250 -- is declared of this (record or task) type without any explicit
13251 -- discriminant constraint given, this element list will form the
13252 -- actual parameters for the corresponding initialization procedure
13255 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
13256 Set_Stored_Constraint
(Current_Scope
, No_Elist
);
13258 -- Default expressions must be provided either for all or for none
13259 -- of the discriminants of a discriminant part. (RM 3.7.1)
13261 if Default_Present
and then Default_Not_Present
then
13263 ("incomplete specification of defaults for discriminants", N
);
13266 -- The use of the name of a discriminant is not allowed in default
13267 -- expressions of a discriminant part if the specification of the
13268 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
13270 -- To detect this, the discriminant names are entered initially with an
13271 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
13272 -- attempt to use a void entity (for example in an expression that is
13273 -- type-checked) produces the error message: premature usage. Now after
13274 -- completing the semantic analysis of the discriminant part, we can set
13275 -- the Ekind of all the discriminants appropriately.
13277 Discr
:= First
(Discriminant_Specifications
(N
));
13278 Discr_Number
:= Uint_1
;
13279 while Present
(Discr
) loop
13280 Id
:= Defining_Identifier
(Discr
);
13281 Set_Ekind
(Id
, E_Discriminant
);
13282 Init_Component_Location
(Id
);
13284 Set_Discriminant_Number
(Id
, Discr_Number
);
13286 -- Make sure this is always set, even in illegal programs
13288 Set_Corresponding_Discriminant
(Id
, Empty
);
13290 -- Initialize the Original_Record_Component to the entity itself.
13291 -- Inherit_Components will propagate the right value to
13292 -- discriminants in derived record types.
13294 Set_Original_Record_Component
(Id
, Id
);
13296 -- Create the discriminal for the discriminant
13298 Build_Discriminal
(Id
);
13301 Discr_Number
:= Discr_Number
+ 1;
13304 Set_Has_Discriminants
(Current_Scope
);
13305 end Process_Discriminants
;
13307 -----------------------
13308 -- Process_Full_View --
13309 -----------------------
13311 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
13312 Priv_Parent
: Entity_Id
;
13313 Full_Parent
: Entity_Id
;
13314 Full_Indic
: Node_Id
;
13316 procedure Collect_Implemented_Interfaces
13318 Ifaces
: Elist_Id
);
13319 -- Ada 2005: Gather all the interfaces that Typ directly or
13320 -- inherently implements. Duplicate entries are not added to
13321 -- the list Ifaces.
13323 function Contain_Interface
13324 (Iface
: Entity_Id
;
13325 Ifaces
: Elist_Id
) return Boolean;
13326 -- Ada 2005: Determine whether Iface is present in the list Ifaces
13328 function Find_Hidden_Interface
13330 Dest
: Elist_Id
) return Entity_Id
;
13331 -- Ada 2005: Determine whether the interfaces in list Src are all
13332 -- present in the list Dest. Return the first differing interface,
13333 -- or Empty otherwise.
13335 ------------------------------------
13336 -- Collect_Implemented_Interfaces --
13337 ------------------------------------
13339 procedure Collect_Implemented_Interfaces
13344 Iface_Elmt
: Elmt_Id
;
13347 -- Implementations of the form:
13348 -- type Typ is new Iface ...
13350 if Is_Interface
(Etype
(Typ
))
13351 and then not Contain_Interface
(Etype
(Typ
), Ifaces
)
13353 Append_Elmt
(Etype
(Typ
), Ifaces
);
13356 -- Implementations of the form:
13357 -- type Typ is ... and Iface ...
13359 if Present
(Abstract_Interfaces
(Typ
)) then
13360 Iface_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
13361 while Present
(Iface_Elmt
) loop
13362 Iface
:= Node
(Iface_Elmt
);
13364 if Is_Interface
(Iface
)
13365 and then not Contain_Interface
(Iface
, Ifaces
)
13367 Append_Elmt
(Iface
, Ifaces
);
13370 Next_Elmt
(Iface_Elmt
);
13374 -- Implementations of the form:
13375 -- type Typ is new Parent_Typ and ...
13377 if Ekind
(Typ
) = E_Record_Type
13378 and then Present
(Parent_Subtype
(Typ
))
13380 Collect_Implemented_Interfaces
(Parent_Subtype
(Typ
), Ifaces
);
13382 -- Implementations of the form:
13383 -- type Typ is ... with private;
13385 elsif Ekind
(Typ
) = E_Record_Type_With_Private
13386 and then Present
(Full_View
(Typ
))
13387 and then Etype
(Typ
) /= Full_View
(Typ
)
13388 and then Etype
(Typ
) /= Typ
13390 Collect_Implemented_Interfaces
(Etype
(Typ
), Ifaces
);
13392 end Collect_Implemented_Interfaces
;
13394 -----------------------
13395 -- Contain_Interface --
13396 -----------------------
13398 function Contain_Interface
13399 (Iface
: Entity_Id
;
13400 Ifaces
: Elist_Id
) return Boolean
13402 Iface_Elmt
: Elmt_Id
;
13405 if Present
(Ifaces
) then
13406 Iface_Elmt
:= First_Elmt
(Ifaces
);
13407 while Present
(Iface_Elmt
) loop
13408 if Node
(Iface_Elmt
) = Iface
then
13412 Next_Elmt
(Iface_Elmt
);
13417 end Contain_Interface
;
13419 ---------------------------
13420 -- Find_Hidden_Interface --
13421 ---------------------------
13423 function Find_Hidden_Interface
13425 Dest
: Elist_Id
) return Entity_Id
13428 Iface_Elmt
: Elmt_Id
;
13431 if Present
(Src
) and then Present
(Dest
) then
13432 Iface_Elmt
:= First_Elmt
(Src
);
13433 while Present
(Iface_Elmt
) loop
13434 Iface
:= Node
(Iface_Elmt
);
13436 if not Contain_Interface
(Iface
, Dest
) then
13440 Next_Elmt
(Iface_Elmt
);
13445 end Find_Hidden_Interface
;
13447 -- Start of processing for Process_Full_View
13450 -- First some sanity checks that must be done after semantic
13451 -- decoration of the full view and thus cannot be placed with other
13452 -- similar checks in Find_Type_Name
13454 if not Is_Limited_Type
(Priv_T
)
13455 and then (Is_Limited_Type
(Full_T
)
13456 or else Is_Limited_Composite
(Full_T
))
13459 ("completion of nonlimited type cannot be limited", Full_T
);
13460 Explain_Limited_Type
(Full_T
, Full_T
);
13462 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
13464 ("completion of nonabstract type cannot be abstract", Full_T
);
13466 elsif Is_Tagged_Type
(Priv_T
)
13467 and then Is_Limited_Type
(Priv_T
)
13468 and then not Is_Limited_Type
(Full_T
)
13470 -- GNAT allow its own definition of Limited_Controlled to disobey
13471 -- this rule in order in ease the implementation. The next test is
13472 -- safe because Root_Controlled is defined in a private system child
13474 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
13475 Set_Is_Limited_Composite
(Full_T
);
13478 ("completion of limited tagged type must be limited", Full_T
);
13481 elsif Is_Generic_Type
(Priv_T
) then
13482 Error_Msg_N
("generic type cannot have a completion", Full_T
);
13485 if Ada_Version
>= Ada_05
13486 and then Is_Tagged_Type
(Priv_T
)
13487 and then Is_Tagged_Type
(Full_T
)
13491 Priv_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
13492 Full_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
13495 Collect_Implemented_Interfaces
(Priv_T
, Priv_T_Ifaces
);
13496 Collect_Implemented_Interfaces
(Full_T
, Full_T_Ifaces
);
13498 -- Ada 2005 (AI-396): The partial view shall be a descendant of
13499 -- an interface type if and only if the full view is a descendant
13500 -- of the interface type.
13502 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
13504 if Present
(Iface
) then
13505 Error_Msg_NE
("interface & not implemented by partial view " &
13506 "('R'M'-2005 7.3(9))", Full_T
, Iface
);
13511 if Is_Tagged_Type
(Priv_T
)
13512 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
13513 and then Is_Derived_Type
(Full_T
)
13515 Priv_Parent
:= Etype
(Priv_T
);
13517 -- The full view of a private extension may have been transformed
13518 -- into an unconstrained derived type declaration and a subtype
13519 -- declaration (see build_derived_record_type for details).
13521 if Nkind
(N
) = N_Subtype_Declaration
then
13522 Full_Indic
:= Subtype_Indication
(N
);
13523 Full_Parent
:= Etype
(Base_Type
(Full_T
));
13525 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
13526 Full_Parent
:= Etype
(Full_T
);
13529 -- Check that the parent type of the full type is a descendant of
13530 -- the ancestor subtype given in the private extension. If either
13531 -- entity has an Etype equal to Any_Type then we had some previous
13532 -- error situation [7.3(8)].
13534 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
13537 -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in
13538 -- any order. Therefore we don't have to check that its parent must
13539 -- be a descendant of the parent of the private type declaration.
13541 elsif Is_Interface
(Priv_Parent
)
13542 and then Is_Interface
(Full_Parent
)
13546 elsif not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
) then
13548 ("parent of full type must descend from parent"
13549 & " of private extension", Full_Indic
);
13551 -- Check the rules of 7.3(10): if the private extension inherits
13552 -- known discriminants, then the full type must also inherit those
13553 -- discriminants from the same (ancestor) type, and the parent
13554 -- subtype of the full type must be constrained if and only if
13555 -- the ancestor subtype of the private extension is constrained.
13557 elsif not Present
(Discriminant_Specifications
(Parent
(Priv_T
)))
13558 and then not Has_Unknown_Discriminants
(Priv_T
)
13559 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
13562 Priv_Indic
: constant Node_Id
:=
13563 Subtype_Indication
(Parent
(Priv_T
));
13565 Priv_Constr
: constant Boolean :=
13566 Is_Constrained
(Priv_Parent
)
13568 Nkind
(Priv_Indic
) = N_Subtype_Indication
13569 or else Is_Constrained
(Entity
(Priv_Indic
));
13571 Full_Constr
: constant Boolean :=
13572 Is_Constrained
(Full_Parent
)
13574 Nkind
(Full_Indic
) = N_Subtype_Indication
13575 or else Is_Constrained
(Entity
(Full_Indic
));
13577 Priv_Discr
: Entity_Id
;
13578 Full_Discr
: Entity_Id
;
13581 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
13582 Full_Discr
:= First_Discriminant
(Full_Parent
);
13583 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
13584 if Original_Record_Component
(Priv_Discr
) =
13585 Original_Record_Component
(Full_Discr
)
13587 Corresponding_Discriminant
(Priv_Discr
) =
13588 Corresponding_Discriminant
(Full_Discr
)
13595 Next_Discriminant
(Priv_Discr
);
13596 Next_Discriminant
(Full_Discr
);
13599 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
13601 ("full view must inherit discriminants of the parent type"
13602 & " used in the private extension", Full_Indic
);
13604 elsif Priv_Constr
and then not Full_Constr
then
13606 ("parent subtype of full type must be constrained",
13609 elsif Full_Constr
and then not Priv_Constr
then
13611 ("parent subtype of full type must be unconstrained",
13616 -- Check the rules of 7.3(12): if a partial view has neither known
13617 -- or unknown discriminants, then the full type declaration shall
13618 -- define a definite subtype.
13620 elsif not Has_Unknown_Discriminants
(Priv_T
)
13621 and then not Has_Discriminants
(Priv_T
)
13622 and then not Is_Constrained
(Full_T
)
13625 ("full view must define a constrained type if partial view"
13626 & " has no discriminants", Full_T
);
13629 -- ??????? Do we implement the following properly ?????
13630 -- If the ancestor subtype of a private extension has constrained
13631 -- discriminants, then the parent subtype of the full view shall
13632 -- impose a statically matching constraint on those discriminants
13636 -- For untagged types, verify that a type without discriminants
13637 -- is not completed with an unconstrained type.
13639 if not Is_Indefinite_Subtype
(Priv_T
)
13640 and then Is_Indefinite_Subtype
(Full_T
)
13642 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
13646 -- AI-419: verify that the use of "limited" is consistent
13649 Orig_Decl
: constant Node_Id
:= Original_Node
(N
);
13651 if Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
13652 and then not Limited_Present
(Parent
(Priv_T
))
13653 and then Nkind
(Orig_Decl
) = N_Full_Type_Declaration
13655 (Type_Definition
(Orig_Decl
)) = N_Derived_Type_Definition
13656 and then Limited_Present
(Type_Definition
(Orig_Decl
))
13659 ("full view of non-limited extension cannot be limited", N
);
13663 -- Ada 2005 AI-363: if the full view has discriminants with
13664 -- defaults, it is illegal to declare constrained access subtypes
13665 -- whose designated type is the current type. This allows objects
13666 -- of the type that are declared in the heap to be unconstrained.
13668 if not Has_Unknown_Discriminants
(Priv_T
)
13669 and then not Has_Discriminants
(Priv_T
)
13670 and then Has_Discriminants
(Full_T
)
13673 (Discriminant_Default_Value
(First_Discriminant
(Full_T
)))
13675 Set_Has_Constrained_Partial_View
(Full_T
);
13676 Set_Has_Constrained_Partial_View
(Priv_T
);
13679 -- Create a full declaration for all its subtypes recorded in
13680 -- Private_Dependents and swap them similarly to the base type. These
13681 -- are subtypes that have been define before the full declaration of
13682 -- the private type. We also swap the entry in Private_Dependents list
13683 -- so we can properly restore the private view on exit from the scope.
13686 Priv_Elmt
: Elmt_Id
;
13691 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
13692 while Present
(Priv_Elmt
) loop
13693 Priv
:= Node
(Priv_Elmt
);
13695 if Ekind
(Priv
) = E_Private_Subtype
13696 or else Ekind
(Priv
) = E_Limited_Private_Subtype
13697 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
13699 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
13700 Set_Is_Itype
(Full
);
13701 Set_Parent
(Full
, Parent
(Priv
));
13702 Set_Associated_Node_For_Itype
(Full
, N
);
13704 -- Now we need to complete the private subtype, but since the
13705 -- base type has already been swapped, we must also swap the
13706 -- subtypes (and thus, reverse the arguments in the call to
13707 -- Complete_Private_Subtype).
13709 Copy_And_Swap
(Priv
, Full
);
13710 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
13711 Replace_Elmt
(Priv_Elmt
, Full
);
13714 Next_Elmt
(Priv_Elmt
);
13718 -- If the private view was tagged, copy the new Primitive
13719 -- operations from the private view to the full view.
13721 if Is_Tagged_Type
(Full_T
) then
13723 Priv_List
: Elist_Id
;
13724 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
13727 D_Type
: Entity_Id
;
13730 if Is_Tagged_Type
(Priv_T
) then
13731 Priv_List
:= Primitive_Operations
(Priv_T
);
13733 P1
:= First_Elmt
(Priv_List
);
13734 while Present
(P1
) loop
13737 -- Transfer explicit primitives, not those inherited from
13738 -- parent of partial view, which will be re-inherited on
13741 if Comes_From_Source
(Prim
) then
13742 P2
:= First_Elmt
(Full_List
);
13743 while Present
(P2
) and then Node
(P2
) /= Prim
loop
13747 -- If not found, that is a new one
13750 Append_Elmt
(Prim
, Full_List
);
13758 -- In this case the partial view is untagged, so here we
13759 -- locate all of the earlier primitives that need to be
13760 -- treated as dispatching (those that appear between the two
13761 -- views). Note that these additional operations must all be
13762 -- new operations (any earlier operations that override
13763 -- inherited operations of the full view will already have
13764 -- been inserted in the primitives list and marked as
13765 -- dispatching by Check_Operation_From_Private_View. Note that
13766 -- implicit "/=" operators are excluded from being added to
13767 -- the primitives list since they shouldn't be treated as
13768 -- dispatching (tagged "/=" is handled specially).
13770 Prim
:= Next_Entity
(Full_T
);
13771 while Present
(Prim
) and then Prim
/= Priv_T
loop
13772 if Ekind
(Prim
) = E_Procedure
13774 Ekind
(Prim
) = E_Function
13777 D_Type
:= Find_Dispatching_Type
(Prim
);
13780 and then (Chars
(Prim
) /= Name_Op_Ne
13781 or else Comes_From_Source
(Prim
))
13783 Check_Controlling_Formals
(Full_T
, Prim
);
13785 if not Is_Dispatching_Operation
(Prim
) then
13786 Append_Elmt
(Prim
, Full_List
);
13787 Set_Is_Dispatching_Operation
(Prim
, True);
13788 Set_DT_Position
(Prim
, No_Uint
);
13791 elsif Is_Dispatching_Operation
(Prim
)
13792 and then D_Type
/= Full_T
13795 -- Verify that it is not otherwise controlled by
13796 -- a formal or a return value of type T.
13798 Check_Controlling_Formals
(D_Type
, Prim
);
13802 Next_Entity
(Prim
);
13806 -- For the tagged case, the two views can share the same
13807 -- Primitive Operation list and the same class wide type.
13808 -- Update attributes of the class-wide type which depend on
13809 -- the full declaration.
13811 if Is_Tagged_Type
(Priv_T
) then
13812 Set_Primitive_Operations
(Priv_T
, Full_List
);
13813 Set_Class_Wide_Type
13814 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
13816 -- Any other attributes should be propagated to C_W ???
13818 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
13823 end Process_Full_View
;
13825 -----------------------------------
13826 -- Process_Incomplete_Dependents --
13827 -----------------------------------
13829 procedure Process_Incomplete_Dependents
13831 Full_T
: Entity_Id
;
13834 Inc_Elmt
: Elmt_Id
;
13835 Priv_Dep
: Entity_Id
;
13836 New_Subt
: Entity_Id
;
13838 Disc_Constraint
: Elist_Id
;
13841 if No
(Private_Dependents
(Inc_T
)) then
13845 -- Itypes that may be generated by the completion of an incomplete
13846 -- subtype are not used by the back-end and not attached to the tree.
13847 -- They are created only for constraint-checking purposes.
13849 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
13850 while Present
(Inc_Elmt
) loop
13851 Priv_Dep
:= Node
(Inc_Elmt
);
13853 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
13855 -- An Access_To_Subprogram type may have a return type or a
13856 -- parameter type that is incomplete. Replace with the full view.
13858 if Etype
(Priv_Dep
) = Inc_T
then
13859 Set_Etype
(Priv_Dep
, Full_T
);
13863 Formal
: Entity_Id
;
13866 Formal
:= First_Formal
(Priv_Dep
);
13867 while Present
(Formal
) loop
13868 if Etype
(Formal
) = Inc_T
then
13869 Set_Etype
(Formal
, Full_T
);
13872 Next_Formal
(Formal
);
13876 elsif Is_Overloadable
(Priv_Dep
) then
13878 -- A protected operation is never dispatching: only its
13879 -- wrapper operation (which has convention Ada) is.
13881 if Is_Tagged_Type
(Full_T
)
13882 and then Convention
(Priv_Dep
) /= Convention_Protected
13885 -- Subprogram has an access parameter whose designated type
13886 -- was incomplete. Reexamine declaration now, because it may
13887 -- be a primitive operation of the full type.
13889 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
13890 Set_Is_Dispatching_Operation
(Priv_Dep
);
13891 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
13894 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
13896 -- Can happen during processing of a body before the completion
13897 -- of a TA type. Ignore, because spec is also on dependent list.
13901 -- Dependent is a subtype
13904 -- We build a new subtype indication using the full view of the
13905 -- incomplete parent. The discriminant constraints have been
13906 -- elaborated already at the point of the subtype declaration.
13908 New_Subt
:= Create_Itype
(E_Void
, N
);
13910 if Has_Discriminants
(Full_T
) then
13911 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
13913 Disc_Constraint
:= No_Elist
;
13916 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
13917 Set_Full_View
(Priv_Dep
, New_Subt
);
13920 Next_Elmt
(Inc_Elmt
);
13922 end Process_Incomplete_Dependents
;
13924 --------------------------------
13925 -- Process_Range_Expr_In_Decl --
13926 --------------------------------
13928 procedure Process_Range_Expr_In_Decl
13931 Check_List
: List_Id
:= Empty_List
;
13932 R_Check_Off
: Boolean := False)
13935 R_Checks
: Check_Result
;
13936 Type_Decl
: Node_Id
;
13937 Def_Id
: Entity_Id
;
13940 Analyze_And_Resolve
(R
, Base_Type
(T
));
13942 if Nkind
(R
) = N_Range
then
13943 Lo
:= Low_Bound
(R
);
13944 Hi
:= High_Bound
(R
);
13946 -- If there were errors in the declaration, try and patch up some
13947 -- common mistakes in the bounds. The cases handled are literals
13948 -- which are Integer where the expected type is Real and vice versa.
13949 -- These corrections allow the compilation process to proceed further
13950 -- along since some basic assumptions of the format of the bounds
13953 if Etype
(R
) = Any_Type
then
13955 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
13957 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
13959 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
13961 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
13963 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
13965 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
13967 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
13969 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
13976 -- If the bounds of the range have been mistakenly given as string
13977 -- literals (perhaps in place of character literals), then an error
13978 -- has already been reported, but we rewrite the string literal as a
13979 -- bound of the range's type to avoid blowups in later processing
13980 -- that looks at static values.
13982 if Nkind
(Lo
) = N_String_Literal
then
13984 Make_Attribute_Reference
(Sloc
(Lo
),
13985 Attribute_Name
=> Name_First
,
13986 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
13987 Analyze_And_Resolve
(Lo
);
13990 if Nkind
(Hi
) = N_String_Literal
then
13992 Make_Attribute_Reference
(Sloc
(Hi
),
13993 Attribute_Name
=> Name_First
,
13994 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
13995 Analyze_And_Resolve
(Hi
);
13998 -- If bounds aren't scalar at this point then exit, avoiding
13999 -- problems with further processing of the range in this procedure.
14001 if not Is_Scalar_Type
(Etype
(Lo
)) then
14005 -- Resolve (actually Sem_Eval) has checked that the bounds are in
14006 -- then range of the base type. Here we check whether the bounds
14007 -- are in the range of the subtype itself. Note that if the bounds
14008 -- represent the null range the Constraint_Error exception should
14011 -- ??? The following code should be cleaned up as follows
14013 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
14014 -- is done in the call to Range_Check (R, T); below
14016 -- 2. The use of R_Check_Off should be investigated and possibly
14017 -- removed, this would clean up things a bit.
14019 if Is_Null_Range
(Lo
, Hi
) then
14023 -- Capture values of bounds and generate temporaries for them
14024 -- if needed, before applying checks, since checks may cause
14025 -- duplication of the expression without forcing evaluation.
14027 if Expander_Active
then
14028 Force_Evaluation
(Lo
);
14029 Force_Evaluation
(Hi
);
14032 -- We use a flag here instead of suppressing checks on the
14033 -- type because the type we check against isn't necessarily
14034 -- the place where we put the check.
14036 if not R_Check_Off
then
14037 R_Checks
:= Range_Check
(R
, T
);
14039 -- Look up tree to find an appropriate insertion point.
14040 -- This seems really junk code, and very brittle, couldn't
14041 -- we just use an insert actions call of some kind ???
14043 Type_Decl
:= Parent
(R
);
14044 while Present
(Type_Decl
) and then not
14045 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
14047 Nkind
(Type_Decl
) = N_Subtype_Declaration
14049 Nkind
(Type_Decl
) = N_Loop_Statement
14051 Nkind
(Type_Decl
) = N_Task_Type_Declaration
14053 Nkind
(Type_Decl
) = N_Single_Task_Declaration
14055 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
14057 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
14059 Type_Decl
:= Parent
(Type_Decl
);
14062 -- Why would Type_Decl not be present??? Without this test,
14063 -- short regression tests fail.
14065 if Present
(Type_Decl
) then
14067 -- Case of loop statement (more comments ???)
14069 if Nkind
(Type_Decl
) = N_Loop_Statement
then
14074 Indic
:= Parent
(R
);
14075 while Present
(Indic
) and then not
14076 (Nkind
(Indic
) = N_Subtype_Indication
)
14078 Indic
:= Parent
(Indic
);
14081 if Present
(Indic
) then
14082 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
14084 Insert_Range_Checks
14090 Do_Before
=> True);
14094 -- All other cases (more comments ???)
14097 Def_Id
:= Defining_Identifier
(Type_Decl
);
14099 if (Ekind
(Def_Id
) = E_Record_Type
14100 and then Depends_On_Discriminant
(R
))
14102 (Ekind
(Def_Id
) = E_Protected_Type
14103 and then Has_Discriminants
(Def_Id
))
14105 Append_Range_Checks
14106 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
14109 Insert_Range_Checks
14110 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
14118 elsif Expander_Active
then
14119 Get_Index_Bounds
(R
, Lo
, Hi
);
14120 Force_Evaluation
(Lo
);
14121 Force_Evaluation
(Hi
);
14123 end Process_Range_Expr_In_Decl
;
14125 --------------------------------------
14126 -- Process_Real_Range_Specification --
14127 --------------------------------------
14129 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
14130 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
14133 Err
: Boolean := False;
14135 procedure Analyze_Bound
(N
: Node_Id
);
14136 -- Analyze and check one bound
14138 -------------------
14139 -- Analyze_Bound --
14140 -------------------
14142 procedure Analyze_Bound
(N
: Node_Id
) is
14144 Analyze_And_Resolve
(N
, Any_Real
);
14146 if not Is_OK_Static_Expression
(N
) then
14147 Flag_Non_Static_Expr
14148 ("bound in real type definition is not static!", N
);
14153 -- Start of processing for Process_Real_Range_Specification
14156 if Present
(Spec
) then
14157 Lo
:= Low_Bound
(Spec
);
14158 Hi
:= High_Bound
(Spec
);
14159 Analyze_Bound
(Lo
);
14160 Analyze_Bound
(Hi
);
14162 -- If error, clear away junk range specification
14165 Set_Real_Range_Specification
(Def
, Empty
);
14168 end Process_Real_Range_Specification
;
14170 ---------------------
14171 -- Process_Subtype --
14172 ---------------------
14174 function Process_Subtype
14176 Related_Nod
: Node_Id
;
14177 Related_Id
: Entity_Id
:= Empty
;
14178 Suffix
: Character := ' ') return Entity_Id
14181 Def_Id
: Entity_Id
;
14182 Error_Node
: Node_Id
;
14183 Full_View_Id
: Entity_Id
;
14184 Subtype_Mark_Id
: Entity_Id
;
14186 May_Have_Null_Exclusion
: Boolean;
14188 procedure Check_Incomplete
(T
: Entity_Id
);
14189 -- Called to verify that an incomplete type is not used prematurely
14191 ----------------------
14192 -- Check_Incomplete --
14193 ----------------------
14195 procedure Check_Incomplete
(T
: Entity_Id
) is
14197 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
then
14198 Error_Msg_N
("invalid use of type before its full declaration", T
);
14200 end Check_Incomplete
;
14202 -- Start of processing for Process_Subtype
14205 -- Case of no constraints present
14207 if Nkind
(S
) /= N_Subtype_Indication
then
14210 Check_Incomplete
(S
);
14213 -- Ada 2005 (AI-231): Static check
14215 if Ada_Version
>= Ada_05
14216 and then Present
(P
)
14217 and then Null_Exclusion_Present
(P
)
14218 and then Nkind
(P
) /= N_Access_To_Object_Definition
14219 and then not Is_Access_Type
(Entity
(S
))
14222 ("(Ada 2005) the null-exclusion part requires an access type",
14226 May_Have_Null_Exclusion
:=
14227 Nkind
(P
) = N_Access_Definition
14228 or else Nkind
(P
) = N_Access_Function_Definition
14229 or else Nkind
(P
) = N_Access_Procedure_Definition
14230 or else Nkind
(P
) = N_Access_To_Object_Definition
14231 or else Nkind
(P
) = N_Allocator
14232 or else Nkind
(P
) = N_Component_Definition
14233 or else Nkind
(P
) = N_Derived_Type_Definition
14234 or else Nkind
(P
) = N_Discriminant_Specification
14235 or else Nkind
(P
) = N_Object_Declaration
14236 or else Nkind
(P
) = N_Parameter_Specification
14237 or else Nkind
(P
) = N_Subtype_Declaration
;
14239 -- Create an Itype that is a duplicate of Entity (S) but with the
14240 -- null-exclusion attribute
14242 if May_Have_Null_Exclusion
14243 and then Is_Access_Type
(Entity
(S
))
14244 and then Null_Exclusion_Present
(P
)
14246 -- No need to check the case of an access to object definition.
14247 -- It is correct to define double not-null pointers.
14249 -- type Not_Null_Int_Ptr is not null access Integer;
14250 -- type Acc is not null access Not_Null_Int_Ptr;
14252 and then Nkind
(P
) /= N_Access_To_Object_Definition
14254 if Can_Never_Be_Null
(Entity
(S
)) then
14255 case Nkind
(Related_Nod
) is
14256 when N_Full_Type_Declaration
=>
14257 if Nkind
(Type_Definition
(Related_Nod
))
14258 in N_Array_Type_Definition
14262 (Component_Definition
14263 (Type_Definition
(Related_Nod
)));
14266 Subtype_Indication
(Type_Definition
(Related_Nod
));
14269 when N_Subtype_Declaration
=>
14270 Error_Node
:= Subtype_Indication
(Related_Nod
);
14272 when N_Object_Declaration
=>
14273 Error_Node
:= Object_Definition
(Related_Nod
);
14275 when N_Component_Declaration
=>
14277 Subtype_Indication
(Component_Definition
(Related_Nod
));
14280 pragma Assert
(False);
14281 Error_Node
:= Related_Nod
;
14285 ("(Ada 2005) already a null-excluding type", Error_Node
);
14289 Create_Null_Excluding_Itype
14291 Related_Nod
=> P
));
14292 Set_Entity
(S
, Etype
(S
));
14297 -- Case of constraint present, so that we have an N_Subtype_Indication
14298 -- node (this node is created only if constraints are present).
14302 Find_Type
(Subtype_Mark
(S
));
14304 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
14306 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
14307 and then Is_Itype
(Defining_Identifier
(Parent
(S
))))
14309 Check_Incomplete
(Subtype_Mark
(S
));
14313 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
14315 -- Explicit subtype declaration case
14317 if Nkind
(P
) = N_Subtype_Declaration
then
14318 Def_Id
:= Defining_Identifier
(P
);
14320 -- Explicit derived type definition case
14322 elsif Nkind
(P
) = N_Derived_Type_Definition
then
14323 Def_Id
:= Defining_Identifier
(Parent
(P
));
14325 -- Implicit case, the Def_Id must be created as an implicit type.
14326 -- The one exception arises in the case of concurrent types, array
14327 -- and access types, where other subsidiary implicit types may be
14328 -- created and must appear before the main implicit type. In these
14329 -- cases we leave Def_Id set to Empty as a signal that Create_Itype
14330 -- has not yet been called to create Def_Id.
14333 if Is_Array_Type
(Subtype_Mark_Id
)
14334 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
14335 or else Is_Access_Type
(Subtype_Mark_Id
)
14339 -- For the other cases, we create a new unattached Itype,
14340 -- and set the indication to ensure it gets attached later.
14344 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14348 -- If the kind of constraint is invalid for this kind of type,
14349 -- then give an error, and then pretend no constraint was given.
14351 if not Is_Valid_Constraint_Kind
14352 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
14355 ("incorrect constraint for this kind of type", Constraint
(S
));
14357 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
14359 -- Set Ekind of orphan itype, to prevent cascaded errors
14361 if Present
(Def_Id
) then
14362 Set_Ekind
(Def_Id
, Ekind
(Any_Type
));
14365 -- Make recursive call, having got rid of the bogus constraint
14367 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
14370 -- Remaining processing depends on type
14372 case Ekind
(Subtype_Mark_Id
) is
14373 when Access_Kind
=>
14374 Constrain_Access
(Def_Id
, S
, Related_Nod
);
14377 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
14379 when Decimal_Fixed_Point_Kind
=>
14380 Constrain_Decimal
(Def_Id
, S
);
14382 when Enumeration_Kind
=>
14383 Constrain_Enumeration
(Def_Id
, S
);
14385 when Ordinary_Fixed_Point_Kind
=>
14386 Constrain_Ordinary_Fixed
(Def_Id
, S
);
14389 Constrain_Float
(Def_Id
, S
);
14391 when Integer_Kind
=>
14392 Constrain_Integer
(Def_Id
, S
);
14394 when E_Record_Type |
14397 E_Incomplete_Type
=>
14398 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14400 when Private_Kind
=>
14401 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14402 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
14404 -- In case of an invalid constraint prevent further processing
14405 -- since the type constructed is missing expected fields.
14407 if Etype
(Def_Id
) = Any_Type
then
14411 -- If the full view is that of a task with discriminants,
14412 -- we must constrain both the concurrent type and its
14413 -- corresponding record type. Otherwise we will just propagate
14414 -- the constraint to the full view, if available.
14416 if Present
(Full_View
(Subtype_Mark_Id
))
14417 and then Has_Discriminants
(Subtype_Mark_Id
)
14418 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
14421 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14423 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
14424 Constrain_Concurrent
(Full_View_Id
, S
,
14425 Related_Nod
, Related_Id
, Suffix
);
14426 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
14427 Set_Full_View
(Def_Id
, Full_View_Id
);
14430 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
14433 when Concurrent_Kind
=>
14434 Constrain_Concurrent
(Def_Id
, S
,
14435 Related_Nod
, Related_Id
, Suffix
);
14438 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
14441 -- Size and Convention are always inherited from the base type
14443 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
14444 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
14448 end Process_Subtype
;
14450 -----------------------------
14451 -- Record_Type_Declaration --
14452 -----------------------------
14454 procedure Record_Type_Declaration
14459 Loc
: constant Source_Ptr
:= Sloc
(N
);
14460 Def
: constant Node_Id
:= Type_Definition
(N
);
14461 Inc_T
: Entity_Id
:= Empty
;
14463 Is_Tagged
: Boolean;
14464 Tag_Comp
: Entity_Id
;
14466 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
);
14467 -- Ada 2005 AI-382: an access component in a record declaration can
14468 -- refer to the enclosing record, in which case it denotes the type
14469 -- itself, and not the current instance of the type. We create an
14470 -- anonymous access type for the component, and flag it as an access
14471 -- to a component, so that accessibility checks are properly performed
14472 -- on it. The declaration of the access type is placed ahead of that
14473 -- of the record, to prevent circular order-of-elaboration issues in
14474 -- Gigi. We create an incomplete type for the record declaration, which
14475 -- is the designated type of the anonymous access.
14477 procedure Make_Incomplete_Type_Declaration
;
14478 -- If the record type contains components that include an access to the
14479 -- current record, create an incomplete type declaration for the record,
14480 -- to be used as the designated type of the anonymous access. This is
14481 -- done only once, and only if there is no previous partial view of the
14484 ----------------------------------
14485 -- Check_Anonymous_Access_Types --
14486 ----------------------------------
14488 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
) is
14489 Anon_Access
: Entity_Id
;
14493 Type_Def
: Node_Id
;
14495 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean;
14496 -- Check whether an access definition includes a reference to
14497 -- the enclosing record type. The reference can be a subtype
14498 -- mark in the access definition itself, or a 'Class attribute
14499 -- reference, or recursively a reference appearing in a parameter
14500 -- type in an access_to_subprogram definition.
14506 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean is
14510 if No
(Access_To_Subprogram_Definition
(Acc_Def
)) then
14511 Subt
:= Subtype_Mark
(Acc_Def
);
14513 if Nkind
(Subt
) = N_Identifier
then
14514 return Chars
(Subt
) = Chars
(T
);
14515 elsif Nkind
(Subt
) = N_Attribute_Reference
14516 and then Attribute_Name
(Subt
) = Name_Class
14518 return (Chars
(Prefix
(Subt
))) = Chars
(T
);
14524 -- Component is an access_to_subprogram: examine its formals
14527 Param_Spec
: Node_Id
;
14532 (Parameter_Specifications
14533 (Access_To_Subprogram_Definition
(Acc_Def
)));
14534 while Present
(Param_Spec
) loop
14535 if Nkind
(Parameter_Type
(Param_Spec
))
14536 = N_Access_Definition
14537 and then Mentions_T
(Parameter_Type
(Param_Spec
))
14550 -- Start of processing for Check_Anonymous_Access_Types
14553 if No
(Comp_List
) then
14557 Comp
:= First
(Component_Items
(Comp_List
));
14558 while Present
(Comp
) loop
14559 if Nkind
(Comp
) = N_Component_Declaration
14561 Present
(Access_Definition
(Component_Definition
(Comp
)))
14563 Mentions_T
(Access_Definition
(Component_Definition
(Comp
)))
14566 Access_To_Subprogram_Definition
14567 (Access_Definition
(Component_Definition
(Comp
)));
14569 Make_Incomplete_Type_Declaration
;
14571 Make_Defining_Identifier
(Loc
,
14572 Chars
=> New_Internal_Name
('S'));
14574 -- Create a declaration for the anonymous access type: either
14575 -- an access_to_object or an access_to_subprogram.
14577 if Present
(Acc_Def
) then
14578 if Nkind
(Acc_Def
) = N_Access_Function_Definition
then
14580 Make_Access_Function_Definition
(Loc
,
14581 Parameter_Specifications
=>
14582 Parameter_Specifications
(Acc_Def
),
14583 Result_Definition
=> Result_Definition
(Acc_Def
));
14586 Make_Access_Procedure_Definition
(Loc
,
14587 Parameter_Specifications
=>
14588 Parameter_Specifications
(Acc_Def
));
14593 Make_Access_To_Object_Definition
(Loc
,
14594 Subtype_Indication
=>
14598 (Component_Definition
(Comp
)))));
14601 Decl
:= Make_Full_Type_Declaration
(Loc
,
14602 Defining_Identifier
=> Anon_Access
,
14603 Type_Definition
=> Type_Def
);
14605 Insert_Before
(N
, Decl
);
14608 Set_Access_Definition
(Component_Definition
(Comp
), Empty
);
14609 Set_Subtype_Indication
(Component_Definition
(Comp
),
14610 New_Occurrence_Of
(Anon_Access
, Loc
));
14611 Set_Ekind
(Anon_Access
, E_Anonymous_Access_Type
);
14612 Set_Is_Local_Anonymous_Access
(Anon_Access
);
14618 if Present
(Variant_Part
(Comp_List
)) then
14622 V
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
14623 while Present
(V
) loop
14624 Check_Anonymous_Access_Types
(Component_List
(V
));
14625 Next_Non_Pragma
(V
);
14629 end Check_Anonymous_Access_Types
;
14631 --------------------------------------
14632 -- Make_Incomplete_Type_Declaration --
14633 --------------------------------------
14635 procedure Make_Incomplete_Type_Declaration
is
14640 -- If there is a previous partial view, no need to create a new one
14645 elsif No
(Inc_T
) then
14646 Inc_T
:= Make_Defining_Identifier
(Loc
, Chars
(T
));
14647 Decl
:= Make_Incomplete_Type_Declaration
(Loc
, Inc_T
);
14649 -- Type has already been inserted into the current scope.
14650 -- Remove it, and add incomplete declaration for type, so
14651 -- that subsequent anonymous access types can use it.
14653 H
:= Current_Entity
(T
);
14656 Set_Name_Entity_Id
(Chars
(T
), Empty
);
14659 and then Homonym
(H
) /= T
14664 Set_Homonym
(H
, Homonym
(T
));
14667 Insert_Before
(N
, Decl
);
14669 Set_Full_View
(Inc_T
, T
);
14671 if Tagged_Present
(Def
) then
14672 Make_Class_Wide_Type
(Inc_T
);
14673 Set_Class_Wide_Type
(T
, Class_Wide_Type
(Inc_T
));
14676 end Make_Incomplete_Type_Declaration
;
14678 -- Start of processing for Record_Type_Declaration
14681 -- These flags must be initialized before calling Process_Discriminants
14682 -- because this routine makes use of them.
14684 Set_Ekind
(T
, E_Record_Type
);
14686 Init_Size_Align
(T
);
14687 Set_Abstract_Interfaces
(T
, No_Elist
);
14688 Set_Stored_Constraint
(T
, No_Elist
);
14692 if Ada_Version
< Ada_05
14693 or else not Interface_Present
(Def
)
14695 -- The flag Is_Tagged_Type might have already been set by
14696 -- Find_Type_Name if it detected an error for declaration T. This
14697 -- arises in the case of private tagged types where the full view
14698 -- omits the word tagged.
14701 Tagged_Present
(Def
)
14702 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
14704 Set_Is_Tagged_Type
(T
, Is_Tagged
);
14705 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
14707 -- Type is abstract if full declaration carries keyword, or if
14708 -- previous partial view did.
14710 Set_Is_Abstract
(T
, Is_Abstract
(T
)
14711 or else Abstract_Present
(Def
));
14715 Analyze_Interface_Declaration
(T
, Def
);
14718 -- First pass: if there are self-referential access components,
14719 -- create the required anonymous access type declarations, and if
14720 -- need be an incomplete type declaration for T itself.
14722 Check_Anonymous_Access_Types
(Component_List
(Def
));
14724 if Ada_Version
>= Ada_05
14725 and then Present
(Interface_List
(Def
))
14729 Iface_Def
: Node_Id
;
14730 Iface_Typ
: Entity_Id
;
14733 Iface
:= First
(Interface_List
(Def
));
14734 while Present
(Iface
) loop
14735 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
14736 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
14738 if not Is_Interface
(Iface_Typ
) then
14739 Error_Msg_NE
("(Ada 2005) & must be an interface",
14743 -- "The declaration of a specific descendant of an
14744 -- interface type freezes the interface type" RM 13.14
14746 Freeze_Before
(N
, Iface_Typ
);
14748 -- Ada 2005 (AI-345): Protected interfaces can only
14749 -- inherit from limited, synchronized or protected
14752 if Protected_Present
(Def
) then
14753 if Limited_Present
(Iface_Def
)
14754 or else Synchronized_Present
(Iface_Def
)
14755 or else Protected_Present
(Iface_Def
)
14759 elsif Task_Present
(Iface_Def
) then
14760 Error_Msg_N
("(Ada 2005) protected interface cannot"
14761 & " inherit from task interface", Iface
);
14764 Error_Msg_N
("(Ada 2005) protected interface cannot"
14765 & " inherit from non-limited interface", Iface
);
14768 -- Ada 2005 (AI-345): Synchronized interfaces can only
14769 -- inherit from limited and synchronized.
14771 elsif Synchronized_Present
(Def
) then
14772 if Limited_Present
(Iface_Def
)
14773 or else Synchronized_Present
(Iface_Def
)
14777 elsif Protected_Present
(Iface_Def
) then
14778 Error_Msg_N
("(Ada 2005) synchronized interface " &
14779 "cannot inherit from protected interface", Iface
);
14781 elsif Task_Present
(Iface_Def
) then
14782 Error_Msg_N
("(Ada 2005) synchronized interface " &
14783 "cannot inherit from task interface", Iface
);
14786 Error_Msg_N
("(Ada 2005) synchronized interface " &
14787 "cannot inherit from non-limited interface",
14791 -- Ada 2005 (AI-345): Task interfaces can only inherit
14792 -- from limited, synchronized or task interfaces.
14794 elsif Task_Present
(Def
) then
14795 if Limited_Present
(Iface_Def
)
14796 or else Synchronized_Present
(Iface_Def
)
14797 or else Task_Present
(Iface_Def
)
14801 elsif Protected_Present
(Iface_Def
) then
14802 Error_Msg_N
("(Ada 2005) task interface cannot" &
14803 " inherit from protected interface", Iface
);
14806 Error_Msg_N
("(Ada 2005) task interface cannot" &
14807 " inherit from non-limited interface", Iface
);
14814 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
14815 Collect_Interfaces
(Def
, T
);
14819 -- Records constitute a scope for the component declarations within.
14820 -- The scope is created prior to the processing of these declarations.
14821 -- Discriminants are processed first, so that they are visible when
14822 -- processing the other components. The Ekind of the record type itself
14823 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
14825 -- Enter record scope
14829 -- If an incomplete or private type declaration was already given for
14830 -- the type, then this scope already exists, and the discriminants have
14831 -- been declared within. We must verify that the full declaration
14832 -- matches the incomplete one.
14834 Check_Or_Process_Discriminants
(N
, T
, Prev
);
14836 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
14837 Set_Has_Delayed_Freeze
(T
, True);
14839 -- For tagged types add a manually analyzed component corresponding
14840 -- to the component _tag, the corresponding piece of tree will be
14841 -- expanded as part of the freezing actions if it is not a CPP_Class.
14845 -- Do not add the tag unless we are in expansion mode
14847 if Expander_Active
then
14848 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
14849 Enter_Name
(Tag_Comp
);
14851 Set_Is_Tag
(Tag_Comp
);
14852 Set_Is_Aliased
(Tag_Comp
);
14853 Set_Ekind
(Tag_Comp
, E_Component
);
14854 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
14855 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
14856 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
14857 Init_Component_Location
(Tag_Comp
);
14859 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
14860 -- implemented interfaces
14862 Add_Interface_Tag_Components
(N
, T
);
14865 Make_Class_Wide_Type
(T
);
14866 Set_Primitive_Operations
(T
, New_Elmt_List
);
14869 -- We must suppress range checks when processing the components
14870 -- of a record in the presence of discriminants, since we don't
14871 -- want spurious checks to be generated during their analysis, but
14872 -- must reset the Suppress_Range_Checks flags after having processed
14873 -- the record definition.
14875 if Has_Discriminants
(T
) and then not Range_Checks_Suppressed
(T
) then
14876 Set_Kill_Range_Checks
(T
, True);
14877 Record_Type_Definition
(Def
, Prev
);
14878 Set_Kill_Range_Checks
(T
, False);
14880 Record_Type_Definition
(Def
, Prev
);
14883 -- Exit from record scope
14889 and then not Is_Empty_List
(Interface_List
(Def
))
14891 -- Ada 2005 (AI-251): Derive the interface subprograms of all the
14892 -- implemented interfaces and check if some of the subprograms
14893 -- inherited from the ancestor cover some interface subprogram.
14895 Derive_Interface_Subprograms
(T
);
14897 end Record_Type_Declaration
;
14899 ----------------------------
14900 -- Record_Type_Definition --
14901 ----------------------------
14903 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
) is
14904 Component
: Entity_Id
;
14905 Ctrl_Components
: Boolean := False;
14906 Final_Storage_Only
: Boolean;
14910 if Ekind
(Prev_T
) = E_Incomplete_Type
then
14911 T
:= Full_View
(Prev_T
);
14916 Final_Storage_Only
:= not Is_Controlled
(T
);
14918 -- If the component list of a record type is defined by the reserved
14919 -- word null and there is no discriminant part, then the record type has
14920 -- no components and all records of the type are null records (RM 3.7)
14921 -- This procedure is also called to process the extension part of a
14922 -- record extension, in which case the current scope may have inherited
14926 or else No
(Component_List
(Def
))
14927 or else Null_Present
(Component_List
(Def
))
14932 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
14934 if Present
(Variant_Part
(Component_List
(Def
))) then
14935 Analyze
(Variant_Part
(Component_List
(Def
)));
14939 -- After completing the semantic analysis of the record definition,
14940 -- record components, both new and inherited, are accessible. Set
14941 -- their kind accordingly.
14943 Component
:= First_Entity
(Current_Scope
);
14944 while Present
(Component
) loop
14945 if Ekind
(Component
) = E_Void
then
14946 Set_Ekind
(Component
, E_Component
);
14947 Init_Component_Location
(Component
);
14950 if Has_Task
(Etype
(Component
)) then
14954 if Ekind
(Component
) /= E_Component
then
14957 elsif Has_Controlled_Component
(Etype
(Component
))
14958 or else (Chars
(Component
) /= Name_uParent
14959 and then Is_Controlled
(Etype
(Component
)))
14961 Set_Has_Controlled_Component
(T
, True);
14962 Final_Storage_Only
:= Final_Storage_Only
14963 and then Finalize_Storage_Only
(Etype
(Component
));
14964 Ctrl_Components
:= True;
14967 Next_Entity
(Component
);
14970 -- A type is Finalize_Storage_Only only if all its controlled
14971 -- components are so.
14973 if Ctrl_Components
then
14974 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
14977 -- Place reference to end record on the proper entity, which may
14978 -- be a partial view.
14980 if Present
(Def
) then
14981 Process_End_Label
(Def
, 'e', Prev_T
);
14983 end Record_Type_Definition
;
14985 ------------------------
14986 -- Replace_Components --
14987 ------------------------
14989 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
14990 function Process
(N
: Node_Id
) return Traverse_Result
;
14996 function Process
(N
: Node_Id
) return Traverse_Result
is
15000 if Nkind
(N
) = N_Discriminant_Specification
then
15001 Comp
:= First_Discriminant
(Typ
);
15002 while Present
(Comp
) loop
15003 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15004 Set_Defining_Identifier
(N
, Comp
);
15008 Next_Discriminant
(Comp
);
15011 elsif Nkind
(N
) = N_Component_Declaration
then
15012 Comp
:= First_Component
(Typ
);
15013 while Present
(Comp
) loop
15014 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15015 Set_Defining_Identifier
(N
, Comp
);
15019 Next_Component
(Comp
);
15026 procedure Replace
is new Traverse_Proc
(Process
);
15028 -- Start of processing for Replace_Components
15032 end Replace_Components
;
15034 -------------------------------
15035 -- Set_Completion_Referenced --
15036 -------------------------------
15038 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
15040 -- If in main unit, mark entity that is a completion as referenced,
15041 -- warnings go on the partial view when needed.
15043 if In_Extended_Main_Source_Unit
(E
) then
15044 Set_Referenced
(E
);
15046 end Set_Completion_Referenced
;
15048 ---------------------
15049 -- Set_Fixed_Range --
15050 ---------------------
15052 -- The range for fixed-point types is complicated by the fact that we
15053 -- do not know the exact end points at the time of the declaration. This
15054 -- is true for three reasons:
15056 -- A size clause may affect the fudging of the end-points
15057 -- A small clause may affect the values of the end-points
15058 -- We try to include the end-points if it does not affect the size
15060 -- This means that the actual end-points must be established at the point
15061 -- when the type is frozen. Meanwhile, we first narrow the range as
15062 -- permitted (so that it will fit if necessary in a small specified size),
15063 -- and then build a range subtree with these narrowed bounds.
15065 -- Set_Fixed_Range constructs the range from real literal values, and sets
15066 -- the range as the Scalar_Range of the given fixed-point type entity.
15068 -- The parent of this range is set to point to the entity so that it is
15069 -- properly hooked into the tree (unlike normal Scalar_Range entries for
15070 -- other scalar types, which are just pointers to the range in the
15071 -- original tree, this would otherwise be an orphan).
15073 -- The tree is left unanalyzed. When the type is frozen, the processing
15074 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
15075 -- analyzed, and uses this as an indication that it should complete
15076 -- work on the range (it will know the final small and size values).
15078 procedure Set_Fixed_Range
15084 S
: constant Node_Id
:=
15086 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
15087 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
15090 Set_Scalar_Range
(E
, S
);
15092 end Set_Fixed_Range
;
15094 ----------------------------------
15095 -- Set_Scalar_Range_For_Subtype --
15096 ----------------------------------
15098 procedure Set_Scalar_Range_For_Subtype
15099 (Def_Id
: Entity_Id
;
15103 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
15106 Set_Scalar_Range
(Def_Id
, R
);
15108 -- We need to link the range into the tree before resolving it so
15109 -- that types that are referenced, including importantly the subtype
15110 -- itself, are properly frozen (Freeze_Expression requires that the
15111 -- expression be properly linked into the tree). Of course if it is
15112 -- already linked in, then we do not disturb the current link.
15114 if No
(Parent
(R
)) then
15115 Set_Parent
(R
, Def_Id
);
15118 -- Reset the kind of the subtype during analysis of the range, to
15119 -- catch possible premature use in the bounds themselves.
15121 Set_Ekind
(Def_Id
, E_Void
);
15122 Process_Range_Expr_In_Decl
(R
, Subt
);
15123 Set_Ekind
(Def_Id
, Kind
);
15125 end Set_Scalar_Range_For_Subtype
;
15127 --------------------------------------------------------
15128 -- Set_Stored_Constraint_From_Discriminant_Constraint --
15129 --------------------------------------------------------
15131 procedure Set_Stored_Constraint_From_Discriminant_Constraint
15135 -- Make sure set if encountered during Expand_To_Stored_Constraint
15137 Set_Stored_Constraint
(E
, No_Elist
);
15139 -- Give it the right value
15141 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
15142 Set_Stored_Constraint
(E
,
15143 Expand_To_Stored_Constraint
(E
, Discriminant_Constraint
(E
)));
15145 end Set_Stored_Constraint_From_Discriminant_Constraint
;
15147 -------------------------------------
15148 -- Signed_Integer_Type_Declaration --
15149 -------------------------------------
15151 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
15152 Implicit_Base
: Entity_Id
;
15153 Base_Typ
: Entity_Id
;
15156 Errs
: Boolean := False;
15160 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
15161 -- Determine whether given bounds allow derivation from specified type
15163 procedure Check_Bound
(Expr
: Node_Id
);
15164 -- Check bound to make sure it is integral and static. If not, post
15165 -- appropriate error message and set Errs flag
15167 ---------------------
15168 -- Can_Derive_From --
15169 ---------------------
15171 -- Note we check both bounds against both end values, to deal with
15172 -- strange types like ones with a range of 0 .. -12341234.
15174 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
15175 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
15176 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
15178 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
15180 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
15181 end Can_Derive_From
;
15187 procedure Check_Bound
(Expr
: Node_Id
) is
15189 -- If a range constraint is used as an integer type definition, each
15190 -- bound of the range must be defined by a static expression of some
15191 -- integer type, but the two bounds need not have the same integer
15192 -- type (Negative bounds are allowed.) (RM 3.5.4)
15194 if not Is_Integer_Type
(Etype
(Expr
)) then
15196 ("integer type definition bounds must be of integer type", Expr
);
15199 elsif not Is_OK_Static_Expression
(Expr
) then
15200 Flag_Non_Static_Expr
15201 ("non-static expression used for integer type bound!", Expr
);
15204 -- The bounds are folded into literals, and we set their type to be
15205 -- universal, to avoid typing difficulties: we cannot set the type
15206 -- of the literal to the new type, because this would be a forward
15207 -- reference for the back end, and if the original type is user-
15208 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
15211 if Is_Entity_Name
(Expr
) then
15212 Fold_Uint
(Expr
, Expr_Value
(Expr
), True);
15215 Set_Etype
(Expr
, Universal_Integer
);
15219 -- Start of processing for Signed_Integer_Type_Declaration
15222 -- Create an anonymous base type
15225 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
15227 -- Analyze and check the bounds, they can be of any integer type
15229 Lo
:= Low_Bound
(Def
);
15230 Hi
:= High_Bound
(Def
);
15232 -- Arbitrarily use Integer as the type if either bound had an error
15234 if Hi
= Error
or else Lo
= Error
then
15235 Base_Typ
:= Any_Integer
;
15236 Set_Error_Posted
(T
, True);
15238 -- Here both bounds are OK expressions
15241 Analyze_And_Resolve
(Lo
, Any_Integer
);
15242 Analyze_And_Resolve
(Hi
, Any_Integer
);
15248 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
15249 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
15252 -- Find type to derive from
15254 Lo_Val
:= Expr_Value
(Lo
);
15255 Hi_Val
:= Expr_Value
(Hi
);
15257 if Can_Derive_From
(Standard_Short_Short_Integer
) then
15258 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
15260 elsif Can_Derive_From
(Standard_Short_Integer
) then
15261 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
15263 elsif Can_Derive_From
(Standard_Integer
) then
15264 Base_Typ
:= Base_Type
(Standard_Integer
);
15266 elsif Can_Derive_From
(Standard_Long_Integer
) then
15267 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
15269 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
15270 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
15273 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
15274 Error_Msg_N
("integer type definition bounds out of range", Def
);
15275 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
15276 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
15280 -- Complete both implicit base and declared first subtype entities
15282 Set_Etype
(Implicit_Base
, Base_Typ
);
15283 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
15284 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
15285 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
15286 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
15288 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
15289 Set_Etype
(T
, Implicit_Base
);
15291 Set_Size_Info
(T
, (Implicit_Base
));
15292 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
15293 Set_Scalar_Range
(T
, Def
);
15294 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
15295 Set_Is_Constrained
(T
);
15296 end Signed_Integer_Type_Declaration
;