1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 given
662 -- Def_Id, the entity for the subtype, and R, the range expression for the
663 -- scalar range. Subt provides the parent subtype to be used to analyze,
664 -- 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
: Entity_Id
;
684 Desig_Type
: Entity_Id
;
687 if Is_Entry
(Current_Scope
)
688 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
690 Error_Msg_N
("task entries cannot have access parameters", N
);
693 -- Ada 2005: for an object declaration the corresponding anonymous
694 -- type is declared in the current scope.
696 if Nkind
(Related_Nod
) = N_Object_Declaration
then
699 (E_Anonymous_Access_Type
, Related_Nod
,
700 Scope_Id
=> Current_Scope
);
702 -- For the anonymous function result case, retrieve the scope of
703 -- the function specification's associated entity rather than using
704 -- the current scope. The current scope will be the function itself
705 -- if the formal part is currently being analyzed, but will be the
706 -- parent scope in the case of a parameterless function, and we
707 -- always want to use the function's parent scope.
709 elsif Nkind
(Related_Nod
) = N_Function_Specification
710 and then Nkind
(Parent
(N
)) /= N_Parameter_Specification
714 (E_Anonymous_Access_Type
, Related_Nod
,
715 Scope_Id
=> Scope
(Defining_Unit_Name
(Related_Nod
)));
718 -- For access formals, access components, and access
719 -- discriminants, the scope is that of the enclosing declaration,
723 (E_Anonymous_Access_Type
, Related_Nod
,
724 Scope_Id
=> Scope
(Current_Scope
));
728 and then Ada_Version
>= Ada_05
730 Error_Msg_N
("ALL is not permitted for anonymous access types", N
);
733 -- Ada 2005 (AI-254): In case of anonymous access to subprograms
734 -- call the corresponding semantic routine
736 if Present
(Access_To_Subprogram_Definition
(N
)) then
737 Access_Subprogram_Declaration
738 (T_Name
=> Anon_Type
,
739 T_Def
=> Access_To_Subprogram_Definition
(N
));
741 if Ekind
(Anon_Type
) = E_Access_Protected_Subprogram_Type
then
743 (Anon_Type
, E_Anonymous_Access_Protected_Subprogram_Type
);
746 (Anon_Type
, E_Anonymous_Access_Subprogram_Type
);
752 Find_Type
(Subtype_Mark
(N
));
753 Desig_Type
:= Entity
(Subtype_Mark
(N
));
755 Set_Directly_Designated_Type
756 (Anon_Type
, Desig_Type
);
757 Set_Etype
(Anon_Type
, Anon_Type
);
758 Init_Size_Align
(Anon_Type
);
759 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
761 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
762 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
763 -- if the null value is allowed. In Ada 95 the null value is never
766 if Ada_Version
>= Ada_05
then
767 Set_Can_Never_Be_Null
(Anon_Type
, Null_Exclusion_Present
(N
));
769 Set_Can_Never_Be_Null
(Anon_Type
, True);
772 -- The anonymous access type is as public as the discriminated type or
773 -- subprogram that defines it. It is imported (for back-end purposes)
774 -- if the designated type is.
776 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
778 -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
779 -- designated type comes from the limited view (for back-end purposes).
781 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
783 -- Ada 2005 (AI-231): Propagate the access-constant attribute
785 Set_Is_Access_Constant
(Anon_Type
, Constant_Present
(N
));
787 -- The context is either a subprogram declaration, object declaration,
788 -- or an access discriminant, in a private or a full type declaration.
789 -- In the case of a subprogram, if the designated type is incomplete,
790 -- the operation will be a primitive operation of the full type, to be
791 -- updated subsequently. If the type is imported through a limited_with
792 -- clause, the subprogram is not a primitive operation of the type
793 -- (which is declared elsewhere in some other scope).
795 if Ekind
(Desig_Type
) = E_Incomplete_Type
796 and then not From_With_Type
(Desig_Type
)
797 and then Is_Overloadable
(Current_Scope
)
799 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
800 Set_Has_Delayed_Freeze
(Current_Scope
);
803 -- Ada 2005: if the designated type is an interface that may contain
804 -- tasks, create a Master entity for the declaration. This must be done
805 -- before expansion of the full declaration, because the declaration
806 -- may include an expression that is an allocator, whose expansion needs
807 -- the proper Master for the created tasks.
809 if Nkind
(Related_Nod
) = N_Object_Declaration
810 and then Expander_Active
811 and then Is_Interface
(Desig_Type
)
812 and then Is_Limited_Record
(Desig_Type
)
814 Build_Class_Wide_Master
(Anon_Type
);
818 end Access_Definition
;
820 -----------------------------------
821 -- Access_Subprogram_Declaration --
822 -----------------------------------
824 procedure Access_Subprogram_Declaration
828 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
832 Desig_Type
: constant Entity_Id
:=
833 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
836 -- Associate the Itype node with the inner full-type declaration
837 -- or subprogram spec. This is required to handle nested anonymous
838 -- declarations. For example:
841 -- (X : access procedure
842 -- (Y : access procedure
845 D_Ityp
:= Associated_Node_For_Itype
(Desig_Type
);
846 while Nkind
(D_Ityp
) /= N_Full_Type_Declaration
847 and then Nkind
(D_Ityp
) /= N_Procedure_Specification
848 and then Nkind
(D_Ityp
) /= N_Function_Specification
849 and then Nkind
(D_Ityp
) /= N_Object_Declaration
850 and then Nkind
(D_Ityp
) /= N_Object_Renaming_Declaration
851 and then Nkind
(D_Ityp
) /= N_Formal_Type_Declaration
853 D_Ityp
:= Parent
(D_Ityp
);
854 pragma Assert
(D_Ityp
/= Empty
);
857 Set_Associated_Node_For_Itype
(Desig_Type
, D_Ityp
);
859 if Nkind
(D_Ityp
) = N_Procedure_Specification
860 or else Nkind
(D_Ityp
) = N_Function_Specification
862 Set_Scope
(Desig_Type
, Scope
(Defining_Unit_Name
(D_Ityp
)));
864 elsif Nkind
(D_Ityp
) = N_Full_Type_Declaration
865 or else Nkind
(D_Ityp
) = N_Object_Declaration
866 or else Nkind
(D_Ityp
) = N_Object_Renaming_Declaration
867 or else Nkind
(D_Ityp
) = N_Formal_Type_Declaration
869 Set_Scope
(Desig_Type
, Scope
(Defining_Identifier
(D_Ityp
)));
872 if Nkind
(T_Def
) = N_Access_Function_Definition
then
873 if Nkind
(Result_Definition
(T_Def
)) = N_Access_Definition
then
876 Access_Definition
(T_Def
, Result_Definition
(T_Def
)));
878 Analyze
(Result_Definition
(T_Def
));
879 Set_Etype
(Desig_Type
, Entity
(Result_Definition
(T_Def
)));
882 if not (Is_Type
(Etype
(Desig_Type
))) then
884 ("expect type in function specification",
885 Result_Definition
(T_Def
));
889 Set_Etype
(Desig_Type
, Standard_Void_Type
);
892 if Present
(Formals
) then
893 New_Scope
(Desig_Type
);
894 Process_Formals
(Formals
, Parent
(T_Def
));
896 -- A bit of a kludge here, End_Scope requires that the parent
897 -- pointer be set to something reasonable, but Itypes don't have
898 -- parent pointers. So we set it and then unset it ??? If and when
899 -- Itypes have proper parent pointers to their declarations, this
900 -- kludge can be removed.
902 Set_Parent
(Desig_Type
, T_Name
);
904 Set_Parent
(Desig_Type
, Empty
);
907 -- The return type and/or any parameter type may be incomplete. Mark
908 -- the subprogram_type as depending on the incomplete type, so that
909 -- it can be updated when the full type declaration is seen.
911 if Present
(Formals
) then
912 Formal
:= First_Formal
(Desig_Type
);
913 while Present
(Formal
) loop
914 if Ekind
(Formal
) /= E_In_Parameter
915 and then Nkind
(T_Def
) = N_Access_Function_Definition
917 Error_Msg_N
("functions can only have IN parameters", Formal
);
920 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
921 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
922 Set_Has_Delayed_Freeze
(Desig_Type
);
925 Next_Formal
(Formal
);
929 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
930 and then not Has_Delayed_Freeze
(Desig_Type
)
932 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
933 Set_Has_Delayed_Freeze
(Desig_Type
);
936 Check_Delayed_Subprogram
(Desig_Type
);
938 if Protected_Present
(T_Def
) then
939 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
940 Set_Convention
(Desig_Type
, Convention_Protected
);
942 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
945 Set_Etype
(T_Name
, T_Name
);
946 Init_Size_Align
(T_Name
);
947 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
949 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
951 Set_Can_Never_Be_Null
(T_Name
, Null_Exclusion_Present
(T_Def
));
953 Check_Restriction
(No_Access_Subprograms
, T_Def
);
954 end Access_Subprogram_Declaration
;
956 ----------------------------
957 -- Access_Type_Declaration --
958 ----------------------------
960 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
961 S
: constant Node_Id
:= Subtype_Indication
(Def
);
962 P
: constant Node_Id
:= Parent
(Def
);
968 -- Check for permissible use of incomplete type
970 if Nkind
(S
) /= N_Subtype_Indication
then
973 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
974 Set_Directly_Designated_Type
(T
, Entity
(S
));
976 Set_Directly_Designated_Type
(T
,
977 Process_Subtype
(S
, P
, T
, 'P'));
981 Set_Directly_Designated_Type
(T
,
982 Process_Subtype
(S
, P
, T
, 'P'));
985 if All_Present
(Def
) or Constant_Present
(Def
) then
986 Set_Ekind
(T
, E_General_Access_Type
);
988 Set_Ekind
(T
, E_Access_Type
);
991 if Base_Type
(Designated_Type
(T
)) = T
then
992 Error_Msg_N
("access type cannot designate itself", S
);
994 -- In Ada 2005, the type may have a limited view through some unit
995 -- in its own context, allowing the following circularity that cannot
996 -- be detected earlier
998 elsif Is_Class_Wide_Type
(Designated_Type
(T
))
999 and then Etype
(Designated_Type
(T
)) = T
1002 ("access type cannot designate its own classwide type", S
);
1004 -- Clean up indication of tagged status to prevent cascaded errors
1006 Set_Is_Tagged_Type
(T
, False);
1011 -- If the type has appeared already in a with_type clause, it is
1012 -- frozen and the pointer size is already set. Else, initialize.
1014 if not From_With_Type
(T
) then
1015 Init_Size_Align
(T
);
1018 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1020 Desig
:= Designated_Type
(T
);
1022 -- If designated type is an imported tagged type, indicate that the
1023 -- access type is also imported, and therefore restricted in its use.
1024 -- The access type may already be imported, so keep setting otherwise.
1026 -- Ada 2005 (AI-50217): If the non-limited view of the designated type
1027 -- is available, use it as the designated type of the access type, so
1028 -- that the back-end gets a usable entity.
1031 N_Desig
: Entity_Id
;
1034 if From_With_Type
(Desig
)
1035 and then Ekind
(Desig
) /= E_Access_Type
1037 Set_From_With_Type
(T
);
1039 if Ekind
(Desig
) = E_Incomplete_Type
then
1040 N_Desig
:= Non_Limited_View
(Desig
);
1042 else pragma Assert
(Ekind
(Desig
) = E_Class_Wide_Type
);
1043 if From_With_Type
(Etype
(Desig
)) then
1044 N_Desig
:= Non_Limited_View
(Etype
(Desig
));
1046 N_Desig
:= Etype
(Desig
);
1050 pragma Assert
(Present
(N_Desig
));
1051 Set_Directly_Designated_Type
(T
, N_Desig
);
1055 -- Note that Has_Task is always false, since the access type itself
1056 -- is not a task type. See Einfo for more description on this point.
1057 -- Exactly the same consideration applies to Has_Controlled_Component.
1059 Set_Has_Task
(T
, False);
1060 Set_Has_Controlled_Component
(T
, False);
1062 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1065 Set_Can_Never_Be_Null
(T
, Null_Exclusion_Present
(Def
));
1066 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1067 end Access_Type_Declaration
;
1069 ----------------------------------
1070 -- Add_Interface_Tag_Components --
1071 ----------------------------------
1073 procedure Add_Interface_Tag_Components
1077 Loc
: constant Source_Ptr
:= Sloc
(N
);
1084 procedure Add_Tag
(Iface
: Entity_Id
);
1085 -- Comment required ???
1091 procedure Add_Tag
(Iface
: Entity_Id
) is
1098 pragma Assert
(Is_Tagged_Type
(Iface
)
1099 and then Is_Interface
(Iface
));
1102 Make_Component_Definition
(Loc
,
1103 Aliased_Present
=> True,
1104 Subtype_Indication
=>
1105 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
));
1107 Tag
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1110 Make_Component_Declaration
(Loc
,
1111 Defining_Identifier
=> Tag
,
1112 Component_Definition
=> Def
);
1114 Analyze_Component_Declaration
(Decl
);
1116 Set_Analyzed
(Decl
);
1117 Set_Ekind
(Tag
, E_Component
);
1118 Set_Is_Limited_Record
(Tag
);
1120 Init_Component_Location
(Tag
);
1122 pragma Assert
(Is_Frozen
(Iface
));
1124 Set_DT_Entry_Count
(Tag
,
1125 DT_Entry_Count
(First_Entity
(Iface
)));
1127 if No
(Last_Tag
) then
1130 Insert_After
(Last_Tag
, Decl
);
1135 -- If the ancestor has discriminants we need to give special support
1136 -- to store the offset_to_top value of the secondary dispatch tables.
1137 -- For this purpose we add a supplementary component just after the
1138 -- field that contains the tag associated with each secondary DT.
1140 if Typ
/= Etype
(Typ
)
1141 and then Has_Discriminants
(Etype
(Typ
))
1144 Make_Component_Definition
(Loc
,
1145 Subtype_Indication
=>
1146 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
));
1149 Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1152 Make_Component_Declaration
(Loc
,
1153 Defining_Identifier
=> Offset
,
1154 Component_Definition
=> Def
);
1156 Analyze_Component_Declaration
(Decl
);
1158 Set_Analyzed
(Decl
);
1159 Set_Ekind
(Offset
, E_Component
);
1160 Init_Component_Location
(Offset
);
1161 Insert_After
(Last_Tag
, Decl
);
1166 -- Start of processing for Add_Interface_Tag_Components
1169 if Ekind
(Typ
) /= E_Record_Type
1170 or else No
(Abstract_Interfaces
(Typ
))
1171 or else Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
))
1172 or else not RTE_Available
(RE_Interface_Tag
)
1177 if Present
(Abstract_Interfaces
(Typ
)) then
1179 -- Find the current last tag
1181 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1182 Ext
:= Record_Extension_Part
(Type_Definition
(N
));
1184 pragma Assert
(Nkind
(Type_Definition
(N
)) = N_Record_Definition
);
1185 Ext
:= Type_Definition
(N
);
1190 if not (Present
(Component_List
(Ext
))) then
1191 Set_Null_Present
(Ext
, False);
1193 Set_Component_List
(Ext
,
1194 Make_Component_List
(Loc
,
1195 Component_Items
=> L
,
1196 Null_Present
=> False));
1198 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1199 L
:= Component_Items
1201 (Record_Extension_Part
1202 (Type_Definition
(N
))));
1204 L
:= Component_Items
1206 (Type_Definition
(N
)));
1209 -- Find the last tag component
1212 while Present
(Comp
) loop
1213 if Is_Tag
(Defining_Identifier
(Comp
)) then
1221 -- At this point L references the list of components and Last_Tag
1222 -- references the current last tag (if any). Now we add the tag
1223 -- corresponding with all the interfaces that are not implemented
1226 pragma Assert
(Present
1227 (First_Elmt
(Abstract_Interfaces
(Typ
))));
1229 Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1230 while Present
(Elmt
) loop
1231 Add_Tag
(Node
(Elmt
));
1235 end Add_Interface_Tag_Components
;
1237 -----------------------------------
1238 -- Analyze_Component_Declaration --
1239 -----------------------------------
1241 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
1242 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1246 function Contains_POC
(Constr
: Node_Id
) return Boolean;
1247 -- Determines whether a constraint uses the discriminant of a record
1248 -- type thus becoming a per-object constraint (POC).
1250 function Is_Known_Limited
(Typ
: Entity_Id
) return Boolean;
1251 -- Check whether enclosing record is limited, to validate declaration
1252 -- of components with limited types.
1253 -- This seems a wrong description to me???
1254 -- What is Typ? For sure it can return a result without checking
1255 -- the enclosing record (enclosing what???)
1261 function Contains_POC
(Constr
: Node_Id
) return Boolean is
1263 case Nkind
(Constr
) is
1264 when N_Attribute_Reference
=>
1265 return Attribute_Name
(Constr
) = Name_Access
1267 Prefix
(Constr
) = Scope
(Entity
(Prefix
(Constr
)));
1269 when N_Discriminant_Association
=>
1270 return Denotes_Discriminant
(Expression
(Constr
));
1272 when N_Identifier
=>
1273 return Denotes_Discriminant
(Constr
);
1275 when N_Index_Or_Discriminant_Constraint
=>
1280 IDC
:= First
(Constraints
(Constr
));
1281 while Present
(IDC
) loop
1283 -- One per-object constraint is sufficient
1285 if Contains_POC
(IDC
) then
1296 return Denotes_Discriminant
(Low_Bound
(Constr
))
1298 Denotes_Discriminant
(High_Bound
(Constr
));
1300 when N_Range_Constraint
=>
1301 return Denotes_Discriminant
(Range_Expression
(Constr
));
1309 ----------------------
1310 -- Is_Known_Limited --
1311 ----------------------
1313 function Is_Known_Limited
(Typ
: Entity_Id
) return Boolean is
1314 P
: constant Entity_Id
:= Etype
(Typ
);
1315 R
: constant Entity_Id
:= Root_Type
(Typ
);
1318 if Is_Limited_Record
(Typ
) then
1321 -- If the root type is limited (and not a limited interface)
1322 -- so is the current type
1324 elsif Is_Limited_Record
(R
)
1326 (not Is_Interface
(R
)
1327 or else not Is_Limited_Interface
(R
))
1331 -- Else the type may have a limited interface progenitor, but a
1332 -- limited record parent.
1335 and then Is_Limited_Record
(P
)
1342 end Is_Known_Limited
;
1344 -- Start of processing for Analyze_Component_Declaration
1347 Generate_Definition
(Id
);
1350 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1351 T
:= Find_Type_Of_Object
1352 (Subtype_Indication
(Component_Definition
(N
)), N
);
1354 -- Ada 2005 (AI-230): Access Definition case
1357 pragma Assert
(Present
1358 (Access_Definition
(Component_Definition
(N
))));
1360 T
:= Access_Definition
1362 N
=> Access_Definition
(Component_Definition
(N
)));
1363 Set_Is_Local_Anonymous_Access
(T
);
1365 -- Ada 2005 (AI-254)
1367 if Present
(Access_To_Subprogram_Definition
1368 (Access_Definition
(Component_Definition
(N
))))
1369 and then Protected_Present
(Access_To_Subprogram_Definition
1371 (Component_Definition
(N
))))
1373 T
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
, T
);
1377 -- If the subtype is a constrained subtype of the enclosing record,
1378 -- (which must have a partial view) the back-end does not properly
1379 -- handle the recursion. Rewrite the component declaration with an
1380 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1381 -- the tree directly because side effects have already been removed from
1382 -- discriminant constraints.
1384 if Ekind
(T
) = E_Access_Subtype
1385 and then Is_Entity_Name
(Subtype_Indication
(Component_Definition
(N
)))
1386 and then Comes_From_Source
(T
)
1387 and then Nkind
(Parent
(T
)) = N_Subtype_Declaration
1388 and then Etype
(Directly_Designated_Type
(T
)) = Current_Scope
1391 (Subtype_Indication
(Component_Definition
(N
)),
1392 New_Copy_Tree
(Subtype_Indication
(Parent
(T
))));
1393 T
:= Find_Type_Of_Object
1394 (Subtype_Indication
(Component_Definition
(N
)), N
);
1397 -- If the component declaration includes a default expression, then we
1398 -- check that the component is not of a limited type (RM 3.7(5)),
1399 -- and do the special preanalysis of the expression (see section on
1400 -- "Handling of Default and Per-Object Expressions" in the spec of
1403 if Present
(Expression
(N
)) then
1404 Analyze_Per_Use_Expression
(Expression
(N
), T
);
1405 Check_Initialization
(T
, Expression
(N
));
1407 if Ada_Version
>= Ada_05
1408 and then Is_Access_Type
(T
)
1409 and then Ekind
(T
) = E_Anonymous_Access_Type
1411 -- Check RM 3.9.2(9): "if the expected type for an expression is
1412 -- an anonymous access-to-specific tagged type, then the object
1413 -- designated by the expression shall not be dynamically tagged
1414 -- unless it is a controlling operand in a call on a dispatching
1417 if Is_Tagged_Type
(Directly_Designated_Type
(T
))
1419 Ekind
(Directly_Designated_Type
(T
)) /= E_Class_Wide_Type
1421 Ekind
(Directly_Designated_Type
(Etype
(Expression
(N
)))) =
1425 ("access to specific tagged type required ('R'M 3.9.2(9))",
1429 -- (Ada 2005: AI-230): Accessibility check for anonymous
1432 if Type_Access_Level
(Etype
(Expression
(N
))) >
1433 Type_Access_Level
(T
)
1436 ("expression has deeper access level than component " &
1437 "('R'M 3.10.2 (12.2))", Expression
(N
));
1442 -- The parent type may be a private view with unknown discriminants,
1443 -- and thus unconstrained. Regular components must be constrained.
1445 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
1446 if Is_Class_Wide_Type
(T
) then
1448 ("class-wide subtype with unknown discriminants" &
1449 " in component declaration",
1450 Subtype_Indication
(Component_Definition
(N
)));
1453 ("unconstrained subtype in component declaration",
1454 Subtype_Indication
(Component_Definition
(N
)));
1457 -- Components cannot be abstract, except for the special case of
1458 -- the _Parent field (case of extending an abstract tagged type)
1460 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
1461 Error_Msg_N
("type of a component cannot be abstract", N
);
1465 Set_Is_Aliased
(Id
, Aliased_Present
(Component_Definition
(N
)));
1467 -- The component declaration may have a per-object constraint, set
1468 -- the appropriate flag in the defining identifier of the subtype.
1470 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1472 Sindic
: constant Node_Id
:=
1473 Subtype_Indication
(Component_Definition
(N
));
1476 if Nkind
(Sindic
) = N_Subtype_Indication
1477 and then Present
(Constraint
(Sindic
))
1478 and then Contains_POC
(Constraint
(Sindic
))
1480 Set_Has_Per_Object_Constraint
(Id
);
1485 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1486 -- out some static checks.
1488 if Ada_Version
>= Ada_05
1489 and then Can_Never_Be_Null
(T
)
1491 Null_Exclusion_Static_Checks
(N
);
1494 -- If this component is private (or depends on a private type), flag the
1495 -- record type to indicate that some operations are not available.
1497 P
:= Private_Component
(T
);
1501 -- Check for circular definitions
1503 if P
= Any_Type
then
1504 Set_Etype
(Id
, Any_Type
);
1506 -- There is a gap in the visibility of operations only if the
1507 -- component type is not defined in the scope of the record type.
1509 elsif Scope
(P
) = Scope
(Current_Scope
) then
1512 elsif Is_Limited_Type
(P
) then
1513 Set_Is_Limited_Composite
(Current_Scope
);
1516 Set_Is_Private_Composite
(Current_Scope
);
1521 and then Is_Limited_Type
(T
)
1522 and then Chars
(Id
) /= Name_uParent
1523 and then Is_Tagged_Type
(Current_Scope
)
1525 if Is_Derived_Type
(Current_Scope
)
1526 and then not Is_Known_Limited
(Current_Scope
)
1529 ("extension of nonlimited type cannot have limited components",
1532 if Is_Interface
(Root_Type
(Current_Scope
)) then
1534 ("\limitedness is not inherited from limited interface", N
);
1536 ("\add LIMITED to type indication", N
);
1539 Explain_Limited_Type
(T
, N
);
1540 Set_Etype
(Id
, Any_Type
);
1541 Set_Is_Limited_Composite
(Current_Scope
, False);
1543 elsif not Is_Derived_Type
(Current_Scope
)
1544 and then not Is_Limited_Record
(Current_Scope
)
1545 and then not Is_Concurrent_Type
(Current_Scope
)
1548 ("nonlimited tagged type cannot have limited components", N
);
1549 Explain_Limited_Type
(T
, N
);
1550 Set_Etype
(Id
, Any_Type
);
1551 Set_Is_Limited_Composite
(Current_Scope
, False);
1555 Set_Original_Record_Component
(Id
, Id
);
1556 end Analyze_Component_Declaration
;
1558 --------------------------
1559 -- Analyze_Declarations --
1560 --------------------------
1562 procedure Analyze_Declarations
(L
: List_Id
) is
1564 Next_Node
: Node_Id
;
1565 Freeze_From
: Entity_Id
:= Empty
;
1568 -- Adjust D not to include implicit label declarations, since these
1569 -- have strange Sloc values that result in elaboration check problems.
1570 -- (They have the sloc of the label as found in the source, and that
1571 -- is ahead of the current declarative part).
1577 procedure Adjust_D
is
1579 while Present
(Prev
(D
))
1580 and then Nkind
(D
) = N_Implicit_Label_Declaration
1586 -- Start of processing for Analyze_Declarations
1590 while Present
(D
) loop
1592 -- Complete analysis of declaration
1595 Next_Node
:= Next
(D
);
1597 if No
(Freeze_From
) then
1598 Freeze_From
:= First_Entity
(Current_Scope
);
1601 -- At the end of a declarative part, freeze remaining entities
1602 -- declared in it. The end of the visible declarations of package
1603 -- specification is not the end of a declarative part if private
1604 -- declarations are present. The end of a package declaration is a
1605 -- freezing point only if it a library package. A task definition or
1606 -- protected type definition is not a freeze point either. Finally,
1607 -- we do not freeze entities in generic scopes, because there is no
1608 -- code generated for them and freeze nodes will be generated for
1611 -- The end of a package instantiation is not a freeze point, but
1612 -- for now we make it one, because the generic body is inserted
1613 -- (currently) immediately after. Generic instantiations will not
1614 -- be a freeze point once delayed freezing of bodies is implemented.
1615 -- (This is needed in any case for early instantiations ???).
1617 if No
(Next_Node
) then
1618 if Nkind
(Parent
(L
)) = N_Component_List
1619 or else Nkind
(Parent
(L
)) = N_Task_Definition
1620 or else Nkind
(Parent
(L
)) = N_Protected_Definition
1624 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
1625 if Nkind
(Parent
(L
)) = N_Package_Body
then
1626 Freeze_From
:= First_Entity
(Current_Scope
);
1630 Freeze_All
(Freeze_From
, D
);
1631 Freeze_From
:= Last_Entity
(Current_Scope
);
1633 elsif Scope
(Current_Scope
) /= Standard_Standard
1634 and then not Is_Child_Unit
(Current_Scope
)
1635 and then No
(Generic_Parent
(Parent
(L
)))
1639 elsif L
/= Visible_Declarations
(Parent
(L
))
1640 or else No
(Private_Declarations
(Parent
(L
)))
1641 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1644 Freeze_All
(Freeze_From
, D
);
1645 Freeze_From
:= Last_Entity
(Current_Scope
);
1648 -- If next node is a body then freeze all types before the body.
1649 -- An exception occurs for expander generated bodies, which can
1650 -- be recognized by their already being analyzed. The expander
1651 -- ensures that all types needed by these bodies have been frozen
1652 -- but it is not necessary to freeze all types (and would be wrong
1653 -- since it would not correspond to an RM defined freeze point).
1655 elsif not Analyzed
(Next_Node
)
1656 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1657 or else Nkind
(Next_Node
) = N_Entry_Body
1658 or else Nkind
(Next_Node
) = N_Package_Body
1659 or else Nkind
(Next_Node
) = N_Protected_Body
1660 or else Nkind
(Next_Node
) = N_Task_Body
1661 or else Nkind
(Next_Node
) in N_Body_Stub
)
1664 Freeze_All
(Freeze_From
, D
);
1665 Freeze_From
:= Last_Entity
(Current_Scope
);
1670 end Analyze_Declarations
;
1672 ----------------------------------
1673 -- Analyze_Incomplete_Type_Decl --
1674 ----------------------------------
1676 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1677 F
: constant Boolean := Is_Pure
(Current_Scope
);
1681 Generate_Definition
(Defining_Identifier
(N
));
1683 -- Process an incomplete declaration. The identifier must not have been
1684 -- declared already in the scope. However, an incomplete declaration may
1685 -- appear in the private part of a package, for a private type that has
1686 -- already been declared.
1688 -- In this case, the discriminants (if any) must match
1690 T
:= Find_Type_Name
(N
);
1692 Set_Ekind
(T
, E_Incomplete_Type
);
1693 Init_Size_Align
(T
);
1694 Set_Is_First_Subtype
(T
, True);
1697 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
1698 -- incomplete types.
1700 if Tagged_Present
(N
) then
1701 Set_Is_Tagged_Type
(T
);
1702 Make_Class_Wide_Type
(T
);
1703 Set_Primitive_Operations
(T
, New_Elmt_List
);
1708 Set_Stored_Constraint
(T
, No_Elist
);
1710 if Present
(Discriminant_Specifications
(N
)) then
1711 Process_Discriminants
(N
);
1716 -- If the type has discriminants, non-trivial subtypes may be be
1717 -- declared before the full view of the type. The full views of those
1718 -- subtypes will be built after the full view of the type.
1720 Set_Private_Dependents
(T
, New_Elmt_List
);
1722 end Analyze_Incomplete_Type_Decl
;
1724 -----------------------------------
1725 -- Analyze_Interface_Declaration --
1726 -----------------------------------
1728 procedure Analyze_Interface_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
1730 Set_Is_Tagged_Type
(T
);
1732 Set_Is_Limited_Record
(T
, Limited_Present
(Def
)
1733 or else Task_Present
(Def
)
1734 or else Protected_Present
(Def
)
1735 or else Synchronized_Present
(Def
));
1737 -- Type is abstract if full declaration carries keyword, or if
1738 -- previous partial view did.
1740 Set_Is_Abstract
(T
);
1741 Set_Is_Interface
(T
);
1743 Set_Is_Limited_Interface
(T
, Limited_Present
(Def
));
1744 Set_Is_Protected_Interface
(T
, Protected_Present
(Def
));
1745 Set_Is_Synchronized_Interface
(T
, Synchronized_Present
(Def
));
1746 Set_Is_Task_Interface
(T
, Task_Present
(Def
));
1747 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
1748 Set_Primitive_Operations
(T
, New_Elmt_List
);
1749 end Analyze_Interface_Declaration
;
1751 -----------------------------
1752 -- Analyze_Itype_Reference --
1753 -----------------------------
1755 -- Nothing to do. This node is placed in the tree only for the benefit of
1756 -- back end processing, and has no effect on the semantic processing.
1758 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1760 pragma Assert
(Is_Itype
(Itype
(N
)));
1762 end Analyze_Itype_Reference
;
1764 --------------------------------
1765 -- Analyze_Number_Declaration --
1766 --------------------------------
1768 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1769 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1770 E
: constant Node_Id
:= Expression
(N
);
1772 Index
: Interp_Index
;
1776 Generate_Definition
(Id
);
1779 -- This is an optimization of a common case of an integer literal
1781 if Nkind
(E
) = N_Integer_Literal
then
1782 Set_Is_Static_Expression
(E
, True);
1783 Set_Etype
(E
, Universal_Integer
);
1785 Set_Etype
(Id
, Universal_Integer
);
1786 Set_Ekind
(Id
, E_Named_Integer
);
1787 Set_Is_Frozen
(Id
, True);
1791 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1793 -- Process expression, replacing error by integer zero, to avoid
1794 -- cascaded errors or aborts further along in the processing
1796 -- Replace Error by integer zero, which seems least likely to
1797 -- cause cascaded errors.
1800 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1801 Set_Error_Posted
(E
);
1806 -- Verify that the expression is static and numeric. If
1807 -- the expression is overloaded, we apply the preference
1808 -- rule that favors root numeric types.
1810 if not Is_Overloaded
(E
) then
1816 Get_First_Interp
(E
, Index
, It
);
1817 while Present
(It
.Typ
) loop
1818 if (Is_Integer_Type
(It
.Typ
)
1819 or else Is_Real_Type
(It
.Typ
))
1820 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1822 if T
= Any_Type
then
1825 elsif It
.Typ
= Universal_Real
1826 or else It
.Typ
= Universal_Integer
1828 -- Choose universal interpretation over any other
1835 Get_Next_Interp
(Index
, It
);
1839 if Is_Integer_Type
(T
) then
1841 Set_Etype
(Id
, Universal_Integer
);
1842 Set_Ekind
(Id
, E_Named_Integer
);
1844 elsif Is_Real_Type
(T
) then
1846 -- Because the real value is converted to universal_real, this is a
1847 -- legal context for a universal fixed expression.
1849 if T
= Universal_Fixed
then
1851 Loc
: constant Source_Ptr
:= Sloc
(N
);
1852 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1854 New_Occurrence_Of
(Universal_Real
, Loc
),
1855 Expression
=> Relocate_Node
(E
));
1862 elsif T
= Any_Fixed
then
1863 Error_Msg_N
("illegal context for mixed mode operation", E
);
1865 -- Expression is of the form : universal_fixed * integer. Try to
1866 -- resolve as universal_real.
1868 T
:= Universal_Real
;
1873 Set_Etype
(Id
, Universal_Real
);
1874 Set_Ekind
(Id
, E_Named_Real
);
1877 Wrong_Type
(E
, Any_Numeric
);
1881 Set_Ekind
(Id
, E_Constant
);
1882 Set_Never_Set_In_Source
(Id
, True);
1883 Set_Is_True_Constant
(Id
, True);
1887 if Nkind
(E
) = N_Integer_Literal
1888 or else Nkind
(E
) = N_Real_Literal
1890 Set_Etype
(E
, Etype
(Id
));
1893 if not Is_OK_Static_Expression
(E
) then
1894 Flag_Non_Static_Expr
1895 ("non-static expression used in number declaration!", E
);
1896 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1897 Set_Etype
(E
, Any_Type
);
1899 end Analyze_Number_Declaration
;
1901 --------------------------------
1902 -- Analyze_Object_Declaration --
1903 --------------------------------
1905 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1906 Loc
: constant Source_Ptr
:= Sloc
(N
);
1907 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1911 E
: Node_Id
:= Expression
(N
);
1912 -- E is set to Expression (N) throughout this routine. When
1913 -- Expression (N) is modified, E is changed accordingly.
1915 Prev_Entity
: Entity_Id
:= Empty
;
1917 function Build_Default_Subtype
return Entity_Id
;
1918 -- If the object is limited or aliased, and if the type is unconstrained
1919 -- and there is no expression, the discriminants cannot be modified and
1920 -- the subtype of the object is constrained by the defaults, so it is
1921 -- worthwhile building the corresponding subtype.
1923 function Count_Tasks
(T
: Entity_Id
) return Uint
;
1924 -- This function is called when a library level object of type is
1925 -- declared. It's function is to count the static number of tasks
1926 -- declared within the type (it is only called if Has_Tasks is set for
1927 -- T). As a side effect, if an array of tasks with non-static bounds or
1928 -- a variant record type is encountered, Check_Restrictions is called
1929 -- indicating the count is unknown.
1931 ---------------------------
1932 -- Build_Default_Subtype --
1933 ---------------------------
1935 function Build_Default_Subtype
return Entity_Id
is
1936 Constraints
: constant List_Id
:= New_List
;
1942 Disc
:= First_Discriminant
(T
);
1944 if No
(Discriminant_Default_Value
(Disc
)) then
1945 return T
; -- previous error.
1948 Act
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1949 while Present
(Disc
) loop
1952 Discriminant_Default_Value
(Disc
)), Constraints
);
1953 Next_Discriminant
(Disc
);
1957 Make_Subtype_Declaration
(Loc
,
1958 Defining_Identifier
=> Act
,
1959 Subtype_Indication
=>
1960 Make_Subtype_Indication
(Loc
,
1961 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1963 Make_Index_Or_Discriminant_Constraint
1964 (Loc
, Constraints
)));
1966 Insert_Before
(N
, Decl
);
1969 end Build_Default_Subtype
;
1975 function Count_Tasks
(T
: Entity_Id
) return Uint
is
1981 if Is_Task_Type
(T
) then
1984 elsif Is_Record_Type
(T
) then
1985 if Has_Discriminants
(T
) then
1986 Check_Restriction
(Max_Tasks
, N
);
1991 C
:= First_Component
(T
);
1992 while Present
(C
) loop
1993 V
:= V
+ Count_Tasks
(Etype
(C
));
2000 elsif Is_Array_Type
(T
) then
2001 X
:= First_Index
(T
);
2002 V
:= Count_Tasks
(Component_Type
(T
));
2003 while Present
(X
) loop
2006 if not Is_Static_Subtype
(C
) then
2007 Check_Restriction
(Max_Tasks
, N
);
2010 V
:= V
* (UI_Max
(Uint_0
,
2011 Expr_Value
(Type_High_Bound
(C
)) -
2012 Expr_Value
(Type_Low_Bound
(C
)) + Uint_1
));
2025 -- Start of processing for Analyze_Object_Declaration
2028 -- There are three kinds of implicit types generated by an
2029 -- object declaration:
2031 -- 1. Those for generated by the original Object Definition
2033 -- 2. Those generated by the Expression
2035 -- 3. Those used to constrained the Object Definition with the
2036 -- expression constraints when it is unconstrained
2038 -- They must be generated in this order to avoid order of elaboration
2039 -- issues. Thus the first step (after entering the name) is to analyze
2040 -- the object definition.
2042 if Constant_Present
(N
) then
2043 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
2045 -- If homograph is an implicit subprogram, it is overridden by the
2046 -- current declaration.
2048 if Present
(Prev_Entity
)
2049 and then Is_Overloadable
(Prev_Entity
)
2050 and then Is_Inherited_Operation
(Prev_Entity
)
2052 Prev_Entity
:= Empty
;
2056 if Present
(Prev_Entity
) then
2057 Constant_Redeclaration
(Id
, N
, T
);
2059 Generate_Reference
(Prev_Entity
, Id
, 'c');
2060 Set_Completion_Referenced
(Id
);
2062 if Error_Posted
(N
) then
2064 -- Type mismatch or illegal redeclaration, Do not analyze
2065 -- expression to avoid cascaded errors.
2067 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2069 Set_Ekind
(Id
, E_Variable
);
2073 -- In the normal case, enter identifier at the start to catch premature
2074 -- usage in the initialization expression.
2077 Generate_Definition
(Id
);
2080 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2082 if Error_Posted
(Id
) then
2084 Set_Ekind
(Id
, E_Variable
);
2089 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2090 -- out some static checks
2092 if Ada_Version
>= Ada_05
2093 and then Can_Never_Be_Null
(T
)
2095 -- In case of aggregates we must also take care of the correct
2096 -- initialization of nested aggregates bug this is done at the
2097 -- point of the analysis of the aggregate (see sem_aggr.adb)
2099 if Present
(Expression
(N
))
2100 and then Nkind
(Expression
(N
)) = N_Aggregate
2106 Save_Typ
: constant Entity_Id
:= Etype
(Id
);
2108 Set_Etype
(Id
, T
); -- Temp. decoration for static checks
2109 Null_Exclusion_Static_Checks
(N
);
2110 Set_Etype
(Id
, Save_Typ
);
2115 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2117 -- If deferred constant, make sure context is appropriate. We detect
2118 -- a deferred constant as a constant declaration with no expression.
2119 -- A deferred constant can appear in a package body if its completion
2120 -- is by means of an interface pragma.
2122 if Constant_Present
(N
)
2125 if not Is_Package_Or_Generic_Package
(Current_Scope
) then
2127 ("invalid context for deferred constant declaration ('R'M 7.4)",
2130 ("\declaration requires an initialization expression",
2132 Set_Constant_Present
(N
, False);
2134 -- In Ada 83, deferred constant must be of private type
2136 elsif not Is_Private_Type
(T
) then
2137 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2139 ("(Ada 83) deferred constant must be private type", N
);
2143 -- If not a deferred constant, then object declaration freezes its type
2146 Check_Fully_Declared
(T
, N
);
2147 Freeze_Before
(N
, T
);
2150 -- If the object was created by a constrained array definition, then
2151 -- set the link in both the anonymous base type and anonymous subtype
2152 -- that are built to represent the array type to point to the object.
2154 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
2155 N_Constrained_Array_Definition
2157 Set_Related_Array_Object
(T
, Id
);
2158 Set_Related_Array_Object
(Base_Type
(T
), Id
);
2161 -- Special checks for protected objects not at library level
2163 if Is_Protected_Type
(T
)
2164 and then not Is_Library_Level_Entity
(Id
)
2166 Check_Restriction
(No_Local_Protected_Objects
, Id
);
2168 -- Protected objects with interrupt handlers must be at library level
2170 -- Ada 2005: this test is not needed (and the corresponding clause
2171 -- in the RM is removed) because accessibility checks are sufficient
2172 -- to make handlers not at the library level illegal.
2174 if Has_Interrupt_Handler
(T
)
2175 and then Ada_Version
< Ada_05
2178 ("interrupt object can only be declared at library level", Id
);
2182 -- The actual subtype of the object is the nominal subtype, unless
2183 -- the nominal one is unconstrained and obtained from the expression.
2187 -- Process initialization expression if present and not in error
2189 if Present
(E
) and then E
/= Error
then
2192 -- In case of errors detected in the analysis of the expression,
2193 -- decorate it with the expected type to avoid cascade errors
2195 if No
(Etype
(E
)) then
2199 -- If an initialization expression is present, then we set the
2200 -- Is_True_Constant flag. It will be reset if this is a variable
2201 -- and it is indeed modified.
2203 Set_Is_True_Constant
(Id
, True);
2205 -- If we are analyzing a constant declaration, set its completion
2206 -- flag after analyzing the expression.
2208 if Constant_Present
(N
) then
2209 Set_Has_Completion
(Id
);
2212 if not Assignment_OK
(N
) then
2213 Check_Initialization
(T
, E
);
2216 Set_Etype
(Id
, T
); -- may be overridden later on
2218 Check_Unset_Reference
(E
);
2220 if Compile_Time_Known_Value
(E
) then
2221 Set_Current_Value
(Id
, E
);
2224 -- Check incorrect use of dynamically tagged expressions. Note
2225 -- the use of Is_Tagged_Type (T) which seems redundant but is in
2226 -- fact important to avoid spurious errors due to expanded code
2227 -- for dispatching functions over an anonymous access type
2229 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
2230 and then Is_Tagged_Type
(T
)
2231 and then not Is_Class_Wide_Type
(T
)
2233 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
2236 Apply_Scalar_Range_Check
(E
, T
);
2237 Apply_Static_Length_Check
(E
, T
);
2240 -- If the No_Streams restriction is set, check that the type of the
2241 -- object is not, and does not contain, any subtype derived from
2242 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
2243 -- Has_Stream just for efficiency reasons. There is no point in
2244 -- spending time on a Has_Stream check if the restriction is not set.
2246 if Restrictions
.Set
(No_Streams
) then
2247 if Has_Stream
(T
) then
2248 Check_Restriction
(No_Streams
, N
);
2252 -- Abstract type is never permitted for a variable or constant.
2253 -- Note: we inhibit this check for objects that do not come from
2254 -- source because there is at least one case (the expansion of
2255 -- x'class'input where x is abstract) where we legitimately
2256 -- generate an abstract object.
2258 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
2259 Error_Msg_N
("type of object cannot be abstract",
2260 Object_Definition
(N
));
2262 if Is_CPP_Class
(T
) then
2263 Error_Msg_NE
("\} may need a cpp_constructor",
2264 Object_Definition
(N
), T
);
2267 -- Case of unconstrained type
2269 elsif Is_Indefinite_Subtype
(T
) then
2271 -- Nothing to do in deferred constant case
2273 if Constant_Present
(N
) and then No
(E
) then
2276 -- Case of no initialization present
2279 if No_Initialization
(N
) then
2282 elsif Is_Class_Wide_Type
(T
) then
2284 ("initialization required in class-wide declaration ", N
);
2288 ("unconstrained subtype not allowed (need initialization)",
2289 Object_Definition
(N
));
2292 -- Case of initialization present but in error. Set initial
2293 -- expression as absent (but do not make above complaints)
2295 elsif E
= Error
then
2296 Set_Expression
(N
, Empty
);
2299 -- Case of initialization present
2302 -- Not allowed in Ada 83
2304 if not Constant_Present
(N
) then
2305 if Ada_Version
= Ada_83
2306 and then Comes_From_Source
(Object_Definition
(N
))
2309 ("(Ada 83) unconstrained variable not allowed",
2310 Object_Definition
(N
));
2314 -- Now we constrain the variable from the initializing expression
2316 -- If the expression is an aggregate, it has been expanded into
2317 -- individual assignments. Retrieve the actual type from the
2318 -- expanded construct.
2320 if Is_Array_Type
(T
)
2321 and then No_Initialization
(N
)
2322 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2327 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
2328 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2331 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
2333 if Aliased_Present
(N
) then
2334 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2337 Freeze_Before
(N
, Act_T
);
2338 Freeze_Before
(N
, T
);
2341 elsif Is_Array_Type
(T
)
2342 and then No_Initialization
(N
)
2343 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2345 if not Is_Entity_Name
(Object_Definition
(N
)) then
2347 Check_Compile_Time_Size
(Act_T
);
2349 if Aliased_Present
(N
) then
2350 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2354 -- When the given object definition and the aggregate are specified
2355 -- independently, and their lengths might differ do a length check.
2356 -- This cannot happen if the aggregate is of the form (others =>...)
2358 if not Is_Constrained
(T
) then
2361 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
2363 -- Aggregate is statically illegal. Place back in declaration
2365 Set_Expression
(N
, E
);
2366 Set_No_Initialization
(N
, False);
2368 elsif T
= Etype
(E
) then
2371 elsif Nkind
(E
) = N_Aggregate
2372 and then Present
(Component_Associations
(E
))
2373 and then Present
(Choices
(First
(Component_Associations
(E
))))
2374 and then Nkind
(First
2375 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
2380 Apply_Length_Check
(E
, T
);
2383 elsif (Is_Limited_Record
(T
)
2384 or else Is_Concurrent_Type
(T
))
2385 and then not Is_Constrained
(T
)
2386 and then Has_Discriminants
(T
)
2389 Act_T
:= Build_Default_Subtype
;
2391 -- Ada 2005: a limited object may be initialized by means of an
2392 -- aggregate. If the type has default discriminants it has an
2393 -- unconstrained nominal type, Its actual subtype will be obtained
2394 -- from the aggregate, and not from the default discriminants.
2399 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
2401 elsif Present
(Underlying_Type
(T
))
2402 and then not Is_Constrained
(Underlying_Type
(T
))
2403 and then Has_Discriminants
(Underlying_Type
(T
))
2404 and then Nkind
(E
) = N_Function_Call
2405 and then Constant_Present
(N
)
2407 -- The back-end has problems with constants of a discriminated type
2408 -- with defaults, if the initial value is a function call. We
2409 -- generate an intermediate temporary for the result of the call.
2410 -- It is unclear why this should make it acceptable to gcc. ???
2412 Remove_Side_Effects
(E
);
2415 if T
= Standard_Wide_Character
or else T
= Standard_Wide_Wide_Character
2416 or else Root_Type
(T
) = Standard_Wide_String
2417 or else Root_Type
(T
) = Standard_Wide_Wide_String
2419 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
2422 -- Now establish the proper kind and type of the object
2424 if Constant_Present
(N
) then
2425 Set_Ekind
(Id
, E_Constant
);
2426 Set_Never_Set_In_Source
(Id
, True);
2427 Set_Is_True_Constant
(Id
, True);
2430 Set_Ekind
(Id
, E_Variable
);
2432 -- A variable is set as shared passive if it appears in a shared
2433 -- passive package, and is at the outer level. This is not done
2434 -- for entities generated during expansion, because those are
2435 -- always manipulated locally.
2437 if Is_Shared_Passive
(Current_Scope
)
2438 and then Is_Library_Level_Entity
(Id
)
2439 and then Comes_From_Source
(Id
)
2441 Set_Is_Shared_Passive
(Id
);
2442 Check_Shared_Var
(Id
, T
, N
);
2445 -- Case of no initializing expression present. If the type is not
2446 -- fully initialized, then we set Never_Set_In_Source, since this
2447 -- is a case of a potentially uninitialized object. Note that we
2448 -- do not consider access variables to be fully initialized for
2449 -- this purpose, since it still seems dubious if someone declares
2451 -- Note that we only do this for source declarations. If the object
2452 -- is declared by a generated declaration, we assume that it is not
2453 -- appropriate to generate warnings in that case.
2456 if (Is_Access_Type
(T
)
2457 or else not Is_Fully_Initialized_Type
(T
))
2458 and then Comes_From_Source
(N
)
2460 Set_Never_Set_In_Source
(Id
);
2465 Init_Alignment
(Id
);
2468 if Aliased_Present
(N
) then
2469 Set_Is_Aliased
(Id
);
2472 and then Is_Record_Type
(T
)
2473 and then not Is_Constrained
(T
)
2474 and then Has_Discriminants
(T
)
2476 Set_Actual_Subtype
(Id
, Build_Default_Subtype
);
2480 Set_Etype
(Id
, Act_T
);
2482 if Has_Controlled_Component
(Etype
(Id
))
2483 or else Is_Controlled
(Etype
(Id
))
2485 if not Is_Library_Level_Entity
(Id
) then
2486 Check_Restriction
(No_Nested_Finalization
, N
);
2488 Validate_Controlled_Object
(Id
);
2491 -- Generate a warning when an initialization causes an obvious ABE
2492 -- violation. If the init expression is a simple aggregate there
2493 -- shouldn't be any initialize/adjust call generated. This will be
2494 -- true as soon as aggregates are built in place when possible.
2496 -- ??? at the moment we do not generate warnings for temporaries
2497 -- created for those aggregates although Program_Error might be
2498 -- generated if compiled with -gnato.
2500 if Is_Controlled
(Etype
(Id
))
2501 and then Comes_From_Source
(Id
)
2504 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
2506 Implicit_Call
: Entity_Id
;
2507 pragma Warnings
(Off
, Implicit_Call
);
2508 -- ??? what is this for (never referenced!)
2510 function Is_Aggr
(N
: Node_Id
) return Boolean;
2511 -- Check that N is an aggregate
2517 function Is_Aggr
(N
: Node_Id
) return Boolean is
2519 case Nkind
(Original_Node
(N
)) is
2520 when N_Aggregate | N_Extension_Aggregate
=>
2523 when N_Qualified_Expression |
2525 N_Unchecked_Type_Conversion
=>
2526 return Is_Aggr
(Expression
(Original_Node
(N
)));
2534 -- If no underlying type, we already are in an error situation.
2535 -- Do not try to add a warning since we do not have access to
2538 if No
(Underlying_Type
(BT
)) then
2539 Implicit_Call
:= Empty
;
2541 -- A generic type does not have usable primitive operators.
2542 -- Initialization calls are built for instances.
2544 elsif Is_Generic_Type
(BT
) then
2545 Implicit_Call
:= Empty
;
2547 -- If the init expression is not an aggregate, an adjust call
2548 -- will be generated
2550 elsif Present
(E
) and then not Is_Aggr
(E
) then
2551 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
2553 -- If no init expression and we are not in the deferred
2554 -- constant case, an Initialize call will be generated
2556 elsif No
(E
) and then not Constant_Present
(N
) then
2557 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
2560 Implicit_Call
:= Empty
;
2566 if Has_Task
(Etype
(Id
)) then
2567 Check_Restriction
(No_Tasking
, N
);
2569 if Is_Library_Level_Entity
(Id
) then
2570 Check_Restriction
(Max_Tasks
, N
, Count_Tasks
(Etype
(Id
)));
2572 Check_Restriction
(Max_Tasks
, N
);
2573 Check_Restriction
(No_Task_Hierarchy
, N
);
2574 Check_Potentially_Blocking_Operation
(N
);
2577 -- A rather specialized test. If we see two tasks being declared
2578 -- of the same type in the same object declaration, and the task
2579 -- has an entry with an address clause, we know that program error
2580 -- will be raised at run-time since we can't have two tasks with
2581 -- entries at the same address.
2583 if Is_Task_Type
(Etype
(Id
)) and then More_Ids
(N
) then
2588 E
:= First_Entity
(Etype
(Id
));
2589 while Present
(E
) loop
2590 if Ekind
(E
) = E_Entry
2591 and then Present
(Get_Attribute_Definition_Clause
2592 (E
, Attribute_Address
))
2595 ("?more than one task with same entry address", N
);
2597 ("\?Program_Error will be raised at run time", N
);
2599 Make_Raise_Program_Error
(Loc
,
2600 Reason
=> PE_Duplicated_Entry_Address
));
2610 -- Some simple constant-propagation: if the expression is a constant
2611 -- string initialized with a literal, share the literal. This avoids
2615 and then Is_Entity_Name
(E
)
2616 and then Ekind
(Entity
(E
)) = E_Constant
2617 and then Base_Type
(Etype
(E
)) = Standard_String
2620 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
2623 and then Nkind
(Val
) = N_String_Literal
2625 Rewrite
(E
, New_Copy
(Val
));
2630 -- Another optimization: if the nominal subtype is unconstrained and
2631 -- the expression is a function call that returns an unconstrained
2632 -- type, rewrite the declaration as a renaming of the result of the
2633 -- call. The exceptions below are cases where the copy is expected,
2634 -- either by the back end (Aliased case) or by the semantics, as for
2635 -- initializing controlled types or copying tags for classwide types.
2638 and then Nkind
(E
) = N_Explicit_Dereference
2639 and then Nkind
(Original_Node
(E
)) = N_Function_Call
2640 and then not Is_Library_Level_Entity
(Id
)
2641 and then not Is_Constrained
(Underlying_Type
(T
))
2642 and then not Is_Aliased
(Id
)
2643 and then not Is_Class_Wide_Type
(T
)
2644 and then not Is_Controlled
(T
)
2645 and then not Has_Controlled_Component
(Base_Type
(T
))
2646 and then Expander_Active
2649 Make_Object_Renaming_Declaration
(Loc
,
2650 Defining_Identifier
=> Id
,
2651 Access_Definition
=> Empty
,
2652 Subtype_Mark
=> New_Occurrence_Of
2653 (Base_Type
(Etype
(Id
)), Loc
),
2656 Set_Renamed_Object
(Id
, E
);
2658 -- Force generation of debugging information for the constant and for
2659 -- the renamed function call.
2661 Set_Needs_Debug_Info
(Id
);
2662 Set_Needs_Debug_Info
(Entity
(Prefix
(E
)));
2665 if Present
(Prev_Entity
)
2666 and then Is_Frozen
(Prev_Entity
)
2667 and then not Error_Posted
(Id
)
2669 Error_Msg_N
("full constant declaration appears too late", N
);
2672 Check_Eliminated
(Id
);
2673 end Analyze_Object_Declaration
;
2675 ---------------------------
2676 -- Analyze_Others_Choice --
2677 ---------------------------
2679 -- Nothing to do for the others choice node itself, the semantic analysis
2680 -- of the others choice will occur as part of the processing of the parent
2682 procedure Analyze_Others_Choice
(N
: Node_Id
) is
2683 pragma Warnings
(Off
, N
);
2686 end Analyze_Others_Choice
;
2688 --------------------------------
2689 -- Analyze_Per_Use_Expression --
2690 --------------------------------
2692 procedure Analyze_Per_Use_Expression
(N
: Node_Id
; T
: Entity_Id
) is
2693 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
2695 In_Default_Expression
:= True;
2696 Pre_Analyze_And_Resolve
(N
, T
);
2697 In_Default_Expression
:= Save_In_Default_Expression
;
2698 end Analyze_Per_Use_Expression
;
2700 -------------------------------------------
2701 -- Analyze_Private_Extension_Declaration --
2702 -------------------------------------------
2704 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
2705 T
: constant Entity_Id
:= Defining_Identifier
(N
);
2706 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
2707 Parent_Type
: Entity_Id
;
2708 Parent_Base
: Entity_Id
;
2711 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
2713 if Is_Non_Empty_List
(Interface_List
(N
)) then
2719 Intf
:= First
(Interface_List
(N
));
2720 while Present
(Intf
) loop
2721 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
2723 if not Is_Interface
(T
) then
2724 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
2732 Generate_Definition
(T
);
2735 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
2736 Parent_Base
:= Base_Type
(Parent_Type
);
2738 if Parent_Type
= Any_Type
2739 or else Etype
(Parent_Type
) = Any_Type
2741 Set_Ekind
(T
, Ekind
(Parent_Type
));
2742 Set_Etype
(T
, Any_Type
);
2745 elsif not Is_Tagged_Type
(Parent_Type
) then
2747 ("parent of type extension must be a tagged type ", Indic
);
2750 elsif Ekind
(Parent_Type
) = E_Void
2751 or else Ekind
(Parent_Type
) = E_Incomplete_Type
2753 Error_Msg_N
("premature derivation of incomplete type", Indic
);
2757 -- Perhaps the parent type should be changed to the class-wide type's
2758 -- specific type in this case to prevent cascading errors ???
2760 if Is_Class_Wide_Type
(Parent_Type
) then
2762 ("parent of type extension must not be a class-wide type", Indic
);
2766 if (not Is_Package_Or_Generic_Package
(Current_Scope
)
2767 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
2768 or else In_Private_Part
(Current_Scope
)
2771 Error_Msg_N
("invalid context for private extension", N
);
2774 -- Set common attributes
2776 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2777 Set_Scope
(T
, Current_Scope
);
2778 Set_Ekind
(T
, E_Record_Type_With_Private
);
2779 Init_Size_Align
(T
);
2781 Set_Etype
(T
, Parent_Base
);
2782 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
2784 Set_Convention
(T
, Convention
(Parent_Type
));
2785 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
2786 Set_Is_First_Subtype
(T
);
2787 Make_Class_Wide_Type
(T
);
2789 if Unknown_Discriminants_Present
(N
) then
2790 Set_Discriminant_Constraint
(T
, No_Elist
);
2793 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
2795 if Limited_Present
(N
) then
2796 Set_Is_Limited_Record
(T
);
2798 if not Is_Limited_Type
(Parent_Type
)
2800 (not Is_Interface
(Parent_Type
)
2801 or else not Is_Limited_Interface
(Parent_Type
))
2803 Error_Msg_NE
("parent type& of limited extension must be limited",
2807 end Analyze_Private_Extension_Declaration
;
2809 ---------------------------------
2810 -- Analyze_Subtype_Declaration --
2811 ---------------------------------
2813 procedure Analyze_Subtype_Declaration
(N
: Node_Id
) is
2814 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2816 R_Checks
: Check_Result
;
2819 Generate_Definition
(Id
);
2820 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2821 Init_Size_Align
(Id
);
2823 -- The following guard condition on Enter_Name is to handle cases where
2824 -- the defining identifier has already been entered into the scope but
2825 -- the declaration as a whole needs to be analyzed.
2827 -- This case in particular happens for derived enumeration types. The
2828 -- derived enumeration type is processed as an inserted enumeration type
2829 -- declaration followed by a rewritten subtype declaration. The defining
2830 -- identifier, however, is entered into the name scope very early in the
2831 -- processing of the original type declaration and therefore needs to be
2832 -- avoided here, when the created subtype declaration is analyzed. (See
2833 -- Build_Derived_Types)
2835 -- This also happens when the full view of a private type is derived
2836 -- type with constraints. In this case the entity has been introduced
2837 -- in the private declaration.
2839 if Present
(Etype
(Id
))
2840 and then (Is_Private_Type
(Etype
(Id
))
2841 or else Is_Task_Type
(Etype
(Id
))
2842 or else Is_Rewrite_Substitution
(N
))
2850 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2852 -- Inherit common attributes
2854 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2855 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2856 Set_Treat_As_Volatile
(Id
, Treat_As_Volatile
(T
));
2857 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2858 Set_Is_Ada_2005
(Id
, Is_Ada_2005
(T
));
2860 -- In the case where there is no constraint given in the subtype
2861 -- indication, Process_Subtype just returns the Subtype_Mark, so its
2862 -- semantic attributes must be established here.
2864 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2865 Set_Etype
(Id
, Base_Type
(T
));
2869 Set_Ekind
(Id
, E_Array_Subtype
);
2870 Copy_Array_Subtype_Attributes
(Id
, T
);
2872 when Decimal_Fixed_Point_Kind
=>
2873 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2874 Set_Digits_Value
(Id
, Digits_Value
(T
));
2875 Set_Delta_Value
(Id
, Delta_Value
(T
));
2876 Set_Scale_Value
(Id
, Scale_Value
(T
));
2877 Set_Small_Value
(Id
, Small_Value
(T
));
2878 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2879 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2880 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2881 Set_RM_Size
(Id
, RM_Size
(T
));
2883 when Enumeration_Kind
=>
2884 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2885 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2886 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2887 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2888 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2889 Set_RM_Size
(Id
, RM_Size
(T
));
2891 when Ordinary_Fixed_Point_Kind
=>
2892 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2893 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2894 Set_Small_Value
(Id
, Small_Value
(T
));
2895 Set_Delta_Value
(Id
, Delta_Value
(T
));
2896 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2897 Set_RM_Size
(Id
, RM_Size
(T
));
2900 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2901 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2902 Set_Digits_Value
(Id
, Digits_Value
(T
));
2903 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2905 when Signed_Integer_Kind
=>
2906 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2907 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2908 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2909 Set_RM_Size
(Id
, RM_Size
(T
));
2911 when Modular_Integer_Kind
=>
2912 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2913 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2914 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2915 Set_RM_Size
(Id
, RM_Size
(T
));
2917 when Class_Wide_Kind
=>
2918 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2919 Set_First_Entity
(Id
, First_Entity
(T
));
2920 Set_Last_Entity
(Id
, Last_Entity
(T
));
2921 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2922 Set_Cloned_Subtype
(Id
, T
);
2923 Set_Is_Tagged_Type
(Id
, True);
2924 Set_Has_Unknown_Discriminants
2927 if Ekind
(T
) = E_Class_Wide_Subtype
then
2928 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
2931 when E_Record_Type | E_Record_Subtype
=>
2932 Set_Ekind
(Id
, E_Record_Subtype
);
2934 if Ekind
(T
) = E_Record_Subtype
2935 and then Present
(Cloned_Subtype
(T
))
2937 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
2939 Set_Cloned_Subtype
(Id
, T
);
2942 Set_First_Entity
(Id
, First_Entity
(T
));
2943 Set_Last_Entity
(Id
, Last_Entity
(T
));
2944 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2945 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2946 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2947 Set_Has_Unknown_Discriminants
2948 (Id
, Has_Unknown_Discriminants
(T
));
2950 if Has_Discriminants
(T
) then
2951 Set_Discriminant_Constraint
2952 (Id
, Discriminant_Constraint
(T
));
2953 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2955 elsif Has_Unknown_Discriminants
(Id
) then
2956 Set_Discriminant_Constraint
(Id
, No_Elist
);
2959 if Is_Tagged_Type
(T
) then
2960 Set_Is_Tagged_Type
(Id
);
2961 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2962 Set_Primitive_Operations
2963 (Id
, Primitive_Operations
(T
));
2964 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2967 when Private_Kind
=>
2968 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2969 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2970 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2971 Set_First_Entity
(Id
, First_Entity
(T
));
2972 Set_Last_Entity
(Id
, Last_Entity
(T
));
2973 Set_Private_Dependents
(Id
, New_Elmt_List
);
2974 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2975 Set_Has_Unknown_Discriminants
2976 (Id
, Has_Unknown_Discriminants
(T
));
2978 if Is_Tagged_Type
(T
) then
2979 Set_Is_Tagged_Type
(Id
);
2980 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2981 Set_Primitive_Operations
2982 (Id
, Primitive_Operations
(T
));
2983 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2986 -- In general the attributes of the subtype of a private type
2987 -- are the attributes of the partial view of parent. However,
2988 -- the full view may be a discriminated type, and the subtype
2989 -- must share the discriminant constraint to generate correct
2990 -- calls to initialization procedures.
2992 if Has_Discriminants
(T
) then
2993 Set_Discriminant_Constraint
2994 (Id
, Discriminant_Constraint
(T
));
2995 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2997 elsif Present
(Full_View
(T
))
2998 and then Has_Discriminants
(Full_View
(T
))
3000 Set_Discriminant_Constraint
3001 (Id
, Discriminant_Constraint
(Full_View
(T
)));
3002 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3004 -- This would seem semantically correct, but apparently
3005 -- confuses the back-end (4412-009). To be explained ???
3007 -- Set_Has_Discriminants (Id);
3010 Prepare_Private_Subtype_Completion
(Id
, N
);
3013 Set_Ekind
(Id
, E_Access_Subtype
);
3014 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3015 Set_Is_Access_Constant
3016 (Id
, Is_Access_Constant
(T
));
3017 Set_Directly_Designated_Type
3018 (Id
, Designated_Type
(T
));
3019 Set_Can_Never_Be_Null
(Id
, Can_Never_Be_Null
(T
));
3021 -- A Pure library_item must not contain the declaration of a
3022 -- named access type, except within a subprogram, generic
3023 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
3025 if Comes_From_Source
(Id
)
3026 and then In_Pure_Unit
3027 and then not In_Subprogram_Task_Protected_Unit
3030 ("named access types not allowed in pure unit", N
);
3033 when Concurrent_Kind
=>
3034 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
3035 Set_Corresponding_Record_Type
(Id
,
3036 Corresponding_Record_Type
(T
));
3037 Set_First_Entity
(Id
, First_Entity
(T
));
3038 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
3039 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
3040 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3041 Set_Last_Entity
(Id
, Last_Entity
(T
));
3043 if Has_Discriminants
(T
) then
3044 Set_Discriminant_Constraint
(Id
,
3045 Discriminant_Constraint
(T
));
3046 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3049 -- If the subtype name denotes an incomplete type an error was
3050 -- already reported by Process_Subtype.
3052 when E_Incomplete_Type
=>
3053 Set_Etype
(Id
, Any_Type
);
3056 raise Program_Error
;
3060 if Etype
(Id
) = Any_Type
then
3064 -- Some common processing on all types
3066 Set_Size_Info
(Id
, T
);
3067 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
3071 Set_Is_Immediately_Visible
(Id
, True);
3072 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
3074 if Present
(Generic_Parent_Type
(N
))
3077 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
3079 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
3080 /= N_Formal_Private_Type_Definition
)
3082 if Is_Tagged_Type
(Id
) then
3083 if Is_Class_Wide_Type
(Id
) then
3084 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
3086 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
3089 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
3090 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
3094 if Is_Private_Type
(T
)
3095 and then Present
(Full_View
(T
))
3097 Conditional_Delay
(Id
, Full_View
(T
));
3099 -- The subtypes of components or subcomponents of protected types
3100 -- do not need freeze nodes, which would otherwise appear in the
3101 -- wrong scope (before the freeze node for the protected type). The
3102 -- proper subtypes are those of the subcomponents of the corresponding
3105 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
3106 and then Present
(Scope
(Scope
(Id
))) -- error defense!
3107 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
3109 Conditional_Delay
(Id
, T
);
3112 -- Check that constraint_error is raised for a scalar subtype
3113 -- indication when the lower or upper bound of a non-null range
3114 -- lies outside the range of the type mark.
3116 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
3117 if Is_Scalar_Type
(Etype
(Id
))
3118 and then Scalar_Range
(Id
) /=
3119 Scalar_Range
(Etype
(Subtype_Mark
3120 (Subtype_Indication
(N
))))
3124 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
3126 elsif Is_Array_Type
(Etype
(Id
))
3127 and then Present
(First_Index
(Id
))
3129 -- This really should be a subprogram that finds the indications
3132 if ((Nkind
(First_Index
(Id
)) = N_Identifier
3133 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
3134 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
3136 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
3139 Target_Typ
: constant Entity_Id
:=
3142 (Subtype_Mark
(Subtype_Indication
(N
)))));
3146 (Scalar_Range
(Etype
(First_Index
(Id
))),
3148 Etype
(First_Index
(Id
)),
3149 Defining_Identifier
(N
));
3155 Sloc
(Defining_Identifier
(N
)));
3161 Check_Eliminated
(Id
);
3162 end Analyze_Subtype_Declaration
;
3164 --------------------------------
3165 -- Analyze_Subtype_Indication --
3166 --------------------------------
3168 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
3169 T
: constant Entity_Id
:= Subtype_Mark
(N
);
3170 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
3177 Set_Etype
(N
, Etype
(R
));
3179 Set_Error_Posted
(R
);
3180 Set_Error_Posted
(T
);
3182 end Analyze_Subtype_Indication
;
3184 ------------------------------
3185 -- Analyze_Type_Declaration --
3186 ------------------------------
3188 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
3189 Def
: constant Node_Id
:= Type_Definition
(N
);
3190 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3194 Is_Remote
: constant Boolean :=
3195 (Is_Remote_Types
(Current_Scope
)
3196 or else Is_Remote_Call_Interface
(Current_Scope
))
3197 and then not (In_Private_Part
(Current_Scope
)
3199 In_Package_Body
(Current_Scope
));
3201 procedure Check_Ops_From_Incomplete_Type
;
3202 -- If there is a tagged incomplete partial view of the type, transfer
3203 -- its operations to the full view, and indicate that the type of the
3204 -- controlling parameter (s) is this full view.
3206 ------------------------------------
3207 -- Check_Ops_From_Incomplete_Type --
3208 ------------------------------------
3210 procedure Check_Ops_From_Incomplete_Type
is
3217 and then Ekind
(Prev
) = E_Incomplete_Type
3218 and then Is_Tagged_Type
(Prev
)
3219 and then Is_Tagged_Type
(T
)
3221 Elmt
:= First_Elmt
(Primitive_Operations
(Prev
));
3222 while Present
(Elmt
) loop
3224 Prepend_Elmt
(Op
, Primitive_Operations
(T
));
3226 Formal
:= First_Formal
(Op
);
3227 while Present
(Formal
) loop
3228 if Etype
(Formal
) = Prev
then
3229 Set_Etype
(Formal
, T
);
3232 Next_Formal
(Formal
);
3235 if Etype
(Op
) = Prev
then
3242 end Check_Ops_From_Incomplete_Type
;
3244 -- Start of processing for Analyze_Type_Declaration
3247 Prev
:= Find_Type_Name
(N
);
3249 -- The full view, if present, now points to the current type
3251 -- Ada 2005 (AI-50217): If the type was previously decorated when
3252 -- imported through a LIMITED WITH clause, it appears as incomplete
3253 -- but has no full view.
3255 if Ekind
(Prev
) = E_Incomplete_Type
3256 and then Present
(Full_View
(Prev
))
3258 T
:= Full_View
(Prev
);
3263 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
3265 -- We set the flag Is_First_Subtype here. It is needed to set the
3266 -- corresponding flag for the Implicit class-wide-type created
3267 -- during tagged types processing.
3269 Set_Is_First_Subtype
(T
, True);
3271 -- Only composite types other than array types are allowed to have
3276 -- For derived types, the rule will be checked once we've figured
3277 -- out the parent type.
3279 when N_Derived_Type_Definition
=>
3282 -- For record types, discriminants are allowed
3284 when N_Record_Definition
=>
3288 if Present
(Discriminant_Specifications
(N
)) then
3290 ("elementary or array type cannot have discriminants",
3292 (First
(Discriminant_Specifications
(N
))));
3296 -- Elaborate the type definition according to kind, and generate
3297 -- subsidiary (implicit) subtypes where needed. We skip this if
3298 -- it was already done (this happens during the reanalysis that
3299 -- follows a call to the high level optimizer).
3301 if not Analyzed
(T
) then
3306 when N_Access_To_Subprogram_Definition
=>
3307 Access_Subprogram_Declaration
(T
, Def
);
3309 -- If this is a remote access to subprogram, we must create
3310 -- the equivalent fat pointer type, and related subprograms.
3313 Process_Remote_AST_Declaration
(N
);
3316 -- Validate categorization rule against access type declaration
3317 -- usually a violation in Pure unit, Shared_Passive unit.
3319 Validate_Access_Type_Declaration
(T
, N
);
3321 when N_Access_To_Object_Definition
=>
3322 Access_Type_Declaration
(T
, Def
);
3324 -- Validate categorization rule against access type declaration
3325 -- usually a violation in Pure unit, Shared_Passive unit.
3327 Validate_Access_Type_Declaration
(T
, N
);
3329 -- If we are in a Remote_Call_Interface package and define
3330 -- a RACW, Read and Write attribute must be added.
3333 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
3335 Add_RACW_Features
(Def_Id
);
3338 -- Set no strict aliasing flag if config pragma seen
3340 if Opt
.No_Strict_Aliasing
then
3341 Set_No_Strict_Aliasing
(Base_Type
(Def_Id
));
3344 when N_Array_Type_Definition
=>
3345 Array_Type_Declaration
(T
, Def
);
3347 when N_Derived_Type_Definition
=>
3348 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
3350 when N_Enumeration_Type_Definition
=>
3351 Enumeration_Type_Declaration
(T
, Def
);
3353 when N_Floating_Point_Definition
=>
3354 Floating_Point_Type_Declaration
(T
, Def
);
3356 when N_Decimal_Fixed_Point_Definition
=>
3357 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
3359 when N_Ordinary_Fixed_Point_Definition
=>
3360 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
3362 when N_Signed_Integer_Type_Definition
=>
3363 Signed_Integer_Type_Declaration
(T
, Def
);
3365 when N_Modular_Type_Definition
=>
3366 Modular_Type_Declaration
(T
, Def
);
3368 when N_Record_Definition
=>
3369 Record_Type_Declaration
(T
, N
, Prev
);
3372 raise Program_Error
;
3377 if Etype
(T
) = Any_Type
then
3381 -- Some common processing for all types
3383 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
3384 Check_Ops_From_Incomplete_Type
;
3386 -- Both the declared entity, and its anonymous base type if one
3387 -- was created, need freeze nodes allocated.
3390 B
: constant Entity_Id
:= Base_Type
(T
);
3393 -- In the case where the base type is different from the first
3394 -- subtype, we pre-allocate a freeze node, and set the proper link
3395 -- to the first subtype. Freeze_Entity will use this preallocated
3396 -- freeze node when it freezes the entity.
3399 Ensure_Freeze_Node
(B
);
3400 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
3403 if not From_With_Type
(T
) then
3404 Set_Has_Delayed_Freeze
(T
);
3408 -- Case of T is the full declaration of some private type which has
3409 -- been swapped in Defining_Identifier (N).
3411 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
3412 Process_Full_View
(N
, T
, Def_Id
);
3414 -- Record the reference. The form of this is a little strange,
3415 -- since the full declaration has been swapped in. So the first
3416 -- parameter here represents the entity to which a reference is
3417 -- made which is the "real" entity, i.e. the one swapped in,
3418 -- and the second parameter provides the reference location.
3420 Generate_Reference
(T
, T
, 'c');
3421 Set_Completion_Referenced
(Def_Id
);
3423 -- For completion of incomplete type, process incomplete dependents
3424 -- and always mark the full type as referenced (it is the incomplete
3425 -- type that we get for any real reference).
3427 elsif Ekind
(Prev
) = E_Incomplete_Type
then
3428 Process_Incomplete_Dependents
(N
, T
, Prev
);
3429 Generate_Reference
(Prev
, Def_Id
, 'c');
3430 Set_Completion_Referenced
(Def_Id
);
3432 -- If not private type or incomplete type completion, this is a real
3433 -- definition of a new entity, so record it.
3436 Generate_Definition
(Def_Id
);
3439 Check_Eliminated
(Def_Id
);
3440 end Analyze_Type_Declaration
;
3442 --------------------------
3443 -- Analyze_Variant_Part --
3444 --------------------------
3446 procedure Analyze_Variant_Part
(N
: Node_Id
) is
3448 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
3449 -- Error routine invoked by the generic instantiation below when
3450 -- the variant part has a non static choice.
3452 procedure Process_Declarations
(Variant
: Node_Id
);
3453 -- Analyzes all the declarations associated with a Variant.
3454 -- Needed by the generic instantiation below.
3456 package Variant_Choices_Processing
is new
3457 Generic_Choices_Processing
3458 (Get_Alternatives
=> Variants
,
3459 Get_Choices
=> Discrete_Choices
,
3460 Process_Empty_Choice
=> No_OP
,
3461 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
3462 Process_Associated_Node
=> Process_Declarations
);
3463 use Variant_Choices_Processing
;
3464 -- Instantiation of the generic choice processing package
3466 -----------------------------
3467 -- Non_Static_Choice_Error --
3468 -----------------------------
3470 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
3472 Flag_Non_Static_Expr
3473 ("choice given in variant part is not static!", Choice
);
3474 end Non_Static_Choice_Error
;
3476 --------------------------
3477 -- Process_Declarations --
3478 --------------------------
3480 procedure Process_Declarations
(Variant
: Node_Id
) is
3482 if not Null_Present
(Component_List
(Variant
)) then
3483 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
3485 if Present
(Variant_Part
(Component_List
(Variant
))) then
3486 Analyze
(Variant_Part
(Component_List
(Variant
)));
3489 end Process_Declarations
;
3491 -- Variables local to Analyze_Case_Statement
3493 Discr_Name
: Node_Id
;
3494 Discr_Type
: Entity_Id
;
3496 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
3498 Dont_Care
: Boolean;
3499 Others_Present
: Boolean := False;
3501 -- Start of processing for Analyze_Variant_Part
3504 Discr_Name
:= Name
(N
);
3505 Analyze
(Discr_Name
);
3507 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
3508 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
3511 Discr_Type
:= Etype
(Entity
(Discr_Name
));
3513 if not Is_Discrete_Type
(Discr_Type
) then
3515 ("discriminant in a variant part must be of a discrete type",
3520 -- Call the instantiated Analyze_Choices which does the rest of the work
3523 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
3524 end Analyze_Variant_Part
;
3526 ----------------------------
3527 -- Array_Type_Declaration --
3528 ----------------------------
3530 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
3531 Component_Def
: constant Node_Id
:= Component_Definition
(Def
);
3532 Element_Type
: Entity_Id
;
3533 Implicit_Base
: Entity_Id
;
3535 Related_Id
: Entity_Id
:= Empty
;
3537 P
: constant Node_Id
:= Parent
(Def
);
3541 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3542 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
3544 Index
:= First
(Subtype_Marks
(Def
));
3547 -- Find proper names for the implicit types which may be public.
3548 -- in case of anonymous arrays we use the name of the first object
3549 -- of that type as prefix.
3552 Related_Id
:= Defining_Identifier
(P
);
3558 while Present
(Index
) loop
3560 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
3562 Nb_Index
:= Nb_Index
+ 1;
3565 if Present
(Subtype_Indication
(Component_Def
)) then
3566 Element_Type
:= Process_Subtype
(Subtype_Indication
(Component_Def
),
3567 P
, Related_Id
, 'C');
3569 -- Ada 2005 (AI-230): Access Definition case
3571 else pragma Assert
(Present
(Access_Definition
(Component_Def
)));
3572 Element_Type
:= Access_Definition
3573 (Related_Nod
=> Related_Id
,
3574 N
=> Access_Definition
(Component_Def
));
3575 Set_Is_Local_Anonymous_Access
(Element_Type
);
3577 -- Ada 2005 (AI-230): In case of components that are anonymous
3578 -- access types the level of accessibility depends on the enclosing
3581 Set_Scope
(Element_Type
, Current_Scope
); -- Ada 2005 (AI-230)
3583 -- Ada 2005 (AI-254)
3586 CD
: constant Node_Id
:=
3587 Access_To_Subprogram_Definition
3588 (Access_Definition
(Component_Def
));
3590 if Present
(CD
) and then Protected_Present
(CD
) then
3592 Replace_Anonymous_Access_To_Protected_Subprogram
3593 (Def
, Element_Type
);
3598 -- Constrained array case
3601 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
3604 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3606 -- Establish Implicit_Base as unconstrained base type
3608 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
3610 Init_Size_Align
(Implicit_Base
);
3611 Set_Etype
(Implicit_Base
, Implicit_Base
);
3612 Set_Scope
(Implicit_Base
, Current_Scope
);
3613 Set_Has_Delayed_Freeze
(Implicit_Base
);
3615 -- The constrained array type is a subtype of the unconstrained one
3617 Set_Ekind
(T
, E_Array_Subtype
);
3618 Init_Size_Align
(T
);
3619 Set_Etype
(T
, Implicit_Base
);
3620 Set_Scope
(T
, Current_Scope
);
3621 Set_Is_Constrained
(T
, True);
3622 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
3623 Set_Has_Delayed_Freeze
(T
);
3625 -- Complete setup of implicit base type
3627 Set_First_Index
(Implicit_Base
, First_Index
(T
));
3628 Set_Component_Type
(Implicit_Base
, Element_Type
);
3629 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
3630 Set_Component_Size
(Implicit_Base
, Uint_0
);
3631 Set_Has_Controlled_Component
3632 (Implicit_Base
, Has_Controlled_Component
3635 Is_Controlled
(Element_Type
));
3636 Set_Finalize_Storage_Only
3637 (Implicit_Base
, Finalize_Storage_Only
3640 -- Unconstrained array case
3643 Set_Ekind
(T
, E_Array_Type
);
3644 Init_Size_Align
(T
);
3646 Set_Scope
(T
, Current_Scope
);
3647 Set_Component_Size
(T
, Uint_0
);
3648 Set_Is_Constrained
(T
, False);
3649 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
3650 Set_Has_Delayed_Freeze
(T
, True);
3651 Set_Has_Task
(T
, Has_Task
(Element_Type
));
3652 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
3655 Is_Controlled
(Element_Type
));
3656 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
3660 Set_Component_Type
(Base_Type
(T
), Element_Type
);
3662 if Aliased_Present
(Component_Definition
(Def
)) then
3663 Set_Has_Aliased_Components
(Etype
(T
));
3666 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
3667 -- array type to ensure that objects of this type are initialized.
3669 if Ada_Version
>= Ada_05
3670 and then Can_Never_Be_Null
(Element_Type
)
3672 Set_Can_Never_Be_Null
(T
);
3674 if Null_Exclusion_Present
(Component_Definition
(Def
))
3675 and then Can_Never_Be_Null
(Element_Type
)
3677 -- No need to check itypes because in their case this check
3678 -- was done at their point of creation
3680 and then not Is_Itype
(Element_Type
)
3683 ("(Ada 2005) already a null-excluding type",
3684 Subtype_Indication
(Component_Definition
(Def
)));
3688 Priv
:= Private_Component
(Element_Type
);
3690 if Present
(Priv
) then
3692 -- Check for circular definitions
3694 if Priv
= Any_Type
then
3695 Set_Component_Type
(Etype
(T
), Any_Type
);
3697 -- There is a gap in the visibility of operations on the composite
3698 -- type only if the component type is defined in a different scope.
3700 elsif Scope
(Priv
) = Current_Scope
then
3703 elsif Is_Limited_Type
(Priv
) then
3704 Set_Is_Limited_Composite
(Etype
(T
));
3705 Set_Is_Limited_Composite
(T
);
3707 Set_Is_Private_Composite
(Etype
(T
));
3708 Set_Is_Private_Composite
(T
);
3712 -- Create a concatenation operator for the new type. Internal
3713 -- array types created for packed entities do not need such, they
3714 -- are compatible with the user-defined type.
3716 if Number_Dimensions
(T
) = 1
3717 and then not Is_Packed_Array_Type
(T
)
3719 New_Concatenation_Op
(T
);
3722 -- In the case of an unconstrained array the parser has already
3723 -- verified that all the indices are unconstrained but we still
3724 -- need to make sure that the element type is constrained.
3726 if Is_Indefinite_Subtype
(Element_Type
) then
3728 ("unconstrained element type in array declaration",
3729 Subtype_Indication
(Component_Def
));
3731 elsif Is_Abstract
(Element_Type
) then
3733 ("the type of a component cannot be abstract",
3734 Subtype_Indication
(Component_Def
));
3737 end Array_Type_Declaration
;
3739 ------------------------------------------------------
3740 -- Replace_Anonymous_Access_To_Protected_Subprogram --
3741 ------------------------------------------------------
3743 function Replace_Anonymous_Access_To_Protected_Subprogram
3745 Prev_E
: Entity_Id
) return Entity_Id
3747 Loc
: constant Source_Ptr
:= Sloc
(N
);
3749 Curr_Scope
: constant Scope_Stack_Entry
:=
3750 Scope_Stack
.Table
(Scope_Stack
.Last
);
3752 Anon
: constant Entity_Id
:=
3753 Make_Defining_Identifier
(Loc
,
3754 Chars
=> New_Internal_Name
('S'));
3762 Set_Is_Internal
(Anon
);
3765 when N_Component_Declaration |
3766 N_Unconstrained_Array_Definition |
3767 N_Constrained_Array_Definition
=>
3768 Comp
:= Component_Definition
(N
);
3769 Acc
:= Access_Definition
(Component_Definition
(N
));
3771 when N_Discriminant_Specification
=>
3772 Comp
:= Discriminant_Type
(N
);
3773 Acc
:= Discriminant_Type
(N
);
3775 when N_Parameter_Specification
=>
3776 Comp
:= Parameter_Type
(N
);
3777 Acc
:= Parameter_Type
(N
);
3780 raise Program_Error
;
3783 Decl
:= Make_Full_Type_Declaration
(Loc
,
3784 Defining_Identifier
=> Anon
,
3786 Copy_Separate_Tree
(Access_To_Subprogram_Definition
(Acc
)));
3788 Mark_Rewrite_Insertion
(Decl
);
3790 -- Insert the new declaration in the nearest enclosing scope
3793 while Present
(P
) and then not Has_Declarations
(P
) loop
3797 pragma Assert
(Present
(P
));
3799 if Nkind
(P
) = N_Package_Specification
then
3800 Prepend
(Decl
, Visible_Declarations
(P
));
3802 Prepend
(Decl
, Declarations
(P
));
3805 -- Replace the anonymous type with an occurrence of the new declaration.
3806 -- In all cases the rewritten node does not have the null-exclusion
3807 -- attribute because (if present) it was already inherited by the
3808 -- anonymous entity (Anon). Thus, in case of components we do not
3809 -- inherit this attribute.
3811 if Nkind
(N
) = N_Parameter_Specification
then
3812 Rewrite
(Comp
, New_Occurrence_Of
(Anon
, Loc
));
3813 Set_Etype
(Defining_Identifier
(N
), Anon
);
3814 Set_Null_Exclusion_Present
(N
, False);
3817 Make_Component_Definition
(Loc
,
3818 Subtype_Indication
=> New_Occurrence_Of
(Anon
, Loc
)));
3821 Mark_Rewrite_Insertion
(Comp
);
3823 -- Temporarily remove the current scope from the stack to add the new
3824 -- declarations to the enclosing scope
3826 Scope_Stack
.Decrement_Last
;
3828 Scope_Stack
.Append
(Curr_Scope
);
3830 Set_Original_Access_Type
(Anon
, Prev_E
);
3832 end Replace_Anonymous_Access_To_Protected_Subprogram
;
3834 -------------------------------
3835 -- Build_Derived_Access_Type --
3836 -------------------------------
3838 procedure Build_Derived_Access_Type
3840 Parent_Type
: Entity_Id
;
3841 Derived_Type
: Entity_Id
)
3843 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
3845 Desig_Type
: Entity_Id
;
3847 Discr_Con_Elist
: Elist_Id
;
3848 Discr_Con_El
: Elmt_Id
;
3852 -- Set the designated type so it is available in case this is
3853 -- an access to a self-referential type, e.g. a standard list
3854 -- type with a next pointer. Will be reset after subtype is built.
3856 Set_Directly_Designated_Type
3857 (Derived_Type
, Designated_Type
(Parent_Type
));
3859 Subt
:= Process_Subtype
(S
, N
);
3861 if Nkind
(S
) /= N_Subtype_Indication
3862 and then Subt
/= Base_Type
(Subt
)
3864 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
3867 if Ekind
(Derived_Type
) = E_Access_Subtype
then
3869 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3870 Ibase
: constant Entity_Id
:=
3871 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
3872 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
3873 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
3876 Copy_Node
(Pbase
, Ibase
);
3878 Set_Chars
(Ibase
, Svg_Chars
);
3879 Set_Next_Entity
(Ibase
, Svg_Next_E
);
3880 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
3881 Set_Scope
(Ibase
, Scope
(Derived_Type
));
3882 Set_Freeze_Node
(Ibase
, Empty
);
3883 Set_Is_Frozen
(Ibase
, False);
3884 Set_Comes_From_Source
(Ibase
, False);
3885 Set_Is_First_Subtype
(Ibase
, False);
3887 Set_Etype
(Ibase
, Pbase
);
3888 Set_Etype
(Derived_Type
, Ibase
);
3892 Set_Directly_Designated_Type
3893 (Derived_Type
, Designated_Type
(Subt
));
3895 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
3896 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
3897 Set_Size_Info
(Derived_Type
, Parent_Type
);
3898 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
3899 Set_Depends_On_Private
(Derived_Type
,
3900 Has_Private_Component
(Derived_Type
));
3901 Conditional_Delay
(Derived_Type
, Subt
);
3903 -- Ada 2005 (AI-231). Set the null-exclusion attribute
3905 if Null_Exclusion_Present
(Type_Definition
(N
))
3906 or else Can_Never_Be_Null
(Parent_Type
)
3908 Set_Can_Never_Be_Null
(Derived_Type
);
3911 -- Note: we do not copy the Storage_Size_Variable, since
3912 -- we always go to the root type for this information.
3914 -- Apply range checks to discriminants for derived record case
3915 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
3917 Desig_Type
:= Designated_Type
(Derived_Type
);
3918 if Is_Composite_Type
(Desig_Type
)
3919 and then (not Is_Array_Type
(Desig_Type
))
3920 and then Has_Discriminants
(Desig_Type
)
3921 and then Base_Type
(Desig_Type
) /= Desig_Type
3923 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
3924 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
3926 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
3927 while Present
(Discr_Con_El
) loop
3928 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
3929 Next_Elmt
(Discr_Con_El
);
3930 Next_Discriminant
(Discr
);
3933 end Build_Derived_Access_Type
;
3935 ------------------------------
3936 -- Build_Derived_Array_Type --
3937 ------------------------------
3939 procedure Build_Derived_Array_Type
3941 Parent_Type
: Entity_Id
;
3942 Derived_Type
: Entity_Id
)
3944 Loc
: constant Source_Ptr
:= Sloc
(N
);
3945 Tdef
: constant Node_Id
:= Type_Definition
(N
);
3946 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
3947 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3948 Implicit_Base
: Entity_Id
;
3949 New_Indic
: Node_Id
;
3951 procedure Make_Implicit_Base
;
3952 -- If the parent subtype is constrained, the derived type is a
3953 -- subtype of an implicit base type derived from the parent base.
3955 ------------------------
3956 -- Make_Implicit_Base --
3957 ------------------------
3959 procedure Make_Implicit_Base
is
3962 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
3964 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
3965 Set_Etype
(Implicit_Base
, Parent_Base
);
3967 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
3968 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
3970 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
3971 end Make_Implicit_Base
;
3973 -- Start of processing for Build_Derived_Array_Type
3976 if not Is_Constrained
(Parent_Type
) then
3977 if Nkind
(Indic
) /= N_Subtype_Indication
then
3978 Set_Ekind
(Derived_Type
, E_Array_Type
);
3980 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
3981 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
3983 Set_Has_Delayed_Freeze
(Derived_Type
, True);
3987 Set_Etype
(Derived_Type
, Implicit_Base
);
3990 Make_Subtype_Declaration
(Loc
,
3991 Defining_Identifier
=> Derived_Type
,
3992 Subtype_Indication
=>
3993 Make_Subtype_Indication
(Loc
,
3994 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
3995 Constraint
=> Constraint
(Indic
)));
3997 Rewrite
(N
, New_Indic
);
4002 if Nkind
(Indic
) /= N_Subtype_Indication
then
4005 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
4006 Set_Etype
(Derived_Type
, Implicit_Base
);
4007 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
4010 Error_Msg_N
("illegal constraint on constrained type", Indic
);
4014 -- If parent type is not a derived type itself, and is declared in
4015 -- closed scope (e.g. a subprogram), then we must explicitly introduce
4016 -- the new type's concatenation operator since Derive_Subprograms
4017 -- will not inherit the parent's operator. If the parent type is
4018 -- unconstrained, the operator is of the unconstrained base type.
4020 if Number_Dimensions
(Parent_Type
) = 1
4021 and then not Is_Limited_Type
(Parent_Type
)
4022 and then not Is_Derived_Type
(Parent_Type
)
4023 and then not Is_Package_Or_Generic_Package
4024 (Scope
(Base_Type
(Parent_Type
)))
4026 if not Is_Constrained
(Parent_Type
)
4027 and then Is_Constrained
(Derived_Type
)
4029 New_Concatenation_Op
(Implicit_Base
);
4031 New_Concatenation_Op
(Derived_Type
);
4034 end Build_Derived_Array_Type
;
4036 -----------------------------------
4037 -- Build_Derived_Concurrent_Type --
4038 -----------------------------------
4040 procedure Build_Derived_Concurrent_Type
4042 Parent_Type
: Entity_Id
;
4043 Derived_Type
: Entity_Id
)
4045 D_Constraint
: Node_Id
;
4046 Disc_Spec
: Node_Id
;
4047 Old_Disc
: Entity_Id
;
4048 New_Disc
: Entity_Id
;
4050 Constraint_Present
: constant Boolean :=
4051 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4052 = N_Subtype_Indication
;
4055 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
4057 if Is_Task_Type
(Parent_Type
) then
4058 Set_Storage_Size_Variable
(Derived_Type
,
4059 Storage_Size_Variable
(Parent_Type
));
4062 if Present
(Discriminant_Specifications
(N
)) then
4063 New_Scope
(Derived_Type
);
4064 Check_Or_Process_Discriminants
(N
, Derived_Type
);
4067 elsif Constraint_Present
then
4069 -- Build constrained subtype and derive from it
4072 Loc
: constant Source_Ptr
:= Sloc
(N
);
4073 Anon
: constant Entity_Id
:=
4074 Make_Defining_Identifier
(Loc
,
4075 New_External_Name
(Chars
(Derived_Type
), 'T'));
4080 Make_Subtype_Declaration
(Loc
,
4081 Defining_Identifier
=> Anon
,
4082 Subtype_Indication
=>
4083 New_Copy_Tree
(Subtype_Indication
(Type_Definition
(N
))));
4084 Insert_Before
(N
, Decl
);
4085 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
4086 New_Occurrence_Of
(Anon
, Loc
));
4088 Set_Analyzed
(Derived_Type
, False);
4094 -- All attributes are inherited from parent. In particular,
4095 -- entries and the corresponding record type are the same.
4096 -- Discriminants may be renamed, and must be treated separately.
4098 Set_Has_Discriminants
4099 (Derived_Type
, Has_Discriminants
(Parent_Type
));
4100 Set_Corresponding_Record_Type
4101 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
4103 if Constraint_Present
then
4104 if not Has_Discriminants
(Parent_Type
) then
4105 Error_Msg_N
("untagged parent must have discriminants", N
);
4107 elsif Present
(Discriminant_Specifications
(N
)) then
4109 -- Verify that new discriminants are used to constrain old ones
4114 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
4116 Old_Disc
:= First_Discriminant
(Parent_Type
);
4117 New_Disc
:= First_Discriminant
(Derived_Type
);
4118 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
4119 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
4120 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
4123 Analyze
(Discriminant_Type
(Disc_Spec
));
4125 if not Subtypes_Statically_Compatible
(
4126 Etype
(Discriminant_Type
(Disc_Spec
)),
4130 ("not statically compatible with parent discriminant",
4131 Discriminant_Type
(Disc_Spec
));
4135 if Nkind
(D_Constraint
) = N_Identifier
4136 and then Chars
(D_Constraint
) /=
4137 Chars
(Defining_Identifier
(Disc_Spec
))
4139 Error_Msg_N
("new discriminants must constrain old ones",
4142 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
4145 Next_Discriminant
(Old_Disc
);
4146 Next_Discriminant
(New_Disc
);
4150 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
4151 Error_Msg_N
("discriminant mismatch in derivation", N
);
4156 elsif Present
(Discriminant_Specifications
(N
)) then
4158 ("missing discriminant constraint in untagged derivation",
4162 if Present
(Discriminant_Specifications
(N
)) then
4163 Old_Disc
:= First_Discriminant
(Parent_Type
);
4164 while Present
(Old_Disc
) loop
4166 if No
(Next_Entity
(Old_Disc
))
4167 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
4169 Set_Next_Entity
(Last_Entity
(Derived_Type
),
4170 Next_Entity
(Old_Disc
));
4174 Next_Discriminant
(Old_Disc
);
4178 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
4179 if Has_Discriminants
(Parent_Type
) then
4180 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4181 Set_Discriminant_Constraint
(
4182 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
4186 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
4188 Set_Has_Completion
(Derived_Type
);
4189 end Build_Derived_Concurrent_Type
;
4191 ------------------------------------
4192 -- Build_Derived_Enumeration_Type --
4193 ------------------------------------
4195 procedure Build_Derived_Enumeration_Type
4197 Parent_Type
: Entity_Id
;
4198 Derived_Type
: Entity_Id
)
4200 Loc
: constant Source_Ptr
:= Sloc
(N
);
4201 Def
: constant Node_Id
:= Type_Definition
(N
);
4202 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
4203 Implicit_Base
: Entity_Id
;
4204 Literal
: Entity_Id
;
4205 New_Lit
: Entity_Id
;
4206 Literals_List
: List_Id
;
4207 Type_Decl
: Node_Id
;
4209 Rang_Expr
: Node_Id
;
4212 -- Since types Standard.Character and Standard.Wide_Character do
4213 -- not have explicit literals lists we need to process types derived
4214 -- from them specially. This is handled by Derived_Standard_Character.
4215 -- If the parent type is a generic type, there are no literals either,
4216 -- and we construct the same skeletal representation as for the generic
4219 if Root_Type
(Parent_Type
) = Standard_Character
4220 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
4221 or else Root_Type
(Parent_Type
) = Standard_Wide_Wide_Character
4223 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
4225 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
4232 Make_Attribute_Reference
(Loc
,
4233 Attribute_Name
=> Name_First
,
4234 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4235 Set_Etype
(Lo
, Derived_Type
);
4238 Make_Attribute_Reference
(Loc
,
4239 Attribute_Name
=> Name_Last
,
4240 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4241 Set_Etype
(Hi
, Derived_Type
);
4243 Set_Scalar_Range
(Derived_Type
,
4250 -- If a constraint is present, analyze the bounds to catch
4251 -- premature usage of the derived literals.
4253 if Nkind
(Indic
) = N_Subtype_Indication
4254 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
4256 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
4257 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
4260 -- Introduce an implicit base type for the derived type even
4261 -- if there is no constraint attached to it, since this seems
4262 -- closer to the Ada semantics. Build a full type declaration
4263 -- tree for the derived type using the implicit base type as
4264 -- the defining identifier. The build a subtype declaration
4265 -- tree which applies the constraint (if any) have it replace
4266 -- the derived type declaration.
4268 Literal
:= First_Literal
(Parent_Type
);
4269 Literals_List
:= New_List
;
4270 while Present
(Literal
)
4271 and then Ekind
(Literal
) = E_Enumeration_Literal
4273 -- Literals of the derived type have the same representation as
4274 -- those of the parent type, but this representation can be
4275 -- overridden by an explicit representation clause. Indicate
4276 -- that there is no explicit representation given yet. These
4277 -- derived literals are implicit operations of the new type,
4278 -- and can be overridden by explicit ones.
4280 if Nkind
(Literal
) = N_Defining_Character_Literal
then
4282 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
4284 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
4287 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
4288 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
4289 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
4290 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
4291 Set_Alias
(New_Lit
, Literal
);
4292 Set_Is_Known_Valid
(New_Lit
, True);
4294 Append
(New_Lit
, Literals_List
);
4295 Next_Literal
(Literal
);
4299 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4300 New_External_Name
(Chars
(Derived_Type
), 'B'));
4302 -- Indicate the proper nature of the derived type. This must
4303 -- be done before analysis of the literals, to recognize cases
4304 -- when a literal may be hidden by a previous explicit function
4305 -- definition (cf. c83031a).
4307 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
4308 Set_Etype
(Derived_Type
, Implicit_Base
);
4311 Make_Full_Type_Declaration
(Loc
,
4312 Defining_Identifier
=> Implicit_Base
,
4313 Discriminant_Specifications
=> No_List
,
4315 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
4317 Mark_Rewrite_Insertion
(Type_Decl
);
4318 Insert_Before
(N
, Type_Decl
);
4319 Analyze
(Type_Decl
);
4321 -- After the implicit base is analyzed its Etype needs to be changed
4322 -- to reflect the fact that it is derived from the parent type which
4323 -- was ignored during analysis. We also set the size at this point.
4325 Set_Etype
(Implicit_Base
, Parent_Type
);
4327 Set_Size_Info
(Implicit_Base
, Parent_Type
);
4328 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
4329 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
4331 Set_Has_Non_Standard_Rep
4332 (Implicit_Base
, Has_Non_Standard_Rep
4334 Set_Has_Delayed_Freeze
(Implicit_Base
);
4336 -- Process the subtype indication including a validation check
4337 -- on the constraint, if any. If a constraint is given, its bounds
4338 -- must be implicitly converted to the new type.
4340 if Nkind
(Indic
) = N_Subtype_Indication
then
4342 R
: constant Node_Id
:=
4343 Range_Expression
(Constraint
(Indic
));
4346 if Nkind
(R
) = N_Range
then
4347 Hi
:= Build_Scalar_Bound
4348 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
4349 Lo
:= Build_Scalar_Bound
4350 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
4353 -- Constraint is a Range attribute. Replace with the
4354 -- explicit mention of the bounds of the prefix, which must
4357 Analyze
(Prefix
(R
));
4359 Convert_To
(Implicit_Base
,
4360 Make_Attribute_Reference
(Loc
,
4361 Attribute_Name
=> Name_Last
,
4363 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4366 Convert_To
(Implicit_Base
,
4367 Make_Attribute_Reference
(Loc
,
4368 Attribute_Name
=> Name_First
,
4370 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4377 (Type_High_Bound
(Parent_Type
),
4378 Parent_Type
, Implicit_Base
);
4381 (Type_Low_Bound
(Parent_Type
),
4382 Parent_Type
, Implicit_Base
);
4390 -- If we constructed a default range for the case where no range
4391 -- was given, then the expressions in the range must not freeze
4392 -- since they do not correspond to expressions in the source.
4394 if Nkind
(Indic
) /= N_Subtype_Indication
then
4395 Set_Must_Not_Freeze
(Lo
);
4396 Set_Must_Not_Freeze
(Hi
);
4397 Set_Must_Not_Freeze
(Rang_Expr
);
4401 Make_Subtype_Declaration
(Loc
,
4402 Defining_Identifier
=> Derived_Type
,
4403 Subtype_Indication
=>
4404 Make_Subtype_Indication
(Loc
,
4405 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
4407 Make_Range_Constraint
(Loc
,
4408 Range_Expression
=> Rang_Expr
))));
4412 -- If pragma Discard_Names applies on the first subtype of the
4413 -- parent type, then it must be applied on this subtype as well.
4415 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
4416 Set_Discard_Names
(Derived_Type
);
4419 -- Apply a range check. Since this range expression doesn't have an
4420 -- Etype, we have to specifically pass the Source_Typ parameter. Is
4423 if Nkind
(Indic
) = N_Subtype_Indication
then
4424 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
4426 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
4429 end Build_Derived_Enumeration_Type
;
4431 --------------------------------
4432 -- Build_Derived_Numeric_Type --
4433 --------------------------------
4435 procedure Build_Derived_Numeric_Type
4437 Parent_Type
: Entity_Id
;
4438 Derived_Type
: Entity_Id
)
4440 Loc
: constant Source_Ptr
:= Sloc
(N
);
4441 Tdef
: constant Node_Id
:= Type_Definition
(N
);
4442 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
4443 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4444 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
4445 N_Subtype_Indication
;
4446 Implicit_Base
: Entity_Id
;
4452 -- Process the subtype indication including a validation check on
4453 -- the constraint if any.
4455 Discard_Node
(Process_Subtype
(Indic
, N
));
4457 -- Introduce an implicit base type for the derived type even if there
4458 -- is no constraint attached to it, since this seems closer to the Ada
4462 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
4464 Set_Etype
(Implicit_Base
, Parent_Base
);
4465 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
4466 Set_Size_Info
(Implicit_Base
, Parent_Base
);
4467 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4468 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
4469 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
4471 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
4472 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4475 Set_Has_Delayed_Freeze
(Implicit_Base
);
4477 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
4478 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
4480 Set_Scalar_Range
(Implicit_Base
,
4485 if Has_Infinities
(Parent_Base
) then
4486 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
4489 -- The Derived_Type, which is the entity of the declaration, is a
4490 -- subtype of the implicit base. Its Ekind is a subtype, even in the
4491 -- absence of an explicit constraint.
4493 Set_Etype
(Derived_Type
, Implicit_Base
);
4495 -- If we did not have a constraint, then the Ekind is set from the
4496 -- parent type (otherwise Process_Subtype has set the bounds)
4498 if No_Constraint
then
4499 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
4502 -- If we did not have a range constraint, then set the range from the
4503 -- parent type. Otherwise, the call to Process_Subtype has set the
4507 or else not Has_Range_Constraint
(Indic
)
4509 Set_Scalar_Range
(Derived_Type
,
4511 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
4512 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
4513 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4515 if Has_Infinities
(Parent_Type
) then
4516 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
4520 -- Set remaining type-specific fields, depending on numeric type
4522 if Is_Modular_Integer_Type
(Parent_Type
) then
4523 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
4525 Set_Non_Binary_Modulus
4526 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
4528 elsif Is_Floating_Point_Type
(Parent_Type
) then
4530 -- Digits of base type is always copied from the digits value of
4531 -- the parent base type, but the digits of the derived type will
4532 -- already have been set if there was a constraint present.
4534 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4535 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
4537 if No_Constraint
then
4538 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
4541 elsif Is_Fixed_Point_Type
(Parent_Type
) then
4543 -- Small of base type and derived type are always copied from the
4544 -- parent base type, since smalls never change. The delta of the
4545 -- base type is also copied from the parent base type. However the
4546 -- delta of the derived type will have been set already if a
4547 -- constraint was present.
4549 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
4550 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
4551 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
4553 if No_Constraint
then
4554 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
4557 -- The scale and machine radix in the decimal case are always
4558 -- copied from the parent base type.
4560 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
4561 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
4562 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
4564 Set_Machine_Radix_10
4565 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
4566 Set_Machine_Radix_10
4567 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
4569 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4571 if No_Constraint
then
4572 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
4575 -- the analysis of the subtype_indication sets the
4576 -- digits value of the derived type.
4583 -- The type of the bounds is that of the parent type, and they
4584 -- must be converted to the derived type.
4586 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
4588 -- The implicit_base should be frozen when the derived type is frozen,
4589 -- but note that it is used in the conversions of the bounds. For fixed
4590 -- types we delay the determination of the bounds until the proper
4591 -- freezing point. For other numeric types this is rejected by GCC, for
4592 -- reasons that are currently unclear (???), so we choose to freeze the
4593 -- implicit base now. In the case of integers and floating point types
4594 -- this is harmless because subsequent representation clauses cannot
4595 -- affect anything, but it is still baffling that we cannot use the
4596 -- same mechanism for all derived numeric types.
4598 if Is_Fixed_Point_Type
(Parent_Type
) then
4599 Conditional_Delay
(Implicit_Base
, Parent_Type
);
4601 Freeze_Before
(N
, Implicit_Base
);
4603 end Build_Derived_Numeric_Type
;
4605 --------------------------------
4606 -- Build_Derived_Private_Type --
4607 --------------------------------
4609 procedure Build_Derived_Private_Type
4611 Parent_Type
: Entity_Id
;
4612 Derived_Type
: Entity_Id
;
4613 Is_Completion
: Boolean;
4614 Derive_Subps
: Boolean := True)
4616 Der_Base
: Entity_Id
;
4618 Full_Decl
: Node_Id
:= Empty
;
4619 Full_Der
: Entity_Id
;
4621 Last_Discr
: Entity_Id
;
4622 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
4623 Swapped
: Boolean := False;
4625 procedure Copy_And_Build
;
4626 -- Copy derived type declaration, replace parent with its full view,
4627 -- and analyze new declaration.
4629 --------------------
4630 -- Copy_And_Build --
4631 --------------------
4633 procedure Copy_And_Build
is
4637 if Ekind
(Parent_Type
) in Record_Kind
4639 (Ekind
(Parent_Type
) in Enumeration_Kind
4640 and then Root_Type
(Parent_Type
) /= Standard_Character
4641 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
4642 and then Root_Type
(Parent_Type
) /= Standard_Wide_Wide_Character
4643 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
4645 Full_N
:= New_Copy_Tree
(N
);
4646 Insert_After
(N
, Full_N
);
4647 Build_Derived_Type
(
4648 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4651 Build_Derived_Type
(
4652 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4656 -- Start of processing for Build_Derived_Private_Type
4659 if Is_Tagged_Type
(Parent_Type
) then
4660 Build_Derived_Record_Type
4661 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4664 elsif Has_Discriminants
(Parent_Type
) then
4665 if Present
(Full_View
(Parent_Type
)) then
4666 if not Is_Completion
then
4668 -- Copy declaration for subsequent analysis, to provide a
4669 -- completion for what is a private declaration. Indicate that
4670 -- the full type is internally generated.
4672 Full_Decl
:= New_Copy_Tree
(N
);
4673 Full_Der
:= New_Copy
(Derived_Type
);
4674 Set_Comes_From_Source
(Full_Decl
, False);
4675 Set_Comes_From_Source
(Full_Der
, False);
4677 Insert_After
(N
, Full_Decl
);
4680 -- If this is a completion, the full view being built is
4681 -- itself private. We build a subtype of the parent with
4682 -- the same constraints as this full view, to convey to the
4683 -- back end the constrained components and the size of this
4684 -- subtype. If the parent is constrained, its full view can
4685 -- serve as the underlying full view of the derived type.
4687 if No
(Discriminant_Specifications
(N
)) then
4688 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4689 N_Subtype_Indication
4691 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
4693 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
4694 Set_Underlying_Full_View
(Derived_Type
,
4695 Full_View
(Parent_Type
));
4699 -- If there are new discriminants, the parent subtype is
4700 -- constrained by them, but it is not clear how to build
4701 -- the underlying_full_view in this case ???
4708 -- Build partial view of derived type from partial view of parent
4710 Build_Derived_Record_Type
4711 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4713 if Present
(Full_View
(Parent_Type
))
4714 and then not Is_Completion
4716 if not In_Open_Scopes
(Par_Scope
)
4717 or else not In_Same_Source_Unit
(N
, Parent_Type
)
4719 -- Swap partial and full views temporarily
4721 Install_Private_Declarations
(Par_Scope
);
4722 Install_Visible_Declarations
(Par_Scope
);
4726 -- Build full view of derived type from full view of parent which
4727 -- is now installed. Subprograms have been derived on the partial
4728 -- view, the completion does not derive them anew.
4730 if not Is_Tagged_Type
(Parent_Type
) then
4732 -- If the parent is itself derived from another private type,
4733 -- installing the private declarations has not affected its
4734 -- privacy status, so use its own full view explicitly.
4736 if Is_Private_Type
(Parent_Type
) then
4737 Build_Derived_Record_Type
4738 (Full_Decl
, Full_View
(Parent_Type
), Full_Der
, False);
4740 Build_Derived_Record_Type
4741 (Full_Decl
, Parent_Type
, Full_Der
, False);
4745 -- If full view of parent is tagged, the completion
4746 -- inherits the proper primitive operations.
4748 Set_Defining_Identifier
(Full_Decl
, Full_Der
);
4749 Build_Derived_Record_Type
4750 (Full_Decl
, Parent_Type
, Full_Der
, Derive_Subps
);
4751 Set_Analyzed
(Full_Decl
);
4755 Uninstall_Declarations
(Par_Scope
);
4757 if In_Open_Scopes
(Par_Scope
) then
4758 Install_Visible_Declarations
(Par_Scope
);
4762 Der_Base
:= Base_Type
(Derived_Type
);
4763 Set_Full_View
(Derived_Type
, Full_Der
);
4764 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
4766 -- Copy the discriminant list from full view to the partial views
4767 -- (base type and its subtype). Gigi requires that the partial
4768 -- and full views have the same discriminants.
4770 -- Note that since the partial view is pointing to discriminants
4771 -- in the full view, their scope will be that of the full view.
4772 -- This might cause some front end problems and need
4775 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
4776 Set_First_Entity
(Der_Base
, Discr
);
4779 Last_Discr
:= Discr
;
4780 Next_Discriminant
(Discr
);
4781 exit when No
(Discr
);
4784 Set_Last_Entity
(Der_Base
, Last_Discr
);
4786 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
4787 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
4788 Set_Stored_Constraint
(Full_Der
, Stored_Constraint
(Derived_Type
));
4791 -- If this is a completion, the derived type stays private
4792 -- and there is no need to create a further full view, except
4793 -- in the unusual case when the derivation is nested within a
4794 -- child unit, see below.
4799 elsif Present
(Full_View
(Parent_Type
))
4800 and then Has_Discriminants
(Full_View
(Parent_Type
))
4802 if Has_Unknown_Discriminants
(Parent_Type
)
4803 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4804 = N_Subtype_Indication
4807 ("cannot constrain type with unknown discriminants",
4808 Subtype_Indication
(Type_Definition
(N
)));
4812 -- If full view of parent is a record type, Build full view as
4813 -- a derivation from the parent's full view. Partial view remains
4814 -- private. For code generation and linking, the full view must
4815 -- have the same public status as the partial one. This full view
4816 -- is only needed if the parent type is in an enclosing scope, so
4817 -- that the full view may actually become visible, e.g. in a child
4818 -- unit. This is both more efficient, and avoids order of freezing
4819 -- problems with the added entities.
4821 if not Is_Private_Type
(Full_View
(Parent_Type
))
4822 and then (In_Open_Scopes
(Scope
(Parent_Type
)))
4824 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
4825 Chars
(Derived_Type
));
4826 Set_Is_Itype
(Full_Der
);
4827 Set_Has_Private_Declaration
(Full_Der
);
4828 Set_Has_Private_Declaration
(Derived_Type
);
4829 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4830 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4831 Set_Full_View
(Derived_Type
, Full_Der
);
4832 Set_Is_Public
(Full_Der
, Is_Public
(Derived_Type
));
4833 Full_P
:= Full_View
(Parent_Type
);
4834 Exchange_Declarations
(Parent_Type
);
4836 Exchange_Declarations
(Full_P
);
4839 Build_Derived_Record_Type
4840 (N
, Full_View
(Parent_Type
), Derived_Type
,
4841 Derive_Subps
=> False);
4844 -- In any case, the primitive operations are inherited from
4845 -- the parent type, not from the internal full view.
4847 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
4849 if Derive_Subps
then
4850 Derive_Subprograms
(Parent_Type
, Derived_Type
);
4854 -- Untagged type, No discriminants on either view
4856 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4857 N_Subtype_Indication
4860 ("illegal constraint on type without discriminants", N
);
4863 if Present
(Discriminant_Specifications
(N
))
4864 and then Present
(Full_View
(Parent_Type
))
4865 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4868 ("cannot add discriminants to untagged type", N
);
4871 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
4872 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4873 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
4874 Set_Has_Controlled_Component
4875 (Derived_Type
, Has_Controlled_Component
4878 -- Direct controlled types do not inherit Finalize_Storage_Only flag
4880 if not Is_Controlled
(Parent_Type
) then
4881 Set_Finalize_Storage_Only
4882 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
4885 -- Construct the implicit full view by deriving from full view of
4886 -- the parent type. In order to get proper visibility, we install
4887 -- the parent scope and its declarations.
4889 -- ??? if the parent is untagged private and its completion is
4890 -- tagged, this mechanism will not work because we cannot derive
4891 -- from the tagged full view unless we have an extension
4893 if Present
(Full_View
(Parent_Type
))
4894 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4895 and then not Is_Completion
4898 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4899 Chars
=> Chars
(Derived_Type
));
4900 Set_Is_Itype
(Full_Der
);
4901 Set_Has_Private_Declaration
(Full_Der
);
4902 Set_Has_Private_Declaration
(Derived_Type
);
4903 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4904 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4905 Set_Full_View
(Derived_Type
, Full_Der
);
4907 if not In_Open_Scopes
(Par_Scope
) then
4908 Install_Private_Declarations
(Par_Scope
);
4909 Install_Visible_Declarations
(Par_Scope
);
4911 Uninstall_Declarations
(Par_Scope
);
4913 -- If parent scope is open and in another unit, and parent has a
4914 -- completion, then the derivation is taking place in the visible
4915 -- part of a child unit. In that case retrieve the full view of
4916 -- the parent momentarily.
4918 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
4919 Full_P
:= Full_View
(Parent_Type
);
4920 Exchange_Declarations
(Parent_Type
);
4922 Exchange_Declarations
(Full_P
);
4924 -- Otherwise it is a local derivation
4930 Set_Scope
(Full_Der
, Current_Scope
);
4931 Set_Is_First_Subtype
(Full_Der
,
4932 Is_First_Subtype
(Derived_Type
));
4933 Set_Has_Size_Clause
(Full_Der
, False);
4934 Set_Has_Alignment_Clause
(Full_Der
, False);
4935 Set_Next_Entity
(Full_Der
, Empty
);
4936 Set_Has_Delayed_Freeze
(Full_Der
);
4937 Set_Is_Frozen
(Full_Der
, False);
4938 Set_Freeze_Node
(Full_Der
, Empty
);
4939 Set_Depends_On_Private
(Full_Der
,
4940 Has_Private_Component
(Full_Der
));
4941 Set_Public_Status
(Full_Der
);
4945 Set_Has_Unknown_Discriminants
(Derived_Type
,
4946 Has_Unknown_Discriminants
(Parent_Type
));
4948 if Is_Private_Type
(Derived_Type
) then
4949 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
4952 if Is_Private_Type
(Parent_Type
)
4953 and then Base_Type
(Parent_Type
) = Parent_Type
4954 and then In_Open_Scopes
(Scope
(Parent_Type
))
4956 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
4958 if Is_Child_Unit
(Scope
(Current_Scope
))
4959 and then Is_Completion
4960 and then In_Private_Part
(Current_Scope
)
4961 and then Scope
(Parent_Type
) /= Current_Scope
4963 -- This is the unusual case where a type completed by a private
4964 -- derivation occurs within a package nested in a child unit,
4965 -- and the parent is declared in an ancestor. In this case, the
4966 -- full view of the parent type will become visible in the body
4967 -- of the enclosing child, and only then will the current type
4968 -- be possibly non-private. We build a underlying full view that
4969 -- will be installed when the enclosing child body is compiled.
4972 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
4976 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4977 Chars
(Derived_Type
));
4978 Set_Is_Itype
(Full_Der
);
4979 Set_Itype
(IR
, Full_Der
);
4980 Insert_After
(N
, IR
);
4982 -- The full view will be used to swap entities on entry/exit
4983 -- to the body, and must appear in the entity list for the
4986 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
4987 Set_Has_Private_Declaration
(Full_Der
);
4988 Set_Has_Private_Declaration
(Derived_Type
);
4989 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4990 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4991 Full_P
:= Full_View
(Parent_Type
);
4992 Exchange_Declarations
(Parent_Type
);
4994 Exchange_Declarations
(Full_P
);
4995 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
4999 end Build_Derived_Private_Type
;
5001 -------------------------------
5002 -- Build_Derived_Record_Type --
5003 -------------------------------
5007 -- Ideally we would like to use the same model of type derivation for
5008 -- tagged and untagged record types. Unfortunately this is not quite
5009 -- possible because the semantics of representation clauses is different
5010 -- for tagged and untagged records under inheritance. Consider the
5013 -- type R (...) is [tagged] record ... end record;
5014 -- type T (...) is new R (...) [with ...];
5016 -- The representation clauses of T can specify a completely different
5017 -- record layout from R's. Hence the same component can be placed in
5018 -- two very different positions in objects of type T and R. If R and T
5019 -- are tagged types, representation clauses for T can only specify the
5020 -- layout of non inherited components, thus components that are common
5021 -- in R and T have the same position in objects of type R and T.
5023 -- This has two implications. The first is that the entire tree for R's
5024 -- declaration needs to be copied for T in the untagged case, so that T
5025 -- can be viewed as a record type of its own with its own representation
5026 -- clauses. The second implication is the way we handle discriminants.
5027 -- Specifically, in the untagged case we need a way to communicate to Gigi
5028 -- what are the real discriminants in the record, while for the semantics
5029 -- we need to consider those introduced by the user to rename the
5030 -- discriminants in the parent type. This is handled by introducing the
5031 -- notion of stored discriminants. See below for more.
5033 -- Fortunately the way regular components are inherited can be handled in
5034 -- the same way in tagged and untagged types.
5036 -- To complicate things a bit more the private view of a private extension
5037 -- cannot be handled in the same way as the full view (for one thing the
5038 -- semantic rules are somewhat different). We will explain what differs
5041 -- 2. DISCRIMINANTS UNDER INHERITANCE
5043 -- The semantic rules governing the discriminants of derived types are
5046 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
5047 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
5049 -- If parent type has discriminants, then the discriminants that are
5050 -- declared in the derived type are [3.4 (11)]:
5052 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
5055 -- o Otherwise, each discriminant of the parent type (implicitly declared
5056 -- in the same order with the same specifications). In this case, the
5057 -- discriminants are said to be "inherited", or if unknown in the parent
5058 -- are also unknown in the derived type.
5060 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
5062 -- o The parent subtype shall be constrained;
5064 -- o If the parent type is not a tagged type, then each discriminant of
5065 -- the derived type shall be used in the constraint defining a parent
5066 -- subtype [Implementation note: this ensures that the new discriminant
5067 -- can share storage with an existing discriminant.].
5069 -- For the derived type each discriminant of the parent type is either
5070 -- inherited, constrained to equal some new discriminant of the derived
5071 -- type, or constrained to the value of an expression.
5073 -- When inherited or constrained to equal some new discriminant, the
5074 -- parent discriminant and the discriminant of the derived type are said
5077 -- If a discriminant of the parent type is constrained to a specific value
5078 -- in the derived type definition, then the discriminant is said to be
5079 -- "specified" by that derived type definition.
5081 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
5083 -- We have spoken about stored discriminants in point 1 (introduction)
5084 -- above. There are two sort of stored discriminants: implicit and
5085 -- explicit. As long as the derived type inherits the same discriminants as
5086 -- the root record type, stored discriminants are the same as regular
5087 -- discriminants, and are said to be implicit. However, if any discriminant
5088 -- in the root type was renamed in the derived type, then the derived
5089 -- type will contain explicit stored discriminants. Explicit stored
5090 -- discriminants are discriminants in addition to the semantically visible
5091 -- discriminants defined for the derived type. Stored discriminants are
5092 -- used by Gigi to figure out what are the physical discriminants in
5093 -- objects of the derived type (see precise definition in einfo.ads).
5094 -- As an example, consider the following:
5096 -- type R (D1, D2, D3 : Int) is record ... end record;
5097 -- type T1 is new R;
5098 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
5099 -- type T3 is new T2;
5100 -- type T4 (Y : Int) is new T3 (Y, 99);
5102 -- The following table summarizes the discriminants and stored
5103 -- discriminants in R and T1 through T4.
5105 -- Type Discrim Stored Discrim Comment
5106 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
5107 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
5108 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
5109 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
5110 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
5112 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
5113 -- find the corresponding discriminant in the parent type, while
5114 -- Original_Record_Component (abbreviated ORC below), the actual physical
5115 -- component that is renamed. Finally the field Is_Completely_Hidden
5116 -- (abbreviated ICH below) is set for all explicit stored discriminants
5117 -- (see einfo.ads for more info). For the above example this gives:
5119 -- Discrim CD ORC ICH
5120 -- ^^^^^^^ ^^ ^^^ ^^^
5121 -- D1 in R empty itself no
5122 -- D2 in R empty itself no
5123 -- D3 in R empty itself no
5125 -- D1 in T1 D1 in R itself no
5126 -- D2 in T1 D2 in R itself no
5127 -- D3 in T1 D3 in R itself no
5129 -- X1 in T2 D3 in T1 D3 in T2 no
5130 -- X2 in T2 D1 in T1 D1 in T2 no
5131 -- D1 in T2 empty itself yes
5132 -- D2 in T2 empty itself yes
5133 -- D3 in T2 empty itself yes
5135 -- X1 in T3 X1 in T2 D3 in T3 no
5136 -- X2 in T3 X2 in T2 D1 in T3 no
5137 -- D1 in T3 empty itself yes
5138 -- D2 in T3 empty itself yes
5139 -- D3 in T3 empty itself yes
5141 -- Y in T4 X1 in T3 D3 in T3 no
5142 -- D1 in T3 empty itself yes
5143 -- D2 in T3 empty itself yes
5144 -- D3 in T3 empty itself yes
5146 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
5148 -- Type derivation for tagged types is fairly straightforward. if no
5149 -- discriminants are specified by the derived type, these are inherited
5150 -- from the parent. No explicit stored discriminants are ever necessary.
5151 -- The only manipulation that is done to the tree is that of adding a
5152 -- _parent field with parent type and constrained to the same constraint
5153 -- specified for the parent in the derived type definition. For instance:
5155 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
5156 -- type T1 is new R with null record;
5157 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
5159 -- are changed into:
5161 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
5162 -- _parent : R (D1, D2, D3);
5165 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
5166 -- _parent : T1 (X2, 88, X1);
5169 -- The discriminants actually present in R, T1 and T2 as well as their CD,
5170 -- ORC and ICH fields are:
5172 -- Discrim CD ORC ICH
5173 -- ^^^^^^^ ^^ ^^^ ^^^
5174 -- D1 in R empty itself no
5175 -- D2 in R empty itself no
5176 -- D3 in R empty itself no
5178 -- D1 in T1 D1 in R D1 in R no
5179 -- D2 in T1 D2 in R D2 in R no
5180 -- D3 in T1 D3 in R D3 in R no
5182 -- X1 in T2 D3 in T1 D3 in R no
5183 -- X2 in T2 D1 in T1 D1 in R no
5185 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
5187 -- Regardless of whether we dealing with a tagged or untagged type
5188 -- we will transform all derived type declarations of the form
5190 -- type T is new R (...) [with ...];
5192 -- subtype S is R (...);
5193 -- type T is new S [with ...];
5195 -- type BT is new R [with ...];
5196 -- subtype T is BT (...);
5198 -- That is, the base derived type is constrained only if it has no
5199 -- discriminants. The reason for doing this is that GNAT's semantic model
5200 -- assumes that a base type with discriminants is unconstrained.
5202 -- Note that, strictly speaking, the above transformation is not always
5203 -- correct. Consider for instance the following excerpt from ACVC b34011a:
5205 -- procedure B34011A is
5206 -- type REC (D : integer := 0) is record
5211 -- type T6 is new Rec;
5212 -- function F return T6;
5217 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
5220 -- The definition of Q6.U is illegal. However transforming Q6.U into
5222 -- type BaseU is new T6;
5223 -- subtype U is BaseU (Q6.F.I)
5225 -- turns U into a legal subtype, which is incorrect. To avoid this problem
5226 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
5227 -- the transformation described above.
5229 -- There is another instance where the above transformation is incorrect.
5233 -- type Base (D : Integer) is tagged null record;
5234 -- procedure P (X : Base);
5236 -- type Der is new Base (2) with null record;
5237 -- procedure P (X : Der);
5240 -- Then the above transformation turns this into
5242 -- type Der_Base is new Base with null record;
5243 -- -- procedure P (X : Base) is implicitly inherited here
5244 -- -- as procedure P (X : Der_Base).
5246 -- subtype Der is Der_Base (2);
5247 -- procedure P (X : Der);
5248 -- -- The overriding of P (X : Der_Base) is illegal since we
5249 -- -- have a parameter conformance problem.
5251 -- To get around this problem, after having semantically processed Der_Base
5252 -- and the rewritten subtype declaration for Der, we copy Der_Base field
5253 -- Discriminant_Constraint from Der so that when parameter conformance is
5254 -- checked when P is overridden, no semantic errors are flagged.
5256 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
5258 -- Regardless of whether we are dealing with a tagged or untagged type
5259 -- we will transform all derived type declarations of the form
5261 -- type R (D1, .., Dn : ...) is [tagged] record ...;
5262 -- type T is new R [with ...];
5264 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
5266 -- The reason for such transformation is that it allows us to implement a
5267 -- very clean form of component inheritance as explained below.
5269 -- Note that this transformation is not achieved by direct tree rewriting
5270 -- and manipulation, but rather by redoing the semantic actions that the
5271 -- above transformation will entail. This is done directly in routine
5272 -- Inherit_Components.
5274 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
5276 -- In both tagged and untagged derived types, regular non discriminant
5277 -- components are inherited in the derived type from the parent type. In
5278 -- the absence of discriminants component, inheritance is straightforward
5279 -- as components can simply be copied from the parent.
5281 -- If the parent has discriminants, inheriting components constrained with
5282 -- these discriminants requires caution. Consider the following example:
5284 -- type R (D1, D2 : Positive) is [tagged] record
5285 -- S : String (D1 .. D2);
5288 -- type T1 is new R [with null record];
5289 -- type T2 (X : positive) is new R (1, X) [with null record];
5291 -- As explained in 6. above, T1 is rewritten as
5292 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
5293 -- which makes the treatment for T1 and T2 identical.
5295 -- What we want when inheriting S, is that references to D1 and D2 in R are
5296 -- replaced with references to their correct constraints, ie D1 and D2 in
5297 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
5298 -- with either discriminant references in the derived type or expressions.
5299 -- This replacement is achieved as follows: before inheriting R's
5300 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
5301 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
5302 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
5303 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
5304 -- by String (1 .. X).
5306 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
5308 -- We explain here the rules governing private type extensions relevant to
5309 -- type derivation. These rules are explained on the following example:
5311 -- type D [(...)] is new A [(...)] with private; <-- partial view
5312 -- type D [(...)] is new P [(...)] with null record; <-- full view
5314 -- Type A is called the ancestor subtype of the private extension.
5315 -- Type P is the parent type of the full view of the private extension. It
5316 -- must be A or a type derived from A.
5318 -- The rules concerning the discriminants of private type extensions are
5321 -- o If a private extension inherits known discriminants from the ancestor
5322 -- subtype, then the full view shall also inherit its discriminants from
5323 -- the ancestor subtype and the parent subtype of the full view shall be
5324 -- constrained if and only if the ancestor subtype is constrained.
5326 -- o If a partial view has unknown discriminants, then the full view may
5327 -- define a definite or an indefinite subtype, with or without
5330 -- o If a partial view has neither known nor unknown discriminants, then
5331 -- the full view shall define a definite subtype.
5333 -- o If the ancestor subtype of a private extension has constrained
5334 -- discriminants, then the parent subtype of the full view shall impose a
5335 -- statically matching constraint on those discriminants.
5337 -- This means that only the following forms of private extensions are
5340 -- type D is new A with private; <-- partial view
5341 -- type D is new P with null record; <-- full view
5343 -- If A has no discriminants than P has no discriminants, otherwise P must
5344 -- inherit A's discriminants.
5346 -- type D is new A (...) with private; <-- partial view
5347 -- type D is new P (:::) with null record; <-- full view
5349 -- P must inherit A's discriminants and (...) and (:::) must statically
5352 -- subtype A is R (...);
5353 -- type D is new A with private; <-- partial view
5354 -- type D is new P with null record; <-- full view
5356 -- P must have inherited R's discriminants and must be derived from A or
5357 -- any of its subtypes.
5359 -- type D (..) is new A with private; <-- partial view
5360 -- type D (..) is new P [(:::)] with null record; <-- full view
5362 -- No specific constraints on P's discriminants or constraint (:::).
5363 -- Note that A can be unconstrained, but the parent subtype P must either
5364 -- be constrained or (:::) must be present.
5366 -- type D (..) is new A [(...)] with private; <-- partial view
5367 -- type D (..) is new P [(:::)] with null record; <-- full view
5369 -- P's constraints on A's discriminants must statically match those
5370 -- imposed by (...).
5372 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
5374 -- The full view of a private extension is handled exactly as described
5375 -- above. The model chose for the private view of a private extension is
5376 -- the same for what concerns discriminants (ie they receive the same
5377 -- treatment as in the tagged case). However, the private view of the
5378 -- private extension always inherits the components of the parent base,
5379 -- without replacing any discriminant reference. Strictly speaking this is
5380 -- incorrect. However, Gigi never uses this view to generate code so this
5381 -- is a purely semantic issue. In theory, a set of transformations similar
5382 -- to those given in 5. and 6. above could be applied to private views of
5383 -- private extensions to have the same model of component inheritance as
5384 -- for non private extensions. However, this is not done because it would
5385 -- further complicate private type processing. Semantically speaking, this
5386 -- leaves us in an uncomfortable situation. As an example consider:
5389 -- type R (D : integer) is tagged record
5390 -- S : String (1 .. D);
5392 -- procedure P (X : R);
5393 -- type T is new R (1) with private;
5395 -- type T is new R (1) with null record;
5398 -- This is transformed into:
5401 -- type R (D : integer) is tagged record
5402 -- S : String (1 .. D);
5404 -- procedure P (X : R);
5405 -- type T is new R (1) with private;
5407 -- type BaseT is new R with null record;
5408 -- subtype T is BaseT (1);
5411 -- (strictly speaking the above is incorrect Ada)
5413 -- From the semantic standpoint the private view of private extension T
5414 -- should be flagged as constrained since one can clearly have
5418 -- in a unit withing Pack. However, when deriving subprograms for the
5419 -- private view of private extension T, T must be seen as unconstrained
5420 -- since T has discriminants (this is a constraint of the current
5421 -- subprogram derivation model). Thus, when processing the private view of
5422 -- a private extension such as T, we first mark T as unconstrained, we
5423 -- process it, we perform program derivation and just before returning from
5424 -- Build_Derived_Record_Type we mark T as constrained.
5426 -- ??? Are there are other uncomfortable cases that we will have to
5429 -- 10. RECORD_TYPE_WITH_PRIVATE complications
5431 -- Types that are derived from a visible record type and have a private
5432 -- extension present other peculiarities. They behave mostly like private
5433 -- types, but if they have primitive operations defined, these will not
5434 -- have the proper signatures for further inheritance, because other
5435 -- primitive operations will use the implicit base that we define for
5436 -- private derivations below. This affect subprogram inheritance (see
5437 -- Derive_Subprograms for details). We also derive the implicit base from
5438 -- the base type of the full view, so that the implicit base is a record
5439 -- type and not another private type, This avoids infinite loops.
5441 procedure Build_Derived_Record_Type
5443 Parent_Type
: Entity_Id
;
5444 Derived_Type
: Entity_Id
;
5445 Derive_Subps
: Boolean := True)
5447 Loc
: constant Source_Ptr
:= Sloc
(N
);
5448 Parent_Base
: Entity_Id
;
5451 Discrim
: Entity_Id
;
5452 Last_Discrim
: Entity_Id
;
5455 Discs
: Elist_Id
:= New_Elmt_List
;
5456 -- An empty Discs list means that there were no constraints in the
5457 -- subtype indication or that there was an error processing it.
5459 Assoc_List
: Elist_Id
;
5460 New_Discrs
: Elist_Id
;
5461 New_Base
: Entity_Id
;
5463 New_Indic
: Node_Id
;
5465 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
5466 Discriminant_Specs
: constant Boolean :=
5467 Present
(Discriminant_Specifications
(N
));
5468 Private_Extension
: constant Boolean :=
5469 (Nkind
(N
) = N_Private_Extension_Declaration
);
5471 Constraint_Present
: Boolean;
5472 Has_Interfaces
: Boolean := False;
5473 Inherit_Discrims
: Boolean := False;
5474 Tagged_Partial_View
: Entity_Id
;
5475 Save_Etype
: Entity_Id
;
5476 Save_Discr_Constr
: Elist_Id
;
5477 Save_Next_Entity
: Entity_Id
;
5480 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
5481 and then Present
(Full_View
(Parent_Type
))
5482 and then Has_Discriminants
(Parent_Type
)
5484 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
5486 Parent_Base
:= Base_Type
(Parent_Type
);
5489 -- Before we start the previously documented transformations, here is
5490 -- a little fix for size and alignment of tagged types. Normally when
5491 -- we derive type D from type P, we copy the size and alignment of P
5492 -- as the default for D, and in the absence of explicit representation
5493 -- clauses for D, the size and alignment are indeed the same as the
5496 -- But this is wrong for tagged types, since fields may be added,
5497 -- and the default size may need to be larger, and the default
5498 -- alignment may need to be larger.
5500 -- We therefore reset the size and alignment fields in the tagged
5501 -- case. Note that the size and alignment will in any case be at
5502 -- least as large as the parent type (since the derived type has
5503 -- a copy of the parent type in the _parent field)
5506 Init_Size_Align
(Derived_Type
);
5509 -- STEP 0a: figure out what kind of derived type declaration we have
5511 if Private_Extension
then
5513 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
5516 Type_Def
:= Type_Definition
(N
);
5518 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
5519 -- Parent_Base can be a private type or private extension. However,
5520 -- for tagged types with an extension the newly added fields are
5521 -- visible and hence the Derived_Type is always an E_Record_Type.
5522 -- (except that the parent may have its own private fields).
5523 -- For untagged types we preserve the Ekind of the Parent_Base.
5525 if Present
(Record_Extension_Part
(Type_Def
)) then
5526 Set_Ekind
(Derived_Type
, E_Record_Type
);
5528 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5532 -- Indic can either be an N_Identifier if the subtype indication
5533 -- contains no constraint or an N_Subtype_Indication if the subtype
5534 -- indication has a constraint.
5536 Indic
:= Subtype_Indication
(Type_Def
);
5537 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
5539 -- Check that the type has visible discriminants. The type may be
5540 -- a private type with unknown discriminants whose full view has
5541 -- discriminants which are invisible.
5543 if Constraint_Present
then
5544 if not Has_Discriminants
(Parent_Base
)
5546 (Has_Unknown_Discriminants
(Parent_Base
)
5547 and then Is_Private_Type
(Parent_Base
))
5550 ("invalid constraint: type has no discriminant",
5551 Constraint
(Indic
));
5553 Constraint_Present
:= False;
5554 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5556 elsif Is_Constrained
(Parent_Type
) then
5558 ("invalid constraint: parent type is already constrained",
5559 Constraint
(Indic
));
5561 Constraint_Present
:= False;
5562 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5566 -- STEP 0b: If needed, apply transformation given in point 5. above
5568 if not Private_Extension
5569 and then Has_Discriminants
(Parent_Type
)
5570 and then not Discriminant_Specs
5571 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
5573 -- First, we must analyze the constraint (see comment in point 5.)
5575 if Constraint_Present
then
5576 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5578 if Has_Discriminants
(Derived_Type
)
5579 and then Has_Private_Declaration
(Derived_Type
)
5580 and then Present
(Discriminant_Constraint
(Derived_Type
))
5582 -- Verify that constraints of the full view conform to those
5583 -- given in partial view.
5589 C1
:= First_Elmt
(New_Discrs
);
5590 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
5591 while Present
(C1
) and then Present
(C2
) loop
5593 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5596 "constraint not conformant to previous declaration",
5607 -- Insert and analyze the declaration for the unconstrained base type
5609 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
5612 Make_Full_Type_Declaration
(Loc
,
5613 Defining_Identifier
=> New_Base
,
5615 Make_Derived_Type_Definition
(Loc
,
5616 Abstract_Present
=> Abstract_Present
(Type_Def
),
5617 Subtype_Indication
=>
5618 New_Occurrence_Of
(Parent_Base
, Loc
),
5619 Record_Extension_Part
=>
5620 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
5622 Set_Parent
(New_Decl
, Parent
(N
));
5623 Mark_Rewrite_Insertion
(New_Decl
);
5624 Insert_Before
(N
, New_Decl
);
5626 -- Note that this call passes False for the Derive_Subps parameter
5627 -- because subprogram derivation is deferred until after creating
5628 -- the subtype (see below).
5631 (New_Decl
, Parent_Base
, New_Base
,
5632 Is_Completion
=> True, Derive_Subps
=> False);
5634 -- ??? This needs re-examination to determine whether the
5635 -- above call can simply be replaced by a call to Analyze.
5637 Set_Analyzed
(New_Decl
);
5639 -- Insert and analyze the declaration for the constrained subtype
5641 if Constraint_Present
then
5643 Make_Subtype_Indication
(Loc
,
5644 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5645 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
5649 Constr_List
: constant List_Id
:= New_List
;
5654 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
5655 while Present
(C
) loop
5658 -- It is safe here to call New_Copy_Tree since
5659 -- Force_Evaluation was called on each constraint in
5660 -- Build_Discriminant_Constraints.
5662 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
5668 Make_Subtype_Indication
(Loc
,
5669 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5671 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
5676 Make_Subtype_Declaration
(Loc
,
5677 Defining_Identifier
=> Derived_Type
,
5678 Subtype_Indication
=> New_Indic
));
5682 -- Derivation of subprograms must be delayed until the full subtype
5683 -- has been established to ensure proper overriding of subprograms
5684 -- inherited by full types. If the derivations occurred as part of
5685 -- the call to Build_Derived_Type above, then the check for type
5686 -- conformance would fail because earlier primitive subprograms
5687 -- could still refer to the full type prior the change to the new
5688 -- subtype and hence would not match the new base type created here.
5690 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5692 -- For tagged types the Discriminant_Constraint of the new base itype
5693 -- is inherited from the first subtype so that no subtype conformance
5694 -- problem arise when the first subtype overrides primitive
5695 -- operations inherited by the implicit base type.
5698 Set_Discriminant_Constraint
5699 (New_Base
, Discriminant_Constraint
(Derived_Type
));
5705 -- If we get here Derived_Type will have no discriminants or it will be
5706 -- a discriminated unconstrained base type.
5708 -- STEP 1a: perform preliminary actions/checks for derived tagged types
5712 -- The parent type is frozen for non-private extensions (RM 13.14(7))
5714 if not Private_Extension
then
5715 Freeze_Before
(N
, Parent_Type
);
5718 -- In Ada 2005 (AI-344), the restriction that a derived tagged type
5719 -- cannot be declared at a deeper level than its parent type is
5720 -- removed. The check on derivation within a generic body is also
5721 -- relaxed, but there's a restriction that a derived tagged type
5722 -- cannot be declared in a generic body if it's derived directly
5723 -- or indirectly from a formal type of that generic.
5725 if Ada_Version
>= Ada_05
then
5726 if Present
(Enclosing_Generic_Body
(Derived_Type
)) then
5728 Ancestor_Type
: Entity_Id
;
5731 -- Check to see if any ancestor of the derived type is a
5734 Ancestor_Type
:= Parent_Type
;
5735 while not Is_Generic_Type
(Ancestor_Type
)
5736 and then Etype
(Ancestor_Type
) /= Ancestor_Type
5738 Ancestor_Type
:= Etype
(Ancestor_Type
);
5741 -- If the derived type does have a formal type as an
5742 -- ancestor, then it's an error if the derived type is
5743 -- declared within the body of the generic unit that
5744 -- declares the formal type in its generic formal part. It's
5745 -- sufficient to check whether the ancestor type is declared
5746 -- inside the same generic body as the derived type (such as
5747 -- within a nested generic spec), in which case the
5748 -- derivation is legal. If the formal type is declared
5749 -- outside of that generic body, then it's guaranteed that
5750 -- the derived type is declared within the generic body of
5751 -- the generic unit declaring the formal type.
5753 if Is_Generic_Type
(Ancestor_Type
)
5754 and then Enclosing_Generic_Body
(Ancestor_Type
) /=
5755 Enclosing_Generic_Body
(Derived_Type
)
5758 ("parent type of& must not be descendant of formal type"
5759 & " of an enclosing generic body",
5760 Indic
, Derived_Type
);
5765 elsif Type_Access_Level
(Derived_Type
) /=
5766 Type_Access_Level
(Parent_Type
)
5767 and then not Is_Generic_Type
(Derived_Type
)
5769 if Is_Controlled
(Parent_Type
) then
5771 ("controlled type must be declared at the library level",
5775 ("type extension at deeper accessibility level than parent",
5781 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
5785 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
5788 ("parent type of& must not be outside generic body"
5789 & " ('R'M 3.9.1(4))",
5790 Indic
, Derived_Type
);
5796 -- Ada 2005 (AI-251)
5798 if Ada_Version
= Ada_05
5802 -- "The declaration of a specific descendant of an interface type
5803 -- freezes the interface type" (RM 13.14).
5808 if Is_Non_Empty_List
(Interface_List
(Type_Def
)) then
5809 Iface
:= First
(Interface_List
(Type_Def
));
5810 while Present
(Iface
) loop
5811 Freeze_Before
(N
, Etype
(Iface
));
5818 -- STEP 1b : preliminary cleanup of the full view of private types
5820 -- If the type is already marked as having discriminants, then it's the
5821 -- completion of a private type or private extension and we need to
5822 -- retain the discriminants from the partial view if the current
5823 -- declaration has Discriminant_Specifications so that we can verify
5824 -- conformance. However, we must remove any existing components that
5825 -- were inherited from the parent (and attached in Copy_And_Swap)
5826 -- because the full type inherits all appropriate components anyway, and
5827 -- we do not want the partial view's components interfering.
5829 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
5830 Discrim
:= First_Discriminant
(Derived_Type
);
5832 Last_Discrim
:= Discrim
;
5833 Next_Discriminant
(Discrim
);
5834 exit when No
(Discrim
);
5837 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
5839 -- In all other cases wipe out the list of inherited components (even
5840 -- inherited discriminants), it will be properly rebuilt here.
5843 Set_First_Entity
(Derived_Type
, Empty
);
5844 Set_Last_Entity
(Derived_Type
, Empty
);
5847 -- STEP 1c: Initialize some flags for the Derived_Type
5849 -- The following flags must be initialized here so that
5850 -- Process_Discriminants can check that discriminants of tagged types
5851 -- do not have a default initial value and that access discriminants
5852 -- are only specified for limited records. For completeness, these
5853 -- flags are also initialized along with all the other flags below.
5855 -- AI-419: limitedness is not inherited from an interface parent
5857 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
5858 Set_Is_Limited_Record
(Derived_Type
,
5859 Is_Limited_Record
(Parent_Type
)
5860 and then not Is_Interface
(Parent_Type
));
5862 -- STEP 2a: process discriminants of derived type if any
5864 New_Scope
(Derived_Type
);
5866 if Discriminant_Specs
then
5867 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
5869 -- The following call initializes fields Has_Discriminants and
5870 -- Discriminant_Constraint, unless we are processing the completion
5871 -- of a private type declaration.
5873 Check_Or_Process_Discriminants
(N
, Derived_Type
);
5875 -- For non-tagged types the constraint on the Parent_Type must be
5876 -- present and is used to rename the discriminants.
5878 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
5879 Error_Msg_N
("untagged parent must have discriminants", Indic
);
5881 elsif not Is_Tagged
and then not Constraint_Present
then
5883 ("discriminant constraint needed for derived untagged records",
5886 -- Otherwise the parent subtype must be constrained unless we have a
5887 -- private extension.
5889 elsif not Constraint_Present
5890 and then not Private_Extension
5891 and then not Is_Constrained
(Parent_Type
)
5894 ("unconstrained type not allowed in this context", Indic
);
5896 elsif Constraint_Present
then
5897 -- The following call sets the field Corresponding_Discriminant
5898 -- for the discriminants in the Derived_Type.
5900 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
5902 -- For untagged types all new discriminants must rename
5903 -- discriminants in the parent. For private extensions new
5904 -- discriminants cannot rename old ones (implied by [7.3(13)]).
5906 Discrim
:= First_Discriminant
(Derived_Type
);
5907 while Present
(Discrim
) loop
5909 and then No
(Corresponding_Discriminant
(Discrim
))
5912 ("new discriminants must constrain old ones", Discrim
);
5914 elsif Private_Extension
5915 and then Present
(Corresponding_Discriminant
(Discrim
))
5918 ("only static constraints allowed for parent"
5919 & " discriminants in the partial view", Indic
);
5923 -- If a new discriminant is used in the constraint, then its
5924 -- subtype must be statically compatible with the parent
5925 -- discriminant's subtype (3.7(15)).
5927 if Present
(Corresponding_Discriminant
(Discrim
))
5929 not Subtypes_Statically_Compatible
5931 Etype
(Corresponding_Discriminant
(Discrim
)))
5934 ("subtype must be compatible with parent discriminant",
5938 Next_Discriminant
(Discrim
);
5941 -- Check whether the constraints of the full view statically
5942 -- match those imposed by the parent subtype [7.3(13)].
5944 if Present
(Stored_Constraint
(Derived_Type
)) then
5949 C1
:= First_Elmt
(Discs
);
5950 C2
:= First_Elmt
(Stored_Constraint
(Derived_Type
));
5951 while Present
(C1
) and then Present
(C2
) loop
5953 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5956 "not conformant with previous declaration",
5967 -- STEP 2b: No new discriminants, inherit discriminants if any
5970 if Private_Extension
then
5971 Set_Has_Unknown_Discriminants
5973 Has_Unknown_Discriminants
(Parent_Type
)
5974 or else Unknown_Discriminants_Present
(N
));
5976 -- The partial view of the parent may have unknown discriminants,
5977 -- but if the full view has discriminants and the parent type is
5978 -- in scope they must be inherited.
5980 elsif Has_Unknown_Discriminants
(Parent_Type
)
5982 (not Has_Discriminants
(Parent_Type
)
5983 or else not In_Open_Scopes
(Scope
(Parent_Type
)))
5985 Set_Has_Unknown_Discriminants
(Derived_Type
);
5988 if not Has_Unknown_Discriminants
(Derived_Type
)
5989 and then not Has_Unknown_Discriminants
(Parent_Base
)
5990 and then Has_Discriminants
(Parent_Type
)
5992 Inherit_Discrims
:= True;
5993 Set_Has_Discriminants
5994 (Derived_Type
, True);
5995 Set_Discriminant_Constraint
5996 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
5999 -- The following test is true for private types (remember
6000 -- transformation 5. is not applied to those) and in an error
6003 if Constraint_Present
then
6004 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
6007 -- For now mark a new derived type as constrained only if it has no
6008 -- discriminants. At the end of Build_Derived_Record_Type we properly
6009 -- set this flag in the case of private extensions. See comments in
6010 -- point 9. just before body of Build_Derived_Record_Type.
6014 not (Inherit_Discrims
6015 or else Has_Unknown_Discriminants
(Derived_Type
)));
6018 -- STEP 3: initialize fields of derived type
6020 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
6021 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
6023 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
6024 -- but cannot be interfaces
6026 if not Private_Extension
6027 and then Ekind
(Derived_Type
) /= E_Private_Type
6028 and then Ekind
(Derived_Type
) /= E_Limited_Private_Type
6030 Set_Is_Interface
(Derived_Type
, Interface_Present
(Type_Def
));
6031 Set_Abstract_Interfaces
(Derived_Type
, No_Elist
);
6034 -- Fields inherited from the Parent_Type
6037 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
6038 Set_Has_Specified_Layout
6039 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
6040 Set_Is_Limited_Composite
6041 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
6042 Set_Is_Limited_Record
6044 Is_Limited_Record
(Parent_Type
)
6045 and then not Is_Interface
(Parent_Type
));
6046 Set_Is_Private_Composite
6047 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
6049 -- Fields inherited from the Parent_Base
6051 Set_Has_Controlled_Component
6052 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
6053 Set_Has_Non_Standard_Rep
6054 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6055 Set_Has_Primitive_Operations
6056 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
6058 -- Direct controlled types do not inherit Finalize_Storage_Only flag
6060 if not Is_Controlled
(Parent_Type
) then
6061 Set_Finalize_Storage_Only
6062 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
6065 -- Set fields for private derived types
6067 if Is_Private_Type
(Derived_Type
) then
6068 Set_Depends_On_Private
(Derived_Type
, True);
6069 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
6071 -- Inherit fields from non private record types. If this is the
6072 -- completion of a derivation from a private type, the parent itself
6073 -- is private, and the attributes come from its full view, which must
6077 if Is_Private_Type
(Parent_Base
)
6078 and then not Is_Record_Type
(Parent_Base
)
6080 Set_Component_Alignment
6081 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
6083 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
6085 Set_Component_Alignment
6086 (Derived_Type
, Component_Alignment
(Parent_Base
));
6089 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
6093 -- Set fields for tagged types
6096 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
6098 -- All tagged types defined in Ada.Finalization are controlled
6100 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
6101 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
6102 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
6104 Set_Is_Controlled
(Derived_Type
);
6106 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
6109 Make_Class_Wide_Type
(Derived_Type
);
6110 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
6112 if Has_Discriminants
(Derived_Type
)
6113 and then Constraint_Present
6115 Set_Stored_Constraint
6116 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Base
, Discs
));
6119 -- Ada 2005 (AI-251): Look for the partial view of tagged types
6120 -- declared in the private part. This will be used 1) to check that
6121 -- the set of interfaces in both views is equal, and 2) to complete
6122 -- the derivation of subprograms covering interfaces.
6124 Tagged_Partial_View
:= Empty
;
6126 if Has_Private_Declaration
(Derived_Type
) then
6127 Tagged_Partial_View
:= Next_Entity
(Derived_Type
);
6129 exit when Has_Private_Declaration
(Tagged_Partial_View
)
6130 and then Full_View
(Tagged_Partial_View
) = Derived_Type
;
6132 Next_Entity
(Tagged_Partial_View
);
6136 -- Ada 2005 (AI-251): Collect the whole list of implemented
6139 if Ada_Version
>= Ada_05
then
6140 Set_Abstract_Interfaces
(Derived_Type
, New_Elmt_List
);
6142 if Nkind
(N
) = N_Private_Extension_Declaration
then
6143 Collect_Interfaces
(N
, Derived_Type
);
6145 Collect_Interfaces
(Type_Definition
(N
), Derived_Type
);
6150 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
6151 Set_Has_Non_Standard_Rep
6152 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6155 -- STEP 4: Inherit components from the parent base and constrain them.
6156 -- Apply the second transformation described in point 6. above.
6158 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
6159 or else not Has_Discriminants
(Parent_Type
)
6160 or else not Is_Constrained
(Parent_Type
)
6164 Constrs
:= Discriminant_Constraint
(Parent_Type
);
6169 (N
, Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
6171 -- STEP 5a: Copy the parent record declaration for untagged types
6173 if not Is_Tagged
then
6175 -- Discriminant_Constraint (Derived_Type) has been properly
6176 -- constructed. Save it and temporarily set it to Empty because we
6177 -- do not want the call to New_Copy_Tree below to mess this list.
6179 if Has_Discriminants
(Derived_Type
) then
6180 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
6181 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
6183 Save_Discr_Constr
:= No_Elist
;
6186 -- Save the Etype field of Derived_Type. It is correctly set now,
6187 -- but the call to New_Copy tree may remap it to point to itself,
6188 -- which is not what we want. Ditto for the Next_Entity field.
6190 Save_Etype
:= Etype
(Derived_Type
);
6191 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
6193 -- Assoc_List maps all stored discriminants in the Parent_Base to
6194 -- stored discriminants in the Derived_Type. It is fundamental that
6195 -- no types or itypes with discriminants other than the stored
6196 -- discriminants appear in the entities declared inside
6197 -- Derived_Type, since the back end cannot deal with it.
6201 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
6203 -- Restore the fields saved prior to the New_Copy_Tree call
6204 -- and compute the stored constraint.
6206 Set_Etype
(Derived_Type
, Save_Etype
);
6207 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
6209 if Has_Discriminants
(Derived_Type
) then
6210 Set_Discriminant_Constraint
6211 (Derived_Type
, Save_Discr_Constr
);
6212 Set_Stored_Constraint
6213 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Type
, Discs
));
6214 Replace_Components
(Derived_Type
, New_Decl
);
6217 -- Insert the new derived type declaration
6219 Rewrite
(N
, New_Decl
);
6221 -- STEP 5b: Complete the processing for record extensions in generics
6223 -- There is no completion for record extensions declared in the
6224 -- parameter part of a generic, so we need to complete processing for
6225 -- these generic record extensions here. The Record_Type_Definition call
6226 -- will change the Ekind of the components from E_Void to E_Component.
6228 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
6229 Record_Type_Definition
(Empty
, Derived_Type
);
6231 -- STEP 5c: Process the record extension for non private tagged types
6233 elsif not Private_Extension
then
6235 -- Add the _parent field in the derived type
6237 Expand_Record_Extension
(Derived_Type
, Type_Def
);
6239 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
6240 -- implemented interfaces if we are in expansion mode
6242 if Expander_Active
then
6243 Add_Interface_Tag_Components
(N
, Derived_Type
);
6246 -- Analyze the record extension
6248 Record_Type_Definition
6249 (Record_Extension_Part
(Type_Def
), Derived_Type
);
6254 if Etype
(Derived_Type
) = Any_Type
then
6258 -- Set delayed freeze and then derive subprograms, we need to do
6259 -- this in this order so that derived subprograms inherit the
6260 -- derived freeze if necessary.
6262 Set_Has_Delayed_Freeze
(Derived_Type
);
6264 if Derive_Subps
then
6266 -- Ada 2005 (AI-251): Check if this tagged type implements abstract
6269 Has_Interfaces
:= False;
6271 if Is_Tagged_Type
(Derived_Type
) then
6276 -- Handle private types
6278 if Present
(Full_View
(Derived_Type
)) then
6279 E
:= Full_View
(Derived_Type
);
6286 or else (Present
(Abstract_Interfaces
(E
))
6288 not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
)))
6290 Has_Interfaces
:= True;
6294 exit when Etype
(E
) = E
6296 -- Handle private types
6298 or else (Present
(Full_View
(Etype
(E
)))
6299 and then Full_View
(Etype
(E
)) = E
)
6301 -- Protect the frontend against wrong source
6303 or else Etype
(E
) = Derived_Type
;
6305 -- Climb to the ancestor type handling private types
6307 if Present
(Full_View
(Etype
(E
))) then
6308 E
:= Full_View
(Etype
(E
));
6316 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6318 -- Ada 2005 (AI-251): Handle tagged types implementing interfaces
6320 if Is_Tagged_Type
(Derived_Type
)
6321 and then Has_Interfaces
6323 -- Ada 2005 (AI-251): If we are analyzing a full view that has
6324 -- no partial view we derive the abstract interface Subprograms
6326 if No
(Tagged_Partial_View
) then
6327 Derive_Interface_Subprograms
(Derived_Type
);
6329 -- Ada 2005 (AI-251): if we are analyzing a full view that has
6330 -- a partial view we complete the derivation of the subprograms
6333 Complete_Subprograms_Derivation
6334 (Partial_View
=> Tagged_Partial_View
,
6335 Derived_Type
=> Derived_Type
);
6338 -- Ada 2005 (AI-251): In both cases we check if some of the
6339 -- inherited subprograms cover interface primitives.
6342 Iface_Subp
: Entity_Id
;
6343 Iface_Subp_Elmt
: Elmt_Id
;
6344 Prev_Alias
: Entity_Id
;
6346 Subp_Elmt
: Elmt_Id
;
6350 First_Elmt
(Primitive_Operations
(Derived_Type
));
6351 while Present
(Iface_Subp_Elmt
) loop
6352 Iface_Subp
:= Node
(Iface_Subp_Elmt
);
6354 -- Look for an abstract interface subprogram
6356 if Is_Abstract
(Iface_Subp
)
6357 and then Present
(Alias
(Iface_Subp
))
6358 and then Present
(DTC_Entity
(Alias
(Iface_Subp
)))
6359 and then Is_Interface
6360 (Scope
(DTC_Entity
(Alias
(Iface_Subp
))))
6362 -- Look for candidate primitive subprograms of the tagged
6363 -- type that can cover this interface subprogram.
6366 First_Elmt
(Primitive_Operations
(Derived_Type
));
6367 while Present
(Subp_Elmt
) loop
6368 Subp
:= Node
(Subp_Elmt
);
6370 if not Is_Abstract
(Subp
)
6371 and then Chars
(Subp
) = Chars
(Iface_Subp
)
6372 and then Type_Conformant
(Iface_Subp
, Subp
)
6374 Prev_Alias
:= Alias
(Iface_Subp
);
6376 Check_Dispatching_Operation
6378 Old_Subp
=> Iface_Subp
);
6381 (Alias
(Iface_Subp
) = Subp
);
6383 (Abstract_Interface_Alias
(Iface_Subp
)
6386 -- Traverse the list of aliased subprograms to link
6387 -- subp with its ultimate aliased subprogram. This
6388 -- avoids problems with the backend.
6395 while Present
(Alias
(E
)) loop
6399 Set_Alias
(Subp
, E
);
6402 Set_Has_Delayed_Freeze
(Subp
);
6406 Next_Elmt
(Subp_Elmt
);
6410 Next_Elmt
(Iface_Subp_Elmt
);
6416 -- If we have a private extension which defines a constrained derived
6417 -- type mark as constrained here after we have derived subprograms. See
6418 -- comment on point 9. just above the body of Build_Derived_Record_Type.
6420 if Private_Extension
and then Inherit_Discrims
then
6421 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
6422 Set_Is_Constrained
(Derived_Type
, True);
6423 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
6425 elsif Is_Constrained
(Parent_Type
) then
6427 (Derived_Type
, True);
6428 Set_Discriminant_Constraint
6429 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
6433 -- Update the class_wide type, which shares the now-completed
6434 -- entity list with its specific type.
6438 (Class_Wide_Type
(Derived_Type
), First_Entity
(Derived_Type
));
6440 (Class_Wide_Type
(Derived_Type
), Last_Entity
(Derived_Type
));
6443 end Build_Derived_Record_Type
;
6445 ------------------------
6446 -- Build_Derived_Type --
6447 ------------------------
6449 procedure Build_Derived_Type
6451 Parent_Type
: Entity_Id
;
6452 Derived_Type
: Entity_Id
;
6453 Is_Completion
: Boolean;
6454 Derive_Subps
: Boolean := True)
6456 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
6459 -- Set common attributes
6461 Set_Scope
(Derived_Type
, Current_Scope
);
6463 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
6464 Set_Etype
(Derived_Type
, Parent_Base
);
6465 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
6467 Set_Size_Info
(Derived_Type
, Parent_Type
);
6468 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
6469 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
6470 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
6472 -- The derived type inherits the representation clauses of the parent.
6473 -- However, for a private type that is completed by a derivation, there
6474 -- may be operation attributes that have been specified already (stream
6475 -- attributes and External_Tag) and those must be provided. Finally,
6476 -- if the partial view is a private extension, the representation items
6477 -- of the parent have been inherited already, and should not be chained
6478 -- twice to the derived type.
6480 if Is_Tagged_Type
(Parent_Type
)
6481 and then Present
(First_Rep_Item
(Derived_Type
))
6483 -- The existing items are either operational items or items inherited
6484 -- from a private extension declaration.
6488 Found
: Boolean := False;
6491 Rep
:= First_Rep_Item
(Derived_Type
);
6492 while Present
(Rep
) loop
6493 if Rep
= First_Rep_Item
(Parent_Type
) then
6497 Rep
:= Next_Rep_Item
(Rep
);
6503 (First_Rep_Item
(Derived_Type
), First_Rep_Item
(Parent_Type
));
6508 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
6511 case Ekind
(Parent_Type
) is
6512 when Numeric_Kind
=>
6513 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
6516 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
6520 | Class_Wide_Kind
=>
6521 Build_Derived_Record_Type
6522 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
6525 when Enumeration_Kind
=>
6526 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
6529 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
6531 when Incomplete_Or_Private_Kind
=>
6532 Build_Derived_Private_Type
6533 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
6535 -- For discriminated types, the derivation includes deriving
6536 -- primitive operations. For others it is done below.
6538 if Is_Tagged_Type
(Parent_Type
)
6539 or else Has_Discriminants
(Parent_Type
)
6540 or else (Present
(Full_View
(Parent_Type
))
6541 and then Has_Discriminants
(Full_View
(Parent_Type
)))
6546 when Concurrent_Kind
=>
6547 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
6550 raise Program_Error
;
6553 if Etype
(Derived_Type
) = Any_Type
then
6557 -- Set delayed freeze and then derive subprograms, we need to do this
6558 -- in this order so that derived subprograms inherit the derived freeze
6561 Set_Has_Delayed_Freeze
(Derived_Type
);
6562 if Derive_Subps
then
6563 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6566 Set_Has_Primitive_Operations
6567 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
6568 end Build_Derived_Type
;
6570 -----------------------
6571 -- Build_Discriminal --
6572 -----------------------
6574 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
6575 D_Minal
: Entity_Id
;
6576 CR_Disc
: Entity_Id
;
6579 -- A discriminal has the same name as the discriminant
6582 Make_Defining_Identifier
(Sloc
(Discrim
),
6583 Chars
=> Chars
(Discrim
));
6585 Set_Ekind
(D_Minal
, E_In_Parameter
);
6586 Set_Mechanism
(D_Minal
, Default_Mechanism
);
6587 Set_Etype
(D_Minal
, Etype
(Discrim
));
6589 Set_Discriminal
(Discrim
, D_Minal
);
6590 Set_Discriminal_Link
(D_Minal
, Discrim
);
6592 -- For task types, build at once the discriminants of the corresponding
6593 -- record, which are needed if discriminants are used in entry defaults
6594 -- and in family bounds.
6596 if Is_Concurrent_Type
(Current_Scope
)
6597 or else Is_Limited_Type
(Current_Scope
)
6599 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
6601 Set_Ekind
(CR_Disc
, E_In_Parameter
);
6602 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
6603 Set_Etype
(CR_Disc
, Etype
(Discrim
));
6604 Set_Discriminal_Link
(CR_Disc
, Discrim
);
6605 Set_CR_Discriminant
(Discrim
, CR_Disc
);
6607 end Build_Discriminal
;
6609 ------------------------------------
6610 -- Build_Discriminant_Constraints --
6611 ------------------------------------
6613 function Build_Discriminant_Constraints
6616 Derived_Def
: Boolean := False) return Elist_Id
6618 C
: constant Node_Id
:= Constraint
(Def
);
6619 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
6621 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
6622 -- Saves the expression corresponding to a given discriminant in T
6624 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
6625 -- Return the Position number within array Discr_Expr of a discriminant
6626 -- D within the discriminant list of the discriminated type T.
6632 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
6636 Disc
:= First_Discriminant
(T
);
6637 for J
in Discr_Expr
'Range loop
6642 Next_Discriminant
(Disc
);
6645 -- Note: Since this function is called on discriminants that are
6646 -- known to belong to the discriminated type, falling through the
6647 -- loop with no match signals an internal compiler error.
6649 raise Program_Error
;
6652 -- Declarations local to Build_Discriminant_Constraints
6656 Elist
: constant Elist_Id
:= New_Elmt_List
;
6664 Discrim_Present
: Boolean := False;
6666 -- Start of processing for Build_Discriminant_Constraints
6669 -- The following loop will process positional associations only.
6670 -- For a positional association, the (single) discriminant is
6671 -- implicitly specified by position, in textual order (RM 3.7.2).
6673 Discr
:= First_Discriminant
(T
);
6674 Constr
:= First
(Constraints
(C
));
6676 for D
in Discr_Expr
'Range loop
6677 exit when Nkind
(Constr
) = N_Discriminant_Association
;
6680 Error_Msg_N
("too few discriminants given in constraint", C
);
6681 return New_Elmt_List
;
6683 elsif Nkind
(Constr
) = N_Range
6684 or else (Nkind
(Constr
) = N_Attribute_Reference
6686 Attribute_Name
(Constr
) = Name_Range
)
6689 ("a range is not a valid discriminant constraint", Constr
);
6690 Discr_Expr
(D
) := Error
;
6693 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
6694 Discr_Expr
(D
) := Constr
;
6697 Next_Discriminant
(Discr
);
6701 if No
(Discr
) and then Present
(Constr
) then
6702 Error_Msg_N
("too many discriminants given in constraint", Constr
);
6703 return New_Elmt_List
;
6706 -- Named associations can be given in any order, but if both positional
6707 -- and named associations are used in the same discriminant constraint,
6708 -- then positional associations must occur first, at their normal
6709 -- position. Hence once a named association is used, the rest of the
6710 -- discriminant constraint must use only named associations.
6712 while Present
(Constr
) loop
6714 -- Positional association forbidden after a named association
6716 if Nkind
(Constr
) /= N_Discriminant_Association
then
6717 Error_Msg_N
("positional association follows named one", Constr
);
6718 return New_Elmt_List
;
6720 -- Otherwise it is a named association
6723 -- E records the type of the discriminants in the named
6724 -- association. All the discriminants specified in the same name
6725 -- association must have the same type.
6729 -- Search the list of discriminants in T to see if the simple name
6730 -- given in the constraint matches any of them.
6732 Id
:= First
(Selector_Names
(Constr
));
6733 while Present
(Id
) loop
6736 -- If Original_Discriminant is present, we are processing a
6737 -- generic instantiation and this is an instance node. We need
6738 -- to find the name of the corresponding discriminant in the
6739 -- actual record type T and not the name of the discriminant in
6740 -- the generic formal. Example:
6743 -- type G (D : int) is private;
6745 -- subtype W is G (D => 1);
6747 -- type Rec (X : int) is record ... end record;
6748 -- package Q is new P (G => Rec);
6750 -- At the point of the instantiation, formal type G is Rec
6751 -- and therefore when reanalyzing "subtype W is G (D => 1);"
6752 -- which really looks like "subtype W is Rec (D => 1);" at
6753 -- the point of instantiation, we want to find the discriminant
6754 -- that corresponds to D in Rec, ie X.
6756 if Present
(Original_Discriminant
(Id
)) then
6757 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
6761 Discr
:= First_Discriminant
(T
);
6762 while Present
(Discr
) loop
6763 if Chars
(Discr
) = Chars
(Id
) then
6768 Next_Discriminant
(Discr
);
6772 Error_Msg_N
("& does not match any discriminant", Id
);
6773 return New_Elmt_List
;
6775 -- The following is only useful for the benefit of generic
6776 -- instances but it does not interfere with other
6777 -- processing for the non-generic case so we do it in all
6778 -- cases (for generics this statement is executed when
6779 -- processing the generic definition, see comment at the
6780 -- beginning of this if statement).
6783 Set_Original_Discriminant
(Id
, Discr
);
6787 Position
:= Pos_Of_Discr
(T
, Discr
);
6789 if Present
(Discr_Expr
(Position
)) then
6790 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
6793 -- Each discriminant specified in the same named association
6794 -- must be associated with a separate copy of the
6795 -- corresponding expression.
6797 if Present
(Next
(Id
)) then
6798 Expr
:= New_Copy_Tree
(Expression
(Constr
));
6799 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
6801 Expr
:= Expression
(Constr
);
6804 Discr_Expr
(Position
) := Expr
;
6805 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
6808 -- A discriminant association with more than one discriminant
6809 -- name is only allowed if the named discriminants are all of
6810 -- the same type (RM 3.7.1(8)).
6813 E
:= Base_Type
(Etype
(Discr
));
6815 elsif Base_Type
(Etype
(Discr
)) /= E
then
6817 ("all discriminants in an association " &
6818 "must have the same type", Id
);
6828 -- A discriminant constraint must provide exactly one value for each
6829 -- discriminant of the type (RM 3.7.1(8)).
6831 for J
in Discr_Expr
'Range loop
6832 if No
(Discr_Expr
(J
)) then
6833 Error_Msg_N
("too few discriminants given in constraint", C
);
6834 return New_Elmt_List
;
6838 -- Determine if there are discriminant expressions in the constraint
6840 for J
in Discr_Expr
'Range loop
6841 if Denotes_Discriminant
(Discr_Expr
(J
), Check_Protected
=> True) then
6842 Discrim_Present
:= True;
6846 -- Build an element list consisting of the expressions given in the
6847 -- discriminant constraint and apply the appropriate checks. The list
6848 -- is constructed after resolving any named discriminant associations
6849 -- and therefore the expressions appear in the textual order of the
6852 Discr
:= First_Discriminant
(T
);
6853 for J
in Discr_Expr
'Range loop
6854 if Discr_Expr
(J
) /= Error
then
6856 Append_Elmt
(Discr_Expr
(J
), Elist
);
6858 -- If any of the discriminant constraints is given by a
6859 -- discriminant and we are in a derived type declaration we
6860 -- have a discriminant renaming. Establish link between new
6861 -- and old discriminant.
6863 if Denotes_Discriminant
(Discr_Expr
(J
)) then
6865 Set_Corresponding_Discriminant
6866 (Entity
(Discr_Expr
(J
)), Discr
);
6869 -- Force the evaluation of non-discriminant expressions.
6870 -- If we have found a discriminant in the constraint 3.4(26)
6871 -- and 3.8(18) demand that no range checks are performed are
6872 -- after evaluation. If the constraint is for a component
6873 -- definition that has a per-object constraint, expressions are
6874 -- evaluated but not checked either. In all other cases perform
6878 if Discrim_Present
then
6881 elsif Nkind
(Parent
(Parent
(Def
))) = N_Component_Declaration
6883 Has_Per_Object_Constraint
6884 (Defining_Identifier
(Parent
(Parent
(Def
))))
6888 elsif Is_Access_Type
(Etype
(Discr
)) then
6889 Apply_Constraint_Check
(Discr_Expr
(J
), Etype
(Discr
));
6892 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
6895 Force_Evaluation
(Discr_Expr
(J
));
6898 -- Check that the designated type of an access discriminant's
6899 -- expression is not a class-wide type unless the discriminant's
6900 -- designated type is also class-wide.
6902 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
6903 and then not Is_Class_Wide_Type
6904 (Designated_Type
(Etype
(Discr
)))
6905 and then Etype
(Discr_Expr
(J
)) /= Any_Type
6906 and then Is_Class_Wide_Type
6907 (Designated_Type
(Etype
(Discr_Expr
(J
))))
6909 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
6913 Next_Discriminant
(Discr
);
6917 end Build_Discriminant_Constraints
;
6919 ---------------------------------
6920 -- Build_Discriminated_Subtype --
6921 ---------------------------------
6923 procedure Build_Discriminated_Subtype
6927 Related_Nod
: Node_Id
;
6928 For_Access
: Boolean := False)
6930 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
6931 Constrained
: constant Boolean
6933 and then not Is_Empty_Elmt_List
(Elist
)
6934 and then not Is_Class_Wide_Type
(T
))
6935 or else Is_Constrained
(T
);
6938 if Ekind
(T
) = E_Record_Type
then
6940 Set_Ekind
(Def_Id
, E_Private_Subtype
);
6941 Set_Is_For_Access_Subtype
(Def_Id
, True);
6943 Set_Ekind
(Def_Id
, E_Record_Subtype
);
6946 elsif Ekind
(T
) = E_Task_Type
then
6947 Set_Ekind
(Def_Id
, E_Task_Subtype
);
6949 elsif Ekind
(T
) = E_Protected_Type
then
6950 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
6952 elsif Is_Private_Type
(T
) then
6953 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
6955 elsif Is_Class_Wide_Type
(T
) then
6956 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
6959 -- Incomplete type. attach subtype to list of dependents, to be
6960 -- completed with full view of parent type, unless is it the
6961 -- designated subtype of a record component within an init_proc.
6962 -- This last case arises for a component of an access type whose
6963 -- designated type is incomplete (e.g. a Taft Amendment type).
6964 -- The designated subtype is within an inner scope, and needs no
6965 -- elaboration, because only the access type is needed in the
6966 -- initialization procedure.
6968 Set_Ekind
(Def_Id
, Ekind
(T
));
6970 if For_Access
and then Within_Init_Proc
then
6973 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
6977 Set_Etype
(Def_Id
, T
);
6978 Init_Size_Align
(Def_Id
);
6979 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
6980 Set_Is_Constrained
(Def_Id
, Constrained
);
6982 Set_First_Entity
(Def_Id
, First_Entity
(T
));
6983 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
6984 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
6986 if Is_Tagged_Type
(T
) then
6987 Set_Is_Tagged_Type
(Def_Id
);
6988 Make_Class_Wide_Type
(Def_Id
);
6991 Set_Stored_Constraint
(Def_Id
, No_Elist
);
6994 Set_Discriminant_Constraint
(Def_Id
, Elist
);
6995 Set_Stored_Constraint_From_Discriminant_Constraint
(Def_Id
);
6998 if Is_Tagged_Type
(T
) then
7000 -- Ada 2005 (AI-251): In case of concurrent types we inherit the
7001 -- concurrent record type (which has the list of primitive
7004 if Ada_Version
>= Ada_05
7005 and then Is_Concurrent_Type
(T
)
7007 Set_Corresponding_Record_Type
(Def_Id
,
7008 Corresponding_Record_Type
(T
));
7010 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
7013 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
7016 -- Subtypes introduced by component declarations do not need to be
7017 -- marked as delayed, and do not get freeze nodes, because the semantics
7018 -- verifies that the parents of the subtypes are frozen before the
7019 -- enclosing record is frozen.
7021 if not Is_Type
(Scope
(Def_Id
)) then
7022 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
7024 if Is_Private_Type
(T
)
7025 and then Present
(Full_View
(T
))
7027 Conditional_Delay
(Def_Id
, Full_View
(T
));
7029 Conditional_Delay
(Def_Id
, T
);
7033 if Is_Record_Type
(T
) then
7034 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
7037 and then not Is_Empty_Elmt_List
(Elist
)
7038 and then not For_Access
7040 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
7041 elsif not For_Access
then
7042 Set_Cloned_Subtype
(Def_Id
, T
);
7046 end Build_Discriminated_Subtype
;
7048 ------------------------
7049 -- Build_Scalar_Bound --
7050 ------------------------
7052 function Build_Scalar_Bound
7055 Der_T
: Entity_Id
) return Node_Id
7057 New_Bound
: Entity_Id
;
7060 -- Note: not clear why this is needed, how can the original bound
7061 -- be unanalyzed at this point? and if it is, what business do we
7062 -- have messing around with it? and why is the base type of the
7063 -- parent type the right type for the resolution. It probably is
7064 -- not! It is OK for the new bound we are creating, but not for
7065 -- the old one??? Still if it never happens, no problem!
7067 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
7069 if Nkind
(Bound
) = N_Integer_Literal
7070 or else Nkind
(Bound
) = N_Real_Literal
7072 New_Bound
:= New_Copy
(Bound
);
7073 Set_Etype
(New_Bound
, Der_T
);
7074 Set_Analyzed
(New_Bound
);
7076 elsif Is_Entity_Name
(Bound
) then
7077 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
7079 -- The following is almost certainly wrong. What business do we have
7080 -- relocating a node (Bound) that is presumably still attached to
7081 -- the tree elsewhere???
7084 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
7087 Set_Etype
(New_Bound
, Der_T
);
7089 end Build_Scalar_Bound
;
7091 --------------------------------
7092 -- Build_Underlying_Full_View --
7093 --------------------------------
7095 procedure Build_Underlying_Full_View
7100 Loc
: constant Source_Ptr
:= Sloc
(N
);
7101 Subt
: constant Entity_Id
:=
7102 Make_Defining_Identifier
7103 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
7110 procedure Set_Discriminant_Name
(Id
: Node_Id
);
7111 -- If the derived type has discriminants, they may rename discriminants
7112 -- of the parent. When building the full view of the parent, we need to
7113 -- recover the names of the original discriminants if the constraint is
7114 -- given by named associations.
7116 ---------------------------
7117 -- Set_Discriminant_Name --
7118 ---------------------------
7120 procedure Set_Discriminant_Name
(Id
: Node_Id
) is
7124 Set_Original_Discriminant
(Id
, Empty
);
7126 if Has_Discriminants
(Typ
) then
7127 Disc
:= First_Discriminant
(Typ
);
7128 while Present
(Disc
) loop
7129 if Chars
(Disc
) = Chars
(Id
)
7130 and then Present
(Corresponding_Discriminant
(Disc
))
7132 Set_Chars
(Id
, Chars
(Corresponding_Discriminant
(Disc
)));
7134 Next_Discriminant
(Disc
);
7137 end Set_Discriminant_Name
;
7139 -- Start of processing for Build_Underlying_Full_View
7142 if Nkind
(N
) = N_Full_Type_Declaration
then
7143 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
7145 elsif Nkind
(N
) = N_Subtype_Declaration
then
7146 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
7148 elsif Nkind
(N
) = N_Component_Declaration
then
7151 (Constraint
(Subtype_Indication
(Component_Definition
(N
))));
7154 raise Program_Error
;
7157 C
:= First
(Constraints
(Constr
));
7158 while Present
(C
) loop
7159 if Nkind
(C
) = N_Discriminant_Association
then
7160 Id
:= First
(Selector_Names
(C
));
7161 while Present
(Id
) loop
7162 Set_Discriminant_Name
(Id
);
7171 Make_Subtype_Declaration
(Loc
,
7172 Defining_Identifier
=> Subt
,
7173 Subtype_Indication
=>
7174 Make_Subtype_Indication
(Loc
,
7175 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
7176 Constraint
=> New_Copy_Tree
(Constr
)));
7178 -- If this is a component subtype for an outer itype, it is not
7179 -- a list member, so simply set the parent link for analysis: if
7180 -- the enclosing type does not need to be in a declarative list,
7181 -- neither do the components.
7183 if Is_List_Member
(N
)
7184 and then Nkind
(N
) /= N_Component_Declaration
7186 Insert_Before
(N
, Indic
);
7188 Set_Parent
(Indic
, Parent
(N
));
7192 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
7193 end Build_Underlying_Full_View
;
7195 -------------------------------
7196 -- Check_Abstract_Overriding --
7197 -------------------------------
7199 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
7203 Alias_Subp
: Entity_Id
;
7207 Op_List
:= Primitive_Operations
(T
);
7209 -- Loop to check primitive operations
7211 Elmt
:= First_Elmt
(Op_List
);
7212 while Present
(Elmt
) loop
7213 Subp
:= Node
(Elmt
);
7214 Alias_Subp
:= Alias
(Subp
);
7216 -- Inherited subprograms are identified by the fact that they do not
7217 -- come from source, and the associated source location is the
7218 -- location of the first subtype of the derived type.
7220 -- Special exception, do not complain about failure to override the
7221 -- stream routines _Input and _Output, as well as the primitive
7222 -- operations used in dispatching selects since we always provide
7223 -- automatic overridings for these subprograms.
7225 if (Is_Abstract
(Subp
)
7226 or else (Has_Controlling_Result
(Subp
)
7227 and then Present
(Alias_Subp
)
7228 and then not Comes_From_Source
(Subp
)
7229 and then Sloc
(Subp
) = Sloc
(First_Subtype
(T
))))
7230 and then not Is_TSS
(Subp
, TSS_Stream_Input
)
7231 and then not Is_TSS
(Subp
, TSS_Stream_Output
)
7232 and then not Is_Abstract
(T
)
7233 and then Chars
(Subp
) /= Name_uDisp_Asynchronous_Select
7234 and then Chars
(Subp
) /= Name_uDisp_Conditional_Select
7235 and then Chars
(Subp
) /= Name_uDisp_Get_Prim_Op_Kind
7236 and then Chars
(Subp
) /= Name_uDisp_Timed_Select
7238 if Present
(Alias_Subp
) then
7240 -- Only perform the check for a derived subprogram when the
7241 -- type has an explicit record extension. This avoids
7242 -- incorrectly flagging abstract subprograms for the case of a
7243 -- type without an extension derived from a formal type with a
7244 -- tagged actual (can occur within a private part).
7246 -- Ada 2005 (AI-391): In the case of an inherited function with
7247 -- a controlling result of the type, the rule does not apply if
7248 -- the type is a null extension (unless the parent function
7249 -- itself is abstract, in which case the function must still be
7250 -- be overridden). The expander will generate an overriding
7251 -- wrapper function calling the parent subprogram (see
7252 -- Exp_Ch3.Make_Controlling_Wrapper_Functions).
7254 Type_Def
:= Type_Definition
(Parent
(T
));
7255 if Nkind
(Type_Def
) = N_Derived_Type_Definition
7256 and then Present
(Record_Extension_Part
(Type_Def
))
7258 (Ada_Version
< Ada_05
7259 or else not Is_Null_Extension
(T
)
7260 or else Ekind
(Subp
) = E_Procedure
7261 or else not Has_Controlling_Result
(Subp
)
7262 or else Is_Abstract
(Alias_Subp
)
7263 or else Is_Access_Type
(Etype
(Subp
)))
7266 ("type must be declared abstract or & overridden",
7269 -- Traverse the whole chain of aliased subprograms to
7270 -- complete the error notification. This is especially
7271 -- useful for traceability of the chain of entities when the
7272 -- subprogram corresponds with an interface subprogram
7273 -- (which might be defined in another package)
7275 if Present
(Alias_Subp
) then
7281 while Present
(Alias
(E
)) loop
7282 Error_Msg_Sloc
:= Sloc
(E
);
7283 Error_Msg_NE
("\& has been inherited #", T
, Subp
);
7287 Error_Msg_Sloc
:= Sloc
(E
);
7289 ("\& has been inherited from subprogram #", T
, Subp
);
7293 -- Ada 2005 (AI-345): Protected or task type implementing
7294 -- abstract interfaces.
7296 elsif Is_Concurrent_Record_Type
(T
)
7297 and then Present
(Abstract_Interfaces
(T
))
7300 ("interface subprogram & must be overridden",
7305 ("abstract subprogram not allowed for type&",
7308 ("nonabstract type has abstract subprogram&",
7315 end Check_Abstract_Overriding
;
7317 ------------------------------------------------
7318 -- Check_Access_Discriminant_Requires_Limited --
7319 ------------------------------------------------
7321 procedure Check_Access_Discriminant_Requires_Limited
7326 -- A discriminant_specification for an access discriminant shall appear
7327 -- only in the declaration for a task or protected type, or for a type
7328 -- with the reserved word 'limited' in its definition or in one of its
7329 -- ancestors. (RM 3.7(10))
7331 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
7332 and then not Is_Concurrent_Type
(Current_Scope
)
7333 and then not Is_Concurrent_Record_Type
(Current_Scope
)
7334 and then not Is_Limited_Record
(Current_Scope
)
7335 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
7338 ("access discriminants allowed only for limited types", Loc
);
7340 end Check_Access_Discriminant_Requires_Limited
;
7342 -----------------------------------
7343 -- Check_Aliased_Component_Types --
7344 -----------------------------------
7346 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
7350 -- ??? Also need to check components of record extensions, but not
7351 -- components of protected types (which are always limited).
7353 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
7354 -- types to be unconstrained. This is safe because it is illegal to
7355 -- create access subtypes to such types with explicit discriminant
7358 if not Is_Limited_Type
(T
) then
7359 if Ekind
(T
) = E_Record_Type
then
7360 C
:= First_Component
(T
);
7361 while Present
(C
) loop
7363 and then Has_Discriminants
(Etype
(C
))
7364 and then not Is_Constrained
(Etype
(C
))
7365 and then not In_Instance_Body
7366 and then Ada_Version
< Ada_05
7369 ("aliased component must be constrained ('R'M 3.6(11))",
7376 elsif Ekind
(T
) = E_Array_Type
then
7377 if Has_Aliased_Components
(T
)
7378 and then Has_Discriminants
(Component_Type
(T
))
7379 and then not Is_Constrained
(Component_Type
(T
))
7380 and then not In_Instance_Body
7381 and then Ada_Version
< Ada_05
7384 ("aliased component type must be constrained ('R'M 3.6(11))",
7389 end Check_Aliased_Component_Types
;
7391 ----------------------
7392 -- Check_Completion --
7393 ----------------------
7395 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
7398 procedure Post_Error
;
7399 -- Post error message for lack of completion for entity E
7405 procedure Post_Error
is
7407 if not Comes_From_Source
(E
) then
7409 if Ekind
(E
) = E_Task_Type
7410 or else Ekind
(E
) = E_Protected_Type
7412 -- It may be an anonymous protected type created for a
7413 -- single variable. Post error on variable, if present.
7419 Var
:= First_Entity
(Current_Scope
);
7420 while Present
(Var
) loop
7421 exit when Etype
(Var
) = E
7422 and then Comes_From_Source
(Var
);
7427 if Present
(Var
) then
7434 -- If a generated entity has no completion, then either previous
7435 -- semantic errors have disabled the expansion phase, or else we had
7436 -- missing subunits, or else we are compiling without expan- sion,
7437 -- or else something is very wrong.
7439 if not Comes_From_Source
(E
) then
7441 (Serious_Errors_Detected
> 0
7442 or else Configurable_Run_Time_Violations
> 0
7443 or else Subunits_Missing
7444 or else not Expander_Active
);
7447 -- Here for source entity
7450 -- Here if no body to post the error message, so we post the error
7451 -- on the declaration that has no completion. This is not really
7452 -- the right place to post it, think about this later ???
7454 if No
(Body_Id
) then
7457 ("missing full declaration for }", Parent
(E
), E
);
7460 ("missing body for &", Parent
(E
), E
);
7463 -- Package body has no completion for a declaration that appears
7464 -- in the corresponding spec. Post error on the body, with a
7465 -- reference to the non-completed declaration.
7468 Error_Msg_Sloc
:= Sloc
(E
);
7472 ("missing full declaration for }!", Body_Id
, E
);
7474 elsif Is_Overloadable
(E
)
7475 and then Current_Entity_In_Scope
(E
) /= E
7477 -- It may be that the completion is mistyped and appears
7478 -- as a distinct overloading of the entity.
7481 Candidate
: constant Entity_Id
:=
7482 Current_Entity_In_Scope
(E
);
7483 Decl
: constant Node_Id
:=
7484 Unit_Declaration_Node
(Candidate
);
7487 if Is_Overloadable
(Candidate
)
7488 and then Ekind
(Candidate
) = Ekind
(E
)
7489 and then Nkind
(Decl
) = N_Subprogram_Body
7490 and then Acts_As_Spec
(Decl
)
7492 Check_Type_Conformant
(Candidate
, E
);
7495 Error_Msg_NE
("missing body for & declared#!",
7500 Error_Msg_NE
("missing body for & declared#!",
7507 -- Start processing for Check_Completion
7510 E
:= First_Entity
(Current_Scope
);
7511 while Present
(E
) loop
7512 if Is_Intrinsic_Subprogram
(E
) then
7515 -- The following situation requires special handling: a child
7516 -- unit that appears in the context clause of the body of its
7519 -- procedure Parent.Child (...);
7521 -- with Parent.Child;
7522 -- package body Parent is
7524 -- Here Parent.Child appears as a local entity, but should not
7525 -- be flagged as requiring completion, because it is a
7526 -- compilation unit.
7528 elsif Ekind
(E
) = E_Function
7529 or else Ekind
(E
) = E_Procedure
7530 or else Ekind
(E
) = E_Generic_Function
7531 or else Ekind
(E
) = E_Generic_Procedure
7533 if not Has_Completion
(E
)
7534 and then not Is_Abstract
(E
)
7535 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7537 and then Chars
(E
) /= Name_uSize
7542 elsif Is_Entry
(E
) then
7543 if not Has_Completion
(E
) and then
7544 (Ekind
(Scope
(E
)) = E_Protected_Object
7545 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
7550 elsif Is_Package_Or_Generic_Package
(E
) then
7551 if Unit_Requires_Body
(E
) then
7552 if not Has_Completion
(E
)
7553 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7559 elsif not Is_Child_Unit
(E
) then
7560 May_Need_Implicit_Body
(E
);
7563 elsif Ekind
(E
) = E_Incomplete_Type
7564 and then No
(Underlying_Type
(E
))
7568 elsif (Ekind
(E
) = E_Task_Type
or else
7569 Ekind
(E
) = E_Protected_Type
)
7570 and then not Has_Completion
(E
)
7574 -- A single task declared in the current scope is a constant, verify
7575 -- that the body of its anonymous type is in the same scope. If the
7576 -- task is defined elsewhere, this may be a renaming declaration for
7577 -- which no completion is needed.
7579 elsif Ekind
(E
) = E_Constant
7580 and then Ekind
(Etype
(E
)) = E_Task_Type
7581 and then not Has_Completion
(Etype
(E
))
7582 and then Scope
(Etype
(E
)) = Current_Scope
7586 elsif Ekind
(E
) = E_Protected_Object
7587 and then not Has_Completion
(Etype
(E
))
7591 elsif Ekind
(E
) = E_Record_Type
then
7592 if Is_Tagged_Type
(E
) then
7593 Check_Abstract_Overriding
(E
);
7596 Check_Aliased_Component_Types
(E
);
7598 elsif Ekind
(E
) = E_Array_Type
then
7599 Check_Aliased_Component_Types
(E
);
7605 end Check_Completion
;
7607 ----------------------------
7608 -- Check_Delta_Expression --
7609 ----------------------------
7611 procedure Check_Delta_Expression
(E
: Node_Id
) is
7613 if not (Is_Real_Type
(Etype
(E
))) then
7614 Wrong_Type
(E
, Any_Real
);
7616 elsif not Is_OK_Static_Expression
(E
) then
7617 Flag_Non_Static_Expr
7618 ("non-static expression used for delta value!", E
);
7620 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
7621 Error_Msg_N
("delta expression must be positive", E
);
7627 -- If any of above errors occurred, then replace the incorrect
7628 -- expression by the real 0.1, which should prevent further errors.
7631 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
7632 Analyze_And_Resolve
(E
, Standard_Float
);
7633 end Check_Delta_Expression
;
7635 -----------------------------
7636 -- Check_Digits_Expression --
7637 -----------------------------
7639 procedure Check_Digits_Expression
(E
: Node_Id
) is
7641 if not (Is_Integer_Type
(Etype
(E
))) then
7642 Wrong_Type
(E
, Any_Integer
);
7644 elsif not Is_OK_Static_Expression
(E
) then
7645 Flag_Non_Static_Expr
7646 ("non-static expression used for digits value!", E
);
7648 elsif Expr_Value
(E
) <= 0 then
7649 Error_Msg_N
("digits value must be greater than zero", E
);
7655 -- If any of above errors occurred, then replace the incorrect
7656 -- expression by the integer 1, which should prevent further errors.
7658 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
7659 Analyze_And_Resolve
(E
, Standard_Integer
);
7661 end Check_Digits_Expression
;
7663 --------------------------
7664 -- Check_Initialization --
7665 --------------------------
7667 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
7669 if (Is_Limited_Type
(T
)
7670 or else Is_Limited_Composite
(T
))
7671 and then not In_Instance
7672 and then not In_Inlined_Body
7674 -- Ada 2005 (AI-287): Relax the strictness of the front-end in
7675 -- case of limited aggregates and extension aggregates.
7677 if Ada_Version
>= Ada_05
7678 and then (Nkind
(Exp
) = N_Aggregate
7679 or else Nkind
(Exp
) = N_Extension_Aggregate
)
7684 ("cannot initialize entities of limited type", Exp
);
7685 Explain_Limited_Type
(T
, Exp
);
7688 end Check_Initialization
;
7690 ------------------------------------
7691 -- Check_Or_Process_Discriminants --
7692 ------------------------------------
7694 -- If an incomplete or private type declaration was already given for the
7695 -- type, the discriminants may have already been processed if they were
7696 -- present on the incomplete declaration. In this case a full conformance
7697 -- check is performed otherwise just process them.
7699 procedure Check_Or_Process_Discriminants
7702 Prev
: Entity_Id
:= Empty
)
7705 if Has_Discriminants
(T
) then
7707 -- Make the discriminants visible to component declarations
7714 D
:= First_Discriminant
(T
);
7715 while Present
(D
) loop
7716 Prev
:= Current_Entity
(D
);
7717 Set_Current_Entity
(D
);
7718 Set_Is_Immediately_Visible
(D
);
7719 Set_Homonym
(D
, Prev
);
7721 -- Ada 2005 (AI-230): Access discriminant allowed in
7722 -- non-limited record types.
7724 if Ada_Version
< Ada_05
then
7726 -- This restriction gets applied to the full type here. It
7727 -- has already been applied earlier to the partial view.
7729 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
7732 Next_Discriminant
(D
);
7736 elsif Present
(Discriminant_Specifications
(N
)) then
7737 Process_Discriminants
(N
, Prev
);
7739 end Check_Or_Process_Discriminants
;
7741 ----------------------
7742 -- Check_Real_Bound --
7743 ----------------------
7745 procedure Check_Real_Bound
(Bound
: Node_Id
) is
7747 if not Is_Real_Type
(Etype
(Bound
)) then
7749 ("bound in real type definition must be of real type", Bound
);
7751 elsif not Is_OK_Static_Expression
(Bound
) then
7752 Flag_Non_Static_Expr
7753 ("non-static expression used for real type bound!", Bound
);
7760 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
7762 Resolve
(Bound
, Standard_Float
);
7763 end Check_Real_Bound
;
7765 ------------------------
7766 -- Collect_Interfaces --
7767 ------------------------
7769 procedure Collect_Interfaces
(N
: Node_Id
; Derived_Type
: Entity_Id
) is
7772 procedure Add_Interface
(Iface
: Entity_Id
);
7773 -- Add one interface
7779 procedure Add_Interface
(Iface
: Entity_Id
) is
7783 Elmt
:= First_Elmt
(Abstract_Interfaces
(Derived_Type
));
7784 while Present
(Elmt
) and then Node
(Elmt
) /= Iface
loop
7789 Append_Elmt
(Node
=> Iface
,
7790 To
=> Abstract_Interfaces
(Derived_Type
));
7794 -- Start of processing for Collect_Interfaces
7797 pragma Assert
(False
7798 or else Nkind
(N
) = N_Derived_Type_Definition
7799 or else Nkind
(N
) = N_Record_Definition
7800 or else Nkind
(N
) = N_Private_Extension_Declaration
);
7802 -- Traverse the graph of ancestor interfaces
7804 if Is_Non_Empty_List
(Interface_List
(N
)) then
7805 Intf
:= First
(Interface_List
(N
));
7806 while Present
(Intf
) loop
7808 -- Protect against wrong uses. For example:
7809 -- type I is interface;
7810 -- type O is tagged null record;
7811 -- type Wrong is new I and O with null record; -- ERROR
7813 if Is_Interface
(Etype
(Intf
)) then
7815 -- Do not add the interface when the derived type already
7816 -- implements this interface
7818 if not Interface_Present_In_Ancestor
(Derived_Type
,
7822 (Type_Definition
(Parent
(Etype
(Intf
))),
7824 Add_Interface
(Etype
(Intf
));
7831 end Collect_Interfaces
;
7833 ------------------------------
7834 -- Complete_Private_Subtype --
7835 ------------------------------
7837 procedure Complete_Private_Subtype
7840 Full_Base
: Entity_Id
;
7841 Related_Nod
: Node_Id
)
7843 Save_Next_Entity
: Entity_Id
;
7844 Save_Homonym
: Entity_Id
;
7847 -- Set semantic attributes for (implicit) private subtype completion.
7848 -- If the full type has no discriminants, then it is a copy of the full
7849 -- view of the base. Otherwise, it is a subtype of the base with a
7850 -- possible discriminant constraint. Save and restore the original
7851 -- Next_Entity field of full to ensure that the calls to Copy_Node
7852 -- do not corrupt the entity chain.
7854 -- Note that the type of the full view is the same entity as the type of
7855 -- the partial view. In this fashion, the subtype has access to the
7856 -- correct view of the parent.
7858 Save_Next_Entity
:= Next_Entity
(Full
);
7859 Save_Homonym
:= Homonym
(Priv
);
7861 case Ekind
(Full_Base
) is
7862 when E_Record_Type |
7868 Copy_Node
(Priv
, Full
);
7870 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
7871 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
7872 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
7875 Copy_Node
(Full_Base
, Full
);
7876 Set_Chars
(Full
, Chars
(Priv
));
7877 Conditional_Delay
(Full
, Priv
);
7878 Set_Sloc
(Full
, Sloc
(Priv
));
7881 Set_Next_Entity
(Full
, Save_Next_Entity
);
7882 Set_Homonym
(Full
, Save_Homonym
);
7883 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
7885 -- Set common attributes for all subtypes
7887 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
7889 -- The Etype of the full view is inconsistent. Gigi needs to see the
7890 -- structural full view, which is what the current scheme gives:
7891 -- the Etype of the full view is the etype of the full base. However,
7892 -- if the full base is a derived type, the full view then looks like
7893 -- a subtype of the parent, not a subtype of the full base. If instead
7896 -- Set_Etype (Full, Full_Base);
7898 -- then we get inconsistencies in the front-end (confusion between
7899 -- views). Several outstanding bugs are related to this ???
7901 Set_Is_First_Subtype
(Full
, False);
7902 Set_Scope
(Full
, Scope
(Priv
));
7903 Set_Size_Info
(Full
, Full_Base
);
7904 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
7905 Set_Is_Itype
(Full
);
7907 -- A subtype of a private-type-without-discriminants, whose full-view
7908 -- has discriminants with default expressions, is not constrained!
7910 if not Has_Discriminants
(Priv
) then
7911 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
7913 if Has_Discriminants
(Full_Base
) then
7914 Set_Discriminant_Constraint
7915 (Full
, Discriminant_Constraint
(Full_Base
));
7917 -- The partial view may have been indefinite, the full view
7920 Set_Has_Unknown_Discriminants
7921 (Full
, Has_Unknown_Discriminants
(Full_Base
));
7925 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
7926 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
7928 -- Freeze the private subtype entity if its parent is delayed, and not
7929 -- already frozen. We skip this processing if the type is an anonymous
7930 -- subtype of a record component, or is the corresponding record of a
7931 -- protected type, since ???
7933 if not Is_Type
(Scope
(Full
)) then
7934 Set_Has_Delayed_Freeze
(Full
,
7935 Has_Delayed_Freeze
(Full_Base
)
7936 and then (not Is_Frozen
(Full_Base
)));
7939 Set_Freeze_Node
(Full
, Empty
);
7940 Set_Is_Frozen
(Full
, False);
7941 Set_Full_View
(Priv
, Full
);
7943 if Has_Discriminants
(Full
) then
7944 Set_Stored_Constraint_From_Discriminant_Constraint
(Full
);
7945 Set_Stored_Constraint
(Priv
, Stored_Constraint
(Full
));
7947 if Has_Unknown_Discriminants
(Full
) then
7948 Set_Discriminant_Constraint
(Full
, No_Elist
);
7952 if Ekind
(Full_Base
) = E_Record_Type
7953 and then Has_Discriminants
(Full_Base
)
7954 and then Has_Discriminants
(Priv
) -- might not, if errors
7955 and then not Has_Unknown_Discriminants
(Priv
)
7956 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
7958 Create_Constrained_Components
7959 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
7961 -- If the full base is itself derived from private, build a congruent
7962 -- subtype of its underlying type, for use by the back end. For a
7963 -- constrained record component, the declaration cannot be placed on
7964 -- the component list, but it must nevertheless be built an analyzed, to
7965 -- supply enough information for Gigi to compute the size of component.
7967 elsif Ekind
(Full_Base
) in Private_Kind
7968 and then Is_Derived_Type
(Full_Base
)
7969 and then Has_Discriminants
(Full_Base
)
7970 and then (Ekind
(Current_Scope
) /= E_Record_Subtype
)
7972 if not Is_Itype
(Priv
)
7974 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
7976 Build_Underlying_Full_View
7977 (Parent
(Priv
), Full
, Etype
(Full_Base
));
7979 elsif Nkind
(Related_Nod
) = N_Component_Declaration
then
7980 Build_Underlying_Full_View
(Related_Nod
, Full
, Etype
(Full_Base
));
7983 elsif Is_Record_Type
(Full_Base
) then
7985 -- Show Full is simply a renaming of Full_Base
7987 Set_Cloned_Subtype
(Full
, Full_Base
);
7990 -- It is unsafe to share to bounds of a scalar type, because the Itype
7991 -- is elaborated on demand, and if a bound is non-static then different
7992 -- orders of elaboration in different units will lead to different
7993 -- external symbols.
7995 if Is_Scalar_Type
(Full_Base
) then
7996 Set_Scalar_Range
(Full
,
7997 Make_Range
(Sloc
(Related_Nod
),
7999 Duplicate_Subexpr_No_Checks
(Type_Low_Bound
(Full_Base
)),
8001 Duplicate_Subexpr_No_Checks
(Type_High_Bound
(Full_Base
))));
8003 -- This completion inherits the bounds of the full parent, but if
8004 -- the parent is an unconstrained floating point type, so is the
8007 if Is_Floating_Point_Type
(Full_Base
) then
8008 Set_Includes_Infinities
8009 (Scalar_Range
(Full
), Has_Infinities
(Full_Base
));
8013 -- ??? It seems that a lot of fields are missing that should be copied
8014 -- from Full_Base to Full. Here are some that are introduced in a
8015 -- non-disruptive way but a cleanup is necessary.
8017 if Is_Tagged_Type
(Full_Base
) then
8018 Set_Is_Tagged_Type
(Full
);
8019 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
8020 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Full_Base
));
8022 -- If this is a subtype of a protected or task type, constrain its
8023 -- corresponding record, unless this is a subtype without constraints,
8024 -- i.e. a simple renaming as with an actual subtype in an instance.
8026 elsif Is_Concurrent_Type
(Full_Base
) then
8027 if Has_Discriminants
(Full
)
8028 and then Present
(Corresponding_Record_Type
(Full_Base
))
8030 not Is_Empty_Elmt_List
(Discriminant_Constraint
(Full
))
8032 Set_Corresponding_Record_Type
(Full
,
8033 Constrain_Corresponding_Record
8034 (Full
, Corresponding_Record_Type
(Full_Base
),
8035 Related_Nod
, Full_Base
));
8038 Set_Corresponding_Record_Type
(Full
,
8039 Corresponding_Record_Type
(Full_Base
));
8042 end Complete_Private_Subtype
;
8044 -------------------------------------
8045 -- Complete_Subprograms_Derivation --
8046 -------------------------------------
8048 procedure Complete_Subprograms_Derivation
8049 (Partial_View
: Entity_Id
;
8050 Derived_Type
: Entity_Id
)
8052 Result
: constant Elist_Id
:= New_Elmt_List
;
8056 Prim_Op
: Entity_Id
;
8060 -- Handle the case in which the full-view is a transitive
8061 -- derivation of the ancestor of the partial view.
8063 -- type I is interface;
8064 -- type T is new I with ...
8067 -- type DT is new I with private;
8069 -- type DT is new T with ...
8072 if Etype
(Partial_View
) /= Etype
(Derived_Type
)
8073 and then Is_Interface
(Etype
(Partial_View
))
8074 and then Is_Ancestor
(Etype
(Partial_View
), Etype
(Derived_Type
))
8079 if Is_Tagged_Type
(Partial_View
) then
8080 Elmt_P
:= First_Elmt
(Primitive_Operations
(Partial_View
));
8085 -- Inherit primitives declared with the partial-view
8087 while Present
(Elmt_P
) loop
8088 Prim_Op
:= Node
(Elmt_P
);
8090 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
8091 while Present
(Elmt_D
) loop
8092 if Node
(Elmt_D
) = Prim_Op
then
8101 Append_Elmt
(Prim_Op
, Result
);
8103 -- Search for entries associated with abstract interfaces that
8104 -- have been covered by this primitive
8106 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
8107 while Present
(Elmt_D
) loop
8110 if Chars
(E
) = Chars
(Prim_Op
)
8111 and then Is_Abstract
(E
)
8112 and then Present
(Alias
(E
))
8113 and then Present
(DTC_Entity
(Alias
(E
)))
8114 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(E
))))
8116 Remove_Elmt
(Primitive_Operations
(Derived_Type
), Elmt_D
);
8126 -- Append the entities of the full-view to the list of primitives
8129 Elmt_D
:= First_Elmt
(Result
);
8130 while Present
(Elmt_D
) loop
8131 Append_Elmt
(Node
(Elmt_D
), Primitive_Operations
(Derived_Type
));
8134 end Complete_Subprograms_Derivation
;
8136 ----------------------------
8137 -- Constant_Redeclaration --
8138 ----------------------------
8140 procedure Constant_Redeclaration
8145 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
8146 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
8149 procedure Check_Possible_Deferred_Completion
8150 (Prev_Id
: Entity_Id
;
8151 Prev_Obj_Def
: Node_Id
;
8152 Curr_Obj_Def
: Node_Id
);
8153 -- Determine whether the two object definitions describe the partial
8154 -- and the full view of a constrained deferred constant. Generate
8155 -- a subtype for the full view and verify that it statically matches
8156 -- the subtype of the partial view.
8158 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
8159 -- If deferred constant is an access type initialized with an allocator,
8160 -- check whether there is an illegal recursion in the definition,
8161 -- through a default value of some record subcomponent. This is normally
8162 -- detected when generating init procs, but requires this additional
8163 -- mechanism when expansion is disabled.
8165 ----------------------------------------
8166 -- Check_Possible_Deferred_Completion --
8167 ----------------------------------------
8169 procedure Check_Possible_Deferred_Completion
8170 (Prev_Id
: Entity_Id
;
8171 Prev_Obj_Def
: Node_Id
;
8172 Curr_Obj_Def
: Node_Id
)
8175 if Nkind
(Prev_Obj_Def
) = N_Subtype_Indication
8176 and then Present
(Constraint
(Prev_Obj_Def
))
8177 and then Nkind
(Curr_Obj_Def
) = N_Subtype_Indication
8178 and then Present
(Constraint
(Curr_Obj_Def
))
8181 Loc
: constant Source_Ptr
:= Sloc
(N
);
8182 Def_Id
: constant Entity_Id
:=
8183 Make_Defining_Identifier
(Loc
,
8184 New_Internal_Name
('S'));
8185 Decl
: constant Node_Id
:=
8186 Make_Subtype_Declaration
(Loc
,
8187 Defining_Identifier
=>
8189 Subtype_Indication
=>
8190 Relocate_Node
(Curr_Obj_Def
));
8193 Insert_Before_And_Analyze
(N
, Decl
);
8194 Set_Etype
(Id
, Def_Id
);
8196 if not Subtypes_Statically_Match
(Etype
(Prev_Id
), Def_Id
) then
8197 Error_Msg_Sloc
:= Sloc
(Prev_Id
);
8198 Error_Msg_N
("subtype does not statically match deferred " &
8203 end Check_Possible_Deferred_Completion
;
8205 ---------------------------------
8206 -- Check_Recursive_Declaration --
8207 ---------------------------------
8209 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
8213 if Is_Record_Type
(Typ
) then
8214 Comp
:= First_Component
(Typ
);
8215 while Present
(Comp
) loop
8216 if Comes_From_Source
(Comp
) then
8217 if Present
(Expression
(Parent
(Comp
)))
8218 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
8219 and then Entity
(Expression
(Parent
(Comp
))) = Prev
8221 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
8223 ("illegal circularity with declaration for&#",
8227 elsif Is_Record_Type
(Etype
(Comp
)) then
8228 Check_Recursive_Declaration
(Etype
(Comp
));
8232 Next_Component
(Comp
);
8235 end Check_Recursive_Declaration
;
8237 -- Start of processing for Constant_Redeclaration
8240 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
8241 if Nkind
(Object_Definition
8242 (Parent
(Prev
))) = N_Subtype_Indication
8244 -- Find type of new declaration. The constraints of the two
8245 -- views must match statically, but there is no point in
8246 -- creating an itype for the full view.
8248 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
8249 Find_Type
(Subtype_Mark
(Obj_Def
));
8250 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
8253 Find_Type
(Obj_Def
);
8254 New_T
:= Entity
(Obj_Def
);
8260 -- The full view may impose a constraint, even if the partial
8261 -- view does not, so construct the subtype.
8263 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
8268 -- Current declaration is illegal, diagnosed below in Enter_Name
8274 -- If previous full declaration exists, or if a homograph is present,
8275 -- let Enter_Name handle it, either with an error, or with the removal
8276 -- of an overridden implicit subprogram.
8278 if Ekind
(Prev
) /= E_Constant
8279 or else Present
(Expression
(Parent
(Prev
)))
8280 or else Present
(Full_View
(Prev
))
8284 -- Verify that types of both declarations match, or else that both types
8285 -- are anonymous access types whose designated subtypes statically match
8286 -- (as allowed in Ada 2005 by AI-385).
8288 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
)
8290 (Ekind
(Etype
(Prev
)) /= E_Anonymous_Access_Type
8291 or else Ekind
(Etype
(New_T
)) /= E_Anonymous_Access_Type
8292 or else not Subtypes_Statically_Match
8293 (Designated_Type
(Etype
(Prev
)),
8294 Designated_Type
(Etype
(New_T
))))
8296 Error_Msg_Sloc
:= Sloc
(Prev
);
8297 Error_Msg_N
("type does not match declaration#", N
);
8298 Set_Full_View
(Prev
, Id
);
8299 Set_Etype
(Id
, Any_Type
);
8301 -- If so, process the full constant declaration
8304 -- RM 7.4 (6): If the subtype defined by the subtype_indication in
8305 -- the deferred declaration is constrained, then the subtype defined
8306 -- by the subtype_indication in the full declaration shall match it
8309 Check_Possible_Deferred_Completion
8311 Prev_Obj_Def
=> Object_Definition
(Parent
(Prev
)),
8312 Curr_Obj_Def
=> Obj_Def
);
8314 Set_Full_View
(Prev
, Id
);
8315 Set_Is_Public
(Id
, Is_Public
(Prev
));
8316 Set_Is_Internal
(Id
);
8317 Append_Entity
(Id
, Current_Scope
);
8319 -- Check ALIASED present if present before (RM 7.4(7))
8321 if Is_Aliased
(Prev
)
8322 and then not Aliased_Present
(N
)
8324 Error_Msg_Sloc
:= Sloc
(Prev
);
8325 Error_Msg_N
("ALIASED required (see declaration#)", N
);
8328 -- Check that placement is in private part and that the incomplete
8329 -- declaration appeared in the visible part.
8331 if Ekind
(Current_Scope
) = E_Package
8332 and then not In_Private_Part
(Current_Scope
)
8334 Error_Msg_Sloc
:= Sloc
(Prev
);
8335 Error_Msg_N
("full constant for declaration#"
8336 & " must be in private part", N
);
8338 elsif Ekind
(Current_Scope
) = E_Package
8339 and then List_Containing
(Parent
(Prev
))
8340 /= Visible_Declarations
8341 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
8344 ("deferred constant must be declared in visible part",
8348 if Is_Access_Type
(T
)
8349 and then Nkind
(Expression
(N
)) = N_Allocator
8351 Check_Recursive_Declaration
(Designated_Type
(T
));
8354 end Constant_Redeclaration
;
8356 ----------------------
8357 -- Constrain_Access --
8358 ----------------------
8360 procedure Constrain_Access
8361 (Def_Id
: in out Entity_Id
;
8363 Related_Nod
: Node_Id
)
8365 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8366 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
8367 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
8368 Constraint_OK
: Boolean := True;
8370 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean;
8371 -- Simple predicate to test for defaulted discriminants
8372 -- Shouldn't this be in sem_util???
8374 ---------------------------------
8375 -- Has_Defaulted_Discriminants --
8376 ---------------------------------
8378 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean is
8380 return Has_Discriminants
(Typ
)
8381 and then Present
(First_Discriminant
(Typ
))
8383 (Discriminant_Default_Value
(First_Discriminant
(Typ
)));
8384 end Has_Defaulted_Discriminants
;
8386 -- Start of processing for Constrain_Access
8389 if Is_Array_Type
(Desig_Type
) then
8390 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
8392 elsif (Is_Record_Type
(Desig_Type
)
8393 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
8394 and then not Is_Constrained
(Desig_Type
)
8396 -- ??? The following code is a temporary kludge to ignore a
8397 -- discriminant constraint on access type if it is constraining
8398 -- the current record. Avoid creating the implicit subtype of the
8399 -- record we are currently compiling since right now, we cannot
8400 -- handle these. For now, just return the access type itself.
8402 if Desig_Type
= Current_Scope
8403 and then No
(Def_Id
)
8405 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
8406 Def_Id
:= Entity
(Subtype_Mark
(S
));
8408 -- This call added to ensure that the constraint is analyzed
8409 -- (needed for a B test). Note that we still return early from
8410 -- this procedure to avoid recursive processing. ???
8412 Constrain_Discriminated_Type
8413 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
8417 if Ekind
(T
) = E_General_Access_Type
8418 and then Has_Private_Declaration
(Desig_Type
)
8419 and then In_Open_Scopes
(Scope
(Desig_Type
))
8421 -- Enforce rule that the constraint is illegal if there is
8422 -- an unconstrained view of the designated type. This means
8423 -- that the partial view (either a private type declaration or
8424 -- a derivation from a private type) has no discriminants.
8425 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
8426 -- by ACATS B371001).
8427 -- Rule updated for Ada 2005: the private type is said to have
8428 -- a constrained partial view, given that objects of the type
8432 Pack
: constant Node_Id
:=
8433 Unit_Declaration_Node
(Scope
(Desig_Type
));
8438 if Nkind
(Pack
) = N_Package_Declaration
then
8439 Decls
:= Visible_Declarations
(Specification
(Pack
));
8440 Decl
:= First
(Decls
);
8441 while Present
(Decl
) loop
8442 if (Nkind
(Decl
) = N_Private_Type_Declaration
8444 Chars
(Defining_Identifier
(Decl
)) =
8448 (Nkind
(Decl
) = N_Full_Type_Declaration
8450 Chars
(Defining_Identifier
(Decl
)) =
8452 and then Is_Derived_Type
(Desig_Type
)
8454 Has_Private_Declaration
(Etype
(Desig_Type
)))
8456 if No
(Discriminant_Specifications
(Decl
)) then
8458 ("cannot constrain general access type if " &
8459 "designated type has constrained partial view",
8472 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
8473 For_Access
=> True);
8475 elsif (Is_Task_Type
(Desig_Type
)
8476 or else Is_Protected_Type
(Desig_Type
))
8477 and then not Is_Constrained
(Desig_Type
)
8479 Constrain_Concurrent
8480 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
8483 Error_Msg_N
("invalid constraint on access type", S
);
8484 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
8485 Constraint_OK
:= False;
8489 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
8491 Set_Ekind
(Def_Id
, E_Access_Subtype
);
8494 if Constraint_OK
then
8495 Set_Etype
(Def_Id
, Base_Type
(T
));
8497 if Is_Private_Type
(Desig_Type
) then
8498 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
8501 Set_Etype
(Def_Id
, Any_Type
);
8504 Set_Size_Info
(Def_Id
, T
);
8505 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
8506 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
8507 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8508 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
8510 Conditional_Delay
(Def_Id
, T
);
8512 -- AI-363 : Subtypes of general access types whose designated types have
8513 -- default discriminants are disallowed. In instances, the rule has to
8514 -- be checked against the actual, of which T is the subtype. In a
8515 -- generic body, the rule is checked assuming that the actual type has
8516 -- defaulted discriminants.
8518 if Ada_Version
>= Ada_05
then
8519 if Ekind
(Base_Type
(T
)) = E_General_Access_Type
8520 and then Has_Defaulted_Discriminants
(Desig_Type
)
8523 ("access subype of general access type not allowed", S
);
8524 Error_Msg_N
("\ when discriminants have defaults", S
);
8526 elsif Is_Access_Type
(T
)
8527 and then Is_Generic_Type
(Desig_Type
)
8528 and then Has_Discriminants
(Desig_Type
)
8529 and then In_Package_Body
(Current_Scope
)
8531 Error_Msg_N
("access subtype not allowed in generic body", S
);
8533 ("\ wben designated type is a discriminated formal", S
);
8536 end Constrain_Access
;
8538 ---------------------
8539 -- Constrain_Array --
8540 ---------------------
8542 procedure Constrain_Array
8543 (Def_Id
: in out Entity_Id
;
8545 Related_Nod
: Node_Id
;
8546 Related_Id
: Entity_Id
;
8549 C
: constant Node_Id
:= Constraint
(SI
);
8550 Number_Of_Constraints
: Nat
:= 0;
8553 Constraint_OK
: Boolean := True;
8556 T
:= Entity
(Subtype_Mark
(SI
));
8558 if Ekind
(T
) in Access_Kind
then
8559 T
:= Designated_Type
(T
);
8562 -- If an index constraint follows a subtype mark in a subtype indication
8563 -- then the type or subtype denoted by the subtype mark must not already
8564 -- impose an index constraint. The subtype mark must denote either an
8565 -- unconstrained array type or an access type whose designated type
8566 -- is such an array type... (RM 3.6.1)
8568 if Is_Constrained
(T
) then
8570 ("array type is already constrained", Subtype_Mark
(SI
));
8571 Constraint_OK
:= False;
8574 S
:= First
(Constraints
(C
));
8575 while Present
(S
) loop
8576 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
8580 -- In either case, the index constraint must provide a discrete
8581 -- range for each index of the array type and the type of each
8582 -- discrete range must be the same as that of the corresponding
8583 -- index. (RM 3.6.1)
8585 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
8586 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
8587 Constraint_OK
:= False;
8590 S
:= First
(Constraints
(C
));
8591 Index
:= First_Index
(T
);
8594 -- Apply constraints to each index type
8596 for J
in 1 .. Number_Of_Constraints
loop
8597 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
8607 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
8608 Set_Parent
(Def_Id
, Related_Nod
);
8611 Set_Ekind
(Def_Id
, E_Array_Subtype
);
8614 Set_Size_Info
(Def_Id
, (T
));
8615 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8616 Set_Etype
(Def_Id
, Base_Type
(T
));
8618 if Constraint_OK
then
8619 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
8621 Set_First_Index
(Def_Id
, First_Index
(T
));
8624 Set_Is_Constrained
(Def_Id
, True);
8625 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
8626 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8628 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
8629 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
8631 -- Build a freeze node if parent still needs one. Also, make sure
8632 -- that the Depends_On_Private status is set (explanation ???)
8633 -- and also that a conditional delay is set.
8635 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
8636 Conditional_Delay
(Def_Id
, T
);
8638 end Constrain_Array
;
8640 ------------------------------
8641 -- Constrain_Component_Type --
8642 ------------------------------
8644 function Constrain_Component_Type
8646 Constrained_Typ
: Entity_Id
;
8647 Related_Node
: Node_Id
;
8649 Constraints
: Elist_Id
) return Entity_Id
8651 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
8652 Compon_Type
: constant Entity_Id
:= Etype
(Comp
);
8654 function Build_Constrained_Array_Type
8655 (Old_Type
: Entity_Id
) return Entity_Id
;
8656 -- If Old_Type is an array type, one of whose indices is constrained
8657 -- by a discriminant, build an Itype whose constraint replaces the
8658 -- discriminant with its value in the constraint.
8660 function Build_Constrained_Discriminated_Type
8661 (Old_Type
: Entity_Id
) return Entity_Id
;
8662 -- Ditto for record components
8664 function Build_Constrained_Access_Type
8665 (Old_Type
: Entity_Id
) return Entity_Id
;
8666 -- Ditto for access types. Makes use of previous two functions, to
8667 -- constrain designated type.
8669 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
8670 -- T is an array or discriminated type, C is a list of constraints
8671 -- that apply to T. This routine builds the constrained subtype.
8673 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
8674 -- Returns True if Expr is a discriminant
8676 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
8677 -- Find the value of discriminant Discrim in Constraint
8679 -----------------------------------
8680 -- Build_Constrained_Access_Type --
8681 -----------------------------------
8683 function Build_Constrained_Access_Type
8684 (Old_Type
: Entity_Id
) return Entity_Id
8686 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
8688 Desig_Subtype
: Entity_Id
;
8692 -- if the original access type was not embedded in the enclosing
8693 -- type definition, there is no need to produce a new access
8694 -- subtype. In fact every access type with an explicit constraint
8695 -- generates an itype whose scope is the enclosing record.
8697 if not Is_Type
(Scope
(Old_Type
)) then
8700 elsif Is_Array_Type
(Desig_Type
) then
8701 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
8703 elsif Has_Discriminants
(Desig_Type
) then
8705 -- This may be an access type to an enclosing record type for
8706 -- which we are constructing the constrained components. Return
8707 -- the enclosing record subtype. This is not always correct,
8708 -- but avoids infinite recursion. ???
8710 Desig_Subtype
:= Any_Type
;
8712 for J
in reverse 0 .. Scope_Stack
.Last
loop
8713 Scop
:= Scope_Stack
.Table
(J
).Entity
;
8716 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
8718 Desig_Subtype
:= Scop
;
8721 exit when not Is_Type
(Scop
);
8724 if Desig_Subtype
= Any_Type
then
8726 Build_Constrained_Discriminated_Type
(Desig_Type
);
8733 if Desig_Subtype
/= Desig_Type
then
8735 -- The Related_Node better be here or else we won't be able
8736 -- to attach new itypes to a node in the tree.
8738 pragma Assert
(Present
(Related_Node
));
8740 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
8742 Set_Etype
(Itype
, Base_Type
(Old_Type
));
8743 Set_Size_Info
(Itype
, (Old_Type
));
8744 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
8745 Set_Depends_On_Private
(Itype
, Has_Private_Component
8747 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
8750 -- The new itype needs freezing when it depends on a not frozen
8751 -- type and the enclosing subtype needs freezing.
8753 if Has_Delayed_Freeze
(Constrained_Typ
)
8754 and then not Is_Frozen
(Constrained_Typ
)
8756 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
8764 end Build_Constrained_Access_Type
;
8766 ----------------------------------
8767 -- Build_Constrained_Array_Type --
8768 ----------------------------------
8770 function Build_Constrained_Array_Type
8771 (Old_Type
: Entity_Id
) return Entity_Id
8775 Old_Index
: Node_Id
;
8776 Range_Node
: Node_Id
;
8777 Constr_List
: List_Id
;
8779 Need_To_Create_Itype
: Boolean := False;
8782 Old_Index
:= First_Index
(Old_Type
);
8783 while Present
(Old_Index
) loop
8784 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8786 if Is_Discriminant
(Lo_Expr
)
8787 or else Is_Discriminant
(Hi_Expr
)
8789 Need_To_Create_Itype
:= True;
8792 Next_Index
(Old_Index
);
8795 if Need_To_Create_Itype
then
8796 Constr_List
:= New_List
;
8798 Old_Index
:= First_Index
(Old_Type
);
8799 while Present
(Old_Index
) loop
8800 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8802 if Is_Discriminant
(Lo_Expr
) then
8803 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
8806 if Is_Discriminant
(Hi_Expr
) then
8807 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
8812 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
8814 Append
(Range_Node
, To
=> Constr_List
);
8816 Next_Index
(Old_Index
);
8819 return Build_Subtype
(Old_Type
, Constr_List
);
8824 end Build_Constrained_Array_Type
;
8826 ------------------------------------------
8827 -- Build_Constrained_Discriminated_Type --
8828 ------------------------------------------
8830 function Build_Constrained_Discriminated_Type
8831 (Old_Type
: Entity_Id
) return Entity_Id
8834 Constr_List
: List_Id
;
8835 Old_Constraint
: Elmt_Id
;
8837 Need_To_Create_Itype
: Boolean := False;
8840 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8841 while Present
(Old_Constraint
) loop
8842 Expr
:= Node
(Old_Constraint
);
8844 if Is_Discriminant
(Expr
) then
8845 Need_To_Create_Itype
:= True;
8848 Next_Elmt
(Old_Constraint
);
8851 if Need_To_Create_Itype
then
8852 Constr_List
:= New_List
;
8854 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8855 while Present
(Old_Constraint
) loop
8856 Expr
:= Node
(Old_Constraint
);
8858 if Is_Discriminant
(Expr
) then
8859 Expr
:= Get_Discr_Value
(Expr
);
8862 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
8864 Next_Elmt
(Old_Constraint
);
8867 return Build_Subtype
(Old_Type
, Constr_List
);
8872 end Build_Constrained_Discriminated_Type
;
8878 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
8880 Subtyp_Decl
: Node_Id
;
8882 Btyp
: Entity_Id
:= Base_Type
(T
);
8885 -- The Related_Node better be here or else we won't be able to
8886 -- attach new itypes to a node in the tree.
8888 pragma Assert
(Present
(Related_Node
));
8890 -- If the view of the component's type is incomplete or private
8891 -- with unknown discriminants, then the constraint must be applied
8892 -- to the full type.
8894 if Has_Unknown_Discriminants
(Btyp
)
8895 and then Present
(Underlying_Type
(Btyp
))
8897 Btyp
:= Underlying_Type
(Btyp
);
8901 Make_Subtype_Indication
(Loc
,
8902 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
8903 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
8905 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
8908 Make_Subtype_Declaration
(Loc
,
8909 Defining_Identifier
=> Def_Id
,
8910 Subtype_Indication
=> Indic
);
8912 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
8914 -- Itypes must be analyzed with checks off (see package Itypes)
8916 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
8921 ---------------------
8922 -- Get_Discr_Value --
8923 ---------------------
8925 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
8931 -- The discriminant may be declared for the type, in which case we
8932 -- find it by iterating over the list of discriminants. If the
8933 -- discriminant is inherited from a parent type, it appears as the
8934 -- corresponding discriminant of the current type. This will be the
8935 -- case when constraining an inherited component whose constraint is
8936 -- given by a discriminant of the parent.
8938 D
:= First_Discriminant
(Typ
);
8939 E
:= First_Elmt
(Constraints
);
8940 while Present
(D
) loop
8941 if D
= Entity
(Discrim
)
8942 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
8947 Next_Discriminant
(D
);
8951 -- The corresponding_Discriminant mechanism is incomplete, because
8952 -- the correspondence between new and old discriminants is not one
8953 -- to one: one new discriminant can constrain several old ones. In
8954 -- that case, scan sequentially the stored_constraint, the list of
8955 -- discriminants of the parents, and the constraints.
8957 if Is_Derived_Type
(Typ
)
8958 and then Present
(Stored_Constraint
(Typ
))
8959 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
8961 D
:= First_Discriminant
(Etype
(Typ
));
8962 E
:= First_Elmt
(Constraints
);
8963 G
:= First_Elmt
(Stored_Constraint
(Typ
));
8964 while Present
(D
) loop
8965 if D
= Entity
(Discrim
) then
8969 Next_Discriminant
(D
);
8975 -- Something is wrong if we did not find the value
8977 raise Program_Error
;
8978 end Get_Discr_Value
;
8980 ---------------------
8981 -- Is_Discriminant --
8982 ---------------------
8984 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
8985 Discrim_Scope
: Entity_Id
;
8988 if Denotes_Discriminant
(Expr
) then
8989 Discrim_Scope
:= Scope
(Entity
(Expr
));
8991 -- Either we have a reference to one of Typ's discriminants,
8993 pragma Assert
(Discrim_Scope
= Typ
8995 -- or to the discriminants of the parent type, in the case
8996 -- of a derivation of a tagged type with variants.
8998 or else Discrim_Scope
= Etype
(Typ
)
8999 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
9001 -- or same as above for the case where the discriminants
9002 -- were declared in Typ's private view.
9004 or else (Is_Private_Type
(Discrim_Scope
)
9005 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
9007 -- or else we are deriving from the full view and the
9008 -- discriminant is declared in the private entity.
9010 or else (Is_Private_Type
(Typ
)
9011 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
9013 -- or we have a class-wide type, in which case make sure the
9014 -- discriminant found belongs to the root type.
9016 or else (Is_Class_Wide_Type
(Typ
)
9017 and then Etype
(Typ
) = Discrim_Scope
));
9022 -- In all other cases we have something wrong
9025 end Is_Discriminant
;
9027 -- Start of processing for Constrain_Component_Type
9030 if Nkind
(Parent
(Comp
)) = N_Component_Declaration
9031 and then Comes_From_Source
(Parent
(Comp
))
9032 and then Comes_From_Source
9033 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
9036 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
9040 elsif Is_Array_Type
(Compon_Type
) then
9041 return Build_Constrained_Array_Type
(Compon_Type
);
9043 elsif Has_Discriminants
(Compon_Type
) then
9044 return Build_Constrained_Discriminated_Type
(Compon_Type
);
9046 elsif Is_Access_Type
(Compon_Type
) then
9047 return Build_Constrained_Access_Type
(Compon_Type
);
9052 end Constrain_Component_Type
;
9054 --------------------------
9055 -- Constrain_Concurrent --
9056 --------------------------
9058 -- For concurrent types, the associated record value type carries the same
9059 -- discriminants, so when we constrain a concurrent type, we must constrain
9060 -- the corresponding record type as well.
9062 procedure Constrain_Concurrent
9063 (Def_Id
: in out Entity_Id
;
9065 Related_Nod
: Node_Id
;
9066 Related_Id
: Entity_Id
;
9069 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
9073 if Ekind
(T_Ent
) in Access_Kind
then
9074 T_Ent
:= Designated_Type
(T_Ent
);
9077 T_Val
:= Corresponding_Record_Type
(T_Ent
);
9079 if Present
(T_Val
) then
9082 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
9085 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
9087 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
9088 Set_Corresponding_Record_Type
(Def_Id
,
9089 Constrain_Corresponding_Record
9090 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
9093 -- If there is no associated record, expansion is disabled and this
9094 -- is a generic context. Create a subtype in any case, so that
9095 -- semantic analysis can proceed.
9098 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
9101 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
9103 end Constrain_Concurrent
;
9105 ------------------------------------
9106 -- Constrain_Corresponding_Record --
9107 ------------------------------------
9109 function Constrain_Corresponding_Record
9110 (Prot_Subt
: Entity_Id
;
9111 Corr_Rec
: Entity_Id
;
9112 Related_Nod
: Node_Id
;
9113 Related_Id
: Entity_Id
) return Entity_Id
9115 T_Sub
: constant Entity_Id
:=
9116 Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
9119 Set_Etype
(T_Sub
, Corr_Rec
);
9120 Init_Size_Align
(T_Sub
);
9121 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
9122 Set_Is_Constrained
(T_Sub
, True);
9123 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
9124 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
9126 Conditional_Delay
(T_Sub
, Corr_Rec
);
9128 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
9129 Set_Discriminant_Constraint
9130 (T_Sub
, Discriminant_Constraint
(Prot_Subt
));
9131 Set_Stored_Constraint_From_Discriminant_Constraint
(T_Sub
);
9132 Create_Constrained_Components
9133 (T_Sub
, Related_Nod
, Corr_Rec
, Discriminant_Constraint
(T_Sub
));
9136 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
9139 end Constrain_Corresponding_Record
;
9141 -----------------------
9142 -- Constrain_Decimal --
9143 -----------------------
9145 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
9146 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9147 C
: constant Node_Id
:= Constraint
(S
);
9148 Loc
: constant Source_Ptr
:= Sloc
(C
);
9149 Range_Expr
: Node_Id
;
9150 Digits_Expr
: Node_Id
;
9155 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
9157 if Nkind
(C
) = N_Range_Constraint
then
9158 Range_Expr
:= Range_Expression
(C
);
9159 Digits_Val
:= Digits_Value
(T
);
9162 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
9163 Digits_Expr
:= Digits_Expression
(C
);
9164 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
9166 Check_Digits_Expression
(Digits_Expr
);
9167 Digits_Val
:= Expr_Value
(Digits_Expr
);
9169 if Digits_Val
> Digits_Value
(T
) then
9171 ("digits expression is incompatible with subtype", C
);
9172 Digits_Val
:= Digits_Value
(T
);
9175 if Present
(Range_Constraint
(C
)) then
9176 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
9178 Range_Expr
:= Empty
;
9182 Set_Etype
(Def_Id
, Base_Type
(T
));
9183 Set_Size_Info
(Def_Id
, (T
));
9184 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9185 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9186 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
9187 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9188 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
9189 Set_Digits_Value
(Def_Id
, Digits_Val
);
9191 -- Manufacture range from given digits value if no range present
9193 if No
(Range_Expr
) then
9194 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
9198 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
9200 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
9203 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
9204 Set_Discrete_RM_Size
(Def_Id
);
9206 -- Unconditionally delay the freeze, since we cannot set size
9207 -- information in all cases correctly until the freeze point.
9209 Set_Has_Delayed_Freeze
(Def_Id
);
9210 end Constrain_Decimal
;
9212 ----------------------------------
9213 -- Constrain_Discriminated_Type --
9214 ----------------------------------
9216 procedure Constrain_Discriminated_Type
9217 (Def_Id
: Entity_Id
;
9219 Related_Nod
: Node_Id
;
9220 For_Access
: Boolean := False)
9222 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9225 Elist
: Elist_Id
:= New_Elmt_List
;
9227 procedure Fixup_Bad_Constraint
;
9228 -- This is called after finding a bad constraint, and after having
9229 -- posted an appropriate error message. The mission is to leave the
9230 -- entity T in as reasonable state as possible!
9232 --------------------------
9233 -- Fixup_Bad_Constraint --
9234 --------------------------
9236 procedure Fixup_Bad_Constraint
is
9238 -- Set a reasonable Ekind for the entity. For an incomplete type,
9239 -- we can't do much, but for other types, we can set the proper
9240 -- corresponding subtype kind.
9242 if Ekind
(T
) = E_Incomplete_Type
then
9243 Set_Ekind
(Def_Id
, Ekind
(T
));
9245 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
9248 Set_Etype
(Def_Id
, Any_Type
);
9249 Set_Error_Posted
(Def_Id
);
9250 end Fixup_Bad_Constraint
;
9252 -- Start of processing for Constrain_Discriminated_Type
9255 C
:= Constraint
(S
);
9257 -- A discriminant constraint is only allowed in a subtype indication,
9258 -- after a subtype mark. This subtype mark must denote either a type
9259 -- with discriminants, or an access type whose designated type is a
9260 -- type with discriminants. A discriminant constraint specifies the
9261 -- values of these discriminants (RM 3.7.2(5)).
9263 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
9265 if Ekind
(T
) in Access_Kind
then
9266 T
:= Designated_Type
(T
);
9269 -- Check that the type has visible discriminants. The type may be
9270 -- a private type with unknown discriminants whose full view has
9271 -- discriminants which are invisible.
9273 if not Has_Discriminants
(T
)
9275 (Has_Unknown_Discriminants
(T
)
9276 and then Is_Private_Type
(T
))
9278 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
9279 Fixup_Bad_Constraint
;
9282 elsif Is_Constrained
(E
)
9283 or else (Ekind
(E
) = E_Class_Wide_Subtype
9284 and then Present
(Discriminant_Constraint
(E
)))
9286 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
9287 Fixup_Bad_Constraint
;
9291 -- T may be an unconstrained subtype (e.g. a generic actual).
9292 -- Constraint applies to the base type.
9296 Elist
:= Build_Discriminant_Constraints
(T
, S
);
9298 -- If the list returned was empty we had an error in building the
9299 -- discriminant constraint. We have also already signalled an error
9300 -- in the incomplete type case
9302 if Is_Empty_Elmt_List
(Elist
) then
9303 Fixup_Bad_Constraint
;
9307 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
9308 end Constrain_Discriminated_Type
;
9310 ---------------------------
9311 -- Constrain_Enumeration --
9312 ---------------------------
9314 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
9315 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9316 C
: constant Node_Id
:= Constraint
(S
);
9319 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9321 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
9323 Set_Etype
(Def_Id
, Base_Type
(T
));
9324 Set_Size_Info
(Def_Id
, (T
));
9325 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9326 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9328 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9330 Set_Discrete_RM_Size
(Def_Id
);
9331 end Constrain_Enumeration
;
9333 ----------------------
9334 -- Constrain_Float --
9335 ----------------------
9337 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
9338 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9344 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
9346 Set_Etype
(Def_Id
, Base_Type
(T
));
9347 Set_Size_Info
(Def_Id
, (T
));
9348 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9350 -- Process the constraint
9352 C
:= Constraint
(S
);
9354 -- Digits constraint present
9356 if Nkind
(C
) = N_Digits_Constraint
then
9357 Check_Restriction
(No_Obsolescent_Features
, C
);
9359 if Warn_On_Obsolescent_Feature
then
9361 ("subtype digits constraint is an " &
9362 "obsolescent feature ('R'M 'J.3(8))?", C
);
9365 D
:= Digits_Expression
(C
);
9366 Analyze_And_Resolve
(D
, Any_Integer
);
9367 Check_Digits_Expression
(D
);
9368 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
9370 -- Check that digits value is in range. Obviously we can do this
9371 -- at compile time, but it is strictly a runtime check, and of
9372 -- course there is an ACVC test that checks this!
9374 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
9375 Error_Msg_Uint_1
:= Digits_Value
(T
);
9376 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
9378 Make_Raise_Constraint_Error
(Sloc
(D
),
9379 Reason
=> CE_Range_Check_Failed
);
9380 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9383 C
:= Range_Constraint
(C
);
9385 -- No digits constraint present
9388 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
9391 -- Range constraint present
9393 if Nkind
(C
) = N_Range_Constraint
then
9394 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9396 -- No range constraint present
9399 pragma Assert
(No
(C
));
9400 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9403 Set_Is_Constrained
(Def_Id
);
9404 end Constrain_Float
;
9406 ---------------------
9407 -- Constrain_Index --
9408 ---------------------
9410 procedure Constrain_Index
9413 Related_Nod
: Node_Id
;
9414 Related_Id
: Entity_Id
;
9419 R
: Node_Id
:= Empty
;
9420 T
: constant Entity_Id
:= Etype
(Index
);
9423 if Nkind
(S
) = N_Range
9425 (Nkind
(S
) = N_Attribute_Reference
9426 and then Attribute_Name
(S
) = Name_Range
)
9428 -- A Range attribute will transformed into N_Range by Resolve
9434 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
);
9436 if not Error_Posted
(S
)
9438 (Nkind
(S
) /= N_Range
9439 or else not Covers
(T
, (Etype
(Low_Bound
(S
))))
9440 or else not Covers
(T
, (Etype
(High_Bound
(S
)))))
9442 if Base_Type
(T
) /= Any_Type
9443 and then Etype
(Low_Bound
(S
)) /= Any_Type
9444 and then Etype
(High_Bound
(S
)) /= Any_Type
9446 Error_Msg_N
("range expected", S
);
9450 elsif Nkind
(S
) = N_Subtype_Indication
then
9452 -- The parser has verified that this is a discrete indication
9454 Resolve_Discrete_Subtype_Indication
(S
, T
);
9455 R
:= Range_Expression
(Constraint
(S
));
9457 elsif Nkind
(S
) = N_Discriminant_Association
then
9459 -- Syntactically valid in subtype indication
9461 Error_Msg_N
("invalid index constraint", S
);
9462 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9465 -- Subtype_Mark case, no anonymous subtypes to construct
9470 if Is_Entity_Name
(S
) then
9471 if not Is_Type
(Entity
(S
)) then
9472 Error_Msg_N
("expect subtype mark for index constraint", S
);
9474 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
9475 Wrong_Type
(S
, Base_Type
(T
));
9481 Error_Msg_N
("invalid index constraint", S
);
9482 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9488 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
9490 Set_Etype
(Def_Id
, Base_Type
(T
));
9492 if Is_Modular_Integer_Type
(T
) then
9493 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9495 elsif Is_Integer_Type
(T
) then
9496 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9499 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9500 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9503 Set_Size_Info
(Def_Id
, (T
));
9504 Set_RM_Size
(Def_Id
, RM_Size
(T
));
9505 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9507 Set_Scalar_Range
(Def_Id
, R
);
9509 Set_Etype
(S
, Def_Id
);
9510 Set_Discrete_RM_Size
(Def_Id
);
9511 end Constrain_Index
;
9513 -----------------------
9514 -- Constrain_Integer --
9515 -----------------------
9517 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
9518 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9519 C
: constant Node_Id
:= Constraint
(S
);
9522 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9524 if Is_Modular_Integer_Type
(T
) then
9525 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9527 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9530 Set_Etype
(Def_Id
, Base_Type
(T
));
9531 Set_Size_Info
(Def_Id
, (T
));
9532 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9533 Set_Discrete_RM_Size
(Def_Id
);
9534 end Constrain_Integer
;
9536 ------------------------------
9537 -- Constrain_Ordinary_Fixed --
9538 ------------------------------
9540 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
9541 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9547 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
9548 Set_Etype
(Def_Id
, Base_Type
(T
));
9549 Set_Size_Info
(Def_Id
, (T
));
9550 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9551 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9553 -- Process the constraint
9555 C
:= Constraint
(S
);
9557 -- Delta constraint present
9559 if Nkind
(C
) = N_Delta_Constraint
then
9560 Check_Restriction
(No_Obsolescent_Features
, C
);
9562 if Warn_On_Obsolescent_Feature
then
9564 ("subtype delta constraint is an " &
9565 "obsolescent feature ('R'M 'J.3(7))?");
9568 D
:= Delta_Expression
(C
);
9569 Analyze_And_Resolve
(D
, Any_Real
);
9570 Check_Delta_Expression
(D
);
9571 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
9573 -- Check that delta value is in range. Obviously we can do this
9574 -- at compile time, but it is strictly a runtime check, and of
9575 -- course there is an ACVC test that checks this!
9577 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
9578 Error_Msg_N
("?delta value is too small", D
);
9580 Make_Raise_Constraint_Error
(Sloc
(D
),
9581 Reason
=> CE_Range_Check_Failed
);
9582 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9585 C
:= Range_Constraint
(C
);
9587 -- No delta constraint present
9590 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9593 -- Range constraint present
9595 if Nkind
(C
) = N_Range_Constraint
then
9596 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9598 -- No range constraint present
9601 pragma Assert
(No
(C
));
9602 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9606 Set_Discrete_RM_Size
(Def_Id
);
9608 -- Unconditionally delay the freeze, since we cannot set size
9609 -- information in all cases correctly until the freeze point.
9611 Set_Has_Delayed_Freeze
(Def_Id
);
9612 end Constrain_Ordinary_Fixed
;
9614 ---------------------------
9615 -- Convert_Scalar_Bounds --
9616 ---------------------------
9618 procedure Convert_Scalar_Bounds
9620 Parent_Type
: Entity_Id
;
9621 Derived_Type
: Entity_Id
;
9624 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
9631 Lo
:= Build_Scalar_Bound
9632 (Type_Low_Bound
(Derived_Type
),
9633 Parent_Type
, Implicit_Base
);
9635 Hi
:= Build_Scalar_Bound
9636 (Type_High_Bound
(Derived_Type
),
9637 Parent_Type
, Implicit_Base
);
9644 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
9646 Set_Parent
(Rng
, N
);
9647 Set_Scalar_Range
(Derived_Type
, Rng
);
9649 -- Analyze the bounds
9651 Analyze_And_Resolve
(Lo
, Implicit_Base
);
9652 Analyze_And_Resolve
(Hi
, Implicit_Base
);
9654 -- Analyze the range itself, except that we do not analyze it if
9655 -- the bounds are real literals, and we have a fixed-point type.
9656 -- The reason for this is that we delay setting the bounds in this
9657 -- case till we know the final Small and Size values (see circuit
9658 -- in Freeze.Freeze_Fixed_Point_Type for further details).
9660 if Is_Fixed_Point_Type
(Parent_Type
)
9661 and then Nkind
(Lo
) = N_Real_Literal
9662 and then Nkind
(Hi
) = N_Real_Literal
9666 -- Here we do the analysis of the range
9668 -- Note: we do this manually, since if we do a normal Analyze and
9669 -- Resolve call, there are problems with the conversions used for
9670 -- the derived type range.
9673 Set_Etype
(Rng
, Implicit_Base
);
9674 Set_Analyzed
(Rng
, True);
9676 end Convert_Scalar_Bounds
;
9682 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
) is
9684 -- Initialize new full declaration entity by copying the pertinent
9685 -- fields of the corresponding private declaration entity.
9687 -- We temporarily set Ekind to a value appropriate for a type to
9688 -- avoid assert failures in Einfo from checking for setting type
9689 -- attributes on something that is not a type. Ekind (Priv) is an
9690 -- appropriate choice, since it allowed the attributes to be set
9691 -- in the first place. This Ekind value will be modified later.
9693 Set_Ekind
(Full
, Ekind
(Priv
));
9695 -- Also set Etype temporarily to Any_Type, again, in the absence
9696 -- of errors, it will be properly reset, and if there are errors,
9697 -- then we want a value of Any_Type to remain.
9699 Set_Etype
(Full
, Any_Type
);
9701 -- Now start copying attributes
9703 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
9705 if Has_Discriminants
(Full
) then
9706 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
9707 Set_Stored_Constraint
(Full
, Stored_Constraint
(Priv
));
9710 Set_First_Rep_Item
(Full
, First_Rep_Item
(Priv
));
9711 Set_Homonym
(Full
, Homonym
(Priv
));
9712 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
9713 Set_Is_Public
(Full
, Is_Public
(Priv
));
9714 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
9715 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
9717 Conditional_Delay
(Full
, Priv
);
9719 if Is_Tagged_Type
(Full
) then
9720 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
9722 if Priv
= Base_Type
(Priv
) then
9723 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
9727 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
9728 Set_Treat_As_Volatile
(Full
, Treat_As_Volatile
(Priv
));
9729 Set_Scope
(Full
, Scope
(Priv
));
9730 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
9731 Set_First_Entity
(Full
, First_Entity
(Priv
));
9732 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
9734 -- If access types have been recorded for later handling, keep them in
9735 -- the full view so that they get handled when the full view freeze
9736 -- node is expanded.
9738 if Present
(Freeze_Node
(Priv
))
9739 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
9741 Ensure_Freeze_Node
(Full
);
9742 Set_Access_Types_To_Process
9743 (Freeze_Node
(Full
),
9744 Access_Types_To_Process
(Freeze_Node
(Priv
)));
9747 -- Swap the two entities. Now Privat is the full type entity and
9748 -- Full is the private one. They will be swapped back at the end
9749 -- of the private part. This swapping ensures that the entity that
9750 -- is visible in the private part is the full declaration.
9752 Exchange_Entities
(Priv
, Full
);
9753 Append_Entity
(Full
, Scope
(Full
));
9756 -------------------------------------
9757 -- Copy_Array_Base_Type_Attributes --
9758 -------------------------------------
9760 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
9762 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
9763 Set_Component_Type
(T1
, Component_Type
(T2
));
9764 Set_Component_Size
(T1
, Component_Size
(T2
));
9765 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
9766 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
9767 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
9768 Set_Has_Task
(T1
, Has_Task
(T2
));
9769 Set_Is_Packed
(T1
, Is_Packed
(T2
));
9770 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
9771 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
9772 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
9773 end Copy_Array_Base_Type_Attributes
;
9775 -----------------------------------
9776 -- Copy_Array_Subtype_Attributes --
9777 -----------------------------------
9779 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
9781 Set_Size_Info
(T1
, T2
);
9783 Set_First_Index
(T1
, First_Index
(T2
));
9784 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
9785 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
9786 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
9787 Set_Treat_As_Volatile
(T1
, Treat_As_Volatile
(T2
));
9788 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
9789 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
9790 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
9791 Set_Convention
(T1
, Convention
(T2
));
9792 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
9793 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
9794 end Copy_Array_Subtype_Attributes
;
9796 -----------------------------------
9797 -- Create_Constrained_Components --
9798 -----------------------------------
9800 procedure Create_Constrained_Components
9802 Decl_Node
: Node_Id
;
9804 Constraints
: Elist_Id
)
9806 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
9807 Comp_List
: constant Elist_Id
:= New_Elmt_List
;
9808 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
9809 Assoc_List
: constant List_Id
:= New_List
;
9810 Discr_Val
: Elmt_Id
;
9814 Is_Static
: Boolean := True;
9816 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
9817 -- Collect parent type components that do not appear in a variant part
9819 procedure Create_All_Components
;
9820 -- Iterate over Comp_List to create the components of the subtype
9822 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
9823 -- Creates a new component from Old_Compon, copying all the fields from
9824 -- it, including its Etype, inserts the new component in the Subt entity
9825 -- chain and returns the new component.
9827 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
9828 -- If true, and discriminants are static, collect only components from
9829 -- variants selected by discriminant values.
9831 ------------------------------
9832 -- Collect_Fixed_Components --
9833 ------------------------------
9835 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
9837 -- Build association list for discriminants, and find components of the
9838 -- variant part selected by the values of the discriminants.
9840 Old_C
:= First_Discriminant
(Typ
);
9841 Discr_Val
:= First_Elmt
(Constraints
);
9842 while Present
(Old_C
) loop
9843 Append_To
(Assoc_List
,
9844 Make_Component_Association
(Loc
,
9845 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
9846 Expression
=> New_Copy
(Node
(Discr_Val
))));
9848 Next_Elmt
(Discr_Val
);
9849 Next_Discriminant
(Old_C
);
9852 -- The tag, and the possible parent and controller components
9853 -- are unconditionally in the subtype.
9855 if Is_Tagged_Type
(Typ
)
9856 or else Has_Controlled_Component
(Typ
)
9858 Old_C
:= First_Component
(Typ
);
9859 while Present
(Old_C
) loop
9860 if Chars
((Old_C
)) = Name_uTag
9861 or else Chars
((Old_C
)) = Name_uParent
9862 or else Chars
((Old_C
)) = Name_uController
9864 Append_Elmt
(Old_C
, Comp_List
);
9867 Next_Component
(Old_C
);
9870 end Collect_Fixed_Components
;
9872 ---------------------------
9873 -- Create_All_Components --
9874 ---------------------------
9876 procedure Create_All_Components
is
9880 Comp
:= First_Elmt
(Comp_List
);
9881 while Present
(Comp
) loop
9882 Old_C
:= Node
(Comp
);
9883 New_C
:= Create_Component
(Old_C
);
9887 Constrain_Component_Type
9888 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9889 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9893 end Create_All_Components
;
9895 ----------------------
9896 -- Create_Component --
9897 ----------------------
9899 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
9900 New_Compon
: constant Entity_Id
:= New_Copy
(Old_Compon
);
9903 -- Set the parent so we have a proper link for freezing etc. This is
9904 -- not a real parent pointer, since of course our parent does not own
9905 -- up to us and reference us, we are an illegitimate child of the
9908 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
9910 -- If the old component's Esize was already determined and is a
9911 -- static value, then the new component simply inherits it. Otherwise
9912 -- the old component's size may require run-time determination, but
9913 -- the new component's size still might be statically determinable
9914 -- (if, for example it has a static constraint). In that case we want
9915 -- Layout_Type to recompute the component's size, so we reset its
9916 -- size and positional fields.
9918 if Frontend_Layout_On_Target
9919 and then not Known_Static_Esize
(Old_Compon
)
9921 Set_Esize
(New_Compon
, Uint_0
);
9922 Init_Normalized_First_Bit
(New_Compon
);
9923 Init_Normalized_Position
(New_Compon
);
9924 Init_Normalized_Position_Max
(New_Compon
);
9927 -- We do not want this node marked as Comes_From_Source, since
9928 -- otherwise it would get first class status and a separate cross-
9929 -- reference line would be generated. Illegitimate children do not
9930 -- rate such recognition.
9932 Set_Comes_From_Source
(New_Compon
, False);
9934 -- But it is a real entity, and a birth certificate must be properly
9935 -- registered by entering it into the entity list.
9937 Enter_Name
(New_Compon
);
9940 end Create_Component
;
9942 -----------------------
9943 -- Is_Variant_Record --
9944 -----------------------
9946 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
9948 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
9949 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
9950 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
9952 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
9953 end Is_Variant_Record
;
9955 -- Start of processing for Create_Constrained_Components
9958 pragma Assert
(Subt
/= Base_Type
(Subt
));
9959 pragma Assert
(Typ
= Base_Type
(Typ
));
9961 Set_First_Entity
(Subt
, Empty
);
9962 Set_Last_Entity
(Subt
, Empty
);
9964 -- Check whether constraint is fully static, in which case we can
9965 -- optimize the list of components.
9967 Discr_Val
:= First_Elmt
(Constraints
);
9968 while Present
(Discr_Val
) loop
9969 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
9974 Next_Elmt
(Discr_Val
);
9979 -- Inherit the discriminants of the parent type
9981 Old_C
:= First_Discriminant
(Typ
);
9982 while Present
(Old_C
) loop
9983 New_C
:= Create_Component
(Old_C
);
9984 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9985 Next_Discriminant
(Old_C
);
9989 and then Is_Variant_Record
(Typ
)
9991 Collect_Fixed_Components
(Typ
);
9995 Component_List
(Type_Definition
(Parent
(Typ
))),
9996 Governed_By
=> Assoc_List
,
9998 Report_Errors
=> Errors
);
9999 pragma Assert
(not Errors
);
10001 Create_All_Components
;
10003 -- If the subtype declaration is created for a tagged type derivation
10004 -- with constraints, we retrieve the record definition of the parent
10005 -- type to select the components of the proper variant.
10008 and then Is_Tagged_Type
(Typ
)
10009 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
10011 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
10012 and then Is_Variant_Record
(Parent_Type
)
10014 Collect_Fixed_Components
(Typ
);
10016 Gather_Components
(
10018 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
10019 Governed_By
=> Assoc_List
,
10021 Report_Errors
=> Errors
);
10022 pragma Assert
(not Errors
);
10024 -- If the tagged derivation has a type extension, collect all the
10025 -- new components therein.
10028 (Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
10030 Old_C
:= First_Component
(Typ
);
10031 while Present
(Old_C
) loop
10032 if Original_Record_Component
(Old_C
) = Old_C
10033 and then Chars
(Old_C
) /= Name_uTag
10034 and then Chars
(Old_C
) /= Name_uParent
10035 and then Chars
(Old_C
) /= Name_uController
10037 Append_Elmt
(Old_C
, Comp_List
);
10040 Next_Component
(Old_C
);
10044 Create_All_Components
;
10047 -- If discriminants are not static, or if this is a multi-level type
10048 -- extension, we have to include all components of the parent type.
10050 Old_C
:= First_Component
(Typ
);
10051 while Present
(Old_C
) loop
10052 New_C
:= Create_Component
(Old_C
);
10056 Constrain_Component_Type
10057 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
10058 Set_Is_Public
(New_C
, Is_Public
(Subt
));
10060 Next_Component
(Old_C
);
10065 end Create_Constrained_Components
;
10067 ------------------------------------------
10068 -- Decimal_Fixed_Point_Type_Declaration --
10069 ------------------------------------------
10071 procedure Decimal_Fixed_Point_Type_Declaration
10075 Loc
: constant Source_Ptr
:= Sloc
(Def
);
10076 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
10077 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
10078 Implicit_Base
: Entity_Id
;
10084 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
10087 Check_Restriction
(No_Fixed_Point
, Def
);
10089 -- Create implicit base type
10092 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
10093 Set_Etype
(Implicit_Base
, Implicit_Base
);
10095 -- Analyze and process delta expression
10097 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
10099 Check_Delta_Expression
(Delta_Expr
);
10100 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
10102 -- Check delta is power of 10, and determine scale value from it
10108 Scale_Val
:= Uint_0
;
10111 if Val
< Ureal_1
then
10112 while Val
< Ureal_1
loop
10113 Val
:= Val
* Ureal_10
;
10114 Scale_Val
:= Scale_Val
+ 1;
10117 if Scale_Val
> 18 then
10118 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
10119 Scale_Val
:= UI_From_Int
(+18);
10123 while Val
> Ureal_1
loop
10124 Val
:= Val
/ Ureal_10
;
10125 Scale_Val
:= Scale_Val
- 1;
10128 if Scale_Val
< -18 then
10129 Error_Msg_N
("scale is less than minimum value of -18", Def
);
10130 Scale_Val
:= UI_From_Int
(-18);
10134 if Val
/= Ureal_1
then
10135 Error_Msg_N
("delta expression must be a power of 10", Def
);
10136 Delta_Val
:= Ureal_10
** (-Scale_Val
);
10140 -- Set delta, scale and small (small = delta for decimal type)
10142 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
10143 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
10144 Set_Small_Value
(Implicit_Base
, Delta_Val
);
10146 -- Analyze and process digits expression
10148 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
10149 Check_Digits_Expression
(Digs_Expr
);
10150 Digs_Val
:= Expr_Value
(Digs_Expr
);
10152 if Digs_Val
> 18 then
10153 Digs_Val
:= UI_From_Int
(+18);
10154 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
10157 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
10158 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
10160 -- Set range of base type from digits value for now. This will be
10161 -- expanded to represent the true underlying base range by Freeze.
10163 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
10165 -- Set size to zero for now, size will be set at freeze time. We have
10166 -- to do this for ordinary fixed-point, because the size depends on
10167 -- the specified small, and we might as well do the same for decimal
10170 Init_Size_Align
(Implicit_Base
);
10172 -- If there are bounds given in the declaration use them as the
10173 -- bounds of the first named subtype.
10175 if Present
(Real_Range_Specification
(Def
)) then
10177 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
10178 Low
: constant Node_Id
:= Low_Bound
(RRS
);
10179 High
: constant Node_Id
:= High_Bound
(RRS
);
10184 Analyze_And_Resolve
(Low
, Any_Real
);
10185 Analyze_And_Resolve
(High
, Any_Real
);
10186 Check_Real_Bound
(Low
);
10187 Check_Real_Bound
(High
);
10188 Low_Val
:= Expr_Value_R
(Low
);
10189 High_Val
:= Expr_Value_R
(High
);
10191 if Low_Val
< (-Bound_Val
) then
10193 ("range low bound too small for digits value", Low
);
10194 Low_Val
:= -Bound_Val
;
10197 if High_Val
> Bound_Val
then
10199 ("range high bound too large for digits value", High
);
10200 High_Val
:= Bound_Val
;
10203 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
10206 -- If no explicit range, use range that corresponds to given
10207 -- digits value. This will end up as the final range for the
10211 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
10214 -- Complete entity for first subtype
10216 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
10217 Set_Etype
(T
, Implicit_Base
);
10218 Set_Size_Info
(T
, Implicit_Base
);
10219 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
10220 Set_Digits_Value
(T
, Digs_Val
);
10221 Set_Delta_Value
(T
, Delta_Val
);
10222 Set_Small_Value
(T
, Delta_Val
);
10223 Set_Scale_Value
(T
, Scale_Val
);
10224 Set_Is_Constrained
(T
);
10225 end Decimal_Fixed_Point_Type_Declaration
;
10227 ---------------------------------
10228 -- Derive_Interface_Subprogram --
10229 ---------------------------------
10231 procedure Derive_Interface_Subprograms
(Derived_Type
: Entity_Id
) is
10233 procedure Do_Derivation
(T
: Entity_Id
);
10234 -- This inner subprograms is used to climb to the ancestors.
10235 -- It is needed to add the derivations to the Derived_Type.
10237 procedure Do_Derivation
(T
: Entity_Id
) is
10238 Etyp
: constant Entity_Id
:= Etype
(T
);
10243 and then Is_Interface
(Etyp
)
10245 Do_Derivation
(Etyp
);
10248 if Present
(Abstract_Interfaces
(T
))
10249 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(T
))
10251 AI
:= First_Elmt
(Abstract_Interfaces
(T
));
10252 while Present
(AI
) loop
10253 if not Is_Ancestor
(Node
(AI
), Derived_Type
) then
10255 (Parent_Type
=> Node
(AI
),
10256 Derived_Type
=> Derived_Type
,
10257 No_Predefined_Prims
=> True);
10266 Do_Derivation
(Derived_Type
);
10268 -- At this point the list of primitive operations of Derived_Type
10269 -- contains the entities corresponding to all the subprograms of all the
10270 -- implemented interfaces. If N interfaces have subprograms with the
10271 -- same profile we have N entities in this list because each one must be
10272 -- allocated in its corresponding virtual table.
10274 -- Its alias attribute references its original interface subprogram.
10275 -- When overridden, the alias attribute is later saved in the
10276 -- Abstract_Interface_Alias attribute.
10278 end Derive_Interface_Subprograms
;
10280 -----------------------
10281 -- Derive_Subprogram --
10282 -----------------------
10284 procedure Derive_Subprogram
10285 (New_Subp
: in out Entity_Id
;
10286 Parent_Subp
: Entity_Id
;
10287 Derived_Type
: Entity_Id
;
10288 Parent_Type
: Entity_Id
;
10289 Actual_Subp
: Entity_Id
:= Empty
)
10291 Formal
: Entity_Id
;
10292 New_Formal
: Entity_Id
;
10293 Visible_Subp
: Entity_Id
:= Parent_Subp
;
10295 function Is_Private_Overriding
return Boolean;
10296 -- If Subp is a private overriding of a visible operation, the in-
10297 -- herited operation derives from the overridden op (even though
10298 -- its body is the overriding one) and the inherited operation is
10299 -- visible now. See sem_disp to see the details of the handling of
10300 -- the overridden subprogram, which is removed from the list of
10301 -- primitive operations of the type. The overridden subprogram is
10302 -- saved locally in Visible_Subp, and used to diagnose abstract
10303 -- operations that need overriding in the derived type.
10305 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
10306 -- When the type is an anonymous access type, create a new access type
10307 -- designating the derived type.
10309 procedure Set_Derived_Name
;
10310 -- This procedure sets the appropriate Chars name for New_Subp. This
10311 -- is normally just a copy of the parent name. An exception arises for
10312 -- type support subprograms, where the name is changed to reflect the
10313 -- name of the derived type, e.g. if type foo is derived from type bar,
10314 -- then a procedure barDA is derived with a name fooDA.
10316 ---------------------------
10317 -- Is_Private_Overriding --
10318 ---------------------------
10320 function Is_Private_Overriding
return Boolean is
10324 -- The visible operation that is overridden is a homonym of the
10325 -- parent subprogram. We scan the homonym chain to find the one
10326 -- whose alias is the subprogram we are deriving.
10328 Prev
:= Current_Entity
(Parent_Subp
);
10329 while Present
(Prev
) loop
10330 if Is_Dispatching_Operation
(Parent_Subp
)
10331 and then Present
(Prev
)
10332 and then Ekind
(Prev
) = Ekind
(Parent_Subp
)
10333 and then Alias
(Prev
) = Parent_Subp
10334 and then Scope
(Parent_Subp
) = Scope
(Prev
)
10336 (not Is_Hidden
(Prev
)
10339 -- Ada 2005 (AI-251): Entities associated with overridden
10340 -- interface subprograms are always marked as hidden; in
10341 -- this case the field abstract_interface_alias references
10342 -- the original entity (cf. override_dispatching_operation).
10344 (Atree
.Present
(Abstract_Interface_Alias
(Prev
))
10345 and then not Is_Hidden
(Abstract_Interface_Alias
(Prev
))))
10347 Visible_Subp
:= Prev
;
10351 Prev
:= Homonym
(Prev
);
10355 end Is_Private_Overriding
;
10361 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
10362 Acc_Type
: Entity_Id
;
10364 Par
: constant Node_Id
:= Parent
(Derived_Type
);
10367 -- When the type is an anonymous access type, create a new access
10368 -- type designating the derived type. This itype must be elaborated
10369 -- at the point of the derivation, not on subsequent calls that may
10370 -- be out of the proper scope for Gigi, so we insert a reference to
10371 -- it after the derivation.
10373 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
10375 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
10378 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
10379 and then Present
(Full_View
(Desig_Typ
))
10380 and then not Is_Private_Type
(Parent_Type
)
10382 Desig_Typ
:= Full_View
(Desig_Typ
);
10385 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
) then
10386 Acc_Type
:= New_Copy
(Etype
(Id
));
10387 Set_Etype
(Acc_Type
, Acc_Type
);
10388 Set_Scope
(Acc_Type
, New_Subp
);
10390 -- Compute size of anonymous access type
10392 if Is_Array_Type
(Desig_Typ
)
10393 and then not Is_Constrained
(Desig_Typ
)
10395 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
10397 Init_Size
(Acc_Type
, System_Address_Size
);
10400 Init_Alignment
(Acc_Type
);
10401 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
10403 Set_Etype
(New_Id
, Acc_Type
);
10404 Set_Scope
(New_Id
, New_Subp
);
10406 -- Create a reference to it
10408 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
10409 Set_Itype
(IR
, Acc_Type
);
10410 Insert_After
(Parent
(Derived_Type
), IR
);
10413 Set_Etype
(New_Id
, Etype
(Id
));
10417 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
10419 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
10420 and then Present
(Full_View
(Etype
(Id
)))
10422 Base_Type
(Full_View
(Etype
(Id
))) = Base_Type
(Parent_Type
))
10424 -- Constraint checks on formals are generated during expansion,
10425 -- based on the signature of the original subprogram. The bounds
10426 -- of the derived type are not relevant, and thus we can use
10427 -- the base type for the formals. However, the return type may be
10428 -- used in a context that requires that the proper static bounds
10429 -- be used (a case statement, for example) and for those cases
10430 -- we must use the derived type (first subtype), not its base.
10432 -- If the derived_type_definition has no constraints, we know that
10433 -- the derived type has the same constraints as the first subtype
10434 -- of the parent, and we can also use it rather than its base,
10435 -- which can lead to more efficient code.
10437 if Etype
(Id
) = Parent_Type
then
10438 if Is_Scalar_Type
(Parent_Type
)
10440 Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
)
10442 Set_Etype
(New_Id
, Derived_Type
);
10444 elsif Nkind
(Par
) = N_Full_Type_Declaration
10446 Nkind
(Type_Definition
(Par
)) = N_Derived_Type_Definition
10449 (Subtype_Indication
(Type_Definition
(Par
)))
10451 Set_Etype
(New_Id
, Derived_Type
);
10454 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10458 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10462 Set_Etype
(New_Id
, Etype
(Id
));
10466 ----------------------
10467 -- Set_Derived_Name --
10468 ----------------------
10470 procedure Set_Derived_Name
is
10471 Nm
: constant TSS_Name_Type
:= Get_TSS_Name
(Parent_Subp
);
10473 if Nm
= TSS_Null
then
10474 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
10476 Set_Chars
(New_Subp
, Make_TSS_Name
(Base_Type
(Derived_Type
), Nm
));
10478 end Set_Derived_Name
;
10480 -- Start of processing for Derive_Subprogram
10484 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
10485 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
10487 -- Check whether the inherited subprogram is a private operation that
10488 -- should be inherited but not yet made visible. Such subprograms can
10489 -- become visible at a later point (e.g., the private part of a public
10490 -- child unit) via Declare_Inherited_Private_Subprograms. If the
10491 -- following predicate is true, then this is not such a private
10492 -- operation and the subprogram simply inherits the name of the parent
10493 -- subprogram. Note the special check for the names of controlled
10494 -- operations, which are currently exempted from being inherited with
10495 -- a hidden name because they must be findable for generation of
10496 -- implicit run-time calls.
10498 if not Is_Hidden
(Parent_Subp
)
10499 or else Is_Internal
(Parent_Subp
)
10500 or else Is_Private_Overriding
10501 or else Is_Internal_Name
(Chars
(Parent_Subp
))
10502 or else Chars
(Parent_Subp
) = Name_Initialize
10503 or else Chars
(Parent_Subp
) = Name_Adjust
10504 or else Chars
(Parent_Subp
) = Name_Finalize
10508 -- If parent is hidden, this can be a regular derivation if the
10509 -- parent is immediately visible in a non-instantiating context,
10510 -- or if we are in the private part of an instance. This test
10511 -- should still be refined ???
10513 -- The test for In_Instance_Not_Visible avoids inheriting the derived
10514 -- operation as a non-visible operation in cases where the parent
10515 -- subprogram might not be visible now, but was visible within the
10516 -- original generic, so it would be wrong to make the inherited
10517 -- subprogram non-visible now. (Not clear if this test is fully
10518 -- correct; are there any cases where we should declare the inherited
10519 -- operation as not visible to avoid it being overridden, e.g., when
10520 -- the parent type is a generic actual with private primitives ???)
10522 -- (they should be treated the same as other private inherited
10523 -- subprograms, but it's not clear how to do this cleanly). ???
10525 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
10526 and then Is_Immediately_Visible
(Parent_Subp
)
10527 and then not In_Instance
)
10528 or else In_Instance_Not_Visible
10532 -- The type is inheriting a private operation, so enter
10533 -- it with a special name so it can't be overridden.
10536 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
10539 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
10540 Replace_Type
(Parent_Subp
, New_Subp
);
10541 Conditional_Delay
(New_Subp
, Parent_Subp
);
10543 Formal
:= First_Formal
(Parent_Subp
);
10544 while Present
(Formal
) loop
10545 New_Formal
:= New_Copy
(Formal
);
10547 -- Normally we do not go copying parents, but in the case of
10548 -- formals, we need to link up to the declaration (which is the
10549 -- parameter specification), and it is fine to link up to the
10550 -- original formal's parameter specification in this case.
10552 Set_Parent
(New_Formal
, Parent
(Formal
));
10554 Append_Entity
(New_Formal
, New_Subp
);
10556 Replace_Type
(Formal
, New_Formal
);
10557 Next_Formal
(Formal
);
10560 -- If this derivation corresponds to a tagged generic actual, then
10561 -- primitive operations rename those of the actual. Otherwise the
10562 -- primitive operations rename those of the parent type, If the
10563 -- parent renames an intrinsic operator, so does the new subprogram.
10564 -- We except concatenation, which is always properly typed, and does
10565 -- not get expanded as other intrinsic operations.
10567 if No
(Actual_Subp
) then
10568 if Is_Intrinsic_Subprogram
(Parent_Subp
) then
10569 Set_Is_Intrinsic_Subprogram
(New_Subp
);
10571 if Present
(Alias
(Parent_Subp
))
10572 and then Chars
(Parent_Subp
) /= Name_Op_Concat
10574 Set_Alias
(New_Subp
, Alias
(Parent_Subp
));
10576 Set_Alias
(New_Subp
, Parent_Subp
);
10580 Set_Alias
(New_Subp
, Parent_Subp
);
10584 Set_Alias
(New_Subp
, Actual_Subp
);
10587 -- Derived subprograms of a tagged type must inherit the convention
10588 -- of the parent subprogram (a requirement of AI-117). Derived
10589 -- subprograms of untagged types simply get convention Ada by default.
10591 if Is_Tagged_Type
(Derived_Type
) then
10592 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
10595 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
10596 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
10598 if Ekind
(Parent_Subp
) = E_Procedure
then
10599 Set_Is_Valued_Procedure
10600 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
10603 -- No_Return must be inherited properly. If this is overridden in the
10604 -- case of a dispatching operation, then a check is made in Sem_Disp
10605 -- that the overriding operation is also No_Return (no such check is
10606 -- required for the case of non-dispatching operation.
10608 Set_No_Return
(New_Subp
, No_Return
(Parent_Subp
));
10610 -- A derived function with a controlling result is abstract. If the
10611 -- Derived_Type is a nonabstract formal generic derived type, then
10612 -- inherited operations are not abstract: the required check is done at
10613 -- instantiation time. If the derivation is for a generic actual, the
10614 -- function is not abstract unless the actual is.
10616 if Is_Generic_Type
(Derived_Type
)
10617 and then not Is_Abstract
(Derived_Type
)
10621 elsif Is_Abstract
(Alias
(New_Subp
))
10622 or else (Is_Tagged_Type
(Derived_Type
)
10623 and then Etype
(New_Subp
) = Derived_Type
10624 and then No
(Actual_Subp
))
10626 Set_Is_Abstract
(New_Subp
);
10628 -- Finally, if the parent type is abstract we must verify that all
10629 -- inherited operations are either non-abstract or overridden, or
10630 -- that the derived type itself is abstract (this check is performed
10631 -- at the end of a package declaration, in Check_Abstract_Overriding).
10632 -- A private overriding in the parent type will not be visible in the
10633 -- derivation if we are not in an inner package or in a child unit of
10634 -- the parent type, in which case the abstractness of the inherited
10635 -- operation is carried to the new subprogram.
10637 elsif Is_Abstract
(Parent_Type
)
10638 and then not In_Open_Scopes
(Scope
(Parent_Type
))
10639 and then Is_Private_Overriding
10640 and then Is_Abstract
(Visible_Subp
)
10642 Set_Alias
(New_Subp
, Visible_Subp
);
10643 Set_Is_Abstract
(New_Subp
);
10646 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
10648 -- Check for case of a derived subprogram for the instantiation of a
10649 -- formal derived tagged type, if so mark the subprogram as dispatching
10650 -- and inherit the dispatching attributes of the parent subprogram. The
10651 -- derived subprogram is effectively renaming of the actual subprogram,
10652 -- so it needs to have the same attributes as the actual.
10654 if Present
(Actual_Subp
)
10655 and then Is_Dispatching_Operation
(Parent_Subp
)
10657 Set_Is_Dispatching_Operation
(New_Subp
);
10658 if Present
(DTC_Entity
(Parent_Subp
)) then
10659 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
10660 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
10664 -- Indicate that a derived subprogram does not require a body and that
10665 -- it does not require processing of default expressions.
10667 Set_Has_Completion
(New_Subp
);
10668 Set_Default_Expressions_Processed
(New_Subp
);
10670 if Ekind
(New_Subp
) = E_Function
then
10671 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
10673 end Derive_Subprogram
;
10675 ------------------------
10676 -- Derive_Subprograms --
10677 ------------------------
10679 procedure Derive_Subprograms
10680 (Parent_Type
: Entity_Id
;
10681 Derived_Type
: Entity_Id
;
10682 Generic_Actual
: Entity_Id
:= Empty
;
10683 No_Predefined_Prims
: Boolean := False)
10685 Op_List
: constant Elist_Id
:=
10686 Collect_Primitive_Operations
(Parent_Type
);
10687 Act_List
: Elist_Id
;
10688 Act_Elmt
: Elmt_Id
;
10690 Is_Predef
: Boolean;
10692 New_Subp
: Entity_Id
:= Empty
;
10693 Parent_Base
: Entity_Id
;
10696 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
10697 and then Has_Discriminants
(Parent_Type
)
10698 and then Present
(Full_View
(Parent_Type
))
10700 Parent_Base
:= Full_View
(Parent_Type
);
10702 Parent_Base
:= Parent_Type
;
10705 if Present
(Generic_Actual
) then
10706 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
10707 Act_Elmt
:= First_Elmt
(Act_List
);
10709 Act_Elmt
:= No_Elmt
;
10712 -- Literals are derived earlier in the process of building the derived
10713 -- type, and are skipped here.
10715 Elmt
:= First_Elmt
(Op_List
);
10716 while Present
(Elmt
) loop
10717 Subp
:= Node
(Elmt
);
10719 if Ekind
(Subp
) /= E_Enumeration_Literal
then
10721 Is_Dispatching_Operation
(Subp
)
10722 and then Is_Predefined_Dispatching_Operation
(Subp
);
10724 if No_Predefined_Prims
and then Is_Predef
then
10727 -- We don't need to derive alias entities associated with
10728 -- abstract interfaces
10730 elsif Is_Dispatching_Operation
(Subp
)
10731 and then Present
(Alias
(Subp
))
10732 and then Present
(Abstract_Interface_Alias
(Subp
))
10736 elsif No
(Generic_Actual
) then
10738 (New_Subp
, Subp
, Derived_Type
, Parent_Base
);
10741 Derive_Subprogram
(New_Subp
, Subp
,
10742 Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
10743 Next_Elmt
(Act_Elmt
);
10749 end Derive_Subprograms
;
10751 --------------------------------
10752 -- Derived_Standard_Character --
10753 --------------------------------
10755 procedure Derived_Standard_Character
10757 Parent_Type
: Entity_Id
;
10758 Derived_Type
: Entity_Id
)
10760 Loc
: constant Source_Ptr
:= Sloc
(N
);
10761 Def
: constant Node_Id
:= Type_Definition
(N
);
10762 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10763 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
10764 Implicit_Base
: constant Entity_Id
:=
10766 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
10772 Discard_Node
(Process_Subtype
(Indic
, N
));
10774 Set_Etype
(Implicit_Base
, Parent_Base
);
10775 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
10776 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
10778 Set_Is_Character_Type
(Implicit_Base
, True);
10779 Set_Has_Delayed_Freeze
(Implicit_Base
);
10781 -- The bounds of the implicit base are the bounds of the parent base.
10782 -- Note that their type is the parent base.
10784 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
10785 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
10787 Set_Scalar_Range
(Implicit_Base
,
10790 High_Bound
=> Hi
));
10792 Conditional_Delay
(Derived_Type
, Parent_Type
);
10794 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
10795 Set_Etype
(Derived_Type
, Implicit_Base
);
10796 Set_Size_Info
(Derived_Type
, Parent_Type
);
10798 if Unknown_RM_Size
(Derived_Type
) then
10799 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
10802 Set_Is_Character_Type
(Derived_Type
, True);
10804 if Nkind
(Indic
) /= N_Subtype_Indication
then
10806 -- If no explicit constraint, the bounds are those
10807 -- of the parent type.
10809 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
10810 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
10811 Set_Scalar_Range
(Derived_Type
, Make_Range
(Loc
, Lo
, Hi
));
10814 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
10816 -- Because the implicit base is used in the conversion of the bounds,
10817 -- we have to freeze it now. This is similar to what is done for
10818 -- numeric types, and it equally suspicious, but otherwise a non-
10819 -- static bound will have a reference to an unfrozen type, which is
10820 -- rejected by Gigi (???).
10822 Freeze_Before
(N
, Implicit_Base
);
10823 end Derived_Standard_Character
;
10825 ------------------------------
10826 -- Derived_Type_Declaration --
10827 ------------------------------
10829 procedure Derived_Type_Declaration
10832 Is_Completion
: Boolean)
10834 Def
: constant Node_Id
:= Type_Definition
(N
);
10835 Iface_Def
: Node_Id
;
10836 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10837 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
10838 Parent_Type
: Entity_Id
;
10839 Parent_Scope
: Entity_Id
;
10842 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean;
10843 -- Check whether the parent type is a generic formal, or derives
10844 -- directly or indirectly from one.
10846 ------------------------
10847 -- Comes_From_Generic --
10848 ------------------------
10850 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean is
10852 if Is_Generic_Type
(Typ
) then
10855 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
10858 elsif Is_Private_Type
(Typ
)
10859 and then Present
(Full_View
(Typ
))
10860 and then Is_Generic_Type
(Root_Type
(Full_View
(Typ
)))
10864 elsif Is_Generic_Actual_Type
(Typ
) then
10870 end Comes_From_Generic
;
10872 -- Start of processing for Derived_Type_Declaration
10875 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
10877 -- Ada 2005 (AI-251): In case of interface derivation check that the
10878 -- parent is also an interface.
10880 if Interface_Present
(Def
) then
10881 if not Is_Interface
(Parent_Type
) then
10882 Error_Msg_NE
("(Ada 2005) & must be an interface",
10883 Indic
, Parent_Type
);
10886 Iface_Def
:= Type_Definition
(Parent
(Parent_Type
));
10888 -- Ada 2005 (AI-251): Limited interfaces can only inherit from
10889 -- other limited interfaces.
10891 if Limited_Present
(Def
) then
10892 if Limited_Present
(Iface_Def
) then
10895 elsif Protected_Present
(Iface_Def
) then
10896 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10897 " inherit from protected interface", Indic
);
10899 elsif Synchronized_Present
(Iface_Def
) then
10900 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10901 " inherit from synchronized interface", Indic
);
10903 elsif Task_Present
(Iface_Def
) then
10904 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10905 " inherit from task interface", Indic
);
10908 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10909 " inherit from non-limited interface", Indic
);
10912 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
10913 -- from non-limited or limited interfaces.
10915 elsif not Protected_Present
(Def
)
10916 and then not Synchronized_Present
(Def
)
10917 and then not Task_Present
(Def
)
10919 if Limited_Present
(Iface_Def
) then
10922 elsif Protected_Present
(Iface_Def
) then
10923 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10924 " inherit from protected interface", Indic
);
10926 elsif Synchronized_Present
(Iface_Def
) then
10927 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10928 " inherit from synchronized interface", Indic
);
10930 elsif Task_Present
(Iface_Def
) then
10931 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10932 " inherit from task interface", Indic
);
10941 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
10944 if Is_Tagged_Type
(Parent_Type
)
10945 and then Is_Non_Empty_List
(Interface_List
(Def
))
10952 Intf
:= First
(Interface_List
(Def
));
10953 while Present
(Intf
) loop
10954 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
10956 if not Is_Interface
(T
) then
10957 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
10959 elsif Limited_Present
(Def
)
10960 and then not Is_Limited_Interface
(T
)
10963 ("progenitor interface& of limited type must be limited",
10972 if Parent_Type
= Any_Type
10973 or else Etype
(Parent_Type
) = Any_Type
10974 or else (Is_Class_Wide_Type
(Parent_Type
)
10975 and then Etype
(Parent_Type
) = T
)
10977 -- If Parent_Type is undefined or illegal, make new type into a
10978 -- subtype of Any_Type, and set a few attributes to prevent cascaded
10979 -- errors. If this is a self-definition, emit error now.
10982 or else T
= Etype
(Parent_Type
)
10984 Error_Msg_N
("type cannot be used in its own definition", Indic
);
10987 Set_Ekind
(T
, Ekind
(Parent_Type
));
10988 Set_Etype
(T
, Any_Type
);
10989 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
10991 if Is_Tagged_Type
(T
) then
10992 Set_Primitive_Operations
(T
, New_Elmt_List
);
10998 -- Ada 2005 (AI-251): The case in which the parent of the full-view is
10999 -- an interface is special because the list of interfaces in the full
11000 -- view can be given in any order. For example:
11002 -- type A is interface;
11003 -- type B is interface and A;
11004 -- type D is new B with private;
11006 -- type D is new A and B with null record; -- 1 --
11008 -- In this case we perform the following transformation of -1-:
11010 -- type D is new B and A with null record;
11012 -- If the parent of the full-view covers the parent of the partial-view
11013 -- we have two possible cases:
11015 -- 1) They have the same parent
11016 -- 2) The parent of the full-view implements some further interfaces
11018 -- In both cases we do not need to perform the transformation. In the
11019 -- first case the source program is correct and the transformation is
11020 -- not needed; in the second case the source program does not fulfill
11021 -- the no-hidden interfaces rule (AI-396) and the error will be reported
11024 -- This transformation not only simplifies the rest of the analysis of
11025 -- this type declaration but also simplifies the correct generation of
11026 -- the object layout to the expander.
11028 if In_Private_Part
(Current_Scope
)
11029 and then Is_Interface
(Parent_Type
)
11033 Partial_View
: Entity_Id
;
11034 Partial_View_Parent
: Entity_Id
;
11035 New_Iface
: Node_Id
;
11038 -- Look for the associated private type declaration
11040 Partial_View
:= First_Entity
(Current_Scope
);
11042 exit when No
(Partial_View
)
11043 or else (Has_Private_Declaration
(Partial_View
)
11044 and then Full_View
(Partial_View
) = T
);
11046 Next_Entity
(Partial_View
);
11049 -- If the partial view was not found then the source code has
11050 -- errors and the transformation is not needed.
11052 if Present
(Partial_View
) then
11053 Partial_View_Parent
:= Etype
(Partial_View
);
11055 -- If the parent of the full-view covers the parent of the
11056 -- partial-view we have nothing else to do.
11058 if Interface_Present_In_Ancestor
11059 (Parent_Type
, Partial_View_Parent
)
11063 -- Traverse the list of interfaces of the full-view to look
11064 -- for the parent of the partial-view and perform the tree
11068 Iface
:= First
(Interface_List
(Def
));
11069 while Present
(Iface
) loop
11070 if Etype
(Iface
) = Etype
(Partial_View
) then
11071 Rewrite
(Subtype_Indication
(Def
),
11072 New_Copy
(Subtype_Indication
11073 (Parent
(Partial_View
))));
11075 New_Iface
:= Make_Identifier
(Sloc
(N
),
11076 Chars
(Parent_Type
));
11077 Append
(New_Iface
, Interface_List
(Def
));
11079 -- Analyze the transformed code
11081 Derived_Type_Declaration
(T
, N
, Is_Completion
);
11092 -- Only composite types other than array types are allowed to have
11095 if Present
(Discriminant_Specifications
(N
))
11096 and then (Is_Elementary_Type
(Parent_Type
)
11097 or else Is_Array_Type
(Parent_Type
))
11098 and then not Error_Posted
(N
)
11101 ("elementary or array type cannot have discriminants",
11102 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
11103 Set_Has_Discriminants
(T
, False);
11106 -- In Ada 83, a derived type defined in a package specification cannot
11107 -- be used for further derivation until the end of its visible part.
11108 -- Note that derivation in the private part of the package is allowed.
11110 if Ada_Version
= Ada_83
11111 and then Is_Derived_Type
(Parent_Type
)
11112 and then In_Visible_Part
(Scope
(Parent_Type
))
11114 if Ada_Version
= Ada_83
and then Comes_From_Source
(Indic
) then
11116 ("(Ada 83): premature use of type for derivation", Indic
);
11120 -- Check for early use of incomplete or private type
11122 if Ekind
(Parent_Type
) = E_Void
11123 or else Ekind
(Parent_Type
) = E_Incomplete_Type
11125 Error_Msg_N
("premature derivation of incomplete type", Indic
);
11128 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
11129 and then not Comes_From_Generic
(Parent_Type
))
11130 or else Has_Private_Component
(Parent_Type
)
11132 -- The ancestor type of a formal type can be incomplete, in which
11133 -- case only the operations of the partial view are available in
11134 -- the generic. Subsequent checks may be required when the full
11135 -- view is analyzed, to verify that derivation from a tagged type
11136 -- has an extension.
11138 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
11141 elsif No
(Underlying_Type
(Parent_Type
))
11142 or else Has_Private_Component
(Parent_Type
)
11145 ("premature derivation of derived or private type", Indic
);
11147 -- Flag the type itself as being in error, this prevents some
11148 -- nasty problems with subsequent uses of the malformed type.
11150 Set_Error_Posted
(T
);
11152 -- Check that within the immediate scope of an untagged partial
11153 -- view it's illegal to derive from the partial view if the
11154 -- full view is tagged. (7.3(7))
11156 -- We verify that the Parent_Type is a partial view by checking
11157 -- that it is not a Full_Type_Declaration (i.e. a private type or
11158 -- private extension declaration), to distinguish a partial view
11159 -- from a derivation from a private type which also appears as
11162 elsif Present
(Full_View
(Parent_Type
))
11163 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
11164 and then not Is_Tagged_Type
(Parent_Type
)
11165 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
11167 Parent_Scope
:= Scope
(T
);
11168 while Present
(Parent_Scope
)
11169 and then Parent_Scope
/= Standard_Standard
11171 if Parent_Scope
= Scope
(Parent_Type
) then
11173 ("premature derivation from type with tagged full view",
11177 Parent_Scope
:= Scope
(Parent_Scope
);
11182 -- Check that form of derivation is appropriate
11184 Taggd
:= Is_Tagged_Type
(Parent_Type
);
11186 -- Perhaps the parent type should be changed to the class-wide type's
11187 -- specific type in this case to prevent cascading errors ???
11189 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
11190 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
11194 if Present
(Extension
) and then not Taggd
then
11196 ("type derived from untagged type cannot have extension", Indic
);
11198 elsif No
(Extension
) and then Taggd
then
11200 -- If this declaration is within a private part (or body) of a
11201 -- generic instantiation then the derivation is allowed (the parent
11202 -- type can only appear tagged in this case if it's a generic actual
11203 -- type, since it would otherwise have been rejected in the analysis
11204 -- of the generic template).
11206 if not Is_Generic_Actual_Type
(Parent_Type
)
11207 or else In_Visible_Part
(Scope
(Parent_Type
))
11210 ("type derived from tagged type must have extension", Indic
);
11214 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
11216 -- AI-419: the parent type of an explicitly limited derived type must
11217 -- be a limited type or a limited interface.
11219 if Limited_Present
(Def
) then
11220 Set_Is_Limited_Record
(T
);
11222 if Is_Interface
(T
) then
11223 Set_Is_Limited_Interface
(T
);
11226 if not Is_Limited_Type
(Parent_Type
)
11228 (not Is_Interface
(Parent_Type
)
11229 or else not Is_Limited_Interface
(Parent_Type
))
11231 Error_Msg_NE
("parent type& of limited type must be limited",
11235 end Derived_Type_Declaration
;
11237 ----------------------------------
11238 -- Enumeration_Type_Declaration --
11239 ----------------------------------
11241 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11248 -- Create identifier node representing lower bound
11250 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11251 L
:= First
(Literals
(Def
));
11252 Set_Chars
(B_Node
, Chars
(L
));
11253 Set_Entity
(B_Node
, L
);
11254 Set_Etype
(B_Node
, T
);
11255 Set_Is_Static_Expression
(B_Node
, True);
11257 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
11258 Set_Low_Bound
(R_Node
, B_Node
);
11260 Set_Ekind
(T
, E_Enumeration_Type
);
11261 Set_First_Literal
(T
, L
);
11263 Set_Is_Constrained
(T
);
11267 -- Loop through literals of enumeration type setting pos and rep values
11268 -- except that if the Ekind is already set, then it means that the
11269 -- literal was already constructed (case of a derived type declaration
11270 -- and we should not disturb the Pos and Rep values.
11272 while Present
(L
) loop
11273 if Ekind
(L
) /= E_Enumeration_Literal
then
11274 Set_Ekind
(L
, E_Enumeration_Literal
);
11275 Set_Enumeration_Pos
(L
, Ev
);
11276 Set_Enumeration_Rep
(L
, Ev
);
11277 Set_Is_Known_Valid
(L
, True);
11281 New_Overloaded_Entity
(L
);
11282 Generate_Definition
(L
);
11283 Set_Convention
(L
, Convention_Intrinsic
);
11285 if Nkind
(L
) = N_Defining_Character_Literal
then
11286 Set_Is_Character_Type
(T
, True);
11293 -- Now create a node representing upper bound
11295 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11296 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
11297 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
11298 Set_Etype
(B_Node
, T
);
11299 Set_Is_Static_Expression
(B_Node
, True);
11301 Set_High_Bound
(R_Node
, B_Node
);
11302 Set_Scalar_Range
(T
, R_Node
);
11303 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
11304 Set_Enum_Esize
(T
);
11306 -- Set Discard_Names if configuration pragma set, or if there is
11307 -- a parameterless pragma in the current declarative region
11309 if Global_Discard_Names
11310 or else Discard_Names
(Scope
(T
))
11312 Set_Discard_Names
(T
);
11315 -- Process end label if there is one
11317 if Present
(Def
) then
11318 Process_End_Label
(Def
, 'e', T
);
11320 end Enumeration_Type_Declaration
;
11322 ---------------------------------
11323 -- Expand_To_Stored_Constraint --
11324 ---------------------------------
11326 function Expand_To_Stored_Constraint
11328 Constraint
: Elist_Id
) return Elist_Id
11330 Explicitly_Discriminated_Type
: Entity_Id
;
11331 Expansion
: Elist_Id
;
11332 Discriminant
: Entity_Id
;
11334 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
11335 -- Find the nearest type that actually specifies discriminants
11337 ---------------------------------
11338 -- Type_With_Explicit_Discrims --
11339 ---------------------------------
11341 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
11342 Typ
: constant E
:= Base_Type
(Id
);
11345 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
11346 if Present
(Full_View
(Typ
)) then
11347 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
11351 if Has_Discriminants
(Typ
) then
11356 if Etype
(Typ
) = Typ
then
11358 elsif Has_Discriminants
(Typ
) then
11361 return Type_With_Explicit_Discrims
(Etype
(Typ
));
11364 end Type_With_Explicit_Discrims
;
11366 -- Start of processing for Expand_To_Stored_Constraint
11370 or else Is_Empty_Elmt_List
(Constraint
)
11375 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
11377 if No
(Explicitly_Discriminated_Type
) then
11381 Expansion
:= New_Elmt_List
;
11384 First_Stored_Discriminant
(Explicitly_Discriminated_Type
);
11385 while Present
(Discriminant
) loop
11387 Get_Discriminant_Value
(
11388 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
11390 Next_Stored_Discriminant
(Discriminant
);
11394 end Expand_To_Stored_Constraint
;
11396 --------------------
11397 -- Find_Type_Name --
11398 --------------------
11400 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
11401 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
11403 New_Id
: Entity_Id
;
11404 Prev_Par
: Node_Id
;
11407 -- Find incomplete declaration, if one was given
11409 Prev
:= Current_Entity_In_Scope
(Id
);
11411 if Present
(Prev
) then
11413 -- Previous declaration exists. Error if not incomplete/private case
11414 -- except if previous declaration is implicit, etc. Enter_Name will
11415 -- emit error if appropriate.
11417 Prev_Par
:= Parent
(Prev
);
11419 if not Is_Incomplete_Or_Private_Type
(Prev
) then
11423 elsif Nkind
(N
) /= N_Full_Type_Declaration
11424 and then Nkind
(N
) /= N_Task_Type_Declaration
11425 and then Nkind
(N
) /= N_Protected_Type_Declaration
11427 -- Completion must be a full type declarations (RM 7.3(4))
11429 Error_Msg_Sloc
:= Sloc
(Prev
);
11430 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
11432 -- Set scope of Id to avoid cascaded errors. Entity is never
11433 -- examined again, except when saving globals in generics.
11435 Set_Scope
(Id
, Current_Scope
);
11438 -- Case of full declaration of incomplete type
11440 elsif Ekind
(Prev
) = E_Incomplete_Type
then
11442 -- Indicate that the incomplete declaration has a matching full
11443 -- declaration. The defining occurrence of the incomplete
11444 -- declaration remains the visible one, and the procedure
11445 -- Get_Full_View dereferences it whenever the type is used.
11447 if Present
(Full_View
(Prev
)) then
11448 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11451 Set_Full_View
(Prev
, Id
);
11452 Append_Entity
(Id
, Current_Scope
);
11453 Set_Is_Public
(Id
, Is_Public
(Prev
));
11454 Set_Is_Internal
(Id
);
11457 -- Case of full declaration of private type
11460 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
11461 if Etype
(Prev
) /= Prev
then
11463 -- Prev is a private subtype or a derived type, and needs
11466 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11469 elsif Ekind
(Prev
) = E_Private_Type
11471 (Nkind
(N
) = N_Task_Type_Declaration
11472 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11475 ("completion of nonlimited type cannot be limited", N
);
11477 elsif Ekind
(Prev
) = E_Record_Type_With_Private
11479 (Nkind
(N
) = N_Task_Type_Declaration
11480 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11482 if not Is_Limited_Record
(Prev
) then
11484 ("completion of nonlimited type cannot be limited", N
);
11486 elsif No
(Interface_List
(N
)) then
11488 ("completion of tagged private type must be tagged",
11493 -- Ada 2005 (AI-251): Private extension declaration of a
11494 -- task type. This case arises with tasks implementing interfaces
11496 elsif Nkind
(N
) = N_Task_Type_Declaration
11497 or else Nkind
(N
) = N_Protected_Type_Declaration
11501 elsif Nkind
(N
) /= N_Full_Type_Declaration
11502 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
11505 ("full view of private extension must be an extension", N
);
11507 elsif not (Abstract_Present
(Parent
(Prev
)))
11508 and then Abstract_Present
(Type_Definition
(N
))
11511 ("full view of non-abstract extension cannot be abstract", N
);
11514 if not In_Private_Part
(Current_Scope
) then
11516 ("declaration of full view must appear in private part", N
);
11519 Copy_And_Swap
(Prev
, Id
);
11520 Set_Has_Private_Declaration
(Prev
);
11521 Set_Has_Private_Declaration
(Id
);
11523 -- If no error, propagate freeze_node from private to full view.
11524 -- It may have been generated for an early operational item.
11526 if Present
(Freeze_Node
(Id
))
11527 and then Serious_Errors_Detected
= 0
11528 and then No
(Full_View
(Id
))
11530 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
11531 Set_Freeze_Node
(Id
, Empty
);
11532 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
11535 Set_Full_View
(Id
, Prev
);
11539 -- Verify that full declaration conforms to incomplete one
11541 if Is_Incomplete_Or_Private_Type
(Prev
)
11542 and then Present
(Discriminant_Specifications
(Prev_Par
))
11544 if Present
(Discriminant_Specifications
(N
)) then
11545 if Ekind
(Prev
) = E_Incomplete_Type
then
11546 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
11548 Check_Discriminant_Conformance
(N
, Prev
, Id
);
11553 ("missing discriminants in full type declaration", N
);
11555 -- To avoid cascaded errors on subsequent use, share the
11556 -- discriminants of the partial view.
11558 Set_Discriminant_Specifications
(N
,
11559 Discriminant_Specifications
(Prev_Par
));
11563 -- A prior untagged private type can have an associated class-wide
11564 -- type due to use of the class attribute, and in this case also the
11565 -- full type is required to be tagged.
11568 and then (Is_Tagged_Type
(Prev
)
11569 or else Present
(Class_Wide_Type
(Prev
)))
11570 and then (Nkind
(N
) /= N_Task_Type_Declaration
11571 and then Nkind
(N
) /= N_Protected_Type_Declaration
)
11573 -- The full declaration is either a tagged record or an
11574 -- extension otherwise this is an error
11576 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
11577 if not Tagged_Present
(Type_Definition
(N
)) then
11579 ("full declaration of } must be tagged", Prev
, Id
);
11580 Set_Is_Tagged_Type
(Id
);
11581 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11584 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
11585 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
11587 "full declaration of } must be a record extension",
11589 Set_Is_Tagged_Type
(Id
);
11590 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11595 ("full declaration of } must be a tagged type", Prev
, Id
);
11603 -- New type declaration
11608 end Find_Type_Name
;
11610 -------------------------
11611 -- Find_Type_Of_Object --
11612 -------------------------
11614 function Find_Type_Of_Object
11615 (Obj_Def
: Node_Id
;
11616 Related_Nod
: Node_Id
) return Entity_Id
11618 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
11619 P
: Node_Id
:= Parent
(Obj_Def
);
11624 -- If the parent is a component_definition node we climb to the
11625 -- component_declaration node
11627 if Nkind
(P
) = N_Component_Definition
then
11631 -- Case of an anonymous array subtype
11633 if Def_Kind
= N_Constrained_Array_Definition
11634 or else Def_Kind
= N_Unconstrained_Array_Definition
11637 Array_Type_Declaration
(T
, Obj_Def
);
11639 -- Create an explicit subtype whenever possible
11641 elsif Nkind
(P
) /= N_Component_Declaration
11642 and then Def_Kind
= N_Subtype_Indication
11644 -- Base name of subtype on object name, which will be unique in
11645 -- the current scope.
11647 -- If this is a duplicate declaration, return base type, to avoid
11648 -- generating duplicate anonymous types.
11650 if Error_Posted
(P
) then
11651 Analyze
(Subtype_Mark
(Obj_Def
));
11652 return Entity
(Subtype_Mark
(Obj_Def
));
11657 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
11659 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
11661 Insert_Action
(Obj_Def
,
11662 Make_Subtype_Declaration
(Sloc
(P
),
11663 Defining_Identifier
=> T
,
11664 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
11666 -- This subtype may need freezing, and this will not be done
11667 -- automatically if the object declaration is not in declarative
11668 -- part. Since this is an object declaration, the type cannot always
11669 -- be frozen here. Deferred constants do not freeze their type
11670 -- (which often enough will be private).
11672 if Nkind
(P
) = N_Object_Declaration
11673 and then Constant_Present
(P
)
11674 and then No
(Expression
(P
))
11678 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
11681 -- Ada 2005 AI-406: the object definition in an object declaration
11682 -- can be an access definition.
11684 elsif Def_Kind
= N_Access_Definition
then
11685 T
:= Access_Definition
(Related_Nod
, Obj_Def
);
11686 Set_Is_Local_Anonymous_Access
(T
);
11688 -- comment here, what cases ???
11691 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
11695 end Find_Type_Of_Object
;
11697 --------------------------------
11698 -- Find_Type_Of_Subtype_Indic --
11699 --------------------------------
11701 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
11705 -- Case of subtype mark with a constraint
11707 if Nkind
(S
) = N_Subtype_Indication
then
11708 Find_Type
(Subtype_Mark
(S
));
11709 Typ
:= Entity
(Subtype_Mark
(S
));
11712 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
11715 ("incorrect constraint for this kind of type", Constraint
(S
));
11716 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11719 -- Otherwise we have a subtype mark without a constraint
11721 elsif Error_Posted
(S
) then
11722 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
11730 if Typ
= Standard_Wide_Character
11731 or else Typ
= Standard_Wide_Wide_Character
11732 or else Typ
= Standard_Wide_String
11733 or else Typ
= Standard_Wide_Wide_String
11735 Check_Restriction
(No_Wide_Characters
, S
);
11739 end Find_Type_Of_Subtype_Indic
;
11741 -------------------------------------
11742 -- Floating_Point_Type_Declaration --
11743 -------------------------------------
11745 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11746 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
11748 Base_Typ
: Entity_Id
;
11749 Implicit_Base
: Entity_Id
;
11752 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
11753 -- Find if given digits value allows derivation from specified type
11755 ---------------------
11756 -- Can_Derive_From --
11757 ---------------------
11759 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
11760 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
11763 if Digs_Val
> Digits_Value
(E
) then
11767 if Present
(Spec
) then
11768 if Expr_Value_R
(Type_Low_Bound
(E
)) >
11769 Expr_Value_R
(Low_Bound
(Spec
))
11774 if Expr_Value_R
(Type_High_Bound
(E
)) <
11775 Expr_Value_R
(High_Bound
(Spec
))
11782 end Can_Derive_From
;
11784 -- Start of processing for Floating_Point_Type_Declaration
11787 Check_Restriction
(No_Floating_Point
, Def
);
11789 -- Create an implicit base type
11792 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
11794 -- Analyze and verify digits value
11796 Analyze_And_Resolve
(Digs
, Any_Integer
);
11797 Check_Digits_Expression
(Digs
);
11798 Digs_Val
:= Expr_Value
(Digs
);
11800 -- Process possible range spec and find correct type to derive from
11802 Process_Real_Range_Specification
(Def
);
11804 if Can_Derive_From
(Standard_Short_Float
) then
11805 Base_Typ
:= Standard_Short_Float
;
11806 elsif Can_Derive_From
(Standard_Float
) then
11807 Base_Typ
:= Standard_Float
;
11808 elsif Can_Derive_From
(Standard_Long_Float
) then
11809 Base_Typ
:= Standard_Long_Float
;
11810 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
11811 Base_Typ
:= Standard_Long_Long_Float
;
11813 -- If we can't derive from any existing type, use long_long_float
11814 -- and give appropriate message explaining the problem.
11817 Base_Typ
:= Standard_Long_Long_Float
;
11819 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
11820 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
11821 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
11825 ("range too large for any predefined type",
11826 Real_Range_Specification
(Def
));
11830 -- If there are bounds given in the declaration use them as the bounds
11831 -- of the type, otherwise use the bounds of the predefined base type
11832 -- that was chosen based on the Digits value.
11834 if Present
(Real_Range_Specification
(Def
)) then
11835 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
11836 Set_Is_Constrained
(T
);
11838 -- The bounds of this range must be converted to machine numbers
11839 -- in accordance with RM 4.9(38).
11841 Bound
:= Type_Low_Bound
(T
);
11843 if Nkind
(Bound
) = N_Real_Literal
then
11845 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11846 Set_Is_Machine_Number
(Bound
);
11849 Bound
:= Type_High_Bound
(T
);
11851 if Nkind
(Bound
) = N_Real_Literal
then
11853 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11854 Set_Is_Machine_Number
(Bound
);
11858 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
11861 -- Complete definition of implicit base and declared first subtype
11863 Set_Etype
(Implicit_Base
, Base_Typ
);
11865 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
11866 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
11867 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
11868 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
11869 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
11870 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
11872 Set_Ekind
(T
, E_Floating_Point_Subtype
);
11873 Set_Etype
(T
, Implicit_Base
);
11875 Set_Size_Info
(T
, (Implicit_Base
));
11876 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
11877 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
11878 Set_Digits_Value
(T
, Digs_Val
);
11879 end Floating_Point_Type_Declaration
;
11881 ----------------------------
11882 -- Get_Discriminant_Value --
11883 ----------------------------
11885 -- This is the situation:
11887 -- There is a non-derived type
11889 -- type T0 (Dx, Dy, Dz...)
11891 -- There are zero or more levels of derivation, with each derivation
11892 -- either purely inheriting the discriminants, or defining its own.
11894 -- type Ti is new Ti-1
11896 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
11898 -- subtype Ti is ...
11900 -- The subtype issue is avoided by the use of Original_Record_Component,
11901 -- and the fact that derived subtypes also derive the constraints.
11903 -- This chain leads back from
11905 -- Typ_For_Constraint
11907 -- Typ_For_Constraint has discriminants, and the value for each
11908 -- discriminant is given by its corresponding Elmt of Constraints.
11910 -- Discriminant is some discriminant in this hierarchy
11912 -- We need to return its value
11914 -- We do this by recursively searching each level, and looking for
11915 -- Discriminant. Once we get to the bottom, we start backing up
11916 -- returning the value for it which may in turn be a discriminant
11917 -- further up, so on the backup we continue the substitution.
11919 function Get_Discriminant_Value
11920 (Discriminant
: Entity_Id
;
11921 Typ_For_Constraint
: Entity_Id
;
11922 Constraint
: Elist_Id
) return Node_Id
11924 function Search_Derivation_Levels
11926 Discrim_Values
: Elist_Id
;
11927 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
;
11928 -- This is the routine that performs the recursive search of levels
11929 -- as described above.
11931 ------------------------------
11932 -- Search_Derivation_Levels --
11933 ------------------------------
11935 function Search_Derivation_Levels
11937 Discrim_Values
: Elist_Id
;
11938 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
11942 Result
: Node_Or_Entity_Id
;
11943 Result_Entity
: Node_Id
;
11946 -- If inappropriate type, return Error, this happens only in
11947 -- cascaded error situations, and we want to avoid a blow up.
11949 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
11953 -- Look deeper if possible. Use Stored_Constraints only for
11954 -- untagged types. For tagged types use the given constraint.
11955 -- This asymmetry needs explanation???
11957 if not Stored_Discrim_Values
11958 and then Present
(Stored_Constraint
(Ti
))
11959 and then not Is_Tagged_Type
(Ti
)
11962 Search_Derivation_Levels
(Ti
, Stored_Constraint
(Ti
), True);
11965 Td
: constant Entity_Id
:= Etype
(Ti
);
11969 Result
:= Discriminant
;
11972 if Present
(Stored_Constraint
(Ti
)) then
11974 Search_Derivation_Levels
11975 (Td
, Stored_Constraint
(Ti
), True);
11978 Search_Derivation_Levels
11979 (Td
, Discrim_Values
, Stored_Discrim_Values
);
11985 -- Extra underlying places to search, if not found above. For
11986 -- concurrent types, the relevant discriminant appears in the
11987 -- corresponding record. For a type derived from a private type
11988 -- without discriminant, the full view inherits the discriminants
11989 -- of the full view of the parent.
11991 if Result
= Discriminant
then
11992 if Is_Concurrent_Type
(Ti
)
11993 and then Present
(Corresponding_Record_Type
(Ti
))
11996 Search_Derivation_Levels
(
11997 Corresponding_Record_Type
(Ti
),
11999 Stored_Discrim_Values
);
12001 elsif Is_Private_Type
(Ti
)
12002 and then not Has_Discriminants
(Ti
)
12003 and then Present
(Full_View
(Ti
))
12004 and then Etype
(Full_View
(Ti
)) /= Ti
12007 Search_Derivation_Levels
(
12010 Stored_Discrim_Values
);
12014 -- If Result is not a (reference to a) discriminant, return it,
12015 -- otherwise set Result_Entity to the discriminant.
12017 if Nkind
(Result
) = N_Defining_Identifier
then
12018 pragma Assert
(Result
= Discriminant
);
12019 Result_Entity
:= Result
;
12022 if not Denotes_Discriminant
(Result
) then
12026 Result_Entity
:= Entity
(Result
);
12029 -- See if this level of derivation actually has discriminants
12030 -- because tagged derivations can add them, hence the lower
12031 -- levels need not have any.
12033 if not Has_Discriminants
(Ti
) then
12037 -- Scan Ti's discriminants for Result_Entity,
12038 -- and return its corresponding value, if any.
12040 Result_Entity
:= Original_Record_Component
(Result_Entity
);
12042 Assoc
:= First_Elmt
(Discrim_Values
);
12044 if Stored_Discrim_Values
then
12045 Disc
:= First_Stored_Discriminant
(Ti
);
12047 Disc
:= First_Discriminant
(Ti
);
12050 while Present
(Disc
) loop
12051 pragma Assert
(Present
(Assoc
));
12053 if Original_Record_Component
(Disc
) = Result_Entity
then
12054 return Node
(Assoc
);
12059 if Stored_Discrim_Values
then
12060 Next_Stored_Discriminant
(Disc
);
12062 Next_Discriminant
(Disc
);
12066 -- Could not find it
12069 end Search_Derivation_Levels
;
12071 Result
: Node_Or_Entity_Id
;
12073 -- Start of processing for Get_Discriminant_Value
12076 -- ??? This routine is a gigantic mess and will be deleted. For the
12077 -- time being just test for the trivial case before calling recurse.
12079 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
12085 D
:= First_Discriminant
(Typ_For_Constraint
);
12086 E
:= First_Elmt
(Constraint
);
12087 while Present
(D
) loop
12088 if Chars
(D
) = Chars
(Discriminant
) then
12092 Next_Discriminant
(D
);
12098 Result
:= Search_Derivation_Levels
12099 (Typ_For_Constraint
, Constraint
, False);
12101 -- ??? hack to disappear when this routine is gone
12103 if Nkind
(Result
) = N_Defining_Identifier
then
12109 D
:= First_Discriminant
(Typ_For_Constraint
);
12110 E
:= First_Elmt
(Constraint
);
12111 while Present
(D
) loop
12112 if Corresponding_Discriminant
(D
) = Discriminant
then
12116 Next_Discriminant
(D
);
12122 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
12124 end Get_Discriminant_Value
;
12126 --------------------------
12127 -- Has_Range_Constraint --
12128 --------------------------
12130 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
12131 C
: constant Node_Id
:= Constraint
(N
);
12134 if Nkind
(C
) = N_Range_Constraint
then
12137 elsif Nkind
(C
) = N_Digits_Constraint
then
12139 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
12141 Present
(Range_Constraint
(C
));
12143 elsif Nkind
(C
) = N_Delta_Constraint
then
12144 return Present
(Range_Constraint
(C
));
12149 end Has_Range_Constraint
;
12151 ------------------------
12152 -- Inherit_Components --
12153 ------------------------
12155 function Inherit_Components
12157 Parent_Base
: Entity_Id
;
12158 Derived_Base
: Entity_Id
;
12159 Is_Tagged
: Boolean;
12160 Inherit_Discr
: Boolean;
12161 Discs
: Elist_Id
) return Elist_Id
12163 Assoc_List
: constant Elist_Id
:= New_Elmt_List
;
12165 procedure Inherit_Component
12166 (Old_C
: Entity_Id
;
12167 Plain_Discrim
: Boolean := False;
12168 Stored_Discrim
: Boolean := False);
12169 -- Inherits component Old_C from Parent_Base to the Derived_Base. If
12170 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
12171 -- True, Old_C is a stored discriminant. If they are both false then
12172 -- Old_C is a regular component.
12174 -----------------------
12175 -- Inherit_Component --
12176 -----------------------
12178 procedure Inherit_Component
12179 (Old_C
: Entity_Id
;
12180 Plain_Discrim
: Boolean := False;
12181 Stored_Discrim
: Boolean := False)
12183 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
12185 Discrim
: Entity_Id
;
12186 Corr_Discrim
: Entity_Id
;
12189 pragma Assert
(not Is_Tagged
or else not Stored_Discrim
);
12191 Set_Parent
(New_C
, Parent
(Old_C
));
12193 -- Regular discriminants and components must be inserted
12194 -- in the scope of the Derived_Base. Do it here.
12196 if not Stored_Discrim
then
12197 Enter_Name
(New_C
);
12200 -- For tagged types the Original_Record_Component must point to
12201 -- whatever this field was pointing to in the parent type. This has
12202 -- already been achieved by the call to New_Copy above.
12204 if not Is_Tagged
then
12205 Set_Original_Record_Component
(New_C
, New_C
);
12208 -- If we have inherited a component then see if its Etype contains
12209 -- references to Parent_Base discriminants. In this case, replace
12210 -- these references with the constraints given in Discs. We do not
12211 -- do this for the partial view of private types because this is
12212 -- not needed (only the components of the full view will be used
12213 -- for code generation) and cause problem. We also avoid this
12214 -- transformation in some error situations.
12216 if Ekind
(New_C
) = E_Component
then
12217 if (Is_Private_Type
(Derived_Base
)
12218 and then not Is_Generic_Type
(Derived_Base
))
12219 or else (Is_Empty_Elmt_List
(Discs
)
12220 and then not Expander_Active
)
12222 Set_Etype
(New_C
, Etype
(Old_C
));
12226 Constrain_Component_Type
12227 (Old_C
, Derived_Base
, N
, Parent_Base
, Discs
));
12231 -- In derived tagged types it is illegal to reference a non
12232 -- discriminant component in the parent type. To catch this, mark
12233 -- these components with an Ekind of E_Void. This will be reset in
12234 -- Record_Type_Definition after processing the record extension of
12235 -- the derived type.
12237 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
12238 Set_Ekind
(New_C
, E_Void
);
12241 if Plain_Discrim
then
12242 Set_Corresponding_Discriminant
(New_C
, Old_C
);
12243 Build_Discriminal
(New_C
);
12245 -- If we are explicitly inheriting a stored discriminant it will be
12246 -- completely hidden.
12248 elsif Stored_Discrim
then
12249 Set_Corresponding_Discriminant
(New_C
, Empty
);
12250 Set_Discriminal
(New_C
, Empty
);
12251 Set_Is_Completely_Hidden
(New_C
);
12253 -- Set the Original_Record_Component of each discriminant in the
12254 -- derived base to point to the corresponding stored that we just
12257 Discrim
:= First_Discriminant
(Derived_Base
);
12258 while Present
(Discrim
) loop
12259 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
12261 -- Corr_Discrim could be missing in an error situation
12263 if Present
(Corr_Discrim
)
12264 and then Original_Record_Component
(Corr_Discrim
) = Old_C
12266 Set_Original_Record_Component
(Discrim
, New_C
);
12269 Next_Discriminant
(Discrim
);
12272 Append_Entity
(New_C
, Derived_Base
);
12275 if not Is_Tagged
then
12276 Append_Elmt
(Old_C
, Assoc_List
);
12277 Append_Elmt
(New_C
, Assoc_List
);
12279 end Inherit_Component
;
12281 -- Variables local to Inherit_Component
12283 Loc
: constant Source_Ptr
:= Sloc
(N
);
12285 Parent_Discrim
: Entity_Id
;
12286 Stored_Discrim
: Entity_Id
;
12288 Component
: Entity_Id
;
12290 -- Start of processing for Inherit_Components
12293 if not Is_Tagged
then
12294 Append_Elmt
(Parent_Base
, Assoc_List
);
12295 Append_Elmt
(Derived_Base
, Assoc_List
);
12298 -- Inherit parent discriminants if needed
12300 if Inherit_Discr
then
12301 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
12302 while Present
(Parent_Discrim
) loop
12303 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
12304 Next_Discriminant
(Parent_Discrim
);
12308 -- Create explicit stored discrims for untagged types when necessary
12310 if not Has_Unknown_Discriminants
(Derived_Base
)
12311 and then Has_Discriminants
(Parent_Base
)
12312 and then not Is_Tagged
12315 or else First_Discriminant
(Parent_Base
) /=
12316 First_Stored_Discriminant
(Parent_Base
))
12318 Stored_Discrim
:= First_Stored_Discriminant
(Parent_Base
);
12319 while Present
(Stored_Discrim
) loop
12320 Inherit_Component
(Stored_Discrim
, Stored_Discrim
=> True);
12321 Next_Stored_Discriminant
(Stored_Discrim
);
12325 -- See if we can apply the second transformation for derived types, as
12326 -- explained in point 6. in the comments above Build_Derived_Record_Type
12327 -- This is achieved by appending Derived_Base discriminants into Discs,
12328 -- which has the side effect of returning a non empty Discs list to the
12329 -- caller of Inherit_Components, which is what we want. This must be
12330 -- done for private derived types if there are explicit stored
12331 -- discriminants, to ensure that we can retrieve the values of the
12332 -- constraints provided in the ancestors.
12335 and then Is_Empty_Elmt_List
(Discs
)
12336 and then Present
(First_Discriminant
(Derived_Base
))
12338 (not Is_Private_Type
(Derived_Base
)
12339 or else Is_Completely_Hidden
12340 (First_Stored_Discriminant
(Derived_Base
))
12341 or else Is_Generic_Type
(Derived_Base
))
12343 D
:= First_Discriminant
(Derived_Base
);
12344 while Present
(D
) loop
12345 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
12346 Next_Discriminant
(D
);
12350 -- Finally, inherit non-discriminant components unless they are not
12351 -- visible because defined or inherited from the full view of the
12352 -- parent. Don't inherit the _parent field of the parent type.
12354 Component
:= First_Entity
(Parent_Base
);
12355 while Present
(Component
) loop
12357 -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
12358 -- interfaces of the parent
12360 if Ekind
(Component
) = E_Component
12361 and then Is_Tag
(Component
)
12362 and then RTE_Available
(RE_Interface_Tag
)
12363 and then Etype
(Component
) = RTE
(RE_Interface_Tag
)
12367 elsif Ekind
(Component
) /= E_Component
12368 or else Chars
(Component
) = Name_uParent
12372 -- If the derived type is within the parent type's declarative
12373 -- region, then the components can still be inherited even though
12374 -- they aren't visible at this point. This can occur for cases
12375 -- such as within public child units where the components must
12376 -- become visible upon entering the child unit's private part.
12378 elsif not Is_Visible_Component
(Component
)
12379 and then not In_Open_Scopes
(Scope
(Parent_Base
))
12383 elsif Ekind
(Derived_Base
) = E_Private_Type
12384 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
12389 Inherit_Component
(Component
);
12392 Next_Entity
(Component
);
12395 -- For tagged derived types, inherited discriminants cannot be used in
12396 -- component declarations of the record extension part. To achieve this
12397 -- we mark the inherited discriminants as not visible.
12399 if Is_Tagged
and then Inherit_Discr
then
12400 D
:= First_Discriminant
(Derived_Base
);
12401 while Present
(D
) loop
12402 Set_Is_Immediately_Visible
(D
, False);
12403 Next_Discriminant
(D
);
12408 end Inherit_Components
;
12410 -----------------------
12411 -- Is_Null_Extension --
12412 -----------------------
12414 function Is_Null_Extension
(T
: Entity_Id
) return Boolean is
12415 Full_Type_Decl
: constant Node_Id
:= Parent
(T
);
12416 Full_Type_Defn
: constant Node_Id
:= Type_Definition
(Full_Type_Decl
);
12417 Comp_List
: Node_Id
;
12418 First_Comp
: Node_Id
;
12421 if not Is_Tagged_Type
(T
)
12422 or else Nkind
(Full_Type_Defn
) /= N_Derived_Type_Definition
12427 Comp_List
:= Component_List
(Record_Extension_Part
(Full_Type_Defn
));
12429 if Present
(Discriminant_Specifications
(Full_Type_Decl
)) then
12432 elsif Present
(Comp_List
)
12433 and then Is_Non_Empty_List
(Component_Items
(Comp_List
))
12435 First_Comp
:= First
(Component_Items
(Comp_List
));
12437 return Chars
(Defining_Identifier
(First_Comp
)) = Name_uParent
12438 and then No
(Next
(First_Comp
));
12443 end Is_Null_Extension
;
12445 ------------------------------
12446 -- Is_Valid_Constraint_Kind --
12447 ------------------------------
12449 function Is_Valid_Constraint_Kind
12450 (T_Kind
: Type_Kind
;
12451 Constraint_Kind
: Node_Kind
) return Boolean
12455 when Enumeration_Kind |
12457 return Constraint_Kind
= N_Range_Constraint
;
12459 when Decimal_Fixed_Point_Kind
=>
12461 Constraint_Kind
= N_Digits_Constraint
12463 Constraint_Kind
= N_Range_Constraint
;
12465 when Ordinary_Fixed_Point_Kind
=>
12467 Constraint_Kind
= N_Delta_Constraint
12469 Constraint_Kind
= N_Range_Constraint
;
12473 Constraint_Kind
= N_Digits_Constraint
12475 Constraint_Kind
= N_Range_Constraint
;
12482 E_Incomplete_Type |
12485 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
12488 return True; -- Error will be detected later
12490 end Is_Valid_Constraint_Kind
;
12492 --------------------------
12493 -- Is_Visible_Component --
12494 --------------------------
12496 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
12497 Original_Comp
: Entity_Id
:= Empty
;
12498 Original_Scope
: Entity_Id
;
12499 Type_Scope
: Entity_Id
;
12501 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean;
12502 -- Check whether parent type of inherited component is declared locally,
12503 -- possibly within a nested package or instance. The current scope is
12504 -- the derived record itself.
12506 -------------------
12507 -- Is_Local_Type --
12508 -------------------
12510 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean is
12514 Scop
:= Scope
(Typ
);
12515 while Present
(Scop
)
12516 and then Scop
/= Standard_Standard
12518 if Scop
= Scope
(Current_Scope
) then
12522 Scop
:= Scope
(Scop
);
12528 -- Start of processing for Is_Visible_Component
12531 if Ekind
(C
) = E_Component
12532 or else Ekind
(C
) = E_Discriminant
12534 Original_Comp
:= Original_Record_Component
(C
);
12537 if No
(Original_Comp
) then
12539 -- Premature usage, or previous error
12544 Original_Scope
:= Scope
(Original_Comp
);
12545 Type_Scope
:= Scope
(Base_Type
(Scope
(C
)));
12548 -- This test only concerns tagged types
12550 if not Is_Tagged_Type
(Original_Scope
) then
12553 -- If it is _Parent or _Tag, there is no visibility issue
12555 elsif not Comes_From_Source
(Original_Comp
) then
12558 -- If we are in the body of an instantiation, the component is visible
12559 -- even when the parent type (possibly defined in an enclosing unit or
12560 -- in a parent unit) might not.
12562 elsif In_Instance_Body
then
12565 -- Discriminants are always visible
12567 elsif Ekind
(Original_Comp
) = E_Discriminant
12568 and then not Has_Unknown_Discriminants
(Original_Scope
)
12572 -- If the component has been declared in an ancestor which is currently
12573 -- a private type, then it is not visible. The same applies if the
12574 -- component's containing type is not in an open scope and the original
12575 -- component's enclosing type is a visible full type of a private type
12576 -- (which can occur in cases where an attempt is being made to reference
12577 -- a component in a sibling package that is inherited from a visible
12578 -- component of a type in an ancestor package; the component in the
12579 -- sibling package should not be visible even though the component it
12580 -- inherited from is visible). This does not apply however in the case
12581 -- where the scope of the type is a private child unit, or when the
12582 -- parent comes from a local package in which the ancestor is currently
12583 -- visible. The latter suppression of visibility is needed for cases
12584 -- that are tested in B730006.
12586 elsif Is_Private_Type
(Original_Scope
)
12588 (not Is_Private_Descendant
(Type_Scope
)
12589 and then not In_Open_Scopes
(Type_Scope
)
12590 and then Has_Private_Declaration
(Original_Scope
))
12592 -- If the type derives from an entity in a formal package, there
12593 -- are no additional visible components.
12595 if Nkind
(Original_Node
(Unit_Declaration_Node
(Type_Scope
))) =
12596 N_Formal_Package_Declaration
12600 -- if we are not in the private part of the current package, there
12601 -- are no additional visible components.
12603 elsif Ekind
(Scope
(Current_Scope
)) = E_Package
12604 and then not In_Private_Part
(Scope
(Current_Scope
))
12609 Is_Child_Unit
(Cunit_Entity
(Current_Sem_Unit
))
12610 and then Is_Local_Type
(Type_Scope
);
12613 -- There is another weird way in which a component may be invisible
12614 -- when the private and the full view are not derived from the same
12615 -- ancestor. Here is an example :
12617 -- type A1 is tagged record F1 : integer; end record;
12618 -- type A2 is new A1 with record F2 : integer; end record;
12619 -- type T is new A1 with private;
12621 -- type T is new A2 with null record;
12623 -- In this case, the full view of T inherits F1 and F2 but the private
12624 -- view inherits only F1
12628 Ancestor
: Entity_Id
:= Scope
(C
);
12632 if Ancestor
= Original_Scope
then
12634 elsif Ancestor
= Etype
(Ancestor
) then
12638 Ancestor
:= Etype
(Ancestor
);
12644 end Is_Visible_Component
;
12646 --------------------------
12647 -- Make_Class_Wide_Type --
12648 --------------------------
12650 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
12651 CW_Type
: Entity_Id
;
12653 Next_E
: Entity_Id
;
12656 -- The class wide type can have been defined by the partial view in
12657 -- which case everything is already done
12659 if Present
(Class_Wide_Type
(T
)) then
12664 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
12666 -- Inherit root type characteristics
12668 CW_Name
:= Chars
(CW_Type
);
12669 Next_E
:= Next_Entity
(CW_Type
);
12670 Copy_Node
(T
, CW_Type
);
12671 Set_Comes_From_Source
(CW_Type
, False);
12672 Set_Chars
(CW_Type
, CW_Name
);
12673 Set_Parent
(CW_Type
, Parent
(T
));
12674 Set_Next_Entity
(CW_Type
, Next_E
);
12675 Set_Has_Delayed_Freeze
(CW_Type
);
12677 -- Customize the class-wide type: It has no prim. op., it cannot be
12678 -- abstract and its Etype points back to the specific root type.
12680 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
12681 Set_Is_Tagged_Type
(CW_Type
, True);
12682 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
12683 Set_Is_Abstract
(CW_Type
, False);
12684 Set_Is_Constrained
(CW_Type
, False);
12685 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
12686 Init_Size_Align
(CW_Type
);
12688 if Ekind
(T
) = E_Class_Wide_Subtype
then
12689 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
12691 Set_Etype
(CW_Type
, T
);
12694 -- If this is the class_wide type of a constrained subtype, it does
12695 -- not have discriminants.
12697 Set_Has_Discriminants
(CW_Type
,
12698 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
12700 Set_Has_Unknown_Discriminants
(CW_Type
, True);
12701 Set_Class_Wide_Type
(T
, CW_Type
);
12702 Set_Equivalent_Type
(CW_Type
, Empty
);
12704 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
12706 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
12707 end Make_Class_Wide_Type
;
12713 procedure Make_Index
12715 Related_Nod
: Node_Id
;
12716 Related_Id
: Entity_Id
:= Empty
;
12717 Suffix_Index
: Nat
:= 1)
12721 Def_Id
: Entity_Id
:= Empty
;
12722 Found
: Boolean := False;
12725 -- For a discrete range used in a constrained array definition and
12726 -- defined by a range, an implicit conversion to the predefined type
12727 -- INTEGER is assumed if each bound is either a numeric literal, a named
12728 -- number, or an attribute, and the type of both bounds (prior to the
12729 -- implicit conversion) is the type universal_integer. Otherwise, both
12730 -- bounds must be of the same discrete type, other than universal
12731 -- integer; this type must be determinable independently of the
12732 -- context, but using the fact that the type must be discrete and that
12733 -- both bounds must have the same type.
12735 -- Character literals also have a universal type in the absence of
12736 -- of additional context, and are resolved to Standard_Character.
12738 if Nkind
(I
) = N_Range
then
12740 -- The index is given by a range constraint. The bounds are known
12741 -- to be of a consistent type.
12743 if not Is_Overloaded
(I
) then
12746 -- If the bounds are universal, choose the specific predefined
12749 if T
= Universal_Integer
then
12750 T
:= Standard_Integer
;
12752 elsif T
= Any_Character
then
12754 if Ada_Version
>= Ada_95
then
12756 ("ambiguous character literals (could be Wide_Character)",
12760 T
:= Standard_Character
;
12767 Ind
: Interp_Index
;
12771 Get_First_Interp
(I
, Ind
, It
);
12772 while Present
(It
.Typ
) loop
12773 if Is_Discrete_Type
(It
.Typ
) then
12776 and then not Covers
(It
.Typ
, T
)
12777 and then not Covers
(T
, It
.Typ
)
12779 Error_Msg_N
("ambiguous bounds in discrete range", I
);
12787 Get_Next_Interp
(Ind
, It
);
12790 if T
= Any_Type
then
12791 Error_Msg_N
("discrete type required for range", I
);
12792 Set_Etype
(I
, Any_Type
);
12795 elsif T
= Universal_Integer
then
12796 T
:= Standard_Integer
;
12801 if not Is_Discrete_Type
(T
) then
12802 Error_Msg_N
("discrete type required for range", I
);
12803 Set_Etype
(I
, Any_Type
);
12807 if Nkind
(Low_Bound
(I
)) = N_Attribute_Reference
12808 and then Attribute_Name
(Low_Bound
(I
)) = Name_First
12809 and then Is_Entity_Name
(Prefix
(Low_Bound
(I
)))
12810 and then Is_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12811 and then Is_Discrete_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12813 -- The type of the index will be the type of the prefix, as long
12814 -- as the upper bound is 'Last of the same type.
12816 Def_Id
:= Entity
(Prefix
(Low_Bound
(I
)));
12818 if Nkind
(High_Bound
(I
)) /= N_Attribute_Reference
12819 or else Attribute_Name
(High_Bound
(I
)) /= Name_Last
12820 or else not Is_Entity_Name
(Prefix
(High_Bound
(I
)))
12821 or else Entity
(Prefix
(High_Bound
(I
))) /= Def_Id
12828 Process_Range_Expr_In_Decl
(R
, T
);
12830 elsif Nkind
(I
) = N_Subtype_Indication
then
12832 -- The index is given by a subtype with a range constraint
12834 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
12836 if not Is_Discrete_Type
(T
) then
12837 Error_Msg_N
("discrete type required for range", I
);
12838 Set_Etype
(I
, Any_Type
);
12842 R
:= Range_Expression
(Constraint
(I
));
12845 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
12847 elsif Nkind
(I
) = N_Attribute_Reference
then
12849 -- The parser guarantees that the attribute is a RANGE attribute
12851 -- If the node denotes the range of a type mark, that is also the
12852 -- resulting type, and we do no need to create an Itype for it.
12854 if Is_Entity_Name
(Prefix
(I
))
12855 and then Comes_From_Source
(I
)
12856 and then Is_Type
(Entity
(Prefix
(I
)))
12857 and then Is_Discrete_Type
(Entity
(Prefix
(I
)))
12859 Def_Id
:= Entity
(Prefix
(I
));
12862 Analyze_And_Resolve
(I
);
12866 -- If none of the above, must be a subtype. We convert this to a
12867 -- range attribute reference because in the case of declared first
12868 -- named subtypes, the types in the range reference can be different
12869 -- from the type of the entity. A range attribute normalizes the
12870 -- reference and obtains the correct types for the bounds.
12872 -- This transformation is in the nature of an expansion, is only
12873 -- done if expansion is active. In particular, it is not done on
12874 -- formal generic types, because we need to retain the name of the
12875 -- original index for instantiation purposes.
12878 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
12879 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
12880 Set_Etype
(I
, Any_Integer
);
12884 -- The type mark may be that of an incomplete type. It is only
12885 -- now that we can get the full view, previous analysis does
12886 -- not look specifically for a type mark.
12888 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
12889 Set_Etype
(I
, Entity
(I
));
12890 Def_Id
:= Entity
(I
);
12892 if not Is_Discrete_Type
(Def_Id
) then
12893 Error_Msg_N
("discrete type required for index", I
);
12894 Set_Etype
(I
, Any_Type
);
12899 if Expander_Active
then
12901 Make_Attribute_Reference
(Sloc
(I
),
12902 Attribute_Name
=> Name_Range
,
12903 Prefix
=> Relocate_Node
(I
)));
12905 -- The original was a subtype mark that does not freeze. This
12906 -- means that the rewritten version must not freeze either.
12908 Set_Must_Not_Freeze
(I
);
12909 Set_Must_Not_Freeze
(Prefix
(I
));
12911 -- Is order critical??? if so, document why, if not
12912 -- use Analyze_And_Resolve
12919 -- If expander is inactive, type is legal, nothing else to construct
12926 if not Is_Discrete_Type
(T
) then
12927 Error_Msg_N
("discrete type required for range", I
);
12928 Set_Etype
(I
, Any_Type
);
12931 elsif T
= Any_Type
then
12932 Set_Etype
(I
, Any_Type
);
12936 -- We will now create the appropriate Itype to describe the range, but
12937 -- first a check. If we originally had a subtype, then we just label
12938 -- the range with this subtype. Not only is there no need to construct
12939 -- a new subtype, but it is wrong to do so for two reasons:
12941 -- 1. A legality concern, if we have a subtype, it must not freeze,
12942 -- and the Itype would cause freezing incorrectly
12944 -- 2. An efficiency concern, if we created an Itype, it would not be
12945 -- recognized as the same type for the purposes of eliminating
12946 -- checks in some circumstances.
12948 -- We signal this case by setting the subtype entity in Def_Id
12950 if No
(Def_Id
) then
12952 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
12953 Set_Etype
(Def_Id
, Base_Type
(T
));
12955 if Is_Signed_Integer_Type
(T
) then
12956 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
12958 elsif Is_Modular_Integer_Type
(T
) then
12959 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
12962 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
12963 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
12964 Set_First_Literal
(Def_Id
, First_Literal
(T
));
12967 Set_Size_Info
(Def_Id
, (T
));
12968 Set_RM_Size
(Def_Id
, RM_Size
(T
));
12969 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
12971 Set_Scalar_Range
(Def_Id
, R
);
12972 Conditional_Delay
(Def_Id
, T
);
12974 -- In the subtype indication case, if the immediate parent of the
12975 -- new subtype is non-static, then the subtype we create is non-
12976 -- static, even if its bounds are static.
12978 if Nkind
(I
) = N_Subtype_Indication
12979 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
12981 Set_Is_Non_Static_Subtype
(Def_Id
);
12985 -- Final step is to label the index with this constructed type
12987 Set_Etype
(I
, Def_Id
);
12990 ------------------------------
12991 -- Modular_Type_Declaration --
12992 ------------------------------
12994 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
12995 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
12998 procedure Set_Modular_Size
(Bits
: Int
);
12999 -- Sets RM_Size to Bits, and Esize to normal word size above this
13001 ----------------------
13002 -- Set_Modular_Size --
13003 ----------------------
13005 procedure Set_Modular_Size
(Bits
: Int
) is
13007 Set_RM_Size
(T
, UI_From_Int
(Bits
));
13012 elsif Bits
<= 16 then
13013 Init_Esize
(T
, 16);
13015 elsif Bits
<= 32 then
13016 Init_Esize
(T
, 32);
13019 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
13021 end Set_Modular_Size
;
13023 -- Start of processing for Modular_Type_Declaration
13026 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
13028 Set_Ekind
(T
, E_Modular_Integer_Type
);
13029 Init_Alignment
(T
);
13030 Set_Is_Constrained
(T
);
13032 if not Is_OK_Static_Expression
(Mod_Expr
) then
13033 Flag_Non_Static_Expr
13034 ("non-static expression used for modular type bound!", Mod_Expr
);
13035 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
13037 M_Val
:= Expr_Value
(Mod_Expr
);
13041 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
13042 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
13045 Set_Modulus
(T
, M_Val
);
13047 -- Create bounds for the modular type based on the modulus given in
13048 -- the type declaration and then analyze and resolve those bounds.
13050 Set_Scalar_Range
(T
,
13051 Make_Range
(Sloc
(Mod_Expr
),
13053 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
13055 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
13057 -- Properly analyze the literals for the range. We do this manually
13058 -- because we can't go calling Resolve, since we are resolving these
13059 -- bounds with the type, and this type is certainly not complete yet!
13061 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
13062 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
13063 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
13064 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
13066 -- Loop through powers of two to find number of bits required
13068 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
13072 if M_Val
= 2 ** Bits
then
13073 Set_Modular_Size
(Bits
);
13078 elsif M_Val
< 2 ** Bits
then
13079 Set_Non_Binary_Modulus
(T
);
13081 if Bits
> System_Max_Nonbinary_Modulus_Power
then
13082 Error_Msg_Uint_1
:=
13083 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
13085 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
13086 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
13090 -- In the non-binary case, set size as per RM 13.3(55)
13092 Set_Modular_Size
(Bits
);
13099 -- If we fall through, then the size exceed System.Max_Binary_Modulus
13100 -- so we just signal an error and set the maximum size.
13102 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
13103 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
13105 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
13106 Init_Alignment
(T
);
13108 end Modular_Type_Declaration
;
13110 --------------------------
13111 -- New_Concatenation_Op --
13112 --------------------------
13114 procedure New_Concatenation_Op
(Typ
: Entity_Id
) is
13115 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
13118 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
13119 -- Create abbreviated declaration for the formal of a predefined
13120 -- Operator 'Op' of type 'Typ'
13122 --------------------
13123 -- Make_Op_Formal --
13124 --------------------
13126 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
13127 Formal
: Entity_Id
;
13129 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
13130 Set_Etype
(Formal
, Typ
);
13131 Set_Mechanism
(Formal
, Default_Mechanism
);
13133 end Make_Op_Formal
;
13135 -- Start of processing for New_Concatenation_Op
13138 Op
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Concat
);
13140 Set_Ekind
(Op
, E_Operator
);
13141 Set_Scope
(Op
, Current_Scope
);
13142 Set_Etype
(Op
, Typ
);
13143 Set_Homonym
(Op
, Get_Name_Entity_Id
(Name_Op_Concat
));
13144 Set_Is_Immediately_Visible
(Op
);
13145 Set_Is_Intrinsic_Subprogram
(Op
);
13146 Set_Has_Completion
(Op
);
13147 Append_Entity
(Op
, Current_Scope
);
13149 Set_Name_Entity_Id
(Name_Op_Concat
, Op
);
13151 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
13152 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
13153 end New_Concatenation_Op
;
13155 -------------------------------------------
13156 -- Ordinary_Fixed_Point_Type_Declaration --
13157 -------------------------------------------
13159 procedure Ordinary_Fixed_Point_Type_Declaration
13163 Loc
: constant Source_Ptr
:= Sloc
(Def
);
13164 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
13165 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
13166 Implicit_Base
: Entity_Id
;
13173 Check_Restriction
(No_Fixed_Point
, Def
);
13175 -- Create implicit base type
13178 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
13179 Set_Etype
(Implicit_Base
, Implicit_Base
);
13181 -- Analyze and process delta expression
13183 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
13185 Check_Delta_Expression
(Delta_Expr
);
13186 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
13188 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
13190 -- Compute default small from given delta, which is the largest power
13191 -- of two that does not exceed the given delta value.
13201 if Delta_Val
< Ureal_1
then
13202 while Delta_Val
< Tmp
loop
13203 Tmp
:= Tmp
/ Ureal_2
;
13204 Scale
:= Scale
+ 1;
13209 Tmp
:= Tmp
* Ureal_2
;
13210 exit when Tmp
> Delta_Val
;
13211 Scale
:= Scale
- 1;
13215 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
13218 Set_Small_Value
(Implicit_Base
, Small_Val
);
13220 -- If no range was given, set a dummy range
13222 if RRS
<= Empty_Or_Error
then
13223 Low_Val
:= -Small_Val
;
13224 High_Val
:= Small_Val
;
13226 -- Otherwise analyze and process given range
13230 Low
: constant Node_Id
:= Low_Bound
(RRS
);
13231 High
: constant Node_Id
:= High_Bound
(RRS
);
13234 Analyze_And_Resolve
(Low
, Any_Real
);
13235 Analyze_And_Resolve
(High
, Any_Real
);
13236 Check_Real_Bound
(Low
);
13237 Check_Real_Bound
(High
);
13239 -- Obtain and set the range
13241 Low_Val
:= Expr_Value_R
(Low
);
13242 High_Val
:= Expr_Value_R
(High
);
13244 if Low_Val
> High_Val
then
13245 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
13250 -- The range for both the implicit base and the declared first subtype
13251 -- cannot be set yet, so we use the special routine Set_Fixed_Range to
13252 -- set a temporary range in place. Note that the bounds of the base
13253 -- type will be widened to be symmetrical and to fill the available
13254 -- bits when the type is frozen.
13256 -- We could do this with all discrete types, and probably should, but
13257 -- we absolutely have to do it for fixed-point, since the end-points
13258 -- of the range and the size are determined by the small value, which
13259 -- could be reset before the freeze point.
13261 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
13262 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
13264 Init_Size_Align
(Implicit_Base
);
13266 -- Complete definition of first subtype
13268 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
13269 Set_Etype
(T
, Implicit_Base
);
13270 Init_Size_Align
(T
);
13271 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
13272 Set_Small_Value
(T
, Small_Val
);
13273 Set_Delta_Value
(T
, Delta_Val
);
13274 Set_Is_Constrained
(T
);
13276 end Ordinary_Fixed_Point_Type_Declaration
;
13278 ----------------------------------------
13279 -- Prepare_Private_Subtype_Completion --
13280 ----------------------------------------
13282 procedure Prepare_Private_Subtype_Completion
13284 Related_Nod
: Node_Id
)
13286 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
13287 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
13291 if Present
(Full_B
) then
13293 -- The Base_Type is already completed, we can complete the subtype
13294 -- now. We have to create a new entity with the same name, Thus we
13295 -- can't use Create_Itype.
13297 -- This is messy, should be fixed ???
13299 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
13300 Set_Is_Itype
(Full
);
13301 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
13302 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
13305 -- The parent subtype may be private, but the base might not, in some
13306 -- nested instances. In that case, the subtype does not need to be
13307 -- exchanged. It would still be nice to make private subtypes and their
13308 -- bases consistent at all times ???
13310 if Is_Private_Type
(Id_B
) then
13311 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
13314 end Prepare_Private_Subtype_Completion
;
13316 ---------------------------
13317 -- Process_Discriminants --
13318 ---------------------------
13320 procedure Process_Discriminants
13322 Prev
: Entity_Id
:= Empty
)
13324 Elist
: constant Elist_Id
:= New_Elmt_List
;
13327 Discr_Number
: Uint
;
13328 Discr_Type
: Entity_Id
;
13329 Default_Present
: Boolean := False;
13330 Default_Not_Present
: Boolean := False;
13333 -- A composite type other than an array type can have discriminants.
13334 -- Discriminants of non-limited types must have a discrete type.
13335 -- On entry, the current scope is the composite type.
13337 -- The discriminants are initially entered into the scope of the type
13338 -- via Enter_Name with the default Ekind of E_Void to prevent premature
13339 -- use, as explained at the end of this procedure.
13341 Discr
:= First
(Discriminant_Specifications
(N
));
13342 while Present
(Discr
) loop
13343 Enter_Name
(Defining_Identifier
(Discr
));
13345 -- For navigation purposes we add a reference to the discriminant
13346 -- in the entity for the type. If the current declaration is a
13347 -- completion, place references on the partial view. Otherwise the
13348 -- type is the current scope.
13350 if Present
(Prev
) then
13352 -- The references go on the partial view, if present. If the
13353 -- partial view has discriminants, the references have been
13354 -- generated already.
13356 if not Has_Discriminants
(Prev
) then
13357 Generate_Reference
(Prev
, Defining_Identifier
(Discr
), 'd');
13361 (Current_Scope
, Defining_Identifier
(Discr
), 'd');
13364 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
13365 Discr_Type
:= Access_Definition
(Discr
, Discriminant_Type
(Discr
));
13367 -- Ada 2005 (AI-230): Access discriminants are now allowed for
13368 -- nonlimited types, and are treated like other components of
13369 -- anonymous access types in terms of accessibility.
13371 if not Is_Concurrent_Type
(Current_Scope
)
13372 and then not Is_Concurrent_Record_Type
(Current_Scope
)
13373 and then not Is_Limited_Record
(Current_Scope
)
13374 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
13376 Set_Is_Local_Anonymous_Access
(Discr_Type
);
13379 -- Ada 2005 (AI-254)
13381 if Present
(Access_To_Subprogram_Definition
13382 (Discriminant_Type
(Discr
)))
13383 and then Protected_Present
(Access_To_Subprogram_Definition
13384 (Discriminant_Type
(Discr
)))
13387 Replace_Anonymous_Access_To_Protected_Subprogram
13388 (Discr
, Discr_Type
);
13392 Find_Type
(Discriminant_Type
(Discr
));
13393 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
13395 if Error_Posted
(Discriminant_Type
(Discr
)) then
13396 Discr_Type
:= Any_Type
;
13400 if Is_Access_Type
(Discr_Type
) then
13402 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
13405 if Ada_Version
< Ada_05
then
13406 Check_Access_Discriminant_Requires_Limited
13407 (Discr
, Discriminant_Type
(Discr
));
13410 if Ada_Version
= Ada_83
and then Comes_From_Source
(Discr
) then
13412 ("(Ada 83) access discriminant not allowed", Discr
);
13415 elsif not Is_Discrete_Type
(Discr_Type
) then
13416 Error_Msg_N
("discriminants must have a discrete or access type",
13417 Discriminant_Type
(Discr
));
13420 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
13422 -- If a discriminant specification includes the assignment compound
13423 -- delimiter followed by an expression, the expression is the default
13424 -- expression of the discriminant; the default expression must be of
13425 -- the type of the discriminant. (RM 3.7.1) Since this expression is
13426 -- a default expression, we do the special preanalysis, since this
13427 -- expression does not freeze (see "Handling of Default and Per-
13428 -- Object Expressions" in spec of package Sem).
13430 if Present
(Expression
(Discr
)) then
13431 Analyze_Per_Use_Expression
(Expression
(Discr
), Discr_Type
);
13433 if Nkind
(N
) = N_Formal_Type_Declaration
then
13435 ("discriminant defaults not allowed for formal type",
13436 Expression
(Discr
));
13438 -- Tagged types cannot have defaulted discriminants, but a
13439 -- non-tagged private type with defaulted discriminants
13440 -- can have a tagged completion.
13442 elsif Is_Tagged_Type
(Current_Scope
)
13443 and then Comes_From_Source
(N
)
13446 ("discriminants of tagged type cannot have defaults",
13447 Expression
(Discr
));
13450 Default_Present
:= True;
13451 Append_Elmt
(Expression
(Discr
), Elist
);
13453 -- Tag the defining identifiers for the discriminants with
13454 -- their corresponding default expressions from the tree.
13456 Set_Discriminant_Default_Value
13457 (Defining_Identifier
(Discr
), Expression
(Discr
));
13461 Default_Not_Present
:= True;
13464 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
13465 -- Discr_Type but with the null-exclusion attribute
13467 if Ada_Version
>= Ada_05
then
13469 -- Ada 2005 (AI-231): Static checks
13471 if Can_Never_Be_Null
(Discr_Type
) then
13472 Null_Exclusion_Static_Checks
(Discr
);
13474 elsif Is_Access_Type
(Discr_Type
)
13475 and then Null_Exclusion_Present
(Discr
)
13477 -- No need to check itypes because in their case this check
13478 -- was done at their point of creation
13480 and then not Is_Itype
(Discr_Type
)
13482 if Can_Never_Be_Null
(Discr_Type
) then
13484 ("(Ada 2005) already a null-excluding type", Discr
);
13487 Set_Etype
(Defining_Identifier
(Discr
),
13488 Create_Null_Excluding_Itype
13490 Related_Nod
=> Discr
));
13498 -- An element list consisting of the default expressions of the
13499 -- discriminants is constructed in the above loop and used to set
13500 -- the Discriminant_Constraint attribute for the type. If an object
13501 -- is declared of this (record or task) type without any explicit
13502 -- discriminant constraint given, this element list will form the
13503 -- actual parameters for the corresponding initialization procedure
13506 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
13507 Set_Stored_Constraint
(Current_Scope
, No_Elist
);
13509 -- Default expressions must be provided either for all or for none
13510 -- of the discriminants of a discriminant part. (RM 3.7.1)
13512 if Default_Present
and then Default_Not_Present
then
13514 ("incomplete specification of defaults for discriminants", N
);
13517 -- The use of the name of a discriminant is not allowed in default
13518 -- expressions of a discriminant part if the specification of the
13519 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
13521 -- To detect this, the discriminant names are entered initially with an
13522 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
13523 -- attempt to use a void entity (for example in an expression that is
13524 -- type-checked) produces the error message: premature usage. Now after
13525 -- completing the semantic analysis of the discriminant part, we can set
13526 -- the Ekind of all the discriminants appropriately.
13528 Discr
:= First
(Discriminant_Specifications
(N
));
13529 Discr_Number
:= Uint_1
;
13530 while Present
(Discr
) loop
13531 Id
:= Defining_Identifier
(Discr
);
13532 Set_Ekind
(Id
, E_Discriminant
);
13533 Init_Component_Location
(Id
);
13535 Set_Discriminant_Number
(Id
, Discr_Number
);
13537 -- Make sure this is always set, even in illegal programs
13539 Set_Corresponding_Discriminant
(Id
, Empty
);
13541 -- Initialize the Original_Record_Component to the entity itself.
13542 -- Inherit_Components will propagate the right value to
13543 -- discriminants in derived record types.
13545 Set_Original_Record_Component
(Id
, Id
);
13547 -- Create the discriminal for the discriminant
13549 Build_Discriminal
(Id
);
13552 Discr_Number
:= Discr_Number
+ 1;
13555 Set_Has_Discriminants
(Current_Scope
);
13556 end Process_Discriminants
;
13558 -----------------------
13559 -- Process_Full_View --
13560 -----------------------
13562 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
13563 Priv_Parent
: Entity_Id
;
13564 Full_Parent
: Entity_Id
;
13565 Full_Indic
: Node_Id
;
13567 procedure Collect_Implemented_Interfaces
13569 Ifaces
: Elist_Id
);
13570 -- Ada 2005: Gather all the interfaces that Typ directly or
13571 -- inherently implements. Duplicate entries are not added to
13572 -- the list Ifaces.
13574 function Contain_Interface
13575 (Iface
: Entity_Id
;
13576 Ifaces
: Elist_Id
) return Boolean;
13577 -- Ada 2005: Determine whether Iface is present in the list Ifaces
13579 function Find_Hidden_Interface
13581 Dest
: Elist_Id
) return Entity_Id
;
13582 -- Ada 2005: Determine whether the interfaces in list Src are all
13583 -- present in the list Dest. Return the first differing interface,
13584 -- or Empty otherwise.
13586 ------------------------------------
13587 -- Collect_Implemented_Interfaces --
13588 ------------------------------------
13590 procedure Collect_Implemented_Interfaces
13595 Iface_Elmt
: Elmt_Id
;
13598 -- Abstract interfaces are only associated with tagged record types
13600 if not Is_Tagged_Type
(Typ
)
13601 or else not Is_Record_Type
(Typ
)
13606 -- Implementations of the form:
13607 -- type Typ is new Iface ...
13609 if Is_Interface
(Etype
(Typ
))
13610 and then not Contain_Interface
(Etype
(Typ
), Ifaces
)
13612 Append_Elmt
(Etype
(Typ
), Ifaces
);
13615 -- Implementations of the form:
13616 -- type Typ is ... and Iface ...
13618 if Present
(Abstract_Interfaces
(Typ
)) then
13619 Iface_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
13620 while Present
(Iface_Elmt
) loop
13621 Iface
:= Node
(Iface_Elmt
);
13623 pragma Assert
(Is_Interface
(Iface
));
13625 if not Contain_Interface
(Iface
, Ifaces
) then
13626 Append_Elmt
(Iface
, Ifaces
);
13627 Collect_Implemented_Interfaces
(Iface
, Ifaces
);
13630 Next_Elmt
(Iface_Elmt
);
13634 -- Implementations of the form:
13635 -- type Typ is new Parent_Typ and ...
13637 if Ekind
(Typ
) = E_Record_Type
13638 and then Present
(Parent_Subtype
(Typ
))
13640 Collect_Implemented_Interfaces
(Parent_Subtype
(Typ
), Ifaces
);
13642 -- Implementations of the form:
13643 -- type Typ is ... with private;
13645 elsif Ekind
(Typ
) = E_Record_Type_With_Private
13646 and then Present
(Full_View
(Typ
))
13647 and then Etype
(Typ
) /= Full_View
(Typ
)
13648 and then Etype
(Typ
) /= Typ
13650 Collect_Implemented_Interfaces
(Etype
(Typ
), Ifaces
);
13652 end Collect_Implemented_Interfaces
;
13654 -----------------------
13655 -- Contain_Interface --
13656 -----------------------
13658 function Contain_Interface
13659 (Iface
: Entity_Id
;
13660 Ifaces
: Elist_Id
) return Boolean
13662 Iface_Elmt
: Elmt_Id
;
13665 if Present
(Ifaces
) then
13666 Iface_Elmt
:= First_Elmt
(Ifaces
);
13667 while Present
(Iface_Elmt
) loop
13668 if Node
(Iface_Elmt
) = Iface
then
13672 Next_Elmt
(Iface_Elmt
);
13677 end Contain_Interface
;
13679 ---------------------------
13680 -- Find_Hidden_Interface --
13681 ---------------------------
13683 function Find_Hidden_Interface
13685 Dest
: Elist_Id
) return Entity_Id
13688 Iface_Elmt
: Elmt_Id
;
13691 if Present
(Src
) and then Present
(Dest
) then
13692 Iface_Elmt
:= First_Elmt
(Src
);
13693 while Present
(Iface_Elmt
) loop
13694 Iface
:= Node
(Iface_Elmt
);
13696 if not Contain_Interface
(Iface
, Dest
) then
13700 Next_Elmt
(Iface_Elmt
);
13705 end Find_Hidden_Interface
;
13707 -- Start of processing for Process_Full_View
13710 -- First some sanity checks that must be done after semantic
13711 -- decoration of the full view and thus cannot be placed with other
13712 -- similar checks in Find_Type_Name
13714 if not Is_Limited_Type
(Priv_T
)
13715 and then (Is_Limited_Type
(Full_T
)
13716 or else Is_Limited_Composite
(Full_T
))
13719 ("completion of nonlimited type cannot be limited", Full_T
);
13720 Explain_Limited_Type
(Full_T
, Full_T
);
13722 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
13724 ("completion of nonabstract type cannot be abstract", Full_T
);
13726 elsif Is_Tagged_Type
(Priv_T
)
13727 and then Is_Limited_Type
(Priv_T
)
13728 and then not Is_Limited_Type
(Full_T
)
13730 -- GNAT allow its own definition of Limited_Controlled to disobey
13731 -- this rule in order in ease the implementation. The next test is
13732 -- safe because Root_Controlled is defined in a private system child
13734 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
13735 Set_Is_Limited_Composite
(Full_T
);
13738 ("completion of limited tagged type must be limited", Full_T
);
13741 elsif Is_Generic_Type
(Priv_T
) then
13742 Error_Msg_N
("generic type cannot have a completion", Full_T
);
13745 if Ada_Version
>= Ada_05
13746 and then Is_Tagged_Type
(Priv_T
)
13747 and then Is_Tagged_Type
(Full_T
)
13751 Priv_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
13752 Full_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
13755 Collect_Implemented_Interfaces
(Priv_T
, Priv_T_Ifaces
);
13756 Collect_Implemented_Interfaces
(Full_T
, Full_T_Ifaces
);
13758 -- Ada 2005 (AI-251): The partial view shall be a descendant of
13759 -- an interface type if and only if the full type is descendant
13760 -- of the interface type (AARM 7.3 (7.3/2).
13762 Iface
:= Find_Hidden_Interface
(Priv_T_Ifaces
, Full_T_Ifaces
);
13764 if Present
(Iface
) then
13765 Error_Msg_NE
("interface & not implemented by full type " &
13766 "('R'M'-2005 7.3 (7.3/2))", Priv_T
, Iface
);
13769 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
13771 if Present
(Iface
) then
13772 Error_Msg_NE
("interface & not implemented by partial view " &
13773 "('R'M'-2005 7.3 (7.3/2))", Full_T
, Iface
);
13778 if Is_Tagged_Type
(Priv_T
)
13779 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
13780 and then Is_Derived_Type
(Full_T
)
13782 Priv_Parent
:= Etype
(Priv_T
);
13784 -- The full view of a private extension may have been transformed
13785 -- into an unconstrained derived type declaration and a subtype
13786 -- declaration (see build_derived_record_type for details).
13788 if Nkind
(N
) = N_Subtype_Declaration
then
13789 Full_Indic
:= Subtype_Indication
(N
);
13790 Full_Parent
:= Etype
(Base_Type
(Full_T
));
13792 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
13793 Full_Parent
:= Etype
(Full_T
);
13796 -- Check that the parent type of the full type is a descendant of
13797 -- the ancestor subtype given in the private extension. If either
13798 -- entity has an Etype equal to Any_Type then we had some previous
13799 -- error situation [7.3(8)].
13801 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
13804 -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in
13805 -- any order. Therefore we don't have to check that its parent must
13806 -- be a descendant of the parent of the private type declaration.
13808 elsif Is_Interface
(Priv_Parent
)
13809 and then Is_Interface
(Full_Parent
)
13813 -- Ada 2005 (AI-251): If the parent of the private type declaration
13814 -- is an interface there is no need to check that it is an ancestor
13815 -- of the associated full type declaration. The required tests for
13816 -- this case case are performed by Build_Derived_Record_Type.
13818 elsif not Is_Interface
(Base_Type
(Priv_Parent
))
13819 and then not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
)
13822 ("parent of full type must descend from parent"
13823 & " of private extension", Full_Indic
);
13825 -- Check the rules of 7.3(10): if the private extension inherits
13826 -- known discriminants, then the full type must also inherit those
13827 -- discriminants from the same (ancestor) type, and the parent
13828 -- subtype of the full type must be constrained if and only if
13829 -- the ancestor subtype of the private extension is constrained.
13831 elsif No
(Discriminant_Specifications
(Parent
(Priv_T
)))
13832 and then not Has_Unknown_Discriminants
(Priv_T
)
13833 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
13836 Priv_Indic
: constant Node_Id
:=
13837 Subtype_Indication
(Parent
(Priv_T
));
13839 Priv_Constr
: constant Boolean :=
13840 Is_Constrained
(Priv_Parent
)
13842 Nkind
(Priv_Indic
) = N_Subtype_Indication
13843 or else Is_Constrained
(Entity
(Priv_Indic
));
13845 Full_Constr
: constant Boolean :=
13846 Is_Constrained
(Full_Parent
)
13848 Nkind
(Full_Indic
) = N_Subtype_Indication
13849 or else Is_Constrained
(Entity
(Full_Indic
));
13851 Priv_Discr
: Entity_Id
;
13852 Full_Discr
: Entity_Id
;
13855 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
13856 Full_Discr
:= First_Discriminant
(Full_Parent
);
13857 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
13858 if Original_Record_Component
(Priv_Discr
) =
13859 Original_Record_Component
(Full_Discr
)
13861 Corresponding_Discriminant
(Priv_Discr
) =
13862 Corresponding_Discriminant
(Full_Discr
)
13869 Next_Discriminant
(Priv_Discr
);
13870 Next_Discriminant
(Full_Discr
);
13873 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
13875 ("full view must inherit discriminants of the parent type"
13876 & " used in the private extension", Full_Indic
);
13878 elsif Priv_Constr
and then not Full_Constr
then
13880 ("parent subtype of full type must be constrained",
13883 elsif Full_Constr
and then not Priv_Constr
then
13885 ("parent subtype of full type must be unconstrained",
13890 -- Check the rules of 7.3(12): if a partial view has neither known
13891 -- or unknown discriminants, then the full type declaration shall
13892 -- define a definite subtype.
13894 elsif not Has_Unknown_Discriminants
(Priv_T
)
13895 and then not Has_Discriminants
(Priv_T
)
13896 and then not Is_Constrained
(Full_T
)
13899 ("full view must define a constrained type if partial view"
13900 & " has no discriminants", Full_T
);
13903 -- ??????? Do we implement the following properly ?????
13904 -- If the ancestor subtype of a private extension has constrained
13905 -- discriminants, then the parent subtype of the full view shall
13906 -- impose a statically matching constraint on those discriminants
13910 -- For untagged types, verify that a type without discriminants
13911 -- is not completed with an unconstrained type.
13913 if not Is_Indefinite_Subtype
(Priv_T
)
13914 and then Is_Indefinite_Subtype
(Full_T
)
13916 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
13920 -- AI-419: verify that the use of "limited" is consistent
13923 Orig_Decl
: constant Node_Id
:= Original_Node
(N
);
13925 if Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
13926 and then not Limited_Present
(Parent
(Priv_T
))
13927 and then Nkind
(Orig_Decl
) = N_Full_Type_Declaration
13929 (Type_Definition
(Orig_Decl
)) = N_Derived_Type_Definition
13930 and then Limited_Present
(Type_Definition
(Orig_Decl
))
13933 ("full view of non-limited extension cannot be limited", N
);
13937 -- Ada 2005 AI-363: if the full view has discriminants with
13938 -- defaults, it is illegal to declare constrained access subtypes
13939 -- whose designated type is the current type. This allows objects
13940 -- of the type that are declared in the heap to be unconstrained.
13942 if not Has_Unknown_Discriminants
(Priv_T
)
13943 and then not Has_Discriminants
(Priv_T
)
13944 and then Has_Discriminants
(Full_T
)
13947 (Discriminant_Default_Value
(First_Discriminant
(Full_T
)))
13949 Set_Has_Constrained_Partial_View
(Full_T
);
13950 Set_Has_Constrained_Partial_View
(Priv_T
);
13953 -- Create a full declaration for all its subtypes recorded in
13954 -- Private_Dependents and swap them similarly to the base type. These
13955 -- are subtypes that have been define before the full declaration of
13956 -- the private type. We also swap the entry in Private_Dependents list
13957 -- so we can properly restore the private view on exit from the scope.
13960 Priv_Elmt
: Elmt_Id
;
13965 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
13966 while Present
(Priv_Elmt
) loop
13967 Priv
:= Node
(Priv_Elmt
);
13969 if Ekind
(Priv
) = E_Private_Subtype
13970 or else Ekind
(Priv
) = E_Limited_Private_Subtype
13971 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
13973 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
13974 Set_Is_Itype
(Full
);
13975 Set_Parent
(Full
, Parent
(Priv
));
13976 Set_Associated_Node_For_Itype
(Full
, N
);
13978 -- Now we need to complete the private subtype, but since the
13979 -- base type has already been swapped, we must also swap the
13980 -- subtypes (and thus, reverse the arguments in the call to
13981 -- Complete_Private_Subtype).
13983 Copy_And_Swap
(Priv
, Full
);
13984 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
13985 Replace_Elmt
(Priv_Elmt
, Full
);
13988 Next_Elmt
(Priv_Elmt
);
13992 -- If the private view was tagged, copy the new Primitive
13993 -- operations from the private view to the full view.
13995 if Is_Tagged_Type
(Full_T
) then
13997 Priv_List
: Elist_Id
;
13998 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
14001 D_Type
: Entity_Id
;
14004 if Is_Tagged_Type
(Priv_T
) then
14005 Priv_List
:= Primitive_Operations
(Priv_T
);
14007 P1
:= First_Elmt
(Priv_List
);
14008 while Present
(P1
) loop
14011 -- Transfer explicit primitives, not those inherited from
14012 -- parent of partial view, which will be re-inherited on
14015 if Comes_From_Source
(Prim
) then
14016 P2
:= First_Elmt
(Full_List
);
14017 while Present
(P2
) and then Node
(P2
) /= Prim
loop
14021 -- If not found, that is a new one
14024 Append_Elmt
(Prim
, Full_List
);
14032 -- In this case the partial view is untagged, so here we
14033 -- locate all of the earlier primitives that need to be
14034 -- treated as dispatching (those that appear between the two
14035 -- views). Note that these additional operations must all be
14036 -- new operations (any earlier operations that override
14037 -- inherited operations of the full view will already have
14038 -- been inserted in the primitives list and marked as
14039 -- dispatching by Check_Operation_From_Private_View. Note that
14040 -- implicit "/=" operators are excluded from being added to
14041 -- the primitives list since they shouldn't be treated as
14042 -- dispatching (tagged "/=" is handled specially).
14044 Prim
:= Next_Entity
(Full_T
);
14045 while Present
(Prim
) and then Prim
/= Priv_T
loop
14046 if Ekind
(Prim
) = E_Procedure
14048 Ekind
(Prim
) = E_Function
14051 D_Type
:= Find_Dispatching_Type
(Prim
);
14054 and then (Chars
(Prim
) /= Name_Op_Ne
14055 or else Comes_From_Source
(Prim
))
14057 Check_Controlling_Formals
(Full_T
, Prim
);
14059 if not Is_Dispatching_Operation
(Prim
) then
14060 Append_Elmt
(Prim
, Full_List
);
14061 Set_Is_Dispatching_Operation
(Prim
, True);
14062 Set_DT_Position
(Prim
, No_Uint
);
14065 elsif Is_Dispatching_Operation
(Prim
)
14066 and then D_Type
/= Full_T
14069 -- Verify that it is not otherwise controlled by
14070 -- a formal or a return value of type T.
14072 Check_Controlling_Formals
(D_Type
, Prim
);
14076 Next_Entity
(Prim
);
14080 -- For the tagged case, the two views can share the same
14081 -- Primitive Operation list and the same class wide type.
14082 -- Update attributes of the class-wide type which depend on
14083 -- the full declaration.
14085 if Is_Tagged_Type
(Priv_T
) then
14086 Set_Primitive_Operations
(Priv_T
, Full_List
);
14087 Set_Class_Wide_Type
14088 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
14090 -- Any other attributes should be propagated to C_W ???
14092 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
14097 end Process_Full_View
;
14099 -----------------------------------
14100 -- Process_Incomplete_Dependents --
14101 -----------------------------------
14103 procedure Process_Incomplete_Dependents
14105 Full_T
: Entity_Id
;
14108 Inc_Elmt
: Elmt_Id
;
14109 Priv_Dep
: Entity_Id
;
14110 New_Subt
: Entity_Id
;
14112 Disc_Constraint
: Elist_Id
;
14115 if No
(Private_Dependents
(Inc_T
)) then
14119 -- Itypes that may be generated by the completion of an incomplete
14120 -- subtype are not used by the back-end and not attached to the tree.
14121 -- They are created only for constraint-checking purposes.
14123 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
14124 while Present
(Inc_Elmt
) loop
14125 Priv_Dep
:= Node
(Inc_Elmt
);
14127 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
14129 -- An Access_To_Subprogram type may have a return type or a
14130 -- parameter type that is incomplete. Replace with the full view.
14132 if Etype
(Priv_Dep
) = Inc_T
then
14133 Set_Etype
(Priv_Dep
, Full_T
);
14137 Formal
: Entity_Id
;
14140 Formal
:= First_Formal
(Priv_Dep
);
14141 while Present
(Formal
) loop
14142 if Etype
(Formal
) = Inc_T
then
14143 Set_Etype
(Formal
, Full_T
);
14146 Next_Formal
(Formal
);
14150 elsif Is_Overloadable
(Priv_Dep
) then
14152 -- A protected operation is never dispatching: only its
14153 -- wrapper operation (which has convention Ada) is.
14155 if Is_Tagged_Type
(Full_T
)
14156 and then Convention
(Priv_Dep
) /= Convention_Protected
14159 -- Subprogram has an access parameter whose designated type
14160 -- was incomplete. Reexamine declaration now, because it may
14161 -- be a primitive operation of the full type.
14163 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
14164 Set_Is_Dispatching_Operation
(Priv_Dep
);
14165 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
14168 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
14170 -- Can happen during processing of a body before the completion
14171 -- of a TA type. Ignore, because spec is also on dependent list.
14175 -- Dependent is a subtype
14178 -- We build a new subtype indication using the full view of the
14179 -- incomplete parent. The discriminant constraints have been
14180 -- elaborated already at the point of the subtype declaration.
14182 New_Subt
:= Create_Itype
(E_Void
, N
);
14184 if Has_Discriminants
(Full_T
) then
14185 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
14187 Disc_Constraint
:= No_Elist
;
14190 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
14191 Set_Full_View
(Priv_Dep
, New_Subt
);
14194 Next_Elmt
(Inc_Elmt
);
14196 end Process_Incomplete_Dependents
;
14198 --------------------------------
14199 -- Process_Range_Expr_In_Decl --
14200 --------------------------------
14202 procedure Process_Range_Expr_In_Decl
14205 Check_List
: List_Id
:= Empty_List
;
14206 R_Check_Off
: Boolean := False)
14209 R_Checks
: Check_Result
;
14210 Type_Decl
: Node_Id
;
14211 Def_Id
: Entity_Id
;
14214 Analyze_And_Resolve
(R
, Base_Type
(T
));
14216 if Nkind
(R
) = N_Range
then
14217 Lo
:= Low_Bound
(R
);
14218 Hi
:= High_Bound
(R
);
14220 -- If there were errors in the declaration, try and patch up some
14221 -- common mistakes in the bounds. The cases handled are literals
14222 -- which are Integer where the expected type is Real and vice versa.
14223 -- These corrections allow the compilation process to proceed further
14224 -- along since some basic assumptions of the format of the bounds
14227 if Etype
(R
) = Any_Type
then
14229 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
14231 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
14233 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
14235 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
14237 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
14239 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
14241 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
14243 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
14250 -- If the bounds of the range have been mistakenly given as string
14251 -- literals (perhaps in place of character literals), then an error
14252 -- has already been reported, but we rewrite the string literal as a
14253 -- bound of the range's type to avoid blowups in later processing
14254 -- that looks at static values.
14256 if Nkind
(Lo
) = N_String_Literal
then
14258 Make_Attribute_Reference
(Sloc
(Lo
),
14259 Attribute_Name
=> Name_First
,
14260 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
14261 Analyze_And_Resolve
(Lo
);
14264 if Nkind
(Hi
) = N_String_Literal
then
14266 Make_Attribute_Reference
(Sloc
(Hi
),
14267 Attribute_Name
=> Name_First
,
14268 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
14269 Analyze_And_Resolve
(Hi
);
14272 -- If bounds aren't scalar at this point then exit, avoiding
14273 -- problems with further processing of the range in this procedure.
14275 if not Is_Scalar_Type
(Etype
(Lo
)) then
14279 -- Resolve (actually Sem_Eval) has checked that the bounds are in
14280 -- then range of the base type. Here we check whether the bounds
14281 -- are in the range of the subtype itself. Note that if the bounds
14282 -- represent the null range the Constraint_Error exception should
14285 -- ??? The following code should be cleaned up as follows
14287 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
14288 -- is done in the call to Range_Check (R, T); below
14290 -- 2. The use of R_Check_Off should be investigated and possibly
14291 -- removed, this would clean up things a bit.
14293 if Is_Null_Range
(Lo
, Hi
) then
14297 -- Capture values of bounds and generate temporaries for them
14298 -- if needed, before applying checks, since checks may cause
14299 -- duplication of the expression without forcing evaluation.
14301 if Expander_Active
then
14302 Force_Evaluation
(Lo
);
14303 Force_Evaluation
(Hi
);
14306 -- We use a flag here instead of suppressing checks on the
14307 -- type because the type we check against isn't necessarily
14308 -- the place where we put the check.
14310 if not R_Check_Off
then
14311 R_Checks
:= Range_Check
(R
, T
);
14313 -- Look up tree to find an appropriate insertion point.
14314 -- This seems really junk code, and very brittle, couldn't
14315 -- we just use an insert actions call of some kind ???
14317 Type_Decl
:= Parent
(R
);
14318 while Present
(Type_Decl
) and then not
14319 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
14321 Nkind
(Type_Decl
) = N_Subtype_Declaration
14323 Nkind
(Type_Decl
) = N_Loop_Statement
14325 Nkind
(Type_Decl
) = N_Task_Type_Declaration
14327 Nkind
(Type_Decl
) = N_Single_Task_Declaration
14329 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
14331 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
14333 Type_Decl
:= Parent
(Type_Decl
);
14336 -- Why would Type_Decl not be present??? Without this test,
14337 -- short regression tests fail.
14339 if Present
(Type_Decl
) then
14341 -- Case of loop statement (more comments ???)
14343 if Nkind
(Type_Decl
) = N_Loop_Statement
then
14348 Indic
:= Parent
(R
);
14349 while Present
(Indic
) and then not
14350 (Nkind
(Indic
) = N_Subtype_Indication
)
14352 Indic
:= Parent
(Indic
);
14355 if Present
(Indic
) then
14356 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
14358 Insert_Range_Checks
14364 Do_Before
=> True);
14368 -- All other cases (more comments ???)
14371 Def_Id
:= Defining_Identifier
(Type_Decl
);
14373 if (Ekind
(Def_Id
) = E_Record_Type
14374 and then Depends_On_Discriminant
(R
))
14376 (Ekind
(Def_Id
) = E_Protected_Type
14377 and then Has_Discriminants
(Def_Id
))
14379 Append_Range_Checks
14380 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
14383 Insert_Range_Checks
14384 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
14392 elsif Expander_Active
then
14393 Get_Index_Bounds
(R
, Lo
, Hi
);
14394 Force_Evaluation
(Lo
);
14395 Force_Evaluation
(Hi
);
14397 end Process_Range_Expr_In_Decl
;
14399 --------------------------------------
14400 -- Process_Real_Range_Specification --
14401 --------------------------------------
14403 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
14404 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
14407 Err
: Boolean := False;
14409 procedure Analyze_Bound
(N
: Node_Id
);
14410 -- Analyze and check one bound
14412 -------------------
14413 -- Analyze_Bound --
14414 -------------------
14416 procedure Analyze_Bound
(N
: Node_Id
) is
14418 Analyze_And_Resolve
(N
, Any_Real
);
14420 if not Is_OK_Static_Expression
(N
) then
14421 Flag_Non_Static_Expr
14422 ("bound in real type definition is not static!", N
);
14427 -- Start of processing for Process_Real_Range_Specification
14430 if Present
(Spec
) then
14431 Lo
:= Low_Bound
(Spec
);
14432 Hi
:= High_Bound
(Spec
);
14433 Analyze_Bound
(Lo
);
14434 Analyze_Bound
(Hi
);
14436 -- If error, clear away junk range specification
14439 Set_Real_Range_Specification
(Def
, Empty
);
14442 end Process_Real_Range_Specification
;
14444 ---------------------
14445 -- Process_Subtype --
14446 ---------------------
14448 function Process_Subtype
14450 Related_Nod
: Node_Id
;
14451 Related_Id
: Entity_Id
:= Empty
;
14452 Suffix
: Character := ' ') return Entity_Id
14455 Def_Id
: Entity_Id
;
14456 Error_Node
: Node_Id
;
14457 Full_View_Id
: Entity_Id
;
14458 Subtype_Mark_Id
: Entity_Id
;
14460 May_Have_Null_Exclusion
: Boolean;
14462 procedure Check_Incomplete
(T
: Entity_Id
);
14463 -- Called to verify that an incomplete type is not used prematurely
14465 ----------------------
14466 -- Check_Incomplete --
14467 ----------------------
14469 procedure Check_Incomplete
(T
: Entity_Id
) is
14471 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
then
14472 Error_Msg_N
("invalid use of type before its full declaration", T
);
14474 end Check_Incomplete
;
14476 -- Start of processing for Process_Subtype
14479 -- Case of no constraints present
14481 if Nkind
(S
) /= N_Subtype_Indication
then
14484 Check_Incomplete
(S
);
14487 -- Ada 2005 (AI-231): Static check
14489 if Ada_Version
>= Ada_05
14490 and then Present
(P
)
14491 and then Null_Exclusion_Present
(P
)
14492 and then Nkind
(P
) /= N_Access_To_Object_Definition
14493 and then not Is_Access_Type
(Entity
(S
))
14496 ("(Ada 2005) the null-exclusion part requires an access type",
14500 May_Have_Null_Exclusion
:=
14501 Nkind
(P
) = N_Access_Definition
14502 or else Nkind
(P
) = N_Access_Function_Definition
14503 or else Nkind
(P
) = N_Access_Procedure_Definition
14504 or else Nkind
(P
) = N_Access_To_Object_Definition
14505 or else Nkind
(P
) = N_Allocator
14506 or else Nkind
(P
) = N_Component_Definition
14507 or else Nkind
(P
) = N_Derived_Type_Definition
14508 or else Nkind
(P
) = N_Discriminant_Specification
14509 or else Nkind
(P
) = N_Object_Declaration
14510 or else Nkind
(P
) = N_Parameter_Specification
14511 or else Nkind
(P
) = N_Subtype_Declaration
;
14513 -- Create an Itype that is a duplicate of Entity (S) but with the
14514 -- null-exclusion attribute
14516 if May_Have_Null_Exclusion
14517 and then Is_Access_Type
(Entity
(S
))
14518 and then Null_Exclusion_Present
(P
)
14520 -- No need to check the case of an access to object definition.
14521 -- It is correct to define double not-null pointers.
14523 -- type Not_Null_Int_Ptr is not null access Integer;
14524 -- type Acc is not null access Not_Null_Int_Ptr;
14526 and then Nkind
(P
) /= N_Access_To_Object_Definition
14528 if Can_Never_Be_Null
(Entity
(S
)) then
14529 case Nkind
(Related_Nod
) is
14530 when N_Full_Type_Declaration
=>
14531 if Nkind
(Type_Definition
(Related_Nod
))
14532 in N_Array_Type_Definition
14536 (Component_Definition
14537 (Type_Definition
(Related_Nod
)));
14540 Subtype_Indication
(Type_Definition
(Related_Nod
));
14543 when N_Subtype_Declaration
=>
14544 Error_Node
:= Subtype_Indication
(Related_Nod
);
14546 when N_Object_Declaration
=>
14547 Error_Node
:= Object_Definition
(Related_Nod
);
14549 when N_Component_Declaration
=>
14551 Subtype_Indication
(Component_Definition
(Related_Nod
));
14554 pragma Assert
(False);
14555 Error_Node
:= Related_Nod
;
14559 ("(Ada 2005) already a null-excluding type", Error_Node
);
14563 Create_Null_Excluding_Itype
14565 Related_Nod
=> P
));
14566 Set_Entity
(S
, Etype
(S
));
14571 -- Case of constraint present, so that we have an N_Subtype_Indication
14572 -- node (this node is created only if constraints are present).
14576 Find_Type
(Subtype_Mark
(S
));
14578 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
14580 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
14581 and then Is_Itype
(Defining_Identifier
(Parent
(S
))))
14583 Check_Incomplete
(Subtype_Mark
(S
));
14587 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
14589 -- Explicit subtype declaration case
14591 if Nkind
(P
) = N_Subtype_Declaration
then
14592 Def_Id
:= Defining_Identifier
(P
);
14594 -- Explicit derived type definition case
14596 elsif Nkind
(P
) = N_Derived_Type_Definition
then
14597 Def_Id
:= Defining_Identifier
(Parent
(P
));
14599 -- Implicit case, the Def_Id must be created as an implicit type.
14600 -- The one exception arises in the case of concurrent types, array
14601 -- and access types, where other subsidiary implicit types may be
14602 -- created and must appear before the main implicit type. In these
14603 -- cases we leave Def_Id set to Empty as a signal that Create_Itype
14604 -- has not yet been called to create Def_Id.
14607 if Is_Array_Type
(Subtype_Mark_Id
)
14608 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
14609 or else Is_Access_Type
(Subtype_Mark_Id
)
14613 -- For the other cases, we create a new unattached Itype,
14614 -- and set the indication to ensure it gets attached later.
14618 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14622 -- If the kind of constraint is invalid for this kind of type,
14623 -- then give an error, and then pretend no constraint was given.
14625 if not Is_Valid_Constraint_Kind
14626 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
14629 ("incorrect constraint for this kind of type", Constraint
(S
));
14631 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
14633 -- Set Ekind of orphan itype, to prevent cascaded errors
14635 if Present
(Def_Id
) then
14636 Set_Ekind
(Def_Id
, Ekind
(Any_Type
));
14639 -- Make recursive call, having got rid of the bogus constraint
14641 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
14644 -- Remaining processing depends on type
14646 case Ekind
(Subtype_Mark_Id
) is
14647 when Access_Kind
=>
14648 Constrain_Access
(Def_Id
, S
, Related_Nod
);
14651 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
14653 when Decimal_Fixed_Point_Kind
=>
14654 Constrain_Decimal
(Def_Id
, S
);
14656 when Enumeration_Kind
=>
14657 Constrain_Enumeration
(Def_Id
, S
);
14659 when Ordinary_Fixed_Point_Kind
=>
14660 Constrain_Ordinary_Fixed
(Def_Id
, S
);
14663 Constrain_Float
(Def_Id
, S
);
14665 when Integer_Kind
=>
14666 Constrain_Integer
(Def_Id
, S
);
14668 when E_Record_Type |
14671 E_Incomplete_Type
=>
14672 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14674 when Private_Kind
=>
14675 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14676 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
14678 -- In case of an invalid constraint prevent further processing
14679 -- since the type constructed is missing expected fields.
14681 if Etype
(Def_Id
) = Any_Type
then
14685 -- If the full view is that of a task with discriminants,
14686 -- we must constrain both the concurrent type and its
14687 -- corresponding record type. Otherwise we will just propagate
14688 -- the constraint to the full view, if available.
14690 if Present
(Full_View
(Subtype_Mark_Id
))
14691 and then Has_Discriminants
(Subtype_Mark_Id
)
14692 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
14695 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14697 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
14698 Constrain_Concurrent
(Full_View_Id
, S
,
14699 Related_Nod
, Related_Id
, Suffix
);
14700 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
14701 Set_Full_View
(Def_Id
, Full_View_Id
);
14704 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
14707 when Concurrent_Kind
=>
14708 Constrain_Concurrent
(Def_Id
, S
,
14709 Related_Nod
, Related_Id
, Suffix
);
14712 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
14715 -- Size and Convention are always inherited from the base type
14717 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
14718 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
14722 end Process_Subtype
;
14724 -----------------------------
14725 -- Record_Type_Declaration --
14726 -----------------------------
14728 procedure Record_Type_Declaration
14733 Loc
: constant Source_Ptr
:= Sloc
(N
);
14734 Def
: constant Node_Id
:= Type_Definition
(N
);
14735 Inc_T
: Entity_Id
:= Empty
;
14737 Is_Tagged
: Boolean;
14738 Tag_Comp
: Entity_Id
;
14740 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
);
14741 -- Ada 2005 AI-382: an access component in a record declaration can
14742 -- refer to the enclosing record, in which case it denotes the type
14743 -- itself, and not the current instance of the type. We create an
14744 -- anonymous access type for the component, and flag it as an access
14745 -- to a component, so that accessibility checks are properly performed
14746 -- on it. The declaration of the access type is placed ahead of that
14747 -- of the record, to prevent circular order-of-elaboration issues in
14748 -- Gigi. We create an incomplete type for the record declaration, which
14749 -- is the designated type of the anonymous access.
14751 procedure Make_Incomplete_Type_Declaration
;
14752 -- If the record type contains components that include an access to the
14753 -- current record, create an incomplete type declaration for the record,
14754 -- to be used as the designated type of the anonymous access. This is
14755 -- done only once, and only if there is no previous partial view of the
14758 ----------------------------------
14759 -- Check_Anonymous_Access_Types --
14760 ----------------------------------
14762 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
) is
14763 Anon_Access
: Entity_Id
;
14767 Type_Def
: Node_Id
;
14769 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean;
14770 -- Check whether an access definition includes a reference to
14771 -- the enclosing record type. The reference can be a subtype
14772 -- mark in the access definition itself, or a 'Class attribute
14773 -- reference, or recursively a reference appearing in a parameter
14774 -- type in an access_to_subprogram definition.
14780 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean is
14784 if No
(Access_To_Subprogram_Definition
(Acc_Def
)) then
14785 Subt
:= Subtype_Mark
(Acc_Def
);
14787 if Nkind
(Subt
) = N_Identifier
then
14788 return Chars
(Subt
) = Chars
(T
);
14790 -- A reference to the current type may appear as the prefix
14791 -- of a 'Class attribute.
14793 elsif Nkind
(Subt
) = N_Attribute_Reference
14794 and then Attribute_Name
(Subt
) = Name_Class
14795 and then Is_Entity_Name
(Prefix
(Subt
))
14797 return (Chars
(Prefix
(Subt
))) = Chars
(T
);
14803 -- Component is an access_to_subprogram: examine its formals
14806 Param_Spec
: Node_Id
;
14811 (Parameter_Specifications
14812 (Access_To_Subprogram_Definition
(Acc_Def
)));
14813 while Present
(Param_Spec
) loop
14814 if Nkind
(Parameter_Type
(Param_Spec
))
14815 = N_Access_Definition
14816 and then Mentions_T
(Parameter_Type
(Param_Spec
))
14829 -- Start of processing for Check_Anonymous_Access_Types
14832 if No
(Comp_List
) then
14836 Comp
:= First
(Component_Items
(Comp_List
));
14837 while Present
(Comp
) loop
14838 if Nkind
(Comp
) = N_Component_Declaration
14840 Present
(Access_Definition
(Component_Definition
(Comp
)))
14842 Mentions_T
(Access_Definition
(Component_Definition
(Comp
)))
14845 Access_To_Subprogram_Definition
14846 (Access_Definition
(Component_Definition
(Comp
)));
14848 Make_Incomplete_Type_Declaration
;
14850 Make_Defining_Identifier
(Loc
,
14851 Chars
=> New_Internal_Name
('S'));
14853 -- Create a declaration for the anonymous access type: either
14854 -- an access_to_object or an access_to_subprogram.
14856 if Present
(Acc_Def
) then
14857 if Nkind
(Acc_Def
) = N_Access_Function_Definition
then
14859 Make_Access_Function_Definition
(Loc
,
14860 Parameter_Specifications
=>
14861 Parameter_Specifications
(Acc_Def
),
14862 Result_Definition
=> Result_Definition
(Acc_Def
));
14865 Make_Access_Procedure_Definition
(Loc
,
14866 Parameter_Specifications
=>
14867 Parameter_Specifications
(Acc_Def
));
14872 Make_Access_To_Object_Definition
(Loc
,
14873 Subtype_Indication
=>
14877 (Component_Definition
(Comp
)))));
14880 Decl
:= Make_Full_Type_Declaration
(Loc
,
14881 Defining_Identifier
=> Anon_Access
,
14882 Type_Definition
=> Type_Def
);
14884 Insert_Before
(N
, Decl
);
14887 Rewrite
(Component_Definition
(Comp
),
14888 Make_Component_Definition
(Loc
,
14889 Subtype_Indication
=>
14890 New_Occurrence_Of
(Anon_Access
, Loc
)));
14891 Set_Ekind
(Anon_Access
, E_Anonymous_Access_Type
);
14892 Set_Is_Local_Anonymous_Access
(Anon_Access
);
14898 if Present
(Variant_Part
(Comp_List
)) then
14902 V
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
14903 while Present
(V
) loop
14904 Check_Anonymous_Access_Types
(Component_List
(V
));
14905 Next_Non_Pragma
(V
);
14909 end Check_Anonymous_Access_Types
;
14911 --------------------------------------
14912 -- Make_Incomplete_Type_Declaration --
14913 --------------------------------------
14915 procedure Make_Incomplete_Type_Declaration
is
14920 -- If there is a previous partial view, no need to create a new one
14921 -- If the partial view is incomplete, it is given by Prev. If it is
14922 -- a private declaration, full declaration is flagged accordingly.
14925 or else Has_Private_Declaration
(T
)
14929 elsif No
(Inc_T
) then
14930 Inc_T
:= Make_Defining_Identifier
(Loc
, Chars
(T
));
14931 Decl
:= Make_Incomplete_Type_Declaration
(Loc
, Inc_T
);
14933 -- Type has already been inserted into the current scope.
14934 -- Remove it, and add incomplete declaration for type, so
14935 -- that subsequent anonymous access types can use it.
14937 H
:= Current_Entity
(T
);
14940 Set_Name_Entity_Id
(Chars
(T
), Empty
);
14943 and then Homonym
(H
) /= T
14948 Set_Homonym
(H
, Homonym
(T
));
14951 Insert_Before
(N
, Decl
);
14953 Set_Full_View
(Inc_T
, T
);
14955 if Tagged_Present
(Def
) then
14956 Make_Class_Wide_Type
(Inc_T
);
14957 Set_Class_Wide_Type
(T
, Class_Wide_Type
(Inc_T
));
14958 Set_Etype
(Class_Wide_Type
(T
), T
);
14961 end Make_Incomplete_Type_Declaration
;
14963 -- Start of processing for Record_Type_Declaration
14966 -- These flags must be initialized before calling Process_Discriminants
14967 -- because this routine makes use of them.
14969 Set_Ekind
(T
, E_Record_Type
);
14971 Init_Size_Align
(T
);
14972 Set_Abstract_Interfaces
(T
, No_Elist
);
14973 Set_Stored_Constraint
(T
, No_Elist
);
14977 if Ada_Version
< Ada_05
14978 or else not Interface_Present
(Def
)
14980 -- The flag Is_Tagged_Type might have already been set by
14981 -- Find_Type_Name if it detected an error for declaration T. This
14982 -- arises in the case of private tagged types where the full view
14983 -- omits the word tagged.
14986 Tagged_Present
(Def
)
14987 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
14989 Set_Is_Tagged_Type
(T
, Is_Tagged
);
14990 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
14992 -- Type is abstract if full declaration carries keyword, or if
14993 -- previous partial view did.
14995 Set_Is_Abstract
(T
, Is_Abstract
(T
)
14996 or else Abstract_Present
(Def
));
15000 Analyze_Interface_Declaration
(T
, Def
);
15003 -- First pass: if there are self-referential access components,
15004 -- create the required anonymous access type declarations, and if
15005 -- need be an incomplete type declaration for T itself.
15007 Check_Anonymous_Access_Types
(Component_List
(Def
));
15009 if Ada_Version
>= Ada_05
15010 and then Present
(Interface_List
(Def
))
15014 Iface_Def
: Node_Id
;
15015 Iface_Typ
: Entity_Id
;
15018 Iface
:= First
(Interface_List
(Def
));
15019 while Present
(Iface
) loop
15020 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
15021 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
15023 if not Is_Interface
(Iface_Typ
) then
15024 Error_Msg_NE
("(Ada 2005) & must be an interface",
15028 -- "The declaration of a specific descendant of an
15029 -- interface type freezes the interface type" RM 13.14
15031 Freeze_Before
(N
, Iface_Typ
);
15033 -- Ada 2005 (AI-345): Protected interfaces can only
15034 -- inherit from limited, synchronized or protected
15037 if Protected_Present
(Def
) then
15038 if Limited_Present
(Iface_Def
)
15039 or else Synchronized_Present
(Iface_Def
)
15040 or else Protected_Present
(Iface_Def
)
15044 elsif Task_Present
(Iface_Def
) then
15045 Error_Msg_N
("(Ada 2005) protected interface cannot"
15046 & " inherit from task interface", Iface
);
15049 Error_Msg_N
("(Ada 2005) protected interface cannot"
15050 & " inherit from non-limited interface", Iface
);
15053 -- Ada 2005 (AI-345): Synchronized interfaces can only
15054 -- inherit from limited and synchronized.
15056 elsif Synchronized_Present
(Def
) then
15057 if Limited_Present
(Iface_Def
)
15058 or else Synchronized_Present
(Iface_Def
)
15062 elsif Protected_Present
(Iface_Def
) then
15063 Error_Msg_N
("(Ada 2005) synchronized interface " &
15064 "cannot inherit from protected interface", Iface
);
15066 elsif Task_Present
(Iface_Def
) then
15067 Error_Msg_N
("(Ada 2005) synchronized interface " &
15068 "cannot inherit from task interface", Iface
);
15071 Error_Msg_N
("(Ada 2005) synchronized interface " &
15072 "cannot inherit from non-limited interface",
15076 -- Ada 2005 (AI-345): Task interfaces can only inherit
15077 -- from limited, synchronized or task interfaces.
15079 elsif Task_Present
(Def
) then
15080 if Limited_Present
(Iface_Def
)
15081 or else Synchronized_Present
(Iface_Def
)
15082 or else Task_Present
(Iface_Def
)
15086 elsif Protected_Present
(Iface_Def
) then
15087 Error_Msg_N
("(Ada 2005) task interface cannot" &
15088 " inherit from protected interface", Iface
);
15091 Error_Msg_N
("(Ada 2005) task interface cannot" &
15092 " inherit from non-limited interface", Iface
);
15099 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
15100 Collect_Interfaces
(Def
, T
);
15104 -- Records constitute a scope for the component declarations within.
15105 -- The scope is created prior to the processing of these declarations.
15106 -- Discriminants are processed first, so that they are visible when
15107 -- processing the other components. The Ekind of the record type itself
15108 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
15110 -- Enter record scope
15114 -- If an incomplete or private type declaration was already given for
15115 -- the type, then this scope already exists, and the discriminants have
15116 -- been declared within. We must verify that the full declaration
15117 -- matches the incomplete one.
15119 Check_Or_Process_Discriminants
(N
, T
, Prev
);
15121 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
15122 Set_Has_Delayed_Freeze
(T
, True);
15124 -- For tagged types add a manually analyzed component corresponding
15125 -- to the component _tag, the corresponding piece of tree will be
15126 -- expanded as part of the freezing actions if it is not a CPP_Class.
15130 -- Do not add the tag unless we are in expansion mode
15132 if Expander_Active
then
15133 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
15134 Enter_Name
(Tag_Comp
);
15136 Set_Is_Tag
(Tag_Comp
);
15137 Set_Is_Aliased
(Tag_Comp
);
15138 Set_Ekind
(Tag_Comp
, E_Component
);
15139 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
15140 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
15141 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
15142 Init_Component_Location
(Tag_Comp
);
15144 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
15145 -- implemented interfaces
15147 Add_Interface_Tag_Components
(N
, T
);
15150 Make_Class_Wide_Type
(T
);
15151 Set_Primitive_Operations
(T
, New_Elmt_List
);
15154 -- We must suppress range checks when processing the components
15155 -- of a record in the presence of discriminants, since we don't
15156 -- want spurious checks to be generated during their analysis, but
15157 -- must reset the Suppress_Range_Checks flags after having processed
15158 -- the record definition.
15160 if Has_Discriminants
(T
) and then not Range_Checks_Suppressed
(T
) then
15161 Set_Kill_Range_Checks
(T
, True);
15162 Record_Type_Definition
(Def
, Prev
);
15163 Set_Kill_Range_Checks
(T
, False);
15165 Record_Type_Definition
(Def
, Prev
);
15168 -- Exit from record scope
15174 and then not Is_Empty_List
(Interface_List
(Def
))
15176 -- Ada 2005 (AI-251): Derive the interface subprograms of all the
15177 -- implemented interfaces and check if some of the subprograms
15178 -- inherited from the ancestor cover some interface subprogram.
15180 Derive_Interface_Subprograms
(T
);
15182 end Record_Type_Declaration
;
15184 ----------------------------
15185 -- Record_Type_Definition --
15186 ----------------------------
15188 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
) is
15189 Component
: Entity_Id
;
15190 Ctrl_Components
: Boolean := False;
15191 Final_Storage_Only
: Boolean;
15195 if Ekind
(Prev_T
) = E_Incomplete_Type
then
15196 T
:= Full_View
(Prev_T
);
15201 Final_Storage_Only
:= not Is_Controlled
(T
);
15203 -- Ada 2005: check whether an explicit Limited is present in a derived
15204 -- type declaration.
15206 if Nkind
(Parent
(Def
)) = N_Derived_Type_Definition
15207 and then Limited_Present
(Parent
(Def
))
15209 Set_Is_Limited_Record
(T
);
15212 -- If the component list of a record type is defined by the reserved
15213 -- word null and there is no discriminant part, then the record type has
15214 -- no components and all records of the type are null records (RM 3.7)
15215 -- This procedure is also called to process the extension part of a
15216 -- record extension, in which case the current scope may have inherited
15220 or else No
(Component_List
(Def
))
15221 or else Null_Present
(Component_List
(Def
))
15226 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
15228 if Present
(Variant_Part
(Component_List
(Def
))) then
15229 Analyze
(Variant_Part
(Component_List
(Def
)));
15233 -- After completing the semantic analysis of the record definition,
15234 -- record components, both new and inherited, are accessible. Set
15235 -- their kind accordingly.
15237 Component
:= First_Entity
(Current_Scope
);
15238 while Present
(Component
) loop
15239 if Ekind
(Component
) = E_Void
then
15240 Set_Ekind
(Component
, E_Component
);
15241 Init_Component_Location
(Component
);
15244 if Has_Task
(Etype
(Component
)) then
15248 if Ekind
(Component
) /= E_Component
then
15251 elsif Has_Controlled_Component
(Etype
(Component
))
15252 or else (Chars
(Component
) /= Name_uParent
15253 and then Is_Controlled
(Etype
(Component
)))
15255 Set_Has_Controlled_Component
(T
, True);
15256 Final_Storage_Only
:= Final_Storage_Only
15257 and then Finalize_Storage_Only
(Etype
(Component
));
15258 Ctrl_Components
:= True;
15261 Next_Entity
(Component
);
15264 -- A type is Finalize_Storage_Only only if all its controlled
15265 -- components are so.
15267 if Ctrl_Components
then
15268 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
15271 -- Place reference to end record on the proper entity, which may
15272 -- be a partial view.
15274 if Present
(Def
) then
15275 Process_End_Label
(Def
, 'e', Prev_T
);
15277 end Record_Type_Definition
;
15279 ------------------------
15280 -- Replace_Components --
15281 ------------------------
15283 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
15284 function Process
(N
: Node_Id
) return Traverse_Result
;
15290 function Process
(N
: Node_Id
) return Traverse_Result
is
15294 if Nkind
(N
) = N_Discriminant_Specification
then
15295 Comp
:= First_Discriminant
(Typ
);
15296 while Present
(Comp
) loop
15297 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15298 Set_Defining_Identifier
(N
, Comp
);
15302 Next_Discriminant
(Comp
);
15305 elsif Nkind
(N
) = N_Component_Declaration
then
15306 Comp
:= First_Component
(Typ
);
15307 while Present
(Comp
) loop
15308 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15309 Set_Defining_Identifier
(N
, Comp
);
15313 Next_Component
(Comp
);
15320 procedure Replace
is new Traverse_Proc
(Process
);
15322 -- Start of processing for Replace_Components
15326 end Replace_Components
;
15328 -------------------------------
15329 -- Set_Completion_Referenced --
15330 -------------------------------
15332 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
15334 -- If in main unit, mark entity that is a completion as referenced,
15335 -- warnings go on the partial view when needed.
15337 if In_Extended_Main_Source_Unit
(E
) then
15338 Set_Referenced
(E
);
15340 end Set_Completion_Referenced
;
15342 ---------------------
15343 -- Set_Fixed_Range --
15344 ---------------------
15346 -- The range for fixed-point types is complicated by the fact that we
15347 -- do not know the exact end points at the time of the declaration. This
15348 -- is true for three reasons:
15350 -- A size clause may affect the fudging of the end-points
15351 -- A small clause may affect the values of the end-points
15352 -- We try to include the end-points if it does not affect the size
15354 -- This means that the actual end-points must be established at the point
15355 -- when the type is frozen. Meanwhile, we first narrow the range as
15356 -- permitted (so that it will fit if necessary in a small specified size),
15357 -- and then build a range subtree with these narrowed bounds.
15359 -- Set_Fixed_Range constructs the range from real literal values, and sets
15360 -- the range as the Scalar_Range of the given fixed-point type entity.
15362 -- The parent of this range is set to point to the entity so that it is
15363 -- properly hooked into the tree (unlike normal Scalar_Range entries for
15364 -- other scalar types, which are just pointers to the range in the
15365 -- original tree, this would otherwise be an orphan).
15367 -- The tree is left unanalyzed. When the type is frozen, the processing
15368 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
15369 -- analyzed, and uses this as an indication that it should complete
15370 -- work on the range (it will know the final small and size values).
15372 procedure Set_Fixed_Range
15378 S
: constant Node_Id
:=
15380 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
15381 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
15384 Set_Scalar_Range
(E
, S
);
15386 end Set_Fixed_Range
;
15388 ----------------------------------
15389 -- Set_Scalar_Range_For_Subtype --
15390 ----------------------------------
15392 procedure Set_Scalar_Range_For_Subtype
15393 (Def_Id
: Entity_Id
;
15397 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
15400 Set_Scalar_Range
(Def_Id
, R
);
15402 -- We need to link the range into the tree before resolving it so
15403 -- that types that are referenced, including importantly the subtype
15404 -- itself, are properly frozen (Freeze_Expression requires that the
15405 -- expression be properly linked into the tree). Of course if it is
15406 -- already linked in, then we do not disturb the current link.
15408 if No
(Parent
(R
)) then
15409 Set_Parent
(R
, Def_Id
);
15412 -- Reset the kind of the subtype during analysis of the range, to
15413 -- catch possible premature use in the bounds themselves.
15415 Set_Ekind
(Def_Id
, E_Void
);
15416 Process_Range_Expr_In_Decl
(R
, Subt
);
15417 Set_Ekind
(Def_Id
, Kind
);
15419 end Set_Scalar_Range_For_Subtype
;
15421 --------------------------------------------------------
15422 -- Set_Stored_Constraint_From_Discriminant_Constraint --
15423 --------------------------------------------------------
15425 procedure Set_Stored_Constraint_From_Discriminant_Constraint
15429 -- Make sure set if encountered during Expand_To_Stored_Constraint
15431 Set_Stored_Constraint
(E
, No_Elist
);
15433 -- Give it the right value
15435 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
15436 Set_Stored_Constraint
(E
,
15437 Expand_To_Stored_Constraint
(E
, Discriminant_Constraint
(E
)));
15439 end Set_Stored_Constraint_From_Discriminant_Constraint
;
15441 -------------------------------------
15442 -- Signed_Integer_Type_Declaration --
15443 -------------------------------------
15445 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
15446 Implicit_Base
: Entity_Id
;
15447 Base_Typ
: Entity_Id
;
15450 Errs
: Boolean := False;
15454 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
15455 -- Determine whether given bounds allow derivation from specified type
15457 procedure Check_Bound
(Expr
: Node_Id
);
15458 -- Check bound to make sure it is integral and static. If not, post
15459 -- appropriate error message and set Errs flag
15461 ---------------------
15462 -- Can_Derive_From --
15463 ---------------------
15465 -- Note we check both bounds against both end values, to deal with
15466 -- strange types like ones with a range of 0 .. -12341234.
15468 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
15469 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
15470 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
15472 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
15474 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
15475 end Can_Derive_From
;
15481 procedure Check_Bound
(Expr
: Node_Id
) is
15483 -- If a range constraint is used as an integer type definition, each
15484 -- bound of the range must be defined by a static expression of some
15485 -- integer type, but the two bounds need not have the same integer
15486 -- type (Negative bounds are allowed.) (RM 3.5.4)
15488 if not Is_Integer_Type
(Etype
(Expr
)) then
15490 ("integer type definition bounds must be of integer type", Expr
);
15493 elsif not Is_OK_Static_Expression
(Expr
) then
15494 Flag_Non_Static_Expr
15495 ("non-static expression used for integer type bound!", Expr
);
15498 -- The bounds are folded into literals, and we set their type to be
15499 -- universal, to avoid typing difficulties: we cannot set the type
15500 -- of the literal to the new type, because this would be a forward
15501 -- reference for the back end, and if the original type is user-
15502 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
15505 if Is_Entity_Name
(Expr
) then
15506 Fold_Uint
(Expr
, Expr_Value
(Expr
), True);
15509 Set_Etype
(Expr
, Universal_Integer
);
15513 -- Start of processing for Signed_Integer_Type_Declaration
15516 -- Create an anonymous base type
15519 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
15521 -- Analyze and check the bounds, they can be of any integer type
15523 Lo
:= Low_Bound
(Def
);
15524 Hi
:= High_Bound
(Def
);
15526 -- Arbitrarily use Integer as the type if either bound had an error
15528 if Hi
= Error
or else Lo
= Error
then
15529 Base_Typ
:= Any_Integer
;
15530 Set_Error_Posted
(T
, True);
15532 -- Here both bounds are OK expressions
15535 Analyze_And_Resolve
(Lo
, Any_Integer
);
15536 Analyze_And_Resolve
(Hi
, Any_Integer
);
15542 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
15543 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
15546 -- Find type to derive from
15548 Lo_Val
:= Expr_Value
(Lo
);
15549 Hi_Val
:= Expr_Value
(Hi
);
15551 if Can_Derive_From
(Standard_Short_Short_Integer
) then
15552 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
15554 elsif Can_Derive_From
(Standard_Short_Integer
) then
15555 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
15557 elsif Can_Derive_From
(Standard_Integer
) then
15558 Base_Typ
:= Base_Type
(Standard_Integer
);
15560 elsif Can_Derive_From
(Standard_Long_Integer
) then
15561 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
15563 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
15564 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
15567 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
15568 Error_Msg_N
("integer type definition bounds out of range", Def
);
15569 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
15570 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
15574 -- Complete both implicit base and declared first subtype entities
15576 Set_Etype
(Implicit_Base
, Base_Typ
);
15577 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
15578 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
15579 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
15580 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
15582 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
15583 Set_Etype
(T
, Implicit_Base
);
15585 Set_Size_Info
(T
, (Implicit_Base
));
15586 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
15587 Set_Scalar_Range
(T
, Def
);
15588 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
15589 Set_Is_Constrained
(T
);
15590 end Signed_Integer_Type_Declaration
;