1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Elists
; use Elists
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Eval_Fat
; use Eval_Fat
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Dist
; use Exp_Dist
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
38 with Itypes
; use Itypes
;
39 with Layout
; use Layout
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Case
; use Sem_Case
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch6
; use Sem_Ch6
;
52 with Sem_Ch7
; use Sem_Ch7
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch13
; use Sem_Ch13
;
55 with Sem_Disp
; use Sem_Disp
;
56 with Sem_Dist
; use Sem_Dist
;
57 with Sem_Elim
; use Sem_Elim
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Mech
; use Sem_Mech
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Smem
; use Sem_Smem
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Warn
; use Sem_Warn
;
65 with Stand
; use Stand
;
66 with Sinfo
; use Sinfo
;
67 with Snames
; use Snames
;
68 with Tbuild
; use Tbuild
;
69 with Ttypes
; use Ttypes
;
70 with Uintp
; use Uintp
;
71 with Urealp
; use Urealp
;
73 package body Sem_Ch3
is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 procedure Add_Interface_Tag_Components
80 (N
: Node_Id
; Typ
: Entity_Id
);
81 -- Ada 2005 (AI-251): Add the tag components corresponding to all the
82 -- abstract interface types implemented by a record type or a derived
85 procedure Build_Derived_Type
87 Parent_Type
: Entity_Id
;
88 Derived_Type
: Entity_Id
;
89 Is_Completion
: Boolean;
90 Derive_Subps
: Boolean := True);
91 -- Create and decorate a Derived_Type given the Parent_Type entity. N is
92 -- the N_Full_Type_Declaration node containing the derived type definition.
93 -- Parent_Type is the entity for the parent type in the derived type
94 -- definition and Derived_Type the actual derived type. Is_Completion must
95 -- be set to False if Derived_Type is the N_Defining_Identifier node in N
96 -- (ie Derived_Type = Defining_Identifier (N)). In this case N is not the
97 -- completion of a private type declaration. If Is_Completion is set to
98 -- True, N is the completion of a private type declaration and Derived_Type
99 -- is different from the defining identifier inside N (i.e. Derived_Type /=
100 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent
101 -- subprograms should be derived. The only case where this parameter is
102 -- False is when Build_Derived_Type is recursively called to process an
103 -- implicit derived full type for a type derived from a private type (in
104 -- that case the subprograms must only be derived for the private view of
107 -- ??? These flags need a bit of re-examination and re-documentation:
108 -- ??? are they both necessary (both seem related to the recursion)?
110 procedure Build_Derived_Access_Type
112 Parent_Type
: Entity_Id
;
113 Derived_Type
: Entity_Id
);
114 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
115 -- create an implicit base if the parent type is constrained or if the
116 -- subtype indication has a constraint.
118 procedure Build_Derived_Array_Type
120 Parent_Type
: Entity_Id
;
121 Derived_Type
: Entity_Id
);
122 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
123 -- create an implicit base if the parent type is constrained or if the
124 -- subtype indication has a constraint.
126 procedure Build_Derived_Concurrent_Type
128 Parent_Type
: Entity_Id
;
129 Derived_Type
: Entity_Id
);
130 -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
131 -- tected type, inherit entries and protected subprograms, check legality
132 -- of discriminant constraints if any.
134 procedure Build_Derived_Enumeration_Type
136 Parent_Type
: Entity_Id
;
137 Derived_Type
: Entity_Id
);
138 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
139 -- type, we must create a new list of literals. Types derived from
140 -- Character and Wide_Character are special-cased.
142 procedure Build_Derived_Numeric_Type
144 Parent_Type
: Entity_Id
;
145 Derived_Type
: Entity_Id
);
146 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
147 -- an anonymous base type, and propagate constraint to subtype if needed.
149 procedure Build_Derived_Private_Type
151 Parent_Type
: Entity_Id
;
152 Derived_Type
: Entity_Id
;
153 Is_Completion
: Boolean;
154 Derive_Subps
: Boolean := True);
155 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
156 -- because the parent may or may not have a completion, and the derivation
157 -- may itself be a completion.
159 procedure Build_Derived_Record_Type
161 Parent_Type
: Entity_Id
;
162 Derived_Type
: Entity_Id
;
163 Derive_Subps
: Boolean := True);
164 -- Subsidiary procedure for Build_Derived_Type and
165 -- Analyze_Private_Extension_Declaration used for tagged and untagged
166 -- record types. All parameters are as in Build_Derived_Type except that
167 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
168 -- N_Private_Extension_Declaration node. See the definition of this routine
169 -- for much more info. Derive_Subps indicates whether subprograms should
170 -- be derived from the parent type. The only case where Derive_Subps is
171 -- False is for an implicit derived full type for a type derived from a
172 -- private type (see Build_Derived_Type).
174 procedure Collect_Interfaces
176 Derived_Type
: Entity_Id
);
177 -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
178 -- Collect the list of interfaces that are not already implemented by the
179 -- ancestors. This is the list of interfaces for which we must provide
180 -- additional tag components.
182 procedure Complete_Subprograms_Derivation
183 (Partial_View
: Entity_Id
;
184 Derived_Type
: Entity_Id
);
185 -- Ada 2005 (AI-251): Used to complete type derivation of private tagged
186 -- types implementing interfaces. In this case some interface primitives
187 -- may have been overriden with the partial-view and, instead of
188 -- re-calculating them, they are included in the list of primitive
189 -- operations of the full-view.
191 function Inherit_Components
193 Parent_Base
: Entity_Id
;
194 Derived_Base
: Entity_Id
;
196 Inherit_Discr
: Boolean;
197 Discs
: Elist_Id
) return Elist_Id
;
198 -- Called from Build_Derived_Record_Type to inherit the components of
199 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
200 -- For more information on derived types and component inheritance please
201 -- consult the comment above the body of Build_Derived_Record_Type.
203 -- N is the original derived type declaration
205 -- Is_Tagged is set if we are dealing with tagged types
207 -- If Inherit_Discr is set, Derived_Base inherits its discriminants
208 -- from Parent_Base, otherwise no discriminants are inherited.
210 -- Discs gives the list of constraints that apply to Parent_Base in the
211 -- derived type declaration. If Discs is set to No_Elist, then we have
212 -- the following situation:
214 -- type Parent (D1..Dn : ..) is [tagged] record ...;
215 -- type Derived is new Parent [with ...];
217 -- which gets treated as
219 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
221 -- For untagged types the returned value is an association list. The list
222 -- starts from the association (Parent_Base => Derived_Base), and then it
223 -- contains a sequence of the associations of the form
225 -- (Old_Component => New_Component),
227 -- where Old_Component is the Entity_Id of a component in Parent_Base
228 -- and New_Component is the Entity_Id of the corresponding component
229 -- in Derived_Base. For untagged records, this association list is
230 -- needed when copying the record declaration for the derived base.
231 -- In the tagged case the value returned is irrelevant.
233 procedure Build_Discriminal
(Discrim
: Entity_Id
);
234 -- Create the discriminal corresponding to discriminant Discrim, that is
235 -- the parameter corresponding to Discrim to be used in initialization
236 -- procedures for the type where Discrim is a discriminant. Discriminals
237 -- are not used during semantic analysis, and are not fully defined
238 -- entities until expansion. Thus they are not given a scope until
239 -- initialization procedures are built.
241 function Build_Discriminant_Constraints
244 Derived_Def
: Boolean := False) return Elist_Id
;
245 -- Validate discriminant constraints, and return the list of the
246 -- constraints in order of discriminant declarations. T is the
247 -- discriminated unconstrained type. Def is the N_Subtype_Indication node
248 -- where the discriminants constraints for T are specified. Derived_Def is
249 -- True if we are building the discriminant constraints in a derived type
250 -- definition of the form "type D (...) is new T (xxx)". In this case T is
251 -- the parent type and Def is the constraint "(xxx)" on T and this routine
252 -- sets the Corresponding_Discriminant field of the discriminants in the
253 -- derived type D to point to the corresponding discriminants in the parent
256 procedure Build_Discriminated_Subtype
260 Related_Nod
: Node_Id
;
261 For_Access
: Boolean := False);
262 -- Subsidiary procedure to Constrain_Discriminated_Type and to
263 -- Process_Incomplete_Dependents. Given
265 -- T (a possibly discriminated base type)
266 -- Def_Id (a very partially built subtype for T),
268 -- the call completes Def_Id to be the appropriate E_*_Subtype.
270 -- The Elist is the list of discriminant constraints if any (it is set to
271 -- No_Elist if T is not a discriminated type, and to an empty list if
272 -- T has discriminants but there are no discriminant constraints). The
273 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
274 -- The For_Access says whether or not this subtype is really constraining
275 -- an access type. That is its sole purpose is the designated type of an
276 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
277 -- is built to avoid freezing T when the access subtype is frozen.
279 function Build_Scalar_Bound
282 Der_T
: Entity_Id
) return Node_Id
;
283 -- The bounds of a derived scalar type are conversions of the bounds of
284 -- the parent type. Optimize the representation if the bounds are literals.
285 -- Needs a more complete spec--what are the parameters exactly, and what
286 -- exactly is the returned value, and how is Bound affected???
288 procedure Build_Underlying_Full_View
292 -- If the completion of a private type is itself derived from a private
293 -- type, or if the full view of a private subtype is itself private, the
294 -- back-end has no way to compute the actual size of this type. We build
295 -- an internal subtype declaration of the proper parent type to convey
296 -- this information. This extra mechanism is needed because a full
297 -- view cannot itself have a full view (it would get clobbered during
300 procedure Check_Access_Discriminant_Requires_Limited
303 -- Check the restriction that the type to which an access discriminant
304 -- belongs must be a concurrent type or a descendant of a type with
305 -- the reserved word 'limited' in its declaration.
307 procedure Check_Delta_Expression
(E
: Node_Id
);
308 -- Check that the expression represented by E is suitable for use
309 -- as a delta expression, i.e. it is of real type and is static.
311 procedure Check_Digits_Expression
(E
: Node_Id
);
312 -- Check that the expression represented by E is suitable for use as
313 -- a digits expression, i.e. it is of integer type, positive and static.
315 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
);
316 -- Validate the initialization of an object declaration. T is the
317 -- required type, and Exp is the initialization expression.
319 procedure Check_Or_Process_Discriminants
322 Prev
: Entity_Id
:= Empty
);
323 -- If T is the full declaration of an incomplete or private type, check
324 -- the conformance of the discriminants, otherwise process them. Prev
325 -- is the entity of the partial declaration, if any.
327 procedure Check_Real_Bound
(Bound
: Node_Id
);
328 -- Check given bound for being of real type and static. If not, post an
329 -- appropriate message, and rewrite the bound with the real literal zero.
331 procedure Constant_Redeclaration
335 -- Various checks on legality of full declaration of deferred constant.
336 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
337 -- node. The caller has not yet set any attributes of this entity.
339 procedure Convert_Scalar_Bounds
341 Parent_Type
: Entity_Id
;
342 Derived_Type
: Entity_Id
;
344 -- For derived scalar types, convert the bounds in the type definition
345 -- to the derived type, and complete their analysis. Given a constraint
347 -- .. new T range Lo .. Hi;
348 -- Lo and Hi are analyzed and resolved with T'Base, the parent_type.
349 -- The bounds of the derived type (the anonymous base) are copies of
350 -- Lo and Hi. Finally, the bounds of the derived subtype are conversions
351 -- of those bounds to the derived_type, so that their typing is
354 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
);
355 -- Copies attributes from array base type T2 to array base type T1.
356 -- Copies only attributes that apply to base types, but not subtypes.
358 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
);
359 -- Copies attributes from array subtype T2 to array subtype T1. Copies
360 -- attributes that apply to both subtypes and base types.
362 procedure Create_Constrained_Components
366 Constraints
: Elist_Id
);
367 -- Build the list of entities for a constrained discriminated record
368 -- subtype. If a component depends on a discriminant, replace its subtype
369 -- using the discriminant values in the discriminant constraint.
370 -- Subt is the defining identifier for the subtype whose list of
371 -- constrained entities we will create. Decl_Node is the type declaration
372 -- node where we will attach all the itypes created. Typ is the base
373 -- discriminated type for the subtype Subt. Constraints is the list of
374 -- discriminant constraints for Typ.
376 function Constrain_Component_Type
378 Constrained_Typ
: Entity_Id
;
379 Related_Node
: Node_Id
;
381 Constraints
: Elist_Id
) return Entity_Id
;
382 -- Given a discriminated base type Typ, a list of discriminant constraint
383 -- Constraints for Typ and a component of Typ, with type Compon_Type,
384 -- create and return the type corresponding to Compon_type where all
385 -- discriminant references are replaced with the corresponding
386 -- constraint. If no discriminant references occur in Compon_Typ then
387 -- return it as is. Constrained_Typ is the final constrained subtype to
388 -- which the constrained Compon_Type belongs. Related_Node is the node
389 -- where we will attach all the itypes created.
391 procedure Constrain_Access
392 (Def_Id
: in out Entity_Id
;
394 Related_Nod
: Node_Id
);
395 -- Apply a list of constraints to an access type. If Def_Id is empty, it is
396 -- an anonymous type created for a subtype indication. In that case it is
397 -- created in the procedure and attached to Related_Nod.
399 procedure Constrain_Array
400 (Def_Id
: in out Entity_Id
;
402 Related_Nod
: Node_Id
;
403 Related_Id
: Entity_Id
;
405 -- Apply a list of index constraints to an unconstrained array type. The
406 -- first parameter is the entity for the resulting subtype. A value of
407 -- Empty for Def_Id indicates that an implicit type must be created, but
408 -- creation is delayed (and must be done by this procedure) because other
409 -- subsidiary implicit types must be created first (which is why Def_Id
410 -- is an in/out parameter). The second parameter is a subtype indication
411 -- node for the constrained array to be created (e.g. something of the
412 -- form string (1 .. 10)). Related_Nod gives the place where this type
413 -- has to be inserted in the tree. The Related_Id and Suffix parameters
414 -- are used to build the associated Implicit type name.
416 procedure Constrain_Concurrent
417 (Def_Id
: in out Entity_Id
;
419 Related_Nod
: Node_Id
;
420 Related_Id
: Entity_Id
;
422 -- Apply list of discriminant constraints to an unconstrained concurrent
425 -- SI is the N_Subtype_Indication node containing the constraint and
426 -- the unconstrained type to constrain.
428 -- Def_Id is the entity for the resulting constrained subtype. A value
429 -- of Empty for Def_Id indicates that an implicit type must be created,
430 -- but creation is delayed (and must be done by this procedure) because
431 -- other subsidiary implicit types must be created first (which is why
432 -- Def_Id is an in/out parameter).
434 -- Related_Nod gives the place where this type has to be inserted
437 -- The last two arguments are used to create its external name if needed.
439 function Constrain_Corresponding_Record
440 (Prot_Subt
: Entity_Id
;
441 Corr_Rec
: Entity_Id
;
442 Related_Nod
: Node_Id
;
443 Related_Id
: Entity_Id
) return Entity_Id
;
444 -- When constraining a protected type or task type with discriminants,
445 -- constrain the corresponding record with the same discriminant values.
447 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
);
448 -- Constrain a decimal fixed point type with a digits constraint and/or a
449 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
451 procedure Constrain_Discriminated_Type
454 Related_Nod
: Node_Id
;
455 For_Access
: Boolean := False);
456 -- Process discriminant constraints of composite type. Verify that values
457 -- have been provided for all discriminants, that the original type is
458 -- unconstrained, and that the types of the supplied expressions match
459 -- the discriminant types. The first three parameters are like in routine
460 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
463 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
);
464 -- Constrain an enumeration type with a range constraint. This is identical
465 -- to Constrain_Integer, but for the Ekind of the resulting subtype.
467 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
);
468 -- Constrain a floating point type with either a digits constraint
469 -- and/or a range constraint, building a E_Floating_Point_Subtype.
471 procedure Constrain_Index
474 Related_Nod
: Node_Id
;
475 Related_Id
: Entity_Id
;
478 -- Process an index constraint in a constrained array declaration. The
479 -- constraint can be a subtype name, or a range with or without an
480 -- explicit subtype mark. The index is the corresponding index of the
481 -- unconstrained array. The Related_Id and Suffix parameters are used to
482 -- build the associated Implicit type name.
484 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
);
485 -- Build subtype of a signed or modular integer type
487 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
);
488 -- Constrain an ordinary fixed point type with a range constraint, and
489 -- build an E_Ordinary_Fixed_Point_Subtype entity.
491 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
);
492 -- Copy the Priv entity into the entity of its full declaration
493 -- then swap the two entities in such a manner that the former private
494 -- type is now seen as a full type.
496 procedure Decimal_Fixed_Point_Type_Declaration
499 -- Create a new decimal fixed point type, and apply the constraint to
500 -- obtain a subtype of this new type.
502 procedure Complete_Private_Subtype
505 Full_Base
: Entity_Id
;
506 Related_Nod
: Node_Id
);
507 -- Complete the implicit full view of a private subtype by setting the
508 -- appropriate semantic fields. If the full view of the parent is a record
509 -- type, build constrained components of subtype.
511 procedure Derive_Interface_Subprograms
512 (Derived_Type
: Entity_Id
);
513 -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
514 -- Traverse the list of implemented interfaces and derive all their
517 procedure Derived_Standard_Character
519 Parent_Type
: Entity_Id
;
520 Derived_Type
: Entity_Id
);
521 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
522 -- derivations from types Standard.Character and Standard.Wide_Character.
524 procedure Derived_Type_Declaration
527 Is_Completion
: Boolean);
528 -- Process a derived type declaration. This routine will invoke
529 -- Build_Derived_Type to process the actual derived type definition.
530 -- Parameters N and Is_Completion have the same meaning as in
531 -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
532 -- defined in the N_Full_Type_Declaration node N, that is T is the derived
535 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
536 -- Insert each literal in symbol table, as an overloadable identifier. Each
537 -- enumeration type is mapped into a sequence of integers, and each literal
538 -- is defined as a constant with integer value. If any of the literals are
539 -- character literals, the type is a character type, which means that
540 -- strings are legal aggregates for arrays of components of the type.
542 function Expand_To_Stored_Constraint
544 Constraint
: Elist_Id
) return Elist_Id
;
545 -- Given a Constraint (i.e. a list of expressions) on the discriminants of
546 -- Typ, expand it into a constraint on the stored discriminants and return
547 -- the new list of expressions constraining the stored discriminants.
549 function Find_Type_Of_Object
551 Related_Nod
: Node_Id
) return Entity_Id
;
552 -- Get type entity for object referenced by Obj_Def, attaching the
553 -- implicit types generated to Related_Nod
555 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
556 -- Create a new float, and apply the constraint to obtain subtype of it
558 function Has_Range_Constraint
(N
: Node_Id
) return Boolean;
559 -- Given an N_Subtype_Indication node N, return True if a range constraint
560 -- is present, either directly, or as part of a digits or delta constraint.
561 -- In addition, a digits constraint in the decimal case returns True, since
562 -- it establishes a default range if no explicit range is present.
564 function Is_Valid_Constraint_Kind
566 Constraint_Kind
: Node_Kind
) return Boolean;
567 -- Returns True if it is legal to apply the given kind of constraint to the
568 -- given kind of type (index constraint to an array type, for example).
570 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
571 -- Create new modular type. Verify that modulus is in bounds and is
572 -- a power of two (implementation restriction).
574 procedure New_Concatenation_Op
(Typ
: Entity_Id
);
575 -- Create an abbreviated declaration for an operator in order to
576 -- materialize concatenation on array types.
578 procedure Ordinary_Fixed_Point_Type_Declaration
581 -- Create a new ordinary fixed point type, and apply the constraint to
582 -- obtain subtype of it.
584 procedure Prepare_Private_Subtype_Completion
586 Related_Nod
: Node_Id
);
587 -- Id is a subtype of some private type. Creates the full declaration
588 -- associated with Id whenever possible, i.e. when the full declaration
589 -- of the base type is already known. Records each subtype into
590 -- Private_Dependents of the base type.
592 procedure Process_Incomplete_Dependents
596 -- Process all entities that depend on an incomplete type. There include
597 -- subtypes, subprogram types that mention the incomplete type in their
598 -- profiles, and subprogram with access parameters that designate the
601 -- Inc_T is the defining identifier of an incomplete type declaration, its
602 -- Ekind is E_Incomplete_Type.
604 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
606 -- Full_T is N's defining identifier.
608 -- Subtypes of incomplete types with discriminants are completed when the
609 -- parent type is. This is simpler than private subtypes, because they can
610 -- only appear in the same scope, and there is no need to exchange views.
611 -- Similarly, access_to_subprogram types may have a parameter or a return
612 -- type that is an incomplete type, and that must be replaced with the
615 -- If the full type is tagged, subprogram with access parameters that
616 -- designated the incomplete may be primitive operations of the full type,
617 -- and have to be processed accordingly.
619 procedure Process_Real_Range_Specification
(Def
: Node_Id
);
620 -- Given the type definition for a real type, this procedure processes
621 -- and checks the real range specification of this type definition if
622 -- one is present. If errors are found, error messages are posted, and
623 -- the Real_Range_Specification of Def is reset to Empty.
625 procedure Record_Type_Declaration
629 -- Process a record type declaration (for both untagged and tagged
630 -- records). Parameters T and N are exactly like in procedure
631 -- Derived_Type_Declaration, except that no flag Is_Completion is needed
632 -- for this routine. If this is the completion of an incomplete type
633 -- declaration, Prev is the entity of the incomplete declaration, used for
634 -- cross-referencing. Otherwise Prev = T.
636 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
);
637 -- This routine is used to process the actual record type definition
638 -- (both for untagged and tagged records). Def is a record type
639 -- definition node. This procedure analyzes the components in this
640 -- record type definition. Prev_T is the entity for the enclosing record
641 -- type. It is provided so that its Has_Task flag can be set if any of
642 -- the component have Has_Task set. If the declaration is the completion
643 -- of an incomplete type declaration, Prev_T is the original incomplete
644 -- type, whose full view is the record type.
646 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
);
647 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
648 -- build a copy of the declaration tree of the parent, and we create
649 -- independently the list of components for the derived type. Semantic
650 -- information uses the component entities, but record representation
651 -- clauses are validated on the declaration tree. This procedure replaces
652 -- discriminants and components in the declaration with those that have
653 -- been created by Inherit_Components.
655 procedure Set_Fixed_Range
660 -- Build a range node with the given bounds and set it as the Scalar_Range
661 -- of the given fixed-point type entity. Loc is the source location used
662 -- for the constructed range. See body for further details.
664 procedure Set_Scalar_Range_For_Subtype
668 -- This routine is used to set the scalar range field for a subtype
669 -- given Def_Id, the entity for the subtype, and R, the range expression
670 -- for the scalar range. Subt provides the parent subtype to be used
671 -- to analyze, resolve, and check the given range.
673 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
674 -- Create a new signed integer entity, and apply the constraint to obtain
675 -- the required first named subtype of this type.
677 procedure Set_Stored_Constraint_From_Discriminant_Constraint
679 -- E is some record type. This routine computes E's Stored_Constraint
680 -- from its Discriminant_Constraint.
682 -----------------------
683 -- Access_Definition --
684 -----------------------
686 function Access_Definition
687 (Related_Nod
: Node_Id
;
688 N
: Node_Id
) return Entity_Id
690 Anon_Type
: constant Entity_Id
:=
691 Create_Itype
(E_Anonymous_Access_Type
, Related_Nod
,
692 Scope_Id
=> Scope
(Current_Scope
));
693 Desig_Type
: Entity_Id
;
696 if Is_Entry
(Current_Scope
)
697 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
699 Error_Msg_N
("task entries cannot have access parameters", N
);
702 -- Ada 2005: for an object declaration or function with an anonymous
703 -- access result, the corresponding anonymous type is declared in the
704 -- current scope. For access formals, access components, and access
705 -- discriminants, the scope is that of the enclosing declaration,
706 -- as set above. This special-case handling of resetting the scope
707 -- is awkward, and it might be better to pass in the required scope
708 -- as a parameter. ???
710 if Nkind
(Related_Nod
) = N_Object_Declaration
then
711 Set_Scope
(Anon_Type
, Current_Scope
);
713 -- For the anonymous function result case, retrieve the scope of
714 -- the function specification's associated entity rather than using
715 -- the current scope. The current scope will be the function itself
716 -- if the formal part is currently being analyzed, but will be the
717 -- parent scope in the case of a parameterless function, and we
718 -- always want to use the function's parent scope.
720 elsif Nkind
(Related_Nod
) = N_Function_Specification
721 and then Nkind
(Parent
(N
)) /= N_Parameter_Specification
723 Set_Scope
(Anon_Type
, Scope
(Defining_Unit_Name
(Related_Nod
)));
727 and then Ada_Version
>= Ada_05
729 Error_Msg_N
("ALL is not permitted for anonymous access types", N
);
732 -- Ada 2005 (AI-254): In case of anonymous access to subprograms
733 -- call the corresponding semantic routine
735 if Present
(Access_To_Subprogram_Definition
(N
)) then
736 Access_Subprogram_Declaration
737 (T_Name
=> Anon_Type
,
738 T_Def
=> Access_To_Subprogram_Definition
(N
));
740 if Ekind
(Anon_Type
) = E_Access_Protected_Subprogram_Type
then
742 (Anon_Type
, E_Anonymous_Access_Protected_Subprogram_Type
);
745 (Anon_Type
, E_Anonymous_Access_Subprogram_Type
);
751 Find_Type
(Subtype_Mark
(N
));
752 Desig_Type
:= Entity
(Subtype_Mark
(N
));
754 Set_Directly_Designated_Type
755 (Anon_Type
, Desig_Type
);
756 Set_Etype
(Anon_Type
, Anon_Type
);
757 Init_Size_Align
(Anon_Type
);
758 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
760 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
761 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
762 -- if the null value is allowed. In Ada 95 the null value is never
765 if Ada_Version
>= Ada_05
then
766 Set_Can_Never_Be_Null
(Anon_Type
, Null_Exclusion_Present
(N
));
768 Set_Can_Never_Be_Null
(Anon_Type
, True);
771 -- The anonymous access type is as public as the discriminated type or
772 -- subprogram that defines it. It is imported (for back-end purposes)
773 -- if the designated type is.
775 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
777 -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
778 -- designated type comes from the limited view (for back-end purposes).
780 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
782 -- Ada 2005 (AI-231): Propagate the access-constant attribute
784 Set_Is_Access_Constant
(Anon_Type
, Constant_Present
(N
));
786 -- The context is either a subprogram declaration, object declaration,
787 -- or an access discriminant, in a private or a full type declaration.
788 -- In the case of a subprogram, if the designated type is incomplete,
789 -- the operation will be a primitive operation of the full type, to be
790 -- updated subsequently. If the type is imported through a limited_with
791 -- clause, the subprogram is not a primitive operation of the type
792 -- (which is declared elsewhere in some other scope).
794 if Ekind
(Desig_Type
) = E_Incomplete_Type
795 and then not From_With_Type
(Desig_Type
)
796 and then Is_Overloadable
(Current_Scope
)
798 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
799 Set_Has_Delayed_Freeze
(Current_Scope
);
803 end Access_Definition
;
805 -----------------------------------
806 -- Access_Subprogram_Declaration --
807 -----------------------------------
809 procedure Access_Subprogram_Declaration
813 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
817 Desig_Type
: constant Entity_Id
:=
818 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
821 -- Associate the Itype node with the inner full-type declaration
822 -- or subprogram spec. This is required to handle nested anonymous
823 -- declarations. For example:
826 -- (X : access procedure
827 -- (Y : access procedure
830 D_Ityp
:= Associated_Node_For_Itype
(Desig_Type
);
831 while Nkind
(D_Ityp
) /= N_Full_Type_Declaration
832 and then Nkind
(D_Ityp
) /= N_Procedure_Specification
833 and then Nkind
(D_Ityp
) /= N_Function_Specification
834 and then Nkind
(D_Ityp
) /= N_Object_Declaration
835 and then Nkind
(D_Ityp
) /= N_Object_Renaming_Declaration
836 and then Nkind
(D_Ityp
) /= N_Formal_Type_Declaration
838 D_Ityp
:= Parent
(D_Ityp
);
839 pragma Assert
(D_Ityp
/= Empty
);
842 Set_Associated_Node_For_Itype
(Desig_Type
, D_Ityp
);
844 if Nkind
(D_Ityp
) = N_Procedure_Specification
845 or else Nkind
(D_Ityp
) = N_Function_Specification
847 Set_Scope
(Desig_Type
, Scope
(Defining_Unit_Name
(D_Ityp
)));
849 elsif Nkind
(D_Ityp
) = N_Full_Type_Declaration
850 or else Nkind
(D_Ityp
) = N_Object_Declaration
851 or else Nkind
(D_Ityp
) = N_Object_Renaming_Declaration
852 or else Nkind
(D_Ityp
) = N_Formal_Type_Declaration
854 Set_Scope
(Desig_Type
, Scope
(Defining_Identifier
(D_Ityp
)));
857 if Nkind
(T_Def
) = N_Access_Function_Definition
then
858 if Nkind
(Result_Definition
(T_Def
)) = N_Access_Definition
then
861 Access_Definition
(T_Def
, Result_Definition
(T_Def
)));
863 Analyze
(Result_Definition
(T_Def
));
864 Set_Etype
(Desig_Type
, Entity
(Result_Definition
(T_Def
)));
867 if not (Is_Type
(Etype
(Desig_Type
))) then
869 ("expect type in function specification",
870 Result_Definition
(T_Def
));
874 Set_Etype
(Desig_Type
, Standard_Void_Type
);
877 if Present
(Formals
) then
878 New_Scope
(Desig_Type
);
879 Process_Formals
(Formals
, Parent
(T_Def
));
881 -- A bit of a kludge here, End_Scope requires that the parent
882 -- pointer be set to something reasonable, but Itypes don't have
883 -- parent pointers. So we set it and then unset it ??? If and when
884 -- Itypes have proper parent pointers to their declarations, this
885 -- kludge can be removed.
887 Set_Parent
(Desig_Type
, T_Name
);
889 Set_Parent
(Desig_Type
, Empty
);
892 -- The return type and/or any parameter type may be incomplete. Mark
893 -- the subprogram_type as depending on the incomplete type, so that
894 -- it can be updated when the full type declaration is seen.
896 if Present
(Formals
) then
897 Formal
:= First_Formal
(Desig_Type
);
898 while Present
(Formal
) loop
899 if Ekind
(Formal
) /= E_In_Parameter
900 and then Nkind
(T_Def
) = N_Access_Function_Definition
902 Error_Msg_N
("functions can only have IN parameters", Formal
);
905 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
906 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
907 Set_Has_Delayed_Freeze
(Desig_Type
);
910 Next_Formal
(Formal
);
914 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
915 and then not Has_Delayed_Freeze
(Desig_Type
)
917 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
918 Set_Has_Delayed_Freeze
(Desig_Type
);
921 Check_Delayed_Subprogram
(Desig_Type
);
923 if Protected_Present
(T_Def
) then
924 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
925 Set_Convention
(Desig_Type
, Convention_Protected
);
927 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
930 Set_Etype
(T_Name
, T_Name
);
931 Init_Size_Align
(T_Name
);
932 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
934 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
936 Set_Can_Never_Be_Null
(T_Name
, Null_Exclusion_Present
(T_Def
));
938 Check_Restriction
(No_Access_Subprograms
, T_Def
);
939 end Access_Subprogram_Declaration
;
941 ----------------------------
942 -- Access_Type_Declaration --
943 ----------------------------
945 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
946 S
: constant Node_Id
:= Subtype_Indication
(Def
);
947 P
: constant Node_Id
:= Parent
(Def
);
953 -- Check for permissible use of incomplete type
955 if Nkind
(S
) /= N_Subtype_Indication
then
958 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
959 Set_Directly_Designated_Type
(T
, Entity
(S
));
961 Set_Directly_Designated_Type
(T
,
962 Process_Subtype
(S
, P
, T
, 'P'));
966 Set_Directly_Designated_Type
(T
,
967 Process_Subtype
(S
, P
, T
, 'P'));
970 if All_Present
(Def
) or Constant_Present
(Def
) then
971 Set_Ekind
(T
, E_General_Access_Type
);
973 Set_Ekind
(T
, E_Access_Type
);
976 if Base_Type
(Designated_Type
(T
)) = T
then
977 Error_Msg_N
("access type cannot designate itself", S
);
979 -- In Ada 2005, the type may have a limited view through some unit
980 -- in its own context, allowing the following circularity that cannot
981 -- be detected earlier
983 elsif Is_Class_Wide_Type
(Designated_Type
(T
))
984 and then Etype
(Designated_Type
(T
)) = T
987 ("access type cannot designate its own classwide type", S
);
992 -- If the type has appeared already in a with_type clause, it is
993 -- frozen and the pointer size is already set. Else, initialize.
995 if not From_With_Type
(T
) then
999 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1001 Desig
:= Designated_Type
(T
);
1003 -- If designated type is an imported tagged type, indicate that the
1004 -- access type is also imported, and therefore restricted in its use.
1005 -- The access type may already be imported, so keep setting otherwise.
1007 -- Ada 2005 (AI-50217): If the non-limited view of the designated type
1008 -- is available, use it as the designated type of the access type, so
1009 -- that the back-end gets a usable entity.
1012 N_Desig
: Entity_Id
;
1015 if From_With_Type
(Desig
)
1016 and then Ekind
(Desig
) /= E_Access_Type
1018 Set_From_With_Type
(T
);
1020 if Ekind
(Desig
) = E_Incomplete_Type
then
1021 N_Desig
:= Non_Limited_View
(Desig
);
1023 else pragma Assert
(Ekind
(Desig
) = E_Class_Wide_Type
);
1024 if From_With_Type
(Etype
(Desig
)) then
1025 N_Desig
:= Non_Limited_View
(Etype
(Desig
));
1027 N_Desig
:= Etype
(Desig
);
1031 pragma Assert
(Present
(N_Desig
));
1032 Set_Directly_Designated_Type
(T
, N_Desig
);
1036 -- Note that Has_Task is always false, since the access type itself
1037 -- is not a task type. See Einfo for more description on this point.
1038 -- Exactly the same consideration applies to Has_Controlled_Component.
1040 Set_Has_Task
(T
, False);
1041 Set_Has_Controlled_Component
(T
, False);
1043 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1046 Set_Can_Never_Be_Null
(T
, Null_Exclusion_Present
(Def
));
1047 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1048 end Access_Type_Declaration
;
1050 ----------------------------------
1051 -- Add_Interface_Tag_Components --
1052 ----------------------------------
1054 procedure Add_Interface_Tag_Components
1058 Loc
: constant Source_Ptr
:= Sloc
(N
);
1065 procedure Add_Tag
(Iface
: Entity_Id
);
1066 -- Comment required ???
1072 procedure Add_Tag
(Iface
: Entity_Id
) is
1078 pragma Assert
(Is_Tagged_Type
(Iface
)
1079 and then Is_Interface
(Iface
));
1082 Make_Component_Definition
(Loc
,
1083 Aliased_Present
=> True,
1084 Subtype_Indication
=>
1085 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
));
1087 Tag
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1090 Make_Component_Declaration
(Loc
,
1091 Defining_Identifier
=> Tag
,
1092 Component_Definition
=> Def
);
1094 Analyze_Component_Declaration
(Decl
);
1096 Set_Analyzed
(Decl
);
1097 Set_Ekind
(Tag
, E_Component
);
1098 Set_Is_Limited_Record
(Tag
);
1100 Init_Component_Location
(Tag
);
1102 pragma Assert
(Is_Frozen
(Iface
));
1104 Set_DT_Entry_Count
(Tag
,
1105 DT_Entry_Count
(First_Entity
(Iface
)));
1107 if not Present
(Last_Tag
) then
1110 Insert_After
(Last_Tag
, Decl
);
1116 -- Start of processing for Add_Interface_Tag_Components
1119 if Ekind
(Typ
) /= E_Record_Type
1120 or else not Present
(Abstract_Interfaces
(Typ
))
1121 or else Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
))
1126 if Present
(Abstract_Interfaces
(Typ
)) then
1128 -- Find the current last tag
1130 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1131 Ext
:= Record_Extension_Part
(Type_Definition
(N
));
1133 pragma Assert
(Nkind
(Type_Definition
(N
)) = N_Record_Definition
);
1134 Ext
:= Type_Definition
(N
);
1139 if not (Present
(Component_List
(Ext
))) then
1140 Set_Null_Present
(Ext
, False);
1142 Set_Component_List
(Ext
,
1143 Make_Component_List
(Loc
,
1144 Component_Items
=> L
,
1145 Null_Present
=> False));
1147 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1148 L
:= Component_Items
1150 (Record_Extension_Part
1151 (Type_Definition
(N
))));
1153 L
:= Component_Items
1155 (Type_Definition
(N
)));
1158 -- Find the last tag component
1161 while Present
(Comp
) loop
1162 if Is_Tag
(Defining_Identifier
(Comp
)) then
1170 -- At this point L references the list of components and Last_Tag
1171 -- references the current last tag (if any). Now we add the tag
1172 -- corresponding with all the interfaces that are not implemented
1175 pragma Assert
(Present
1176 (First_Elmt
(Abstract_Interfaces
(Typ
))));
1178 Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1179 while Present
(Elmt
) loop
1180 Add_Tag
(Node
(Elmt
));
1184 end Add_Interface_Tag_Components
;
1186 -----------------------------------
1187 -- Analyze_Component_Declaration --
1188 -----------------------------------
1190 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
1191 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1195 function Contains_POC
(Constr
: Node_Id
) return Boolean;
1196 -- Determines whether a constraint uses the discriminant of a record
1197 -- type thus becoming a per-object constraint (POC).
1203 function Contains_POC
(Constr
: Node_Id
) return Boolean is
1205 case Nkind
(Constr
) is
1206 when N_Attribute_Reference
=>
1207 return Attribute_Name
(Constr
) = Name_Access
1209 Prefix
(Constr
) = Scope
(Entity
(Prefix
(Constr
)));
1211 when N_Discriminant_Association
=>
1212 return Denotes_Discriminant
(Expression
(Constr
));
1214 when N_Identifier
=>
1215 return Denotes_Discriminant
(Constr
);
1217 when N_Index_Or_Discriminant_Constraint
=>
1222 IDC
:= First
(Constraints
(Constr
));
1223 while Present
(IDC
) loop
1225 -- One per-object constraint is sufficient
1227 if Contains_POC
(IDC
) then
1238 return Denotes_Discriminant
(Low_Bound
(Constr
))
1240 Denotes_Discriminant
(High_Bound
(Constr
));
1242 when N_Range_Constraint
=>
1243 return Denotes_Discriminant
(Range_Expression
(Constr
));
1251 -- Start of processing for Analyze_Component_Declaration
1254 Generate_Definition
(Id
);
1257 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1258 T
:= Find_Type_Of_Object
1259 (Subtype_Indication
(Component_Definition
(N
)), N
);
1261 -- Ada 2005 (AI-230): Access Definition case
1264 pragma Assert
(Present
1265 (Access_Definition
(Component_Definition
(N
))));
1267 T
:= Access_Definition
1269 N
=> Access_Definition
(Component_Definition
(N
)));
1270 Set_Is_Local_Anonymous_Access
(T
);
1272 -- Ada 2005 (AI-254)
1274 if Present
(Access_To_Subprogram_Definition
1275 (Access_Definition
(Component_Definition
(N
))))
1276 and then Protected_Present
(Access_To_Subprogram_Definition
1278 (Component_Definition
(N
))))
1280 T
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
, T
);
1284 -- If the subtype is a constrained subtype of the enclosing record,
1285 -- (which must have a partial view) the back-end does not properly
1286 -- handle the recursion. Rewrite the component declaration with an
1287 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1288 -- the tree directly because side effects have already been removed from
1289 -- discriminant constraints.
1291 if Ekind
(T
) = E_Access_Subtype
1292 and then Is_Entity_Name
(Subtype_Indication
(Component_Definition
(N
)))
1293 and then Comes_From_Source
(T
)
1294 and then Nkind
(Parent
(T
)) = N_Subtype_Declaration
1295 and then Etype
(Directly_Designated_Type
(T
)) = Current_Scope
1298 (Subtype_Indication
(Component_Definition
(N
)),
1299 New_Copy_Tree
(Subtype_Indication
(Parent
(T
))));
1300 T
:= Find_Type_Of_Object
1301 (Subtype_Indication
(Component_Definition
(N
)), N
);
1304 -- If the component declaration includes a default expression, then we
1305 -- check that the component is not of a limited type (RM 3.7(5)),
1306 -- and do the special preanalysis of the expression (see section on
1307 -- "Handling of Default and Per-Object Expressions" in the spec of
1310 if Present
(Expression
(N
)) then
1311 Analyze_Per_Use_Expression
(Expression
(N
), T
);
1312 Check_Initialization
(T
, Expression
(N
));
1315 -- The parent type may be a private view with unknown discriminants,
1316 -- and thus unconstrained. Regular components must be constrained.
1318 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
1319 if Is_Class_Wide_Type
(T
) then
1321 ("class-wide subtype with unknown discriminants" &
1322 " in component declaration",
1323 Subtype_Indication
(Component_Definition
(N
)));
1326 ("unconstrained subtype in component declaration",
1327 Subtype_Indication
(Component_Definition
(N
)));
1330 -- Components cannot be abstract, except for the special case of
1331 -- the _Parent field (case of extending an abstract tagged type)
1333 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
1334 Error_Msg_N
("type of a component cannot be abstract", N
);
1338 Set_Is_Aliased
(Id
, Aliased_Present
(Component_Definition
(N
)));
1340 -- The component declaration may have a per-object constraint, set
1341 -- the appropriate flag in the defining identifier of the subtype.
1343 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1345 Sindic
: constant Node_Id
:=
1346 Subtype_Indication
(Component_Definition
(N
));
1349 if Nkind
(Sindic
) = N_Subtype_Indication
1350 and then Present
(Constraint
(Sindic
))
1351 and then Contains_POC
(Constraint
(Sindic
))
1353 Set_Has_Per_Object_Constraint
(Id
);
1358 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1359 -- out some static checks.
1361 if Ada_Version
>= Ada_05
1362 and then Can_Never_Be_Null
(T
)
1364 Null_Exclusion_Static_Checks
(N
);
1367 -- If this component is private (or depends on a private type), flag the
1368 -- record type to indicate that some operations are not available.
1370 P
:= Private_Component
(T
);
1373 -- Check for circular definitions
1375 if P
= Any_Type
then
1376 Set_Etype
(Id
, Any_Type
);
1378 -- There is a gap in the visibility of operations only if the
1379 -- component type is not defined in the scope of the record type.
1381 elsif Scope
(P
) = Scope
(Current_Scope
) then
1384 elsif Is_Limited_Type
(P
) then
1385 Set_Is_Limited_Composite
(Current_Scope
);
1388 Set_Is_Private_Composite
(Current_Scope
);
1393 and then Is_Limited_Type
(T
)
1394 and then Chars
(Id
) /= Name_uParent
1395 and then Is_Tagged_Type
(Current_Scope
)
1397 if Is_Derived_Type
(Current_Scope
)
1398 and then not Is_Limited_Record
(Root_Type
(Current_Scope
))
1401 ("extension of nonlimited type cannot have limited components",
1403 Explain_Limited_Type
(T
, N
);
1404 Set_Etype
(Id
, Any_Type
);
1405 Set_Is_Limited_Composite
(Current_Scope
, False);
1407 elsif not Is_Derived_Type
(Current_Scope
)
1408 and then not Is_Limited_Record
(Current_Scope
)
1411 ("nonlimited tagged type cannot have limited components", N
);
1412 Explain_Limited_Type
(T
, N
);
1413 Set_Etype
(Id
, Any_Type
);
1414 Set_Is_Limited_Composite
(Current_Scope
, False);
1418 Set_Original_Record_Component
(Id
, Id
);
1419 end Analyze_Component_Declaration
;
1421 --------------------------
1422 -- Analyze_Declarations --
1423 --------------------------
1425 procedure Analyze_Declarations
(L
: List_Id
) is
1427 Next_Node
: Node_Id
;
1428 Freeze_From
: Entity_Id
:= Empty
;
1431 -- Adjust D not to include implicit label declarations, since these
1432 -- have strange Sloc values that result in elaboration check problems.
1433 -- (They have the sloc of the label as found in the source, and that
1434 -- is ahead of the current declarative part).
1440 procedure Adjust_D
is
1442 while Present
(Prev
(D
))
1443 and then Nkind
(D
) = N_Implicit_Label_Declaration
1449 -- Start of processing for Analyze_Declarations
1453 while Present
(D
) loop
1455 -- Complete analysis of declaration
1458 Next_Node
:= Next
(D
);
1460 if No
(Freeze_From
) then
1461 Freeze_From
:= First_Entity
(Current_Scope
);
1464 -- At the end of a declarative part, freeze remaining entities
1465 -- declared in it. The end of the visible declarations of package
1466 -- specification is not the end of a declarative part if private
1467 -- declarations are present. The end of a package declaration is a
1468 -- freezing point only if it a library package. A task definition or
1469 -- protected type definition is not a freeze point either. Finally,
1470 -- we do not freeze entities in generic scopes, because there is no
1471 -- code generated for them and freeze nodes will be generated for
1474 -- The end of a package instantiation is not a freeze point, but
1475 -- for now we make it one, because the generic body is inserted
1476 -- (currently) immediately after. Generic instantiations will not
1477 -- be a freeze point once delayed freezing of bodies is implemented.
1478 -- (This is needed in any case for early instantiations ???).
1480 if No
(Next_Node
) then
1481 if Nkind
(Parent
(L
)) = N_Component_List
1482 or else Nkind
(Parent
(L
)) = N_Task_Definition
1483 or else Nkind
(Parent
(L
)) = N_Protected_Definition
1487 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
1488 if Nkind
(Parent
(L
)) = N_Package_Body
then
1489 Freeze_From
:= First_Entity
(Current_Scope
);
1493 Freeze_All
(Freeze_From
, D
);
1494 Freeze_From
:= Last_Entity
(Current_Scope
);
1496 elsif Scope
(Current_Scope
) /= Standard_Standard
1497 and then not Is_Child_Unit
(Current_Scope
)
1498 and then No
(Generic_Parent
(Parent
(L
)))
1502 elsif L
/= Visible_Declarations
(Parent
(L
))
1503 or else No
(Private_Declarations
(Parent
(L
)))
1504 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1507 Freeze_All
(Freeze_From
, D
);
1508 Freeze_From
:= Last_Entity
(Current_Scope
);
1511 -- If next node is a body then freeze all types before the body.
1512 -- An exception occurs for expander generated bodies, which can
1513 -- be recognized by their already being analyzed. The expander
1514 -- ensures that all types needed by these bodies have been frozen
1515 -- but it is not necessary to freeze all types (and would be wrong
1516 -- since it would not correspond to an RM defined freeze point).
1518 elsif not Analyzed
(Next_Node
)
1519 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1520 or else Nkind
(Next_Node
) = N_Entry_Body
1521 or else Nkind
(Next_Node
) = N_Package_Body
1522 or else Nkind
(Next_Node
) = N_Protected_Body
1523 or else Nkind
(Next_Node
) = N_Task_Body
1524 or else Nkind
(Next_Node
) in N_Body_Stub
)
1527 Freeze_All
(Freeze_From
, D
);
1528 Freeze_From
:= Last_Entity
(Current_Scope
);
1533 end Analyze_Declarations
;
1535 ----------------------------------
1536 -- Analyze_Incomplete_Type_Decl --
1537 ----------------------------------
1539 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1540 F
: constant Boolean := Is_Pure
(Current_Scope
);
1544 Generate_Definition
(Defining_Identifier
(N
));
1546 -- Process an incomplete declaration. The identifier must not have been
1547 -- declared already in the scope. However, an incomplete declaration may
1548 -- appear in the private part of a package, for a private type that has
1549 -- already been declared.
1551 -- In this case, the discriminants (if any) must match
1553 T
:= Find_Type_Name
(N
);
1555 Set_Ekind
(T
, E_Incomplete_Type
);
1556 Init_Size_Align
(T
);
1557 Set_Is_First_Subtype
(T
, True);
1560 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
1561 -- incomplete types.
1563 if Tagged_Present
(N
) then
1564 Set_Is_Tagged_Type
(T
);
1565 Make_Class_Wide_Type
(T
);
1566 Set_Primitive_Operations
(T
, New_Elmt_List
);
1571 Set_Stored_Constraint
(T
, No_Elist
);
1573 if Present
(Discriminant_Specifications
(N
)) then
1574 Process_Discriminants
(N
);
1579 -- If the type has discriminants, non-trivial subtypes may be be
1580 -- declared before the full view of the type. The full views of those
1581 -- subtypes will be built after the full view of the type.
1583 Set_Private_Dependents
(T
, New_Elmt_List
);
1585 end Analyze_Incomplete_Type_Decl
;
1587 -----------------------------
1588 -- Analyze_Itype_Reference --
1589 -----------------------------
1591 -- Nothing to do. This node is placed in the tree only for the benefit of
1592 -- back end processing, and has no effect on the semantic processing.
1594 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1596 pragma Assert
(Is_Itype
(Itype
(N
)));
1598 end Analyze_Itype_Reference
;
1600 --------------------------------
1601 -- Analyze_Number_Declaration --
1602 --------------------------------
1604 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1605 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1606 E
: constant Node_Id
:= Expression
(N
);
1608 Index
: Interp_Index
;
1612 Generate_Definition
(Id
);
1615 -- This is an optimization of a common case of an integer literal
1617 if Nkind
(E
) = N_Integer_Literal
then
1618 Set_Is_Static_Expression
(E
, True);
1619 Set_Etype
(E
, Universal_Integer
);
1621 Set_Etype
(Id
, Universal_Integer
);
1622 Set_Ekind
(Id
, E_Named_Integer
);
1623 Set_Is_Frozen
(Id
, True);
1627 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1629 -- Process expression, replacing error by integer zero, to avoid
1630 -- cascaded errors or aborts further along in the processing
1632 -- Replace Error by integer zero, which seems least likely to
1633 -- cause cascaded errors.
1636 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1637 Set_Error_Posted
(E
);
1642 -- Verify that the expression is static and numeric. If
1643 -- the expression is overloaded, we apply the preference
1644 -- rule that favors root numeric types.
1646 if not Is_Overloaded
(E
) then
1652 Get_First_Interp
(E
, Index
, It
);
1653 while Present
(It
.Typ
) loop
1654 if (Is_Integer_Type
(It
.Typ
)
1655 or else Is_Real_Type
(It
.Typ
))
1656 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1658 if T
= Any_Type
then
1661 elsif It
.Typ
= Universal_Real
1662 or else It
.Typ
= Universal_Integer
1664 -- Choose universal interpretation over any other
1671 Get_Next_Interp
(Index
, It
);
1675 if Is_Integer_Type
(T
) then
1677 Set_Etype
(Id
, Universal_Integer
);
1678 Set_Ekind
(Id
, E_Named_Integer
);
1680 elsif Is_Real_Type
(T
) then
1682 -- Because the real value is converted to universal_real, this is a
1683 -- legal context for a universal fixed expression.
1685 if T
= Universal_Fixed
then
1687 Loc
: constant Source_Ptr
:= Sloc
(N
);
1688 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1690 New_Occurrence_Of
(Universal_Real
, Loc
),
1691 Expression
=> Relocate_Node
(E
));
1698 elsif T
= Any_Fixed
then
1699 Error_Msg_N
("illegal context for mixed mode operation", E
);
1701 -- Expression is of the form : universal_fixed * integer. Try to
1702 -- resolve as universal_real.
1704 T
:= Universal_Real
;
1709 Set_Etype
(Id
, Universal_Real
);
1710 Set_Ekind
(Id
, E_Named_Real
);
1713 Wrong_Type
(E
, Any_Numeric
);
1717 Set_Ekind
(Id
, E_Constant
);
1718 Set_Never_Set_In_Source
(Id
, True);
1719 Set_Is_True_Constant
(Id
, True);
1723 if Nkind
(E
) = N_Integer_Literal
1724 or else Nkind
(E
) = N_Real_Literal
1726 Set_Etype
(E
, Etype
(Id
));
1729 if not Is_OK_Static_Expression
(E
) then
1730 Flag_Non_Static_Expr
1731 ("non-static expression used in number declaration!", E
);
1732 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1733 Set_Etype
(E
, Any_Type
);
1735 end Analyze_Number_Declaration
;
1737 --------------------------------
1738 -- Analyze_Object_Declaration --
1739 --------------------------------
1741 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1742 Loc
: constant Source_Ptr
:= Sloc
(N
);
1743 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1747 E
: Node_Id
:= Expression
(N
);
1748 -- E is set to Expression (N) throughout this routine. When
1749 -- Expression (N) is modified, E is changed accordingly.
1751 Prev_Entity
: Entity_Id
:= Empty
;
1753 function Build_Default_Subtype
return Entity_Id
;
1754 -- If the object is limited or aliased, and if the type is unconstrained
1755 -- and there is no expression, the discriminants cannot be modified and
1756 -- the subtype of the object is constrained by the defaults, so it is
1757 -- worthwhile building the corresponding subtype.
1759 function Count_Tasks
(T
: Entity_Id
) return Uint
;
1760 -- This function is called when a library level object of type is
1761 -- declared. It's function is to count the static number of tasks
1762 -- declared within the type (it is only called if Has_Tasks is set for
1763 -- T). As a side effect, if an array of tasks with non-static bounds or
1764 -- a variant record type is encountered, Check_Restrictions is called
1765 -- indicating the count is unknown.
1767 ---------------------------
1768 -- Build_Default_Subtype --
1769 ---------------------------
1771 function Build_Default_Subtype
return Entity_Id
is
1772 Constraints
: constant List_Id
:= New_List
;
1778 Disc
:= First_Discriminant
(T
);
1780 if No
(Discriminant_Default_Value
(Disc
)) then
1781 return T
; -- previous error.
1784 Act
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1785 while Present
(Disc
) loop
1788 Discriminant_Default_Value
(Disc
)), Constraints
);
1789 Next_Discriminant
(Disc
);
1793 Make_Subtype_Declaration
(Loc
,
1794 Defining_Identifier
=> Act
,
1795 Subtype_Indication
=>
1796 Make_Subtype_Indication
(Loc
,
1797 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1799 Make_Index_Or_Discriminant_Constraint
1800 (Loc
, Constraints
)));
1802 Insert_Before
(N
, Decl
);
1805 end Build_Default_Subtype
;
1811 function Count_Tasks
(T
: Entity_Id
) return Uint
is
1817 if Is_Task_Type
(T
) then
1820 elsif Is_Record_Type
(T
) then
1821 if Has_Discriminants
(T
) then
1822 Check_Restriction
(Max_Tasks
, N
);
1827 C
:= First_Component
(T
);
1828 while Present
(C
) loop
1829 V
:= V
+ Count_Tasks
(Etype
(C
));
1836 elsif Is_Array_Type
(T
) then
1837 X
:= First_Index
(T
);
1838 V
:= Count_Tasks
(Component_Type
(T
));
1839 while Present
(X
) loop
1842 if not Is_Static_Subtype
(C
) then
1843 Check_Restriction
(Max_Tasks
, N
);
1846 V
:= V
* (UI_Max
(Uint_0
,
1847 Expr_Value
(Type_High_Bound
(C
)) -
1848 Expr_Value
(Type_Low_Bound
(C
)) + Uint_1
));
1861 -- Start of processing for Analyze_Object_Declaration
1864 -- There are three kinds of implicit types generated by an
1865 -- object declaration:
1867 -- 1. Those for generated by the original Object Definition
1869 -- 2. Those generated by the Expression
1871 -- 3. Those used to constrained the Object Definition with the
1872 -- expression constraints when it is unconstrained
1874 -- They must be generated in this order to avoid order of elaboration
1875 -- issues. Thus the first step (after entering the name) is to analyze
1876 -- the object definition.
1878 if Constant_Present
(N
) then
1879 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
1881 -- If homograph is an implicit subprogram, it is overridden by the
1882 -- current declaration.
1884 if Present
(Prev_Entity
)
1885 and then Is_Overloadable
(Prev_Entity
)
1886 and then Is_Inherited_Operation
(Prev_Entity
)
1888 Prev_Entity
:= Empty
;
1892 if Present
(Prev_Entity
) then
1893 Constant_Redeclaration
(Id
, N
, T
);
1895 Generate_Reference
(Prev_Entity
, Id
, 'c');
1896 Set_Completion_Referenced
(Id
);
1898 if Error_Posted
(N
) then
1900 -- Type mismatch or illegal redeclaration, Do not analyze
1901 -- expression to avoid cascaded errors.
1903 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1905 Set_Ekind
(Id
, E_Variable
);
1909 -- In the normal case, enter identifier at the start to catch premature
1910 -- usage in the initialization expression.
1913 Generate_Definition
(Id
);
1916 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1918 if Error_Posted
(Id
) then
1920 Set_Ekind
(Id
, E_Variable
);
1925 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1926 -- out some static checks
1928 if Ada_Version
>= Ada_05
1929 and then Can_Never_Be_Null
(T
)
1931 -- In case of aggregates we must also take care of the correct
1932 -- initialization of nested aggregates bug this is done at the
1933 -- point of the analysis of the aggregate (see sem_aggr.adb)
1935 if Present
(Expression
(N
))
1936 and then Nkind
(Expression
(N
)) = N_Aggregate
1942 Save_Typ
: constant Entity_Id
:= Etype
(Id
);
1944 Set_Etype
(Id
, T
); -- Temp. decoration for static checks
1945 Null_Exclusion_Static_Checks
(N
);
1946 Set_Etype
(Id
, Save_Typ
);
1951 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1953 -- If deferred constant, make sure context is appropriate. We detect
1954 -- a deferred constant as a constant declaration with no expression.
1955 -- A deferred constant can appear in a package body if its completion
1956 -- is by means of an interface pragma.
1958 if Constant_Present
(N
)
1961 if not Is_Package
(Current_Scope
) then
1963 ("invalid context for deferred constant declaration ('R'M 7.4)",
1966 ("\declaration requires an initialization expression",
1968 Set_Constant_Present
(N
, False);
1970 -- In Ada 83, deferred constant must be of private type
1972 elsif not Is_Private_Type
(T
) then
1973 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
1975 ("(Ada 83) deferred constant must be private type", N
);
1979 -- If not a deferred constant, then object declaration freezes its type
1982 Check_Fully_Declared
(T
, N
);
1983 Freeze_Before
(N
, T
);
1986 -- If the object was created by a constrained array definition, then
1987 -- set the link in both the anonymous base type and anonymous subtype
1988 -- that are built to represent the array type to point to the object.
1990 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
1991 N_Constrained_Array_Definition
1993 Set_Related_Array_Object
(T
, Id
);
1994 Set_Related_Array_Object
(Base_Type
(T
), Id
);
1997 -- Special checks for protected objects not at library level
1999 if Is_Protected_Type
(T
)
2000 and then not Is_Library_Level_Entity
(Id
)
2002 Check_Restriction
(No_Local_Protected_Objects
, Id
);
2004 -- Protected objects with interrupt handlers must be at library level
2006 -- Ada 2005: this test is not needed (and the corresponding clause
2007 -- in the RM is removed) because accessibility checks are sufficient
2008 -- to make handlers not at the library level illegal.
2010 if Has_Interrupt_Handler
(T
)
2011 and then Ada_Version
< Ada_05
2014 ("interrupt object can only be declared at library level", Id
);
2018 -- The actual subtype of the object is the nominal subtype, unless
2019 -- the nominal one is unconstrained and obtained from the expression.
2023 -- Process initialization expression if present and not in error
2025 if Present
(E
) and then E
/= Error
then
2028 -- In case of errors detected in the analysis of the expression,
2029 -- decorate it with the expected type to avoid cascade errors
2031 if not Present
(Etype
(E
)) then
2035 -- If an initialization expression is present, then we set the
2036 -- Is_True_Constant flag. It will be reset if this is a variable
2037 -- and it is indeed modified.
2039 Set_Is_True_Constant
(Id
, True);
2041 -- If we are analyzing a constant declaration, set its completion
2042 -- flag after analyzing the expression.
2044 if Constant_Present
(N
) then
2045 Set_Has_Completion
(Id
);
2048 if not Assignment_OK
(N
) then
2049 Check_Initialization
(T
, E
);
2052 Set_Etype
(Id
, T
); -- may be overridden later on
2054 Check_Unset_Reference
(E
);
2056 if Compile_Time_Known_Value
(E
) then
2057 Set_Current_Value
(Id
, E
);
2060 -- Check incorrect use of dynamically tagged expressions. Note
2061 -- the use of Is_Tagged_Type (T) which seems redundant but is in
2062 -- fact important to avoid spurious errors due to expanded code
2063 -- for dispatching functions over an anonymous access type
2065 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
2066 and then Is_Tagged_Type
(T
)
2067 and then not Is_Class_Wide_Type
(T
)
2069 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
2072 Apply_Scalar_Range_Check
(E
, T
);
2073 Apply_Static_Length_Check
(E
, T
);
2076 -- If the No_Streams restriction is set, check that the type of the
2077 -- object is not, and does not contain, any subtype derived from
2078 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
2079 -- Has_Stream just for efficiency reasons. There is no point in
2080 -- spending time on a Has_Stream check if the restriction is not set.
2082 if Restrictions
.Set
(No_Streams
) then
2083 if Has_Stream
(T
) then
2084 Check_Restriction
(No_Streams
, N
);
2088 -- Abstract type is never permitted for a variable or constant.
2089 -- Note: we inhibit this check for objects that do not come from
2090 -- source because there is at least one case (the expansion of
2091 -- x'class'input where x is abstract) where we legitimately
2092 -- generate an abstract object.
2094 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
2095 Error_Msg_N
("type of object cannot be abstract",
2096 Object_Definition
(N
));
2098 if Is_CPP_Class
(T
) then
2099 Error_Msg_NE
("\} may need a cpp_constructor",
2100 Object_Definition
(N
), T
);
2103 -- Case of unconstrained type
2105 elsif Is_Indefinite_Subtype
(T
) then
2107 -- Nothing to do in deferred constant case
2109 if Constant_Present
(N
) and then No
(E
) then
2112 -- Case of no initialization present
2115 if No_Initialization
(N
) then
2118 elsif Is_Class_Wide_Type
(T
) then
2120 ("initialization required in class-wide declaration ", N
);
2124 ("unconstrained subtype not allowed (need initialization)",
2125 Object_Definition
(N
));
2128 -- Case of initialization present but in error. Set initial
2129 -- expression as absent (but do not make above complaints)
2131 elsif E
= Error
then
2132 Set_Expression
(N
, Empty
);
2135 -- Case of initialization present
2138 -- Not allowed in Ada 83
2140 if not Constant_Present
(N
) then
2141 if Ada_Version
= Ada_83
2142 and then Comes_From_Source
(Object_Definition
(N
))
2145 ("(Ada 83) unconstrained variable not allowed",
2146 Object_Definition
(N
));
2150 -- Now we constrain the variable from the initializing expression
2152 -- If the expression is an aggregate, it has been expanded into
2153 -- individual assignments. Retrieve the actual type from the
2154 -- expanded construct.
2156 if Is_Array_Type
(T
)
2157 and then No_Initialization
(N
)
2158 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2163 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
2164 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2167 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
2169 if Aliased_Present
(N
) then
2170 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2173 Freeze_Before
(N
, Act_T
);
2174 Freeze_Before
(N
, T
);
2177 elsif Is_Array_Type
(T
)
2178 and then No_Initialization
(N
)
2179 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2181 if not Is_Entity_Name
(Object_Definition
(N
)) then
2183 Check_Compile_Time_Size
(Act_T
);
2185 if Aliased_Present
(N
) then
2186 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2190 -- When the given object definition and the aggregate are specified
2191 -- independently, and their lengths might differ do a length check.
2192 -- This cannot happen if the aggregate is of the form (others =>...)
2194 if not Is_Constrained
(T
) then
2197 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
2199 -- Aggregate is statically illegal. Place back in declaration
2201 Set_Expression
(N
, E
);
2202 Set_No_Initialization
(N
, False);
2204 elsif T
= Etype
(E
) then
2207 elsif Nkind
(E
) = N_Aggregate
2208 and then Present
(Component_Associations
(E
))
2209 and then Present
(Choices
(First
(Component_Associations
(E
))))
2210 and then Nkind
(First
2211 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
2216 Apply_Length_Check
(E
, T
);
2219 elsif (Is_Limited_Record
(T
)
2220 or else Is_Concurrent_Type
(T
))
2221 and then not Is_Constrained
(T
)
2222 and then Has_Discriminants
(T
)
2224 Act_T
:= Build_Default_Subtype
;
2225 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
2227 elsif Present
(Underlying_Type
(T
))
2228 and then not Is_Constrained
(Underlying_Type
(T
))
2229 and then Has_Discriminants
(Underlying_Type
(T
))
2230 and then Nkind
(E
) = N_Function_Call
2231 and then Constant_Present
(N
)
2233 -- The back-end has problems with constants of a discriminated type
2234 -- with defaults, if the initial value is a function call. We
2235 -- generate an intermediate temporary for the result of the call.
2236 -- It is unclear why this should make it acceptable to gcc. ???
2238 Remove_Side_Effects
(E
);
2241 if T
= Standard_Wide_Character
or else T
= Standard_Wide_Wide_Character
2242 or else Root_Type
(T
) = Standard_Wide_String
2243 or else Root_Type
(T
) = Standard_Wide_Wide_String
2245 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
2248 -- Now establish the proper kind and type of the object
2250 if Constant_Present
(N
) then
2251 Set_Ekind
(Id
, E_Constant
);
2252 Set_Never_Set_In_Source
(Id
, True);
2253 Set_Is_True_Constant
(Id
, True);
2256 Set_Ekind
(Id
, E_Variable
);
2258 -- A variable is set as shared passive if it appears in a shared
2259 -- passive package, and is at the outer level. This is not done
2260 -- for entities generated during expansion, because those are
2261 -- always manipulated locally.
2263 if Is_Shared_Passive
(Current_Scope
)
2264 and then Is_Library_Level_Entity
(Id
)
2265 and then Comes_From_Source
(Id
)
2267 Set_Is_Shared_Passive
(Id
);
2268 Check_Shared_Var
(Id
, T
, N
);
2271 -- Case of no initializing expression present. If the type is not
2272 -- fully initialized, then we set Never_Set_In_Source, since this
2273 -- is a case of a potentially uninitialized object. Note that we
2274 -- do not consider access variables to be fully initialized for
2275 -- this purpose, since it still seems dubious if someone declares
2277 -- Note that we only do this for source declarations. If the object
2278 -- is declared by a generated declaration, we assume that it is not
2279 -- appropriate to generate warnings in that case.
2282 if (Is_Access_Type
(T
)
2283 or else not Is_Fully_Initialized_Type
(T
))
2284 and then Comes_From_Source
(N
)
2286 Set_Never_Set_In_Source
(Id
);
2291 Init_Alignment
(Id
);
2294 if Aliased_Present
(N
) then
2295 Set_Is_Aliased
(Id
);
2298 and then Is_Record_Type
(T
)
2299 and then not Is_Constrained
(T
)
2300 and then Has_Discriminants
(T
)
2302 Set_Actual_Subtype
(Id
, Build_Default_Subtype
);
2306 Set_Etype
(Id
, Act_T
);
2308 if Has_Controlled_Component
(Etype
(Id
))
2309 or else Is_Controlled
(Etype
(Id
))
2311 if not Is_Library_Level_Entity
(Id
) then
2312 Check_Restriction
(No_Nested_Finalization
, N
);
2314 Validate_Controlled_Object
(Id
);
2317 -- Generate a warning when an initialization causes an obvious ABE
2318 -- violation. If the init expression is a simple aggregate there
2319 -- shouldn't be any initialize/adjust call generated. This will be
2320 -- true as soon as aggregates are built in place when possible.
2322 -- ??? at the moment we do not generate warnings for temporaries
2323 -- created for those aggregates although Program_Error might be
2324 -- generated if compiled with -gnato.
2326 if Is_Controlled
(Etype
(Id
))
2327 and then Comes_From_Source
(Id
)
2330 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
2332 Implicit_Call
: Entity_Id
;
2333 pragma Warnings
(Off
, Implicit_Call
);
2334 -- ??? what is this for (never referenced!)
2336 function Is_Aggr
(N
: Node_Id
) return Boolean;
2337 -- Check that N is an aggregate
2343 function Is_Aggr
(N
: Node_Id
) return Boolean is
2345 case Nkind
(Original_Node
(N
)) is
2346 when N_Aggregate | N_Extension_Aggregate
=>
2349 when N_Qualified_Expression |
2351 N_Unchecked_Type_Conversion
=>
2352 return Is_Aggr
(Expression
(Original_Node
(N
)));
2360 -- If no underlying type, we already are in an error situation.
2361 -- Do not try to add a warning since we do not have access to
2364 if No
(Underlying_Type
(BT
)) then
2365 Implicit_Call
:= Empty
;
2367 -- A generic type does not have usable primitive operators.
2368 -- Initialization calls are built for instances.
2370 elsif Is_Generic_Type
(BT
) then
2371 Implicit_Call
:= Empty
;
2373 -- If the init expression is not an aggregate, an adjust call
2374 -- will be generated
2376 elsif Present
(E
) and then not Is_Aggr
(E
) then
2377 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
2379 -- If no init expression and we are not in the deferred
2380 -- constant case, an Initialize call will be generated
2382 elsif No
(E
) and then not Constant_Present
(N
) then
2383 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
2386 Implicit_Call
:= Empty
;
2392 if Has_Task
(Etype
(Id
)) then
2393 Check_Restriction
(No_Tasking
, N
);
2395 if Is_Library_Level_Entity
(Id
) then
2396 Check_Restriction
(Max_Tasks
, N
, Count_Tasks
(Etype
(Id
)));
2398 Check_Restriction
(Max_Tasks
, N
);
2399 Check_Restriction
(No_Task_Hierarchy
, N
);
2400 Check_Potentially_Blocking_Operation
(N
);
2403 -- A rather specialized test. If we see two tasks being declared
2404 -- of the same type in the same object declaration, and the task
2405 -- has an entry with an address clause, we know that program error
2406 -- will be raised at run-time since we can't have two tasks with
2407 -- entries at the same address.
2409 if Is_Task_Type
(Etype
(Id
)) and then More_Ids
(N
) then
2414 E
:= First_Entity
(Etype
(Id
));
2415 while Present
(E
) loop
2416 if Ekind
(E
) = E_Entry
2417 and then Present
(Get_Attribute_Definition_Clause
2418 (E
, Attribute_Address
))
2421 ("?more than one task with same entry address", N
);
2423 ("\?Program_Error will be raised at run time", N
);
2425 Make_Raise_Program_Error
(Loc
,
2426 Reason
=> PE_Duplicated_Entry_Address
));
2436 -- Some simple constant-propagation: if the expression is a constant
2437 -- string initialized with a literal, share the literal. This avoids
2441 and then Is_Entity_Name
(E
)
2442 and then Ekind
(Entity
(E
)) = E_Constant
2443 and then Base_Type
(Etype
(E
)) = Standard_String
2446 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
2449 and then Nkind
(Val
) = N_String_Literal
2451 Rewrite
(E
, New_Copy
(Val
));
2456 -- Another optimization: if the nominal subtype is unconstrained and
2457 -- the expression is a function call that returns an unconstrained
2458 -- type, rewrite the declaration as a renaming of the result of the
2459 -- call. The exceptions below are cases where the copy is expected,
2460 -- either by the back end (Aliased case) or by the semantics, as for
2461 -- initializing controlled types or copying tags for classwide types.
2464 and then Nkind
(E
) = N_Explicit_Dereference
2465 and then Nkind
(Original_Node
(E
)) = N_Function_Call
2466 and then not Is_Library_Level_Entity
(Id
)
2467 and then not Is_Constrained
(Underlying_Type
(T
))
2468 and then not Is_Aliased
(Id
)
2469 and then not Is_Class_Wide_Type
(T
)
2470 and then not Is_Controlled
(T
)
2471 and then not Has_Controlled_Component
(Base_Type
(T
))
2472 and then Expander_Active
2475 Make_Object_Renaming_Declaration
(Loc
,
2476 Defining_Identifier
=> Id
,
2477 Access_Definition
=> Empty
,
2478 Subtype_Mark
=> New_Occurrence_Of
2479 (Base_Type
(Etype
(Id
)), Loc
),
2482 Set_Renamed_Object
(Id
, E
);
2484 -- Force generation of debugging information for the constant and for
2485 -- the renamed function call.
2487 Set_Needs_Debug_Info
(Id
);
2488 Set_Needs_Debug_Info
(Entity
(Prefix
(E
)));
2491 if Present
(Prev_Entity
)
2492 and then Is_Frozen
(Prev_Entity
)
2493 and then not Error_Posted
(Id
)
2495 Error_Msg_N
("full constant declaration appears too late", N
);
2498 Check_Eliminated
(Id
);
2499 end Analyze_Object_Declaration
;
2501 ---------------------------
2502 -- Analyze_Others_Choice --
2503 ---------------------------
2505 -- Nothing to do for the others choice node itself, the semantic analysis
2506 -- of the others choice will occur as part of the processing of the parent
2508 procedure Analyze_Others_Choice
(N
: Node_Id
) is
2509 pragma Warnings
(Off
, N
);
2512 end Analyze_Others_Choice
;
2514 --------------------------------
2515 -- Analyze_Per_Use_Expression --
2516 --------------------------------
2518 procedure Analyze_Per_Use_Expression
(N
: Node_Id
; T
: Entity_Id
) is
2519 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
2521 In_Default_Expression
:= True;
2522 Pre_Analyze_And_Resolve
(N
, T
);
2523 In_Default_Expression
:= Save_In_Default_Expression
;
2524 end Analyze_Per_Use_Expression
;
2526 -------------------------------------------
2527 -- Analyze_Private_Extension_Declaration --
2528 -------------------------------------------
2530 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
2531 T
: constant Entity_Id
:= Defining_Identifier
(N
);
2532 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
2533 Parent_Type
: Entity_Id
;
2534 Parent_Base
: Entity_Id
;
2537 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
2539 if Is_Non_Empty_List
(Interface_List
(N
)) then
2545 Intf
:= First
(Interface_List
(N
));
2546 while Present
(Intf
) loop
2547 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
2549 if not Is_Interface
(T
) then
2550 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
2558 Generate_Definition
(T
);
2561 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
2562 Parent_Base
:= Base_Type
(Parent_Type
);
2564 if Parent_Type
= Any_Type
2565 or else Etype
(Parent_Type
) = Any_Type
2567 Set_Ekind
(T
, Ekind
(Parent_Type
));
2568 Set_Etype
(T
, Any_Type
);
2571 elsif not Is_Tagged_Type
(Parent_Type
) then
2573 ("parent of type extension must be a tagged type ", Indic
);
2576 elsif Ekind
(Parent_Type
) = E_Void
2577 or else Ekind
(Parent_Type
) = E_Incomplete_Type
2579 Error_Msg_N
("premature derivation of incomplete type", Indic
);
2583 -- Perhaps the parent type should be changed to the class-wide type's
2584 -- specific type in this case to prevent cascading errors ???
2586 if Is_Class_Wide_Type
(Parent_Type
) then
2588 ("parent of type extension must not be a class-wide type", Indic
);
2592 if (not Is_Package
(Current_Scope
)
2593 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
2594 or else In_Private_Part
(Current_Scope
)
2597 Error_Msg_N
("invalid context for private extension", N
);
2600 -- Set common attributes
2602 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2603 Set_Scope
(T
, Current_Scope
);
2604 Set_Ekind
(T
, E_Record_Type_With_Private
);
2605 Init_Size_Align
(T
);
2607 Set_Etype
(T
, Parent_Base
);
2608 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
2610 Set_Convention
(T
, Convention
(Parent_Type
));
2611 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
2612 Set_Is_First_Subtype
(T
);
2613 Make_Class_Wide_Type
(T
);
2615 if Unknown_Discriminants_Present
(N
) then
2616 Set_Discriminant_Constraint
(T
, No_Elist
);
2619 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
2620 end Analyze_Private_Extension_Declaration
;
2622 ---------------------------------
2623 -- Analyze_Subtype_Declaration --
2624 ---------------------------------
2626 procedure Analyze_Subtype_Declaration
(N
: Node_Id
) is
2627 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2629 R_Checks
: Check_Result
;
2632 Generate_Definition
(Id
);
2633 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2634 Init_Size_Align
(Id
);
2636 -- The following guard condition on Enter_Name is to handle cases where
2637 -- the defining identifier has already been entered into the scope but
2638 -- the declaration as a whole needs to be analyzed.
2640 -- This case in particular happens for derived enumeration types. The
2641 -- derived enumeration type is processed as an inserted enumeration type
2642 -- declaration followed by a rewritten subtype declaration. The defining
2643 -- identifier, however, is entered into the name scope very early in the
2644 -- processing of the original type declaration and therefore needs to be
2645 -- avoided here, when the created subtype declaration is analyzed. (See
2646 -- Build_Derived_Types)
2648 -- This also happens when the full view of a private type is derived
2649 -- type with constraints. In this case the entity has been introduced
2650 -- in the private declaration.
2652 if Present
(Etype
(Id
))
2653 and then (Is_Private_Type
(Etype
(Id
))
2654 or else Is_Task_Type
(Etype
(Id
))
2655 or else Is_Rewrite_Substitution
(N
))
2663 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2665 -- Inherit common attributes
2667 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2668 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2669 Set_Treat_As_Volatile
(Id
, Treat_As_Volatile
(T
));
2670 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2671 Set_Is_Ada_2005
(Id
, Is_Ada_2005
(T
));
2673 -- In the case where there is no constraint given in the subtype
2674 -- indication, Process_Subtype just returns the Subtype_Mark, so its
2675 -- semantic attributes must be established here.
2677 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2678 Set_Etype
(Id
, Base_Type
(T
));
2682 Set_Ekind
(Id
, E_Array_Subtype
);
2683 Copy_Array_Subtype_Attributes
(Id
, T
);
2685 when Decimal_Fixed_Point_Kind
=>
2686 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2687 Set_Digits_Value
(Id
, Digits_Value
(T
));
2688 Set_Delta_Value
(Id
, Delta_Value
(T
));
2689 Set_Scale_Value
(Id
, Scale_Value
(T
));
2690 Set_Small_Value
(Id
, Small_Value
(T
));
2691 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2692 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2693 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2694 Set_RM_Size
(Id
, RM_Size
(T
));
2696 when Enumeration_Kind
=>
2697 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2698 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2699 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2700 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2701 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2702 Set_RM_Size
(Id
, RM_Size
(T
));
2704 when Ordinary_Fixed_Point_Kind
=>
2705 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2706 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2707 Set_Small_Value
(Id
, Small_Value
(T
));
2708 Set_Delta_Value
(Id
, Delta_Value
(T
));
2709 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2710 Set_RM_Size
(Id
, RM_Size
(T
));
2713 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2714 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2715 Set_Digits_Value
(Id
, Digits_Value
(T
));
2716 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2718 when Signed_Integer_Kind
=>
2719 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2720 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2721 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2722 Set_RM_Size
(Id
, RM_Size
(T
));
2724 when Modular_Integer_Kind
=>
2725 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2726 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2727 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2728 Set_RM_Size
(Id
, RM_Size
(T
));
2730 when Class_Wide_Kind
=>
2731 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2732 Set_First_Entity
(Id
, First_Entity
(T
));
2733 Set_Last_Entity
(Id
, Last_Entity
(T
));
2734 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2735 Set_Cloned_Subtype
(Id
, T
);
2736 Set_Is_Tagged_Type
(Id
, True);
2737 Set_Has_Unknown_Discriminants
2740 if Ekind
(T
) = E_Class_Wide_Subtype
then
2741 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
2744 when E_Record_Type | E_Record_Subtype
=>
2745 Set_Ekind
(Id
, E_Record_Subtype
);
2747 if Ekind
(T
) = E_Record_Subtype
2748 and then Present
(Cloned_Subtype
(T
))
2750 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
2752 Set_Cloned_Subtype
(Id
, T
);
2755 Set_First_Entity
(Id
, First_Entity
(T
));
2756 Set_Last_Entity
(Id
, Last_Entity
(T
));
2757 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2758 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2759 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2760 Set_Has_Unknown_Discriminants
2761 (Id
, Has_Unknown_Discriminants
(T
));
2763 if Has_Discriminants
(T
) then
2764 Set_Discriminant_Constraint
2765 (Id
, Discriminant_Constraint
(T
));
2766 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2768 elsif Has_Unknown_Discriminants
(Id
) then
2769 Set_Discriminant_Constraint
(Id
, No_Elist
);
2772 if Is_Tagged_Type
(T
) then
2773 Set_Is_Tagged_Type
(Id
);
2774 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2775 Set_Primitive_Operations
2776 (Id
, Primitive_Operations
(T
));
2777 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2780 when Private_Kind
=>
2781 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2782 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2783 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2784 Set_First_Entity
(Id
, First_Entity
(T
));
2785 Set_Last_Entity
(Id
, Last_Entity
(T
));
2786 Set_Private_Dependents
(Id
, New_Elmt_List
);
2787 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2788 Set_Has_Unknown_Discriminants
2789 (Id
, Has_Unknown_Discriminants
(T
));
2791 if Is_Tagged_Type
(T
) then
2792 Set_Is_Tagged_Type
(Id
);
2793 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2794 Set_Primitive_Operations
2795 (Id
, Primitive_Operations
(T
));
2796 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2799 -- In general the attributes of the subtype of a private type
2800 -- are the attributes of the partial view of parent. However,
2801 -- the full view may be a discriminated type, and the subtype
2802 -- must share the discriminant constraint to generate correct
2803 -- calls to initialization procedures.
2805 if Has_Discriminants
(T
) then
2806 Set_Discriminant_Constraint
2807 (Id
, Discriminant_Constraint
(T
));
2808 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2810 elsif Present
(Full_View
(T
))
2811 and then Has_Discriminants
(Full_View
(T
))
2813 Set_Discriminant_Constraint
2814 (Id
, Discriminant_Constraint
(Full_View
(T
)));
2815 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2817 -- This would seem semantically correct, but apparently
2818 -- confuses the back-end (4412-009). To be explained ???
2820 -- Set_Has_Discriminants (Id);
2823 Prepare_Private_Subtype_Completion
(Id
, N
);
2826 Set_Ekind
(Id
, E_Access_Subtype
);
2827 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2828 Set_Is_Access_Constant
2829 (Id
, Is_Access_Constant
(T
));
2830 Set_Directly_Designated_Type
2831 (Id
, Designated_Type
(T
));
2832 Set_Can_Never_Be_Null
(Id
, Can_Never_Be_Null
(T
));
2834 -- A Pure library_item must not contain the declaration of a
2835 -- named access type, except within a subprogram, generic
2836 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
2838 if Comes_From_Source
(Id
)
2839 and then In_Pure_Unit
2840 and then not In_Subprogram_Task_Protected_Unit
2843 ("named access types not allowed in pure unit", N
);
2846 when Concurrent_Kind
=>
2847 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2848 Set_Corresponding_Record_Type
(Id
,
2849 Corresponding_Record_Type
(T
));
2850 Set_First_Entity
(Id
, First_Entity
(T
));
2851 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
2852 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2853 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2854 Set_Last_Entity
(Id
, Last_Entity
(T
));
2856 if Has_Discriminants
(T
) then
2857 Set_Discriminant_Constraint
(Id
,
2858 Discriminant_Constraint
(T
));
2859 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
2862 -- If the subtype name denotes an incomplete type an error was
2863 -- already reported by Process_Subtype.
2865 when E_Incomplete_Type
=>
2866 Set_Etype
(Id
, Any_Type
);
2869 raise Program_Error
;
2873 if Etype
(Id
) = Any_Type
then
2877 -- Some common processing on all types
2879 Set_Size_Info
(Id
, T
);
2880 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
2884 Set_Is_Immediately_Visible
(Id
, True);
2885 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
2887 if Present
(Generic_Parent_Type
(N
))
2890 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
2892 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
2893 /= N_Formal_Private_Type_Definition
)
2895 if Is_Tagged_Type
(Id
) then
2896 if Is_Class_Wide_Type
(Id
) then
2897 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
2899 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
2902 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
2903 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
2907 if Is_Private_Type
(T
)
2908 and then Present
(Full_View
(T
))
2910 Conditional_Delay
(Id
, Full_View
(T
));
2912 -- The subtypes of components or subcomponents of protected types
2913 -- do not need freeze nodes, which would otherwise appear in the
2914 -- wrong scope (before the freeze node for the protected type). The
2915 -- proper subtypes are those of the subcomponents of the corresponding
2918 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
2919 and then Present
(Scope
(Scope
(Id
))) -- error defense!
2920 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
2922 Conditional_Delay
(Id
, T
);
2925 -- Check that constraint_error is raised for a scalar subtype
2926 -- indication when the lower or upper bound of a non-null range
2927 -- lies outside the range of the type mark.
2929 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
2930 if Is_Scalar_Type
(Etype
(Id
))
2931 and then Scalar_Range
(Id
) /=
2932 Scalar_Range
(Etype
(Subtype_Mark
2933 (Subtype_Indication
(N
))))
2937 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
2939 elsif Is_Array_Type
(Etype
(Id
))
2940 and then Present
(First_Index
(Id
))
2942 -- This really should be a subprogram that finds the indications
2945 if ((Nkind
(First_Index
(Id
)) = N_Identifier
2946 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
2947 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
2949 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
2952 Target_Typ
: constant Entity_Id
:=
2955 (Subtype_Mark
(Subtype_Indication
(N
)))));
2959 (Scalar_Range
(Etype
(First_Index
(Id
))),
2961 Etype
(First_Index
(Id
)),
2962 Defining_Identifier
(N
));
2968 Sloc
(Defining_Identifier
(N
)));
2974 Check_Eliminated
(Id
);
2975 end Analyze_Subtype_Declaration
;
2977 --------------------------------
2978 -- Analyze_Subtype_Indication --
2979 --------------------------------
2981 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
2982 T
: constant Entity_Id
:= Subtype_Mark
(N
);
2983 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
2990 Set_Etype
(N
, Etype
(R
));
2992 Set_Error_Posted
(R
);
2993 Set_Error_Posted
(T
);
2995 end Analyze_Subtype_Indication
;
2997 ------------------------------
2998 -- Analyze_Type_Declaration --
2999 ------------------------------
3001 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
3002 Def
: constant Node_Id
:= Type_Definition
(N
);
3003 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3007 Is_Remote
: constant Boolean :=
3008 (Is_Remote_Types
(Current_Scope
)
3009 or else Is_Remote_Call_Interface
(Current_Scope
))
3010 and then not (In_Private_Part
(Current_Scope
)
3012 In_Package_Body
(Current_Scope
));
3015 Prev
:= Find_Type_Name
(N
);
3017 -- The full view, if present, now points to the current type
3019 -- Ada 2005 (AI-50217): If the type was previously decorated when
3020 -- imported through a LIMITED WITH clause, it appears as incomplete
3021 -- but has no full view.
3023 if Ekind
(Prev
) = E_Incomplete_Type
3024 and then Present
(Full_View
(Prev
))
3026 T
:= Full_View
(Prev
);
3031 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
3033 -- We set the flag Is_First_Subtype here. It is needed to set the
3034 -- corresponding flag for the Implicit class-wide-type created
3035 -- during tagged types processing.
3037 Set_Is_First_Subtype
(T
, True);
3039 -- Only composite types other than array types are allowed to have
3044 -- For derived types, the rule will be checked once we've figured
3045 -- out the parent type.
3047 when N_Derived_Type_Definition
=>
3050 -- For record types, discriminants are allowed
3052 when N_Record_Definition
=>
3056 if Present
(Discriminant_Specifications
(N
)) then
3058 ("elementary or array type cannot have discriminants",
3060 (First
(Discriminant_Specifications
(N
))));
3064 -- Elaborate the type definition according to kind, and generate
3065 -- subsidiary (implicit) subtypes where needed. We skip this if
3066 -- it was already done (this happens during the reanalysis that
3067 -- follows a call to the high level optimizer).
3069 if not Analyzed
(T
) then
3074 when N_Access_To_Subprogram_Definition
=>
3075 Access_Subprogram_Declaration
(T
, Def
);
3077 -- If this is a remote access to subprogram, we must create
3078 -- the equivalent fat pointer type, and related subprograms.
3081 Process_Remote_AST_Declaration
(N
);
3084 -- Validate categorization rule against access type declaration
3085 -- usually a violation in Pure unit, Shared_Passive unit.
3087 Validate_Access_Type_Declaration
(T
, N
);
3089 when N_Access_To_Object_Definition
=>
3090 Access_Type_Declaration
(T
, Def
);
3092 -- Validate categorization rule against access type declaration
3093 -- usually a violation in Pure unit, Shared_Passive unit.
3095 Validate_Access_Type_Declaration
(T
, N
);
3097 -- If we are in a Remote_Call_Interface package and define
3098 -- a RACW, Read and Write attribute must be added.
3101 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
3103 Add_RACW_Features
(Def_Id
);
3106 -- Set no strict aliasing flag if config pragma seen
3108 if Opt
.No_Strict_Aliasing
then
3109 Set_No_Strict_Aliasing
(Base_Type
(Def_Id
));
3112 when N_Array_Type_Definition
=>
3113 Array_Type_Declaration
(T
, Def
);
3115 when N_Derived_Type_Definition
=>
3116 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
3118 when N_Enumeration_Type_Definition
=>
3119 Enumeration_Type_Declaration
(T
, Def
);
3121 when N_Floating_Point_Definition
=>
3122 Floating_Point_Type_Declaration
(T
, Def
);
3124 when N_Decimal_Fixed_Point_Definition
=>
3125 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
3127 when N_Ordinary_Fixed_Point_Definition
=>
3128 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
3130 when N_Signed_Integer_Type_Definition
=>
3131 Signed_Integer_Type_Declaration
(T
, Def
);
3133 when N_Modular_Type_Definition
=>
3134 Modular_Type_Declaration
(T
, Def
);
3136 when N_Record_Definition
=>
3137 Record_Type_Declaration
(T
, N
, Prev
);
3140 raise Program_Error
;
3145 if Etype
(T
) = Any_Type
then
3149 -- Some common processing for all types
3151 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
3153 -- Both the declared entity, and its anonymous base type if one
3154 -- was created, need freeze nodes allocated.
3157 B
: constant Entity_Id
:= Base_Type
(T
);
3160 -- In the case where the base type is different from the first
3161 -- subtype, we pre-allocate a freeze node, and set the proper link
3162 -- to the first subtype. Freeze_Entity will use this preallocated
3163 -- freeze node when it freezes the entity.
3166 Ensure_Freeze_Node
(B
);
3167 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
3170 if not From_With_Type
(T
) then
3171 Set_Has_Delayed_Freeze
(T
);
3175 -- Case of T is the full declaration of some private type which has
3176 -- been swapped in Defining_Identifier (N).
3178 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
3179 Process_Full_View
(N
, T
, Def_Id
);
3181 -- Record the reference. The form of this is a little strange,
3182 -- since the full declaration has been swapped in. So the first
3183 -- parameter here represents the entity to which a reference is
3184 -- made which is the "real" entity, i.e. the one swapped in,
3185 -- and the second parameter provides the reference location.
3187 Generate_Reference
(T
, T
, 'c');
3188 Set_Completion_Referenced
(Def_Id
);
3190 -- For completion of incomplete type, process incomplete dependents
3191 -- and always mark the full type as referenced (it is the incomplete
3192 -- type that we get for any real reference).
3194 elsif Ekind
(Prev
) = E_Incomplete_Type
then
3195 Process_Incomplete_Dependents
(N
, T
, Prev
);
3196 Generate_Reference
(Prev
, Def_Id
, 'c');
3197 Set_Completion_Referenced
(Def_Id
);
3199 -- If not private type or incomplete type completion, this is a real
3200 -- definition of a new entity, so record it.
3203 Generate_Definition
(Def_Id
);
3206 Check_Eliminated
(Def_Id
);
3207 end Analyze_Type_Declaration
;
3209 --------------------------
3210 -- Analyze_Variant_Part --
3211 --------------------------
3213 procedure Analyze_Variant_Part
(N
: Node_Id
) is
3215 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
3216 -- Error routine invoked by the generic instantiation below when
3217 -- the variant part has a non static choice.
3219 procedure Process_Declarations
(Variant
: Node_Id
);
3220 -- Analyzes all the declarations associated with a Variant.
3221 -- Needed by the generic instantiation below.
3223 package Variant_Choices_Processing
is new
3224 Generic_Choices_Processing
3225 (Get_Alternatives
=> Variants
,
3226 Get_Choices
=> Discrete_Choices
,
3227 Process_Empty_Choice
=> No_OP
,
3228 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
3229 Process_Associated_Node
=> Process_Declarations
);
3230 use Variant_Choices_Processing
;
3231 -- Instantiation of the generic choice processing package
3233 -----------------------------
3234 -- Non_Static_Choice_Error --
3235 -----------------------------
3237 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
3239 Flag_Non_Static_Expr
3240 ("choice given in variant part is not static!", Choice
);
3241 end Non_Static_Choice_Error
;
3243 --------------------------
3244 -- Process_Declarations --
3245 --------------------------
3247 procedure Process_Declarations
(Variant
: Node_Id
) is
3249 if not Null_Present
(Component_List
(Variant
)) then
3250 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
3252 if Present
(Variant_Part
(Component_List
(Variant
))) then
3253 Analyze
(Variant_Part
(Component_List
(Variant
)));
3256 end Process_Declarations
;
3258 -- Variables local to Analyze_Case_Statement
3260 Discr_Name
: Node_Id
;
3261 Discr_Type
: Entity_Id
;
3263 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
3265 Dont_Care
: Boolean;
3266 Others_Present
: Boolean := False;
3268 -- Start of processing for Analyze_Variant_Part
3271 Discr_Name
:= Name
(N
);
3272 Analyze
(Discr_Name
);
3274 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
3275 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
3278 Discr_Type
:= Etype
(Entity
(Discr_Name
));
3280 if not Is_Discrete_Type
(Discr_Type
) then
3282 ("discriminant in a variant part must be of a discrete type",
3287 -- Call the instantiated Analyze_Choices which does the rest of the work
3290 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
3291 end Analyze_Variant_Part
;
3293 ----------------------------
3294 -- Array_Type_Declaration --
3295 ----------------------------
3297 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
3298 Component_Def
: constant Node_Id
:= Component_Definition
(Def
);
3299 Element_Type
: Entity_Id
;
3300 Implicit_Base
: Entity_Id
;
3302 Related_Id
: Entity_Id
:= Empty
;
3304 P
: constant Node_Id
:= Parent
(Def
);
3308 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3309 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
3311 Index
:= First
(Subtype_Marks
(Def
));
3314 -- Find proper names for the implicit types which may be public.
3315 -- in case of anonymous arrays we use the name of the first object
3316 -- of that type as prefix.
3319 Related_Id
:= Defining_Identifier
(P
);
3325 while Present
(Index
) loop
3327 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
3329 Nb_Index
:= Nb_Index
+ 1;
3332 if Present
(Subtype_Indication
(Component_Def
)) then
3333 Element_Type
:= Process_Subtype
(Subtype_Indication
(Component_Def
),
3334 P
, Related_Id
, 'C');
3336 -- Ada 2005 (AI-230): Access Definition case
3338 else pragma Assert
(Present
(Access_Definition
(Component_Def
)));
3339 Element_Type
:= Access_Definition
3340 (Related_Nod
=> Related_Id
,
3341 N
=> Access_Definition
(Component_Def
));
3342 Set_Is_Local_Anonymous_Access
(Element_Type
);
3344 -- Ada 2005 (AI-230): In case of components that are anonymous
3345 -- access types the level of accessibility depends on the enclosing
3348 Set_Scope
(Element_Type
, Current_Scope
); -- Ada 2005 (AI-230)
3350 -- Ada 2005 (AI-254)
3353 CD
: constant Node_Id
:=
3354 Access_To_Subprogram_Definition
3355 (Access_Definition
(Component_Def
));
3357 if Present
(CD
) and then Protected_Present
(CD
) then
3359 Replace_Anonymous_Access_To_Protected_Subprogram
3360 (Def
, Element_Type
);
3365 -- Constrained array case
3368 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
3371 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3373 -- Establish Implicit_Base as unconstrained base type
3375 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
3377 Init_Size_Align
(Implicit_Base
);
3378 Set_Etype
(Implicit_Base
, Implicit_Base
);
3379 Set_Scope
(Implicit_Base
, Current_Scope
);
3380 Set_Has_Delayed_Freeze
(Implicit_Base
);
3382 -- The constrained array type is a subtype of the unconstrained one
3384 Set_Ekind
(T
, E_Array_Subtype
);
3385 Init_Size_Align
(T
);
3386 Set_Etype
(T
, Implicit_Base
);
3387 Set_Scope
(T
, Current_Scope
);
3388 Set_Is_Constrained
(T
, True);
3389 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
3390 Set_Has_Delayed_Freeze
(T
);
3392 -- Complete setup of implicit base type
3394 Set_First_Index
(Implicit_Base
, First_Index
(T
));
3395 Set_Component_Type
(Implicit_Base
, Element_Type
);
3396 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
3397 Set_Component_Size
(Implicit_Base
, Uint_0
);
3398 Set_Has_Controlled_Component
3399 (Implicit_Base
, Has_Controlled_Component
3402 Is_Controlled
(Element_Type
));
3403 Set_Finalize_Storage_Only
3404 (Implicit_Base
, Finalize_Storage_Only
3407 -- Unconstrained array case
3410 Set_Ekind
(T
, E_Array_Type
);
3411 Init_Size_Align
(T
);
3413 Set_Scope
(T
, Current_Scope
);
3414 Set_Component_Size
(T
, Uint_0
);
3415 Set_Is_Constrained
(T
, False);
3416 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
3417 Set_Has_Delayed_Freeze
(T
, True);
3418 Set_Has_Task
(T
, Has_Task
(Element_Type
));
3419 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
3422 Is_Controlled
(Element_Type
));
3423 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
3427 Set_Component_Type
(Base_Type
(T
), Element_Type
);
3429 if Aliased_Present
(Component_Definition
(Def
)) then
3430 Set_Has_Aliased_Components
(Etype
(T
));
3433 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
3434 -- array type to ensure that objects of this type are initialized.
3436 if Ada_Version
>= Ada_05
3437 and then Can_Never_Be_Null
(Element_Type
)
3439 Set_Can_Never_Be_Null
(T
);
3441 if Null_Exclusion_Present
(Component_Definition
(Def
))
3442 and then Can_Never_Be_Null
(Element_Type
)
3444 -- No need to check itypes because in their case this check
3445 -- was done at their point of creation
3447 and then not Is_Itype
(Element_Type
)
3450 ("(Ada 2005) already a null-excluding type",
3451 Subtype_Indication
(Component_Definition
(Def
)));
3455 Priv
:= Private_Component
(Element_Type
);
3457 if Present
(Priv
) then
3459 -- Check for circular definitions
3461 if Priv
= Any_Type
then
3462 Set_Component_Type
(Etype
(T
), Any_Type
);
3464 -- There is a gap in the visibility of operations on the composite
3465 -- type only if the component type is defined in a different scope.
3467 elsif Scope
(Priv
) = Current_Scope
then
3470 elsif Is_Limited_Type
(Priv
) then
3471 Set_Is_Limited_Composite
(Etype
(T
));
3472 Set_Is_Limited_Composite
(T
);
3474 Set_Is_Private_Composite
(Etype
(T
));
3475 Set_Is_Private_Composite
(T
);
3479 -- Create a concatenation operator for the new type. Internal
3480 -- array types created for packed entities do not need such, they
3481 -- are compatible with the user-defined type.
3483 if Number_Dimensions
(T
) = 1
3484 and then not Is_Packed_Array_Type
(T
)
3486 New_Concatenation_Op
(T
);
3489 -- In the case of an unconstrained array the parser has already
3490 -- verified that all the indices are unconstrained but we still
3491 -- need to make sure that the element type is constrained.
3493 if Is_Indefinite_Subtype
(Element_Type
) then
3495 ("unconstrained element type in array declaration",
3496 Subtype_Indication
(Component_Def
));
3498 elsif Is_Abstract
(Element_Type
) then
3500 ("the type of a component cannot be abstract",
3501 Subtype_Indication
(Component_Def
));
3504 end Array_Type_Declaration
;
3506 ------------------------------------------------------
3507 -- Replace_Anonymous_Access_To_Protected_Subprogram --
3508 ------------------------------------------------------
3510 function Replace_Anonymous_Access_To_Protected_Subprogram
3512 Prev_E
: Entity_Id
) return Entity_Id
3514 Loc
: constant Source_Ptr
:= Sloc
(N
);
3516 Curr_Scope
: constant Scope_Stack_Entry
:=
3517 Scope_Stack
.Table
(Scope_Stack
.Last
);
3519 Anon
: constant Entity_Id
:=
3520 Make_Defining_Identifier
(Loc
,
3521 Chars
=> New_Internal_Name
('S'));
3529 Set_Is_Internal
(Anon
);
3532 when N_Component_Declaration |
3533 N_Unconstrained_Array_Definition |
3534 N_Constrained_Array_Definition
=>
3535 Comp
:= Component_Definition
(N
);
3536 Acc
:= Access_Definition
(Component_Definition
(N
));
3538 when N_Discriminant_Specification
=>
3539 Comp
:= Discriminant_Type
(N
);
3540 Acc
:= Discriminant_Type
(N
);
3542 when N_Parameter_Specification
=>
3543 Comp
:= Parameter_Type
(N
);
3544 Acc
:= Parameter_Type
(N
);
3547 raise Program_Error
;
3550 Decl
:= Make_Full_Type_Declaration
(Loc
,
3551 Defining_Identifier
=> Anon
,
3553 Copy_Separate_Tree
(Access_To_Subprogram_Definition
(Acc
)));
3555 Mark_Rewrite_Insertion
(Decl
);
3557 -- Insert the new declaration in the nearest enclosing scope
3560 while Present
(P
) and then not Has_Declarations
(P
) loop
3564 pragma Assert
(Present
(P
));
3566 if Nkind
(P
) = N_Package_Specification
then
3567 Prepend
(Decl
, Visible_Declarations
(P
));
3569 Prepend
(Decl
, Declarations
(P
));
3572 -- Replace the anonymous type with an occurrence of the new declaration.
3573 -- In all cases the rewritten node does not have the null-exclusion
3574 -- attribute because (if present) it was already inherited by the
3575 -- anonymous entity (Anon). Thus, in case of components we do not
3576 -- inherit this attribute.
3578 if Nkind
(N
) = N_Parameter_Specification
then
3579 Rewrite
(Comp
, New_Occurrence_Of
(Anon
, Loc
));
3580 Set_Etype
(Defining_Identifier
(N
), Anon
);
3581 Set_Null_Exclusion_Present
(N
, False);
3584 Make_Component_Definition
(Loc
,
3585 Subtype_Indication
=> New_Occurrence_Of
(Anon
, Loc
)));
3588 Mark_Rewrite_Insertion
(Comp
);
3590 -- Temporarily remove the current scope from the stack to add the new
3591 -- declarations to the enclosing scope
3593 Scope_Stack
.Decrement_Last
;
3595 Scope_Stack
.Append
(Curr_Scope
);
3597 Set_Original_Access_Type
(Anon
, Prev_E
);
3599 end Replace_Anonymous_Access_To_Protected_Subprogram
;
3601 -------------------------------
3602 -- Build_Derived_Access_Type --
3603 -------------------------------
3605 procedure Build_Derived_Access_Type
3607 Parent_Type
: Entity_Id
;
3608 Derived_Type
: Entity_Id
)
3610 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
3612 Desig_Type
: Entity_Id
;
3614 Discr_Con_Elist
: Elist_Id
;
3615 Discr_Con_El
: Elmt_Id
;
3619 -- Set the designated type so it is available in case this is
3620 -- an access to a self-referential type, e.g. a standard list
3621 -- type with a next pointer. Will be reset after subtype is built.
3623 Set_Directly_Designated_Type
3624 (Derived_Type
, Designated_Type
(Parent_Type
));
3626 Subt
:= Process_Subtype
(S
, N
);
3628 if Nkind
(S
) /= N_Subtype_Indication
3629 and then Subt
/= Base_Type
(Subt
)
3631 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
3634 if Ekind
(Derived_Type
) = E_Access_Subtype
then
3636 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3637 Ibase
: constant Entity_Id
:=
3638 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
3639 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
3640 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
3643 Copy_Node
(Pbase
, Ibase
);
3645 Set_Chars
(Ibase
, Svg_Chars
);
3646 Set_Next_Entity
(Ibase
, Svg_Next_E
);
3647 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
3648 Set_Scope
(Ibase
, Scope
(Derived_Type
));
3649 Set_Freeze_Node
(Ibase
, Empty
);
3650 Set_Is_Frozen
(Ibase
, False);
3651 Set_Comes_From_Source
(Ibase
, False);
3652 Set_Is_First_Subtype
(Ibase
, False);
3654 Set_Etype
(Ibase
, Pbase
);
3655 Set_Etype
(Derived_Type
, Ibase
);
3659 Set_Directly_Designated_Type
3660 (Derived_Type
, Designated_Type
(Subt
));
3662 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
3663 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
3664 Set_Size_Info
(Derived_Type
, Parent_Type
);
3665 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
3666 Set_Depends_On_Private
(Derived_Type
,
3667 Has_Private_Component
(Derived_Type
));
3668 Conditional_Delay
(Derived_Type
, Subt
);
3670 -- Ada 2005 (AI-231). Set the null-exclusion attribute
3672 if Null_Exclusion_Present
(Type_Definition
(N
))
3673 or else Can_Never_Be_Null
(Parent_Type
)
3675 Set_Can_Never_Be_Null
(Derived_Type
);
3678 -- Note: we do not copy the Storage_Size_Variable, since
3679 -- we always go to the root type for this information.
3681 -- Apply range checks to discriminants for derived record case
3682 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
3684 Desig_Type
:= Designated_Type
(Derived_Type
);
3685 if Is_Composite_Type
(Desig_Type
)
3686 and then (not Is_Array_Type
(Desig_Type
))
3687 and then Has_Discriminants
(Desig_Type
)
3688 and then Base_Type
(Desig_Type
) /= Desig_Type
3690 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
3691 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
3693 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
3694 while Present
(Discr_Con_El
) loop
3695 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
3696 Next_Elmt
(Discr_Con_El
);
3697 Next_Discriminant
(Discr
);
3700 end Build_Derived_Access_Type
;
3702 ------------------------------
3703 -- Build_Derived_Array_Type --
3704 ------------------------------
3706 procedure Build_Derived_Array_Type
3708 Parent_Type
: Entity_Id
;
3709 Derived_Type
: Entity_Id
)
3711 Loc
: constant Source_Ptr
:= Sloc
(N
);
3712 Tdef
: constant Node_Id
:= Type_Definition
(N
);
3713 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
3714 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3715 Implicit_Base
: Entity_Id
;
3716 New_Indic
: Node_Id
;
3718 procedure Make_Implicit_Base
;
3719 -- If the parent subtype is constrained, the derived type is a
3720 -- subtype of an implicit base type derived from the parent base.
3722 ------------------------
3723 -- Make_Implicit_Base --
3724 ------------------------
3726 procedure Make_Implicit_Base
is
3729 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
3731 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
3732 Set_Etype
(Implicit_Base
, Parent_Base
);
3734 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
3735 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
3737 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
3738 end Make_Implicit_Base
;
3740 -- Start of processing for Build_Derived_Array_Type
3743 if not Is_Constrained
(Parent_Type
) then
3744 if Nkind
(Indic
) /= N_Subtype_Indication
then
3745 Set_Ekind
(Derived_Type
, E_Array_Type
);
3747 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
3748 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
3750 Set_Has_Delayed_Freeze
(Derived_Type
, True);
3754 Set_Etype
(Derived_Type
, Implicit_Base
);
3757 Make_Subtype_Declaration
(Loc
,
3758 Defining_Identifier
=> Derived_Type
,
3759 Subtype_Indication
=>
3760 Make_Subtype_Indication
(Loc
,
3761 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
3762 Constraint
=> Constraint
(Indic
)));
3764 Rewrite
(N
, New_Indic
);
3769 if Nkind
(Indic
) /= N_Subtype_Indication
then
3772 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
3773 Set_Etype
(Derived_Type
, Implicit_Base
);
3774 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
3777 Error_Msg_N
("illegal constraint on constrained type", Indic
);
3781 -- If parent type is not a derived type itself, and is declared in
3782 -- closed scope (e.g. a subprogram), then we must explicitly introduce
3783 -- the new type's concatenation operator since Derive_Subprograms
3784 -- will not inherit the parent's operator. If the parent type is
3785 -- unconstrained, the operator is of the unconstrained base type.
3787 if Number_Dimensions
(Parent_Type
) = 1
3788 and then not Is_Limited_Type
(Parent_Type
)
3789 and then not Is_Derived_Type
(Parent_Type
)
3790 and then not Is_Package
(Scope
(Base_Type
(Parent_Type
)))
3792 if not Is_Constrained
(Parent_Type
)
3793 and then Is_Constrained
(Derived_Type
)
3795 New_Concatenation_Op
(Implicit_Base
);
3797 New_Concatenation_Op
(Derived_Type
);
3800 end Build_Derived_Array_Type
;
3802 -----------------------------------
3803 -- Build_Derived_Concurrent_Type --
3804 -----------------------------------
3806 procedure Build_Derived_Concurrent_Type
3808 Parent_Type
: Entity_Id
;
3809 Derived_Type
: Entity_Id
)
3811 D_Constraint
: Node_Id
;
3812 Disc_Spec
: Node_Id
;
3813 Old_Disc
: Entity_Id
;
3814 New_Disc
: Entity_Id
;
3816 Constraint_Present
: constant Boolean :=
3817 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3818 = N_Subtype_Indication
;
3821 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
3823 if Is_Task_Type
(Parent_Type
) then
3824 Set_Storage_Size_Variable
(Derived_Type
,
3825 Storage_Size_Variable
(Parent_Type
));
3828 if Present
(Discriminant_Specifications
(N
)) then
3829 New_Scope
(Derived_Type
);
3830 Check_Or_Process_Discriminants
(N
, Derived_Type
);
3833 elsif Constraint_Present
then
3835 -- Build constrained subtype and derive from it
3838 Loc
: constant Source_Ptr
:= Sloc
(N
);
3839 Anon
: constant Entity_Id
:=
3840 Make_Defining_Identifier
(Loc
,
3841 New_External_Name
(Chars
(Derived_Type
), 'T'));
3846 Make_Subtype_Declaration
(Loc
,
3847 Defining_Identifier
=> Anon
,
3848 Subtype_Indication
=>
3849 New_Copy_Tree
(Subtype_Indication
(Type_Definition
(N
))));
3850 Insert_Before
(N
, Decl
);
3851 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
3852 New_Occurrence_Of
(Anon
, Loc
));
3854 Set_Analyzed
(Derived_Type
, False);
3860 -- All attributes are inherited from parent. In particular,
3861 -- entries and the corresponding record type are the same.
3862 -- Discriminants may be renamed, and must be treated separately.
3864 Set_Has_Discriminants
3865 (Derived_Type
, Has_Discriminants
(Parent_Type
));
3866 Set_Corresponding_Record_Type
3867 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
3869 if Constraint_Present
then
3870 if not Has_Discriminants
(Parent_Type
) then
3871 Error_Msg_N
("untagged parent must have discriminants", N
);
3873 elsif Present
(Discriminant_Specifications
(N
)) then
3875 -- Verify that new discriminants are used to constrain old ones
3880 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
3882 Old_Disc
:= First_Discriminant
(Parent_Type
);
3883 New_Disc
:= First_Discriminant
(Derived_Type
);
3884 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
3885 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
3886 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
3889 Analyze
(Discriminant_Type
(Disc_Spec
));
3891 if not Subtypes_Statically_Compatible
(
3892 Etype
(Discriminant_Type
(Disc_Spec
)),
3896 ("not statically compatible with parent discriminant",
3897 Discriminant_Type
(Disc_Spec
));
3901 if Nkind
(D_Constraint
) = N_Identifier
3902 and then Chars
(D_Constraint
) /=
3903 Chars
(Defining_Identifier
(Disc_Spec
))
3905 Error_Msg_N
("new discriminants must constrain old ones",
3908 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
3911 Next_Discriminant
(Old_Disc
);
3912 Next_Discriminant
(New_Disc
);
3916 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
3917 Error_Msg_N
("discriminant mismatch in derivation", N
);
3922 elsif Present
(Discriminant_Specifications
(N
)) then
3924 ("missing discriminant constraint in untagged derivation",
3928 if Present
(Discriminant_Specifications
(N
)) then
3929 Old_Disc
:= First_Discriminant
(Parent_Type
);
3930 while Present
(Old_Disc
) loop
3932 if No
(Next_Entity
(Old_Disc
))
3933 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
3935 Set_Next_Entity
(Last_Entity
(Derived_Type
),
3936 Next_Entity
(Old_Disc
));
3940 Next_Discriminant
(Old_Disc
);
3944 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
3945 if Has_Discriminants
(Parent_Type
) then
3946 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
3947 Set_Discriminant_Constraint
(
3948 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
3952 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
3954 Set_Has_Completion
(Derived_Type
);
3955 end Build_Derived_Concurrent_Type
;
3957 ------------------------------------
3958 -- Build_Derived_Enumeration_Type --
3959 ------------------------------------
3961 procedure Build_Derived_Enumeration_Type
3963 Parent_Type
: Entity_Id
;
3964 Derived_Type
: Entity_Id
)
3966 Loc
: constant Source_Ptr
:= Sloc
(N
);
3967 Def
: constant Node_Id
:= Type_Definition
(N
);
3968 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
3969 Implicit_Base
: Entity_Id
;
3970 Literal
: Entity_Id
;
3971 New_Lit
: Entity_Id
;
3972 Literals_List
: List_Id
;
3973 Type_Decl
: Node_Id
;
3975 Rang_Expr
: Node_Id
;
3978 -- Since types Standard.Character and Standard.Wide_Character do
3979 -- not have explicit literals lists we need to process types derived
3980 -- from them specially. This is handled by Derived_Standard_Character.
3981 -- If the parent type is a generic type, there are no literals either,
3982 -- and we construct the same skeletal representation as for the generic
3985 if Root_Type
(Parent_Type
) = Standard_Character
3986 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
3987 or else Root_Type
(Parent_Type
) = Standard_Wide_Wide_Character
3989 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
3991 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
3998 Make_Attribute_Reference
(Loc
,
3999 Attribute_Name
=> Name_First
,
4000 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4001 Set_Etype
(Lo
, Derived_Type
);
4004 Make_Attribute_Reference
(Loc
,
4005 Attribute_Name
=> Name_Last
,
4006 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4007 Set_Etype
(Hi
, Derived_Type
);
4009 Set_Scalar_Range
(Derived_Type
,
4016 -- If a constraint is present, analyze the bounds to catch
4017 -- premature usage of the derived literals.
4019 if Nkind
(Indic
) = N_Subtype_Indication
4020 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
4022 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
4023 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
4026 -- Introduce an implicit base type for the derived type even
4027 -- if there is no constraint attached to it, since this seems
4028 -- closer to the Ada semantics. Build a full type declaration
4029 -- tree for the derived type using the implicit base type as
4030 -- the defining identifier. The build a subtype declaration
4031 -- tree which applies the constraint (if any) have it replace
4032 -- the derived type declaration.
4034 Literal
:= First_Literal
(Parent_Type
);
4035 Literals_List
:= New_List
;
4036 while Present
(Literal
)
4037 and then Ekind
(Literal
) = E_Enumeration_Literal
4039 -- Literals of the derived type have the same representation as
4040 -- those of the parent type, but this representation can be
4041 -- overridden by an explicit representation clause. Indicate
4042 -- that there is no explicit representation given yet. These
4043 -- derived literals are implicit operations of the new type,
4044 -- and can be overridden by explicit ones.
4046 if Nkind
(Literal
) = N_Defining_Character_Literal
then
4048 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
4050 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
4053 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
4054 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
4055 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
4056 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
4057 Set_Alias
(New_Lit
, Literal
);
4058 Set_Is_Known_Valid
(New_Lit
, True);
4060 Append
(New_Lit
, Literals_List
);
4061 Next_Literal
(Literal
);
4065 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4066 New_External_Name
(Chars
(Derived_Type
), 'B'));
4068 -- Indicate the proper nature of the derived type. This must
4069 -- be done before analysis of the literals, to recognize cases
4070 -- when a literal may be hidden by a previous explicit function
4071 -- definition (cf. c83031a).
4073 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
4074 Set_Etype
(Derived_Type
, Implicit_Base
);
4077 Make_Full_Type_Declaration
(Loc
,
4078 Defining_Identifier
=> Implicit_Base
,
4079 Discriminant_Specifications
=> No_List
,
4081 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
4083 Mark_Rewrite_Insertion
(Type_Decl
);
4084 Insert_Before
(N
, Type_Decl
);
4085 Analyze
(Type_Decl
);
4087 -- After the implicit base is analyzed its Etype needs to be changed
4088 -- to reflect the fact that it is derived from the parent type which
4089 -- was ignored during analysis. We also set the size at this point.
4091 Set_Etype
(Implicit_Base
, Parent_Type
);
4093 Set_Size_Info
(Implicit_Base
, Parent_Type
);
4094 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
4095 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
4097 Set_Has_Non_Standard_Rep
4098 (Implicit_Base
, Has_Non_Standard_Rep
4100 Set_Has_Delayed_Freeze
(Implicit_Base
);
4102 -- Process the subtype indication including a validation check
4103 -- on the constraint, if any. If a constraint is given, its bounds
4104 -- must be implicitly converted to the new type.
4106 if Nkind
(Indic
) = N_Subtype_Indication
then
4108 R
: constant Node_Id
:=
4109 Range_Expression
(Constraint
(Indic
));
4112 if Nkind
(R
) = N_Range
then
4113 Hi
:= Build_Scalar_Bound
4114 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
4115 Lo
:= Build_Scalar_Bound
4116 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
4119 -- Constraint is a Range attribute. Replace with the
4120 -- explicit mention of the bounds of the prefix, which must
4123 Analyze
(Prefix
(R
));
4125 Convert_To
(Implicit_Base
,
4126 Make_Attribute_Reference
(Loc
,
4127 Attribute_Name
=> Name_Last
,
4129 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4132 Convert_To
(Implicit_Base
,
4133 Make_Attribute_Reference
(Loc
,
4134 Attribute_Name
=> Name_First
,
4136 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4143 (Type_High_Bound
(Parent_Type
),
4144 Parent_Type
, Implicit_Base
);
4147 (Type_Low_Bound
(Parent_Type
),
4148 Parent_Type
, Implicit_Base
);
4156 -- If we constructed a default range for the case where no range
4157 -- was given, then the expressions in the range must not freeze
4158 -- since they do not correspond to expressions in the source.
4160 if Nkind
(Indic
) /= N_Subtype_Indication
then
4161 Set_Must_Not_Freeze
(Lo
);
4162 Set_Must_Not_Freeze
(Hi
);
4163 Set_Must_Not_Freeze
(Rang_Expr
);
4167 Make_Subtype_Declaration
(Loc
,
4168 Defining_Identifier
=> Derived_Type
,
4169 Subtype_Indication
=>
4170 Make_Subtype_Indication
(Loc
,
4171 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
4173 Make_Range_Constraint
(Loc
,
4174 Range_Expression
=> Rang_Expr
))));
4178 -- If pragma Discard_Names applies on the first subtype of the
4179 -- parent type, then it must be applied on this subtype as well.
4181 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
4182 Set_Discard_Names
(Derived_Type
);
4185 -- Apply a range check. Since this range expression doesn't have an
4186 -- Etype, we have to specifically pass the Source_Typ parameter. Is
4189 if Nkind
(Indic
) = N_Subtype_Indication
then
4190 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
4192 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
4195 end Build_Derived_Enumeration_Type
;
4197 --------------------------------
4198 -- Build_Derived_Numeric_Type --
4199 --------------------------------
4201 procedure Build_Derived_Numeric_Type
4203 Parent_Type
: Entity_Id
;
4204 Derived_Type
: Entity_Id
)
4206 Loc
: constant Source_Ptr
:= Sloc
(N
);
4207 Tdef
: constant Node_Id
:= Type_Definition
(N
);
4208 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
4209 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4210 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
4211 N_Subtype_Indication
;
4212 Implicit_Base
: Entity_Id
;
4218 -- Process the subtype indication including a validation check on
4219 -- the constraint if any.
4221 Discard_Node
(Process_Subtype
(Indic
, N
));
4223 -- Introduce an implicit base type for the derived type even if there
4224 -- is no constraint attached to it, since this seems closer to the Ada
4228 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
4230 Set_Etype
(Implicit_Base
, Parent_Base
);
4231 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
4232 Set_Size_Info
(Implicit_Base
, Parent_Base
);
4233 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4234 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
4235 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
4237 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
4238 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4241 Set_Has_Delayed_Freeze
(Implicit_Base
);
4243 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
4244 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
4246 Set_Scalar_Range
(Implicit_Base
,
4251 if Has_Infinities
(Parent_Base
) then
4252 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
4255 -- The Derived_Type, which is the entity of the declaration, is a
4256 -- subtype of the implicit base. Its Ekind is a subtype, even in the
4257 -- absence of an explicit constraint.
4259 Set_Etype
(Derived_Type
, Implicit_Base
);
4261 -- If we did not have a constraint, then the Ekind is set from the
4262 -- parent type (otherwise Process_Subtype has set the bounds)
4264 if No_Constraint
then
4265 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
4268 -- If we did not have a range constraint, then set the range from the
4269 -- parent type. Otherwise, the call to Process_Subtype has set the
4273 or else not Has_Range_Constraint
(Indic
)
4275 Set_Scalar_Range
(Derived_Type
,
4277 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
4278 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
4279 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4281 if Has_Infinities
(Parent_Type
) then
4282 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
4286 -- Set remaining type-specific fields, depending on numeric type
4288 if Is_Modular_Integer_Type
(Parent_Type
) then
4289 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
4291 Set_Non_Binary_Modulus
4292 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
4294 elsif Is_Floating_Point_Type
(Parent_Type
) then
4296 -- Digits of base type is always copied from the digits value of
4297 -- the parent base type, but the digits of the derived type will
4298 -- already have been set if there was a constraint present.
4300 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4301 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
4303 if No_Constraint
then
4304 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
4307 elsif Is_Fixed_Point_Type
(Parent_Type
) then
4309 -- Small of base type and derived type are always copied from the
4310 -- parent base type, since smalls never change. The delta of the
4311 -- base type is also copied from the parent base type. However the
4312 -- delta of the derived type will have been set already if a
4313 -- constraint was present.
4315 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
4316 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
4317 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
4319 if No_Constraint
then
4320 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
4323 -- The scale and machine radix in the decimal case are always
4324 -- copied from the parent base type.
4326 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
4327 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
4328 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
4330 Set_Machine_Radix_10
4331 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
4332 Set_Machine_Radix_10
4333 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
4335 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4337 if No_Constraint
then
4338 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
4341 -- the analysis of the subtype_indication sets the
4342 -- digits value of the derived type.
4349 -- The type of the bounds is that of the parent type, and they
4350 -- must be converted to the derived type.
4352 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
4354 -- The implicit_base should be frozen when the derived type is frozen,
4355 -- but note that it is used in the conversions of the bounds. For fixed
4356 -- types we delay the determination of the bounds until the proper
4357 -- freezing point. For other numeric types this is rejected by GCC, for
4358 -- reasons that are currently unclear (???), so we choose to freeze the
4359 -- implicit base now. In the case of integers and floating point types
4360 -- this is harmless because subsequent representation clauses cannot
4361 -- affect anything, but it is still baffling that we cannot use the
4362 -- same mechanism for all derived numeric types.
4364 if Is_Fixed_Point_Type
(Parent_Type
) then
4365 Conditional_Delay
(Implicit_Base
, Parent_Type
);
4367 Freeze_Before
(N
, Implicit_Base
);
4369 end Build_Derived_Numeric_Type
;
4371 --------------------------------
4372 -- Build_Derived_Private_Type --
4373 --------------------------------
4375 procedure Build_Derived_Private_Type
4377 Parent_Type
: Entity_Id
;
4378 Derived_Type
: Entity_Id
;
4379 Is_Completion
: Boolean;
4380 Derive_Subps
: Boolean := True)
4382 Der_Base
: Entity_Id
;
4384 Full_Decl
: Node_Id
:= Empty
;
4385 Full_Der
: Entity_Id
;
4387 Last_Discr
: Entity_Id
;
4388 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
4389 Swapped
: Boolean := False;
4391 procedure Copy_And_Build
;
4392 -- Copy derived type declaration, replace parent with its full view,
4393 -- and analyze new declaration.
4395 --------------------
4396 -- Copy_And_Build --
4397 --------------------
4399 procedure Copy_And_Build
is
4403 if Ekind
(Parent_Type
) in Record_Kind
4405 (Ekind
(Parent_Type
) in Enumeration_Kind
4406 and then Root_Type
(Parent_Type
) /= Standard_Character
4407 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
4408 and then Root_Type
(Parent_Type
) /= Standard_Wide_Wide_Character
4409 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
4411 Full_N
:= New_Copy_Tree
(N
);
4412 Insert_After
(N
, Full_N
);
4413 Build_Derived_Type
(
4414 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4417 Build_Derived_Type
(
4418 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4422 -- Start of processing for Build_Derived_Private_Type
4425 if Is_Tagged_Type
(Parent_Type
) then
4426 Build_Derived_Record_Type
4427 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4430 elsif Has_Discriminants
(Parent_Type
) then
4431 if Present
(Full_View
(Parent_Type
)) then
4432 if not Is_Completion
then
4434 -- Copy declaration for subsequent analysis, to provide a
4435 -- completion for what is a private declaration. Indicate that
4436 -- the full type is internally generated.
4438 Full_Decl
:= New_Copy_Tree
(N
);
4439 Full_Der
:= New_Copy
(Derived_Type
);
4440 Set_Comes_From_Source
(Full_Decl
, False);
4442 Insert_After
(N
, Full_Decl
);
4445 -- If this is a completion, the full view being built is
4446 -- itself private. We build a subtype of the parent with
4447 -- the same constraints as this full view, to convey to the
4448 -- back end the constrained components and the size of this
4449 -- subtype. If the parent is constrained, its full view can
4450 -- serve as the underlying full view of the derived type.
4452 if No
(Discriminant_Specifications
(N
)) then
4453 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4454 N_Subtype_Indication
4456 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
4458 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
4459 Set_Underlying_Full_View
(Derived_Type
,
4460 Full_View
(Parent_Type
));
4464 -- If there are new discriminants, the parent subtype is
4465 -- constrained by them, but it is not clear how to build
4466 -- the underlying_full_view in this case ???
4473 -- Build partial view of derived type from partial view of parent
4475 Build_Derived_Record_Type
4476 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4478 if Present
(Full_View
(Parent_Type
))
4479 and then not Is_Completion
4481 if not In_Open_Scopes
(Par_Scope
)
4482 or else not In_Same_Source_Unit
(N
, Parent_Type
)
4484 -- Swap partial and full views temporarily
4486 Install_Private_Declarations
(Par_Scope
);
4487 Install_Visible_Declarations
(Par_Scope
);
4491 -- Build full view of derived type from full view of parent which
4492 -- is now installed. Subprograms have been derived on the partial
4493 -- view, the completion does not derive them anew.
4495 if not Is_Tagged_Type
(Parent_Type
) then
4496 Build_Derived_Record_Type
4497 (Full_Decl
, Parent_Type
, Full_Der
, False);
4500 -- If full view of parent is tagged, the completion
4501 -- inherits the proper primitive operations.
4503 Set_Defining_Identifier
(Full_Decl
, Full_Der
);
4504 Build_Derived_Record_Type
4505 (Full_Decl
, Parent_Type
, Full_Der
, Derive_Subps
);
4506 Set_Analyzed
(Full_Decl
);
4510 Uninstall_Declarations
(Par_Scope
);
4512 if In_Open_Scopes
(Par_Scope
) then
4513 Install_Visible_Declarations
(Par_Scope
);
4517 Der_Base
:= Base_Type
(Derived_Type
);
4518 Set_Full_View
(Derived_Type
, Full_Der
);
4519 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
4521 -- Copy the discriminant list from full view to the partial views
4522 -- (base type and its subtype). Gigi requires that the partial
4523 -- and full views have the same discriminants.
4525 -- Note that since the partial view is pointing to discriminants
4526 -- in the full view, their scope will be that of the full view.
4527 -- This might cause some front end problems and need
4530 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
4531 Set_First_Entity
(Der_Base
, Discr
);
4534 Last_Discr
:= Discr
;
4535 Next_Discriminant
(Discr
);
4536 exit when No
(Discr
);
4539 Set_Last_Entity
(Der_Base
, Last_Discr
);
4541 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
4542 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
4543 Set_Stored_Constraint
(Full_Der
, Stored_Constraint
(Derived_Type
));
4546 -- If this is a completion, the derived type stays private
4547 -- and there is no need to create a further full view, except
4548 -- in the unusual case when the derivation is nested within a
4549 -- child unit, see below.
4554 elsif Present
(Full_View
(Parent_Type
))
4555 and then Has_Discriminants
(Full_View
(Parent_Type
))
4557 if Has_Unknown_Discriminants
(Parent_Type
)
4558 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4559 = N_Subtype_Indication
4562 ("cannot constrain type with unknown discriminants",
4563 Subtype_Indication
(Type_Definition
(N
)));
4567 -- If full view of parent is a record type, Build full view as
4568 -- a derivation from the parent's full view. Partial view remains
4569 -- private. For code generation and linking, the full view must
4570 -- have the same public status as the partial one. This full view
4571 -- is only needed if the parent type is in an enclosing scope, so
4572 -- that the full view may actually become visible, e.g. in a child
4573 -- unit. This is both more efficient, and avoids order of freezing
4574 -- problems with the added entities.
4576 if not Is_Private_Type
(Full_View
(Parent_Type
))
4577 and then (In_Open_Scopes
(Scope
(Parent_Type
)))
4579 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
4580 Chars
(Derived_Type
));
4581 Set_Is_Itype
(Full_Der
);
4582 Set_Has_Private_Declaration
(Full_Der
);
4583 Set_Has_Private_Declaration
(Derived_Type
);
4584 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4585 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4586 Set_Full_View
(Derived_Type
, Full_Der
);
4587 Set_Is_Public
(Full_Der
, Is_Public
(Derived_Type
));
4588 Full_P
:= Full_View
(Parent_Type
);
4589 Exchange_Declarations
(Parent_Type
);
4591 Exchange_Declarations
(Full_P
);
4594 Build_Derived_Record_Type
4595 (N
, Full_View
(Parent_Type
), Derived_Type
,
4596 Derive_Subps
=> False);
4599 -- In any case, the primitive operations are inherited from
4600 -- the parent type, not from the internal full view.
4602 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
4604 if Derive_Subps
then
4605 Derive_Subprograms
(Parent_Type
, Derived_Type
);
4609 -- Untagged type, No discriminants on either view
4611 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4612 N_Subtype_Indication
4615 ("illegal constraint on type without discriminants", N
);
4618 if Present
(Discriminant_Specifications
(N
))
4619 and then Present
(Full_View
(Parent_Type
))
4620 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4623 ("cannot add discriminants to untagged type", N
);
4626 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
4627 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4628 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
4629 Set_Has_Controlled_Component
4630 (Derived_Type
, Has_Controlled_Component
4633 -- Direct controlled types do not inherit Finalize_Storage_Only flag
4635 if not Is_Controlled
(Parent_Type
) then
4636 Set_Finalize_Storage_Only
4637 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
4640 -- Construct the implicit full view by deriving from full view of
4641 -- the parent type. In order to get proper visibility, we install
4642 -- the parent scope and its declarations.
4644 -- ??? if the parent is untagged private and its completion is
4645 -- tagged, this mechanism will not work because we cannot derive
4646 -- from the tagged full view unless we have an extension
4648 if Present
(Full_View
(Parent_Type
))
4649 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
4650 and then not Is_Completion
4653 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4654 Chars
=> Chars
(Derived_Type
));
4655 Set_Is_Itype
(Full_Der
);
4656 Set_Has_Private_Declaration
(Full_Der
);
4657 Set_Has_Private_Declaration
(Derived_Type
);
4658 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4659 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4660 Set_Full_View
(Derived_Type
, Full_Der
);
4662 if not In_Open_Scopes
(Par_Scope
) then
4663 Install_Private_Declarations
(Par_Scope
);
4664 Install_Visible_Declarations
(Par_Scope
);
4666 Uninstall_Declarations
(Par_Scope
);
4668 -- If parent scope is open and in another unit, and parent has a
4669 -- completion, then the derivation is taking place in the visible
4670 -- part of a child unit. In that case retrieve the full view of
4671 -- the parent momentarily.
4673 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
4674 Full_P
:= Full_View
(Parent_Type
);
4675 Exchange_Declarations
(Parent_Type
);
4677 Exchange_Declarations
(Full_P
);
4679 -- Otherwise it is a local derivation
4685 Set_Scope
(Full_Der
, Current_Scope
);
4686 Set_Is_First_Subtype
(Full_Der
,
4687 Is_First_Subtype
(Derived_Type
));
4688 Set_Has_Size_Clause
(Full_Der
, False);
4689 Set_Has_Alignment_Clause
(Full_Der
, False);
4690 Set_Next_Entity
(Full_Der
, Empty
);
4691 Set_Has_Delayed_Freeze
(Full_Der
);
4692 Set_Is_Frozen
(Full_Der
, False);
4693 Set_Freeze_Node
(Full_Der
, Empty
);
4694 Set_Depends_On_Private
(Full_Der
,
4695 Has_Private_Component
(Full_Der
));
4696 Set_Public_Status
(Full_Der
);
4700 Set_Has_Unknown_Discriminants
(Derived_Type
,
4701 Has_Unknown_Discriminants
(Parent_Type
));
4703 if Is_Private_Type
(Derived_Type
) then
4704 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
4707 if Is_Private_Type
(Parent_Type
)
4708 and then Base_Type
(Parent_Type
) = Parent_Type
4709 and then In_Open_Scopes
(Scope
(Parent_Type
))
4711 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
4713 if Is_Child_Unit
(Scope
(Current_Scope
))
4714 and then Is_Completion
4715 and then In_Private_Part
(Current_Scope
)
4716 and then Scope
(Parent_Type
) /= Current_Scope
4718 -- This is the unusual case where a type completed by a private
4719 -- derivation occurs within a package nested in a child unit,
4720 -- and the parent is declared in an ancestor. In this case, the
4721 -- full view of the parent type will become visible in the body
4722 -- of the enclosing child, and only then will the current type
4723 -- be possibly non-private. We build a underlying full view that
4724 -- will be installed when the enclosing child body is compiled.
4727 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
4731 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4732 Chars
(Derived_Type
));
4733 Set_Is_Itype
(Full_Der
);
4734 Set_Itype
(IR
, Full_Der
);
4735 Insert_After
(N
, IR
);
4737 -- The full view will be used to swap entities on entry/exit
4738 -- to the body, and must appear in the entity list for the
4741 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
4742 Set_Has_Private_Declaration
(Full_Der
);
4743 Set_Has_Private_Declaration
(Derived_Type
);
4744 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4745 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4746 Full_P
:= Full_View
(Parent_Type
);
4747 Exchange_Declarations
(Parent_Type
);
4749 Exchange_Declarations
(Full_P
);
4750 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
4754 end Build_Derived_Private_Type
;
4756 -------------------------------
4757 -- Build_Derived_Record_Type --
4758 -------------------------------
4762 -- Ideally we would like to use the same model of type derivation for
4763 -- tagged and untagged record types. Unfortunately this is not quite
4764 -- possible because the semantics of representation clauses is different
4765 -- for tagged and untagged records under inheritance. Consider the
4768 -- type R (...) is [tagged] record ... end record;
4769 -- type T (...) is new R (...) [with ...];
4771 -- The representation clauses of T can specify a completely different
4772 -- record layout from R's. Hence the same component can be placed in
4773 -- two very different positions in objects of type T and R. If R and T
4774 -- are tagged types, representation clauses for T can only specify the
4775 -- layout of non inherited components, thus components that are common
4776 -- in R and T have the same position in objects of type R and T.
4778 -- This has two implications. The first is that the entire tree for R's
4779 -- declaration needs to be copied for T in the untagged case, so that T
4780 -- can be viewed as a record type of its own with its own representation
4781 -- clauses. The second implication is the way we handle discriminants.
4782 -- Specifically, in the untagged case we need a way to communicate to Gigi
4783 -- what are the real discriminants in the record, while for the semantics
4784 -- we need to consider those introduced by the user to rename the
4785 -- discriminants in the parent type. This is handled by introducing the
4786 -- notion of stored discriminants. See below for more.
4788 -- Fortunately the way regular components are inherited can be handled in
4789 -- the same way in tagged and untagged types.
4791 -- To complicate things a bit more the private view of a private extension
4792 -- cannot be handled in the same way as the full view (for one thing the
4793 -- semantic rules are somewhat different). We will explain what differs
4796 -- 2. DISCRIMINANTS UNDER INHERITANCE
4798 -- The semantic rules governing the discriminants of derived types are
4801 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
4802 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
4804 -- If parent type has discriminants, then the discriminants that are
4805 -- declared in the derived type are [3.4 (11)]:
4807 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
4810 -- o Otherwise, each discriminant of the parent type (implicitly declared
4811 -- in the same order with the same specifications). In this case, the
4812 -- discriminants are said to be "inherited", or if unknown in the parent
4813 -- are also unknown in the derived type.
4815 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
4817 -- o The parent subtype shall be constrained;
4819 -- o If the parent type is not a tagged type, then each discriminant of
4820 -- the derived type shall be used in the constraint defining a parent
4821 -- subtype [Implementation note: this ensures that the new discriminant
4822 -- can share storage with an existing discriminant.].
4824 -- For the derived type each discriminant of the parent type is either
4825 -- inherited, constrained to equal some new discriminant of the derived
4826 -- type, or constrained to the value of an expression.
4828 -- When inherited or constrained to equal some new discriminant, the
4829 -- parent discriminant and the discriminant of the derived type are said
4832 -- If a discriminant of the parent type is constrained to a specific value
4833 -- in the derived type definition, then the discriminant is said to be
4834 -- "specified" by that derived type definition.
4836 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
4838 -- We have spoken about stored discriminants in point 1 (introduction)
4839 -- above. There are two sort of stored discriminants: implicit and
4840 -- explicit. As long as the derived type inherits the same discriminants as
4841 -- the root record type, stored discriminants are the same as regular
4842 -- discriminants, and are said to be implicit. However, if any discriminant
4843 -- in the root type was renamed in the derived type, then the derived
4844 -- type will contain explicit stored discriminants. Explicit stored
4845 -- discriminants are discriminants in addition to the semantically visible
4846 -- discriminants defined for the derived type. Stored discriminants are
4847 -- used by Gigi to figure out what are the physical discriminants in
4848 -- objects of the derived type (see precise definition in einfo.ads).
4849 -- As an example, consider the following:
4851 -- type R (D1, D2, D3 : Int) is record ... end record;
4852 -- type T1 is new R;
4853 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
4854 -- type T3 is new T2;
4855 -- type T4 (Y : Int) is new T3 (Y, 99);
4857 -- The following table summarizes the discriminants and stored
4858 -- discriminants in R and T1 through T4.
4860 -- Type Discrim Stored Discrim Comment
4861 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
4862 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
4863 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
4864 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
4865 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
4867 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
4868 -- find the corresponding discriminant in the parent type, while
4869 -- Original_Record_Component (abbreviated ORC below), the actual physical
4870 -- component that is renamed. Finally the field Is_Completely_Hidden
4871 -- (abbreviated ICH below) is set for all explicit stored discriminants
4872 -- (see einfo.ads for more info). For the above example this gives:
4874 -- Discrim CD ORC ICH
4875 -- ^^^^^^^ ^^ ^^^ ^^^
4876 -- D1 in R empty itself no
4877 -- D2 in R empty itself no
4878 -- D3 in R empty itself no
4880 -- D1 in T1 D1 in R itself no
4881 -- D2 in T1 D2 in R itself no
4882 -- D3 in T1 D3 in R itself no
4884 -- X1 in T2 D3 in T1 D3 in T2 no
4885 -- X2 in T2 D1 in T1 D1 in T2 no
4886 -- D1 in T2 empty itself yes
4887 -- D2 in T2 empty itself yes
4888 -- D3 in T2 empty itself yes
4890 -- X1 in T3 X1 in T2 D3 in T3 no
4891 -- X2 in T3 X2 in T2 D1 in T3 no
4892 -- D1 in T3 empty itself yes
4893 -- D2 in T3 empty itself yes
4894 -- D3 in T3 empty itself yes
4896 -- Y in T4 X1 in T3 D3 in T3 no
4897 -- D1 in T3 empty itself yes
4898 -- D2 in T3 empty itself yes
4899 -- D3 in T3 empty itself yes
4901 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
4903 -- Type derivation for tagged types is fairly straightforward. if no
4904 -- discriminants are specified by the derived type, these are inherited
4905 -- from the parent. No explicit stored discriminants are ever necessary.
4906 -- The only manipulation that is done to the tree is that of adding a
4907 -- _parent field with parent type and constrained to the same constraint
4908 -- specified for the parent in the derived type definition. For instance:
4910 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
4911 -- type T1 is new R with null record;
4912 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
4914 -- are changed into:
4916 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
4917 -- _parent : R (D1, D2, D3);
4920 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
4921 -- _parent : T1 (X2, 88, X1);
4924 -- The discriminants actually present in R, T1 and T2 as well as their CD,
4925 -- ORC and ICH fields are:
4927 -- Discrim CD ORC ICH
4928 -- ^^^^^^^ ^^ ^^^ ^^^
4929 -- D1 in R empty itself no
4930 -- D2 in R empty itself no
4931 -- D3 in R empty itself no
4933 -- D1 in T1 D1 in R D1 in R no
4934 -- D2 in T1 D2 in R D2 in R no
4935 -- D3 in T1 D3 in R D3 in R no
4937 -- X1 in T2 D3 in T1 D3 in R no
4938 -- X2 in T2 D1 in T1 D1 in R no
4940 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
4942 -- Regardless of whether we dealing with a tagged or untagged type
4943 -- we will transform all derived type declarations of the form
4945 -- type T is new R (...) [with ...];
4947 -- subtype S is R (...);
4948 -- type T is new S [with ...];
4950 -- type BT is new R [with ...];
4951 -- subtype T is BT (...);
4953 -- That is, the base derived type is constrained only if it has no
4954 -- discriminants. The reason for doing this is that GNAT's semantic model
4955 -- assumes that a base type with discriminants is unconstrained.
4957 -- Note that, strictly speaking, the above transformation is not always
4958 -- correct. Consider for instance the following excerpt from ACVC b34011a:
4960 -- procedure B34011A is
4961 -- type REC (D : integer := 0) is record
4966 -- type T6 is new Rec;
4967 -- function F return T6;
4972 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
4975 -- The definition of Q6.U is illegal. However transforming Q6.U into
4977 -- type BaseU is new T6;
4978 -- subtype U is BaseU (Q6.F.I)
4980 -- turns U into a legal subtype, which is incorrect. To avoid this problem
4981 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
4982 -- the transformation described above.
4984 -- There is another instance where the above transformation is incorrect.
4988 -- type Base (D : Integer) is tagged null record;
4989 -- procedure P (X : Base);
4991 -- type Der is new Base (2) with null record;
4992 -- procedure P (X : Der);
4995 -- Then the above transformation turns this into
4997 -- type Der_Base is new Base with null record;
4998 -- -- procedure P (X : Base) is implicitly inherited here
4999 -- -- as procedure P (X : Der_Base).
5001 -- subtype Der is Der_Base (2);
5002 -- procedure P (X : Der);
5003 -- -- The overriding of P (X : Der_Base) is illegal since we
5004 -- -- have a parameter conformance problem.
5006 -- To get around this problem, after having semantically processed Der_Base
5007 -- and the rewritten subtype declaration for Der, we copy Der_Base field
5008 -- Discriminant_Constraint from Der so that when parameter conformance is
5009 -- checked when P is overridden, no semantic errors are flagged.
5011 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
5013 -- Regardless of whether we are dealing with a tagged or untagged type
5014 -- we will transform all derived type declarations of the form
5016 -- type R (D1, .., Dn : ...) is [tagged] record ...;
5017 -- type T is new R [with ...];
5019 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
5021 -- The reason for such transformation is that it allows us to implement a
5022 -- very clean form of component inheritance as explained below.
5024 -- Note that this transformation is not achieved by direct tree rewriting
5025 -- and manipulation, but rather by redoing the semantic actions that the
5026 -- above transformation will entail. This is done directly in routine
5027 -- Inherit_Components.
5029 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
5031 -- In both tagged and untagged derived types, regular non discriminant
5032 -- components are inherited in the derived type from the parent type. In
5033 -- the absence of discriminants component, inheritance is straightforward
5034 -- as components can simply be copied from the parent.
5036 -- If the parent has discriminants, inheriting components constrained with
5037 -- these discriminants requires caution. Consider the following example:
5039 -- type R (D1, D2 : Positive) is [tagged] record
5040 -- S : String (D1 .. D2);
5043 -- type T1 is new R [with null record];
5044 -- type T2 (X : positive) is new R (1, X) [with null record];
5046 -- As explained in 6. above, T1 is rewritten as
5047 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
5048 -- which makes the treatment for T1 and T2 identical.
5050 -- What we want when inheriting S, is that references to D1 and D2 in R are
5051 -- replaced with references to their correct constraints, ie D1 and D2 in
5052 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
5053 -- with either discriminant references in the derived type or expressions.
5054 -- This replacement is achieved as follows: before inheriting R's
5055 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
5056 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
5057 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
5058 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
5059 -- by String (1 .. X).
5061 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
5063 -- We explain here the rules governing private type extensions relevant to
5064 -- type derivation. These rules are explained on the following example:
5066 -- type D [(...)] is new A [(...)] with private; <-- partial view
5067 -- type D [(...)] is new P [(...)] with null record; <-- full view
5069 -- Type A is called the ancestor subtype of the private extension.
5070 -- Type P is the parent type of the full view of the private extension. It
5071 -- must be A or a type derived from A.
5073 -- The rules concerning the discriminants of private type extensions are
5076 -- o If a private extension inherits known discriminants from the ancestor
5077 -- subtype, then the full view shall also inherit its discriminants from
5078 -- the ancestor subtype and the parent subtype of the full view shall be
5079 -- constrained if and only if the ancestor subtype is constrained.
5081 -- o If a partial view has unknown discriminants, then the full view may
5082 -- define a definite or an indefinite subtype, with or without
5085 -- o If a partial view has neither known nor unknown discriminants, then
5086 -- the full view shall define a definite subtype.
5088 -- o If the ancestor subtype of a private extension has constrained
5089 -- discriminants, then the parent subtype of the full view shall impose a
5090 -- statically matching constraint on those discriminants.
5092 -- This means that only the following forms of private extensions are
5095 -- type D is new A with private; <-- partial view
5096 -- type D is new P with null record; <-- full view
5098 -- If A has no discriminants than P has no discriminants, otherwise P must
5099 -- inherit A's discriminants.
5101 -- type D is new A (...) with private; <-- partial view
5102 -- type D is new P (:::) with null record; <-- full view
5104 -- P must inherit A's discriminants and (...) and (:::) must statically
5107 -- subtype A is R (...);
5108 -- type D is new A with private; <-- partial view
5109 -- type D is new P with null record; <-- full view
5111 -- P must have inherited R's discriminants and must be derived from A or
5112 -- any of its subtypes.
5114 -- type D (..) is new A with private; <-- partial view
5115 -- type D (..) is new P [(:::)] with null record; <-- full view
5117 -- No specific constraints on P's discriminants or constraint (:::).
5118 -- Note that A can be unconstrained, but the parent subtype P must either
5119 -- be constrained or (:::) must be present.
5121 -- type D (..) is new A [(...)] with private; <-- partial view
5122 -- type D (..) is new P [(:::)] with null record; <-- full view
5124 -- P's constraints on A's discriminants must statically match those
5125 -- imposed by (...).
5127 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
5129 -- The full view of a private extension is handled exactly as described
5130 -- above. The model chose for the private view of a private extension is
5131 -- the same for what concerns discriminants (ie they receive the same
5132 -- treatment as in the tagged case). However, the private view of the
5133 -- private extension always inherits the components of the parent base,
5134 -- without replacing any discriminant reference. Strictly speaking this is
5135 -- incorrect. However, Gigi never uses this view to generate code so this
5136 -- is a purely semantic issue. In theory, a set of transformations similar
5137 -- to those given in 5. and 6. above could be applied to private views of
5138 -- private extensions to have the same model of component inheritance as
5139 -- for non private extensions. However, this is not done because it would
5140 -- further complicate private type processing. Semantically speaking, this
5141 -- leaves us in an uncomfortable situation. As an example consider:
5144 -- type R (D : integer) is tagged record
5145 -- S : String (1 .. D);
5147 -- procedure P (X : R);
5148 -- type T is new R (1) with private;
5150 -- type T is new R (1) with null record;
5153 -- This is transformed into:
5156 -- type R (D : integer) is tagged record
5157 -- S : String (1 .. D);
5159 -- procedure P (X : R);
5160 -- type T is new R (1) with private;
5162 -- type BaseT is new R with null record;
5163 -- subtype T is BaseT (1);
5166 -- (strictly speaking the above is incorrect Ada)
5168 -- From the semantic standpoint the private view of private extension T
5169 -- should be flagged as constrained since one can clearly have
5173 -- in a unit withing Pack. However, when deriving subprograms for the
5174 -- private view of private extension T, T must be seen as unconstrained
5175 -- since T has discriminants (this is a constraint of the current
5176 -- subprogram derivation model). Thus, when processing the private view of
5177 -- a private extension such as T, we first mark T as unconstrained, we
5178 -- process it, we perform program derivation and just before returning from
5179 -- Build_Derived_Record_Type we mark T as constrained.
5181 -- ??? Are there are other uncomfortable cases that we will have to
5184 -- 10. RECORD_TYPE_WITH_PRIVATE complications
5186 -- Types that are derived from a visible record type and have a private
5187 -- extension present other peculiarities. They behave mostly like private
5188 -- types, but if they have primitive operations defined, these will not
5189 -- have the proper signatures for further inheritance, because other
5190 -- primitive operations will use the implicit base that we define for
5191 -- private derivations below. This affect subprogram inheritance (see
5192 -- Derive_Subprograms for details). We also derive the implicit base from
5193 -- the base type of the full view, so that the implicit base is a record
5194 -- type and not another private type, This avoids infinite loops.
5196 procedure Build_Derived_Record_Type
5198 Parent_Type
: Entity_Id
;
5199 Derived_Type
: Entity_Id
;
5200 Derive_Subps
: Boolean := True)
5202 Loc
: constant Source_Ptr
:= Sloc
(N
);
5203 Parent_Base
: Entity_Id
;
5206 Discrim
: Entity_Id
;
5207 Last_Discrim
: Entity_Id
;
5210 Discs
: Elist_Id
:= New_Elmt_List
;
5211 -- An empty Discs list means that there were no constraints in the
5212 -- subtype indication or that there was an error processing it.
5214 Assoc_List
: Elist_Id
;
5215 New_Discrs
: Elist_Id
;
5216 New_Base
: Entity_Id
;
5218 New_Indic
: Node_Id
;
5220 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
5221 Discriminant_Specs
: constant Boolean :=
5222 Present
(Discriminant_Specifications
(N
));
5223 Private_Extension
: constant Boolean :=
5224 (Nkind
(N
) = N_Private_Extension_Declaration
);
5226 Constraint_Present
: Boolean;
5227 Has_Interfaces
: Boolean := False;
5228 Inherit_Discrims
: Boolean := False;
5229 Last_Inherited_Prim_Op
: Elmt_Id
;
5230 Tagged_Partial_View
: Entity_Id
;
5231 Save_Etype
: Entity_Id
;
5232 Save_Discr_Constr
: Elist_Id
;
5233 Save_Next_Entity
: Entity_Id
;
5236 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
5237 and then Present
(Full_View
(Parent_Type
))
5238 and then Has_Discriminants
(Parent_Type
)
5240 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
5242 Parent_Base
:= Base_Type
(Parent_Type
);
5245 -- Before we start the previously documented transformations, here is
5246 -- a little fix for size and alignment of tagged types. Normally when
5247 -- we derive type D from type P, we copy the size and alignment of P
5248 -- as the default for D, and in the absence of explicit representation
5249 -- clauses for D, the size and alignment are indeed the same as the
5252 -- But this is wrong for tagged types, since fields may be added,
5253 -- and the default size may need to be larger, and the default
5254 -- alignment may need to be larger.
5256 -- We therefore reset the size and alignment fields in the tagged
5257 -- case. Note that the size and alignment will in any case be at
5258 -- least as large as the parent type (since the derived type has
5259 -- a copy of the parent type in the _parent field)
5262 Init_Size_Align
(Derived_Type
);
5265 -- STEP 0a: figure out what kind of derived type declaration we have
5267 if Private_Extension
then
5269 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
5272 Type_Def
:= Type_Definition
(N
);
5274 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
5275 -- Parent_Base can be a private type or private extension. However,
5276 -- for tagged types with an extension the newly added fields are
5277 -- visible and hence the Derived_Type is always an E_Record_Type.
5278 -- (except that the parent may have its own private fields).
5279 -- For untagged types we preserve the Ekind of the Parent_Base.
5281 if Present
(Record_Extension_Part
(Type_Def
)) then
5282 Set_Ekind
(Derived_Type
, E_Record_Type
);
5284 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5288 -- Indic can either be an N_Identifier if the subtype indication
5289 -- contains no constraint or an N_Subtype_Indication if the subtype
5290 -- indication has a constraint.
5292 Indic
:= Subtype_Indication
(Type_Def
);
5293 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
5295 -- Check that the type has visible discriminants. The type may be
5296 -- a private type with unknown discriminants whose full view has
5297 -- discriminants which are invisible.
5299 if Constraint_Present
then
5300 if not Has_Discriminants
(Parent_Base
)
5302 (Has_Unknown_Discriminants
(Parent_Base
)
5303 and then Is_Private_Type
(Parent_Base
))
5306 ("invalid constraint: type has no discriminant",
5307 Constraint
(Indic
));
5309 Constraint_Present
:= False;
5310 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5312 elsif Is_Constrained
(Parent_Type
) then
5314 ("invalid constraint: parent type is already constrained",
5315 Constraint
(Indic
));
5317 Constraint_Present
:= False;
5318 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5322 -- STEP 0b: If needed, apply transformation given in point 5. above
5324 if not Private_Extension
5325 and then Has_Discriminants
(Parent_Type
)
5326 and then not Discriminant_Specs
5327 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
5329 -- First, we must analyze the constraint (see comment in point 5.)
5331 if Constraint_Present
then
5332 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5334 if Has_Discriminants
(Derived_Type
)
5335 and then Has_Private_Declaration
(Derived_Type
)
5336 and then Present
(Discriminant_Constraint
(Derived_Type
))
5338 -- Verify that constraints of the full view conform to those
5339 -- given in partial view.
5345 C1
:= First_Elmt
(New_Discrs
);
5346 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
5347 while Present
(C1
) and then Present
(C2
) loop
5349 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5352 "constraint not conformant to previous declaration",
5363 -- Insert and analyze the declaration for the unconstrained base type
5365 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
5368 Make_Full_Type_Declaration
(Loc
,
5369 Defining_Identifier
=> New_Base
,
5371 Make_Derived_Type_Definition
(Loc
,
5372 Abstract_Present
=> Abstract_Present
(Type_Def
),
5373 Subtype_Indication
=>
5374 New_Occurrence_Of
(Parent_Base
, Loc
),
5375 Record_Extension_Part
=>
5376 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
5378 Set_Parent
(New_Decl
, Parent
(N
));
5379 Mark_Rewrite_Insertion
(New_Decl
);
5380 Insert_Before
(N
, New_Decl
);
5382 -- Note that this call passes False for the Derive_Subps parameter
5383 -- because subprogram derivation is deferred until after creating
5384 -- the subtype (see below).
5387 (New_Decl
, Parent_Base
, New_Base
,
5388 Is_Completion
=> True, Derive_Subps
=> False);
5390 -- ??? This needs re-examination to determine whether the
5391 -- above call can simply be replaced by a call to Analyze.
5393 Set_Analyzed
(New_Decl
);
5395 -- Insert and analyze the declaration for the constrained subtype
5397 if Constraint_Present
then
5399 Make_Subtype_Indication
(Loc
,
5400 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5401 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
5405 Constr_List
: constant List_Id
:= New_List
;
5410 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
5411 while Present
(C
) loop
5414 -- It is safe here to call New_Copy_Tree since
5415 -- Force_Evaluation was called on each constraint in
5416 -- Build_Discriminant_Constraints.
5418 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
5424 Make_Subtype_Indication
(Loc
,
5425 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5427 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
5432 Make_Subtype_Declaration
(Loc
,
5433 Defining_Identifier
=> Derived_Type
,
5434 Subtype_Indication
=> New_Indic
));
5438 -- Derivation of subprograms must be delayed until the full subtype
5439 -- has been established to ensure proper overriding of subprograms
5440 -- inherited by full types. If the derivations occurred as part of
5441 -- the call to Build_Derived_Type above, then the check for type
5442 -- conformance would fail because earlier primitive subprograms
5443 -- could still refer to the full type prior the change to the new
5444 -- subtype and hence would not match the new base type created here.
5446 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5448 -- For tagged types the Discriminant_Constraint of the new base itype
5449 -- is inherited from the first subtype so that no subtype conformance
5450 -- problem arise when the first subtype overrides primitive
5451 -- operations inherited by the implicit base type.
5454 Set_Discriminant_Constraint
5455 (New_Base
, Discriminant_Constraint
(Derived_Type
));
5461 -- If we get here Derived_Type will have no discriminants or it will be
5462 -- a discriminated unconstrained base type.
5464 -- STEP 1a: perform preliminary actions/checks for derived tagged types
5468 -- The parent type is frozen for non-private extensions (RM 13.14(7))
5470 if not Private_Extension
then
5471 Freeze_Before
(N
, Parent_Type
);
5474 -- In Ada 2005 (AI-344), the restriction that a derived tagged type
5475 -- cannot be declared at a deeper level than its parent type is
5476 -- removed. The check on derivation within a generic body is also
5477 -- relaxed, but there's a restriction that a derived tagged type
5478 -- cannot be declared in a generic body if it's derived directly
5479 -- or indirectly from a formal type of that generic.
5481 if Ada_Version
>= Ada_05
then
5482 if Present
(Enclosing_Generic_Body
(Derived_Type
)) then
5484 Ancestor_Type
: Entity_Id
;
5487 -- Check to see if any ancestor of the derived type is a
5490 Ancestor_Type
:= Parent_Type
;
5491 while not Is_Generic_Type
(Ancestor_Type
)
5492 and then Etype
(Ancestor_Type
) /= Ancestor_Type
5494 Ancestor_Type
:= Etype
(Ancestor_Type
);
5497 -- If the derived type does have a formal type as an
5498 -- ancestor, then it's an error if the derived type is
5499 -- declared within the body of the generic unit that
5500 -- declares the formal type in its generic formal part. It's
5501 -- sufficient to check whether the ancestor type is declared
5502 -- inside the same generic body as the derived type (such as
5503 -- within a nested generic spec), in which case the
5504 -- derivation is legal. If the formal type is declared
5505 -- outside of that generic body, then it's guaranteed that
5506 -- the derived type is declared within the generic body of
5507 -- the generic unit declaring the formal type.
5509 if Is_Generic_Type
(Ancestor_Type
)
5510 and then Enclosing_Generic_Body
(Ancestor_Type
) /=
5511 Enclosing_Generic_Body
(Derived_Type
)
5514 ("parent type of& must not be descendant of formal type"
5515 & " of an enclosing generic body",
5516 Indic
, Derived_Type
);
5521 elsif Type_Access_Level
(Derived_Type
) /=
5522 Type_Access_Level
(Parent_Type
)
5523 and then not Is_Generic_Type
(Derived_Type
)
5525 if Is_Controlled
(Parent_Type
) then
5527 ("controlled type must be declared at the library level",
5531 ("type extension at deeper accessibility level than parent",
5537 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
5541 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
5544 ("parent type of& must not be outside generic body"
5545 & " ('R'M 3.9.1(4))",
5546 Indic
, Derived_Type
);
5552 -- Ada 2005 (AI-251)
5554 if Ada_Version
= Ada_05
5558 -- "The declaration of a specific descendant of an interface type
5559 -- freezes the interface type" (RM 13.14).
5564 if Is_Non_Empty_List
(Interface_List
(Type_Def
)) then
5565 Iface
:= First
(Interface_List
(Type_Def
));
5566 while Present
(Iface
) loop
5567 Freeze_Before
(N
, Etype
(Iface
));
5574 -- STEP 1b : preliminary cleanup of the full view of private types
5576 -- If the type is already marked as having discriminants, then it's the
5577 -- completion of a private type or private extension and we need to
5578 -- retain the discriminants from the partial view if the current
5579 -- declaration has Discriminant_Specifications so that we can verify
5580 -- conformance. However, we must remove any existing components that
5581 -- were inherited from the parent (and attached in Copy_And_Swap)
5582 -- because the full type inherits all appropriate components anyway, and
5583 -- we do not want the partial view's components interfering.
5585 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
5586 Discrim
:= First_Discriminant
(Derived_Type
);
5588 Last_Discrim
:= Discrim
;
5589 Next_Discriminant
(Discrim
);
5590 exit when No
(Discrim
);
5593 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
5595 -- In all other cases wipe out the list of inherited components (even
5596 -- inherited discriminants), it will be properly rebuilt here.
5599 Set_First_Entity
(Derived_Type
, Empty
);
5600 Set_Last_Entity
(Derived_Type
, Empty
);
5603 -- STEP 1c: Initialize some flags for the Derived_Type
5605 -- The following flags must be initialized here so that
5606 -- Process_Discriminants can check that discriminants of tagged types
5607 -- do not have a default initial value and that access discriminants
5608 -- are only specified for limited records. For completeness, these
5609 -- flags are also initialized along with all the other flags below.
5611 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
5612 Set_Is_Limited_Record
(Derived_Type
, Is_Limited_Record
(Parent_Type
));
5614 -- STEP 2a: process discriminants of derived type if any
5616 New_Scope
(Derived_Type
);
5618 if Discriminant_Specs
then
5619 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
5621 -- The following call initializes fields Has_Discriminants and
5622 -- Discriminant_Constraint, unless we are processing the completion
5623 -- of a private type declaration.
5625 Check_Or_Process_Discriminants
(N
, Derived_Type
);
5627 -- For non-tagged types the constraint on the Parent_Type must be
5628 -- present and is used to rename the discriminants.
5630 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
5631 Error_Msg_N
("untagged parent must have discriminants", Indic
);
5633 elsif not Is_Tagged
and then not Constraint_Present
then
5635 ("discriminant constraint needed for derived untagged records",
5638 -- Otherwise the parent subtype must be constrained unless we have a
5639 -- private extension.
5641 elsif not Constraint_Present
5642 and then not Private_Extension
5643 and then not Is_Constrained
(Parent_Type
)
5646 ("unconstrained type not allowed in this context", Indic
);
5648 elsif Constraint_Present
then
5649 -- The following call sets the field Corresponding_Discriminant
5650 -- for the discriminants in the Derived_Type.
5652 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
5654 -- For untagged types all new discriminants must rename
5655 -- discriminants in the parent. For private extensions new
5656 -- discriminants cannot rename old ones (implied by [7.3(13)]).
5658 Discrim
:= First_Discriminant
(Derived_Type
);
5659 while Present
(Discrim
) loop
5661 and then not Present
(Corresponding_Discriminant
(Discrim
))
5664 ("new discriminants must constrain old ones", Discrim
);
5666 elsif Private_Extension
5667 and then Present
(Corresponding_Discriminant
(Discrim
))
5670 ("only static constraints allowed for parent"
5671 & " discriminants in the partial view", Indic
);
5675 -- If a new discriminant is used in the constraint, then its
5676 -- subtype must be statically compatible with the parent
5677 -- discriminant's subtype (3.7(15)).
5679 if Present
(Corresponding_Discriminant
(Discrim
))
5681 not Subtypes_Statically_Compatible
5683 Etype
(Corresponding_Discriminant
(Discrim
)))
5686 ("subtype must be compatible with parent discriminant",
5690 Next_Discriminant
(Discrim
);
5693 -- Check whether the constraints of the full view statically
5694 -- match those imposed by the parent subtype [7.3(13)].
5696 if Present
(Stored_Constraint
(Derived_Type
)) then
5701 C1
:= First_Elmt
(Discs
);
5702 C2
:= First_Elmt
(Stored_Constraint
(Derived_Type
));
5703 while Present
(C1
) and then Present
(C2
) loop
5705 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5708 "not conformant with previous declaration",
5719 -- STEP 2b: No new discriminants, inherit discriminants if any
5722 if Private_Extension
then
5723 Set_Has_Unknown_Discriminants
5725 Has_Unknown_Discriminants
(Parent_Type
)
5726 or else Unknown_Discriminants_Present
(N
));
5728 -- The partial view of the parent may have unknown discriminants,
5729 -- but if the full view has discriminants and the parent type is
5730 -- in scope they must be inherited.
5732 elsif Has_Unknown_Discriminants
(Parent_Type
)
5734 (not Has_Discriminants
(Parent_Type
)
5735 or else not In_Open_Scopes
(Scope
(Parent_Type
)))
5737 Set_Has_Unknown_Discriminants
(Derived_Type
);
5740 if not Has_Unknown_Discriminants
(Derived_Type
)
5741 and then not Has_Unknown_Discriminants
(Parent_Base
)
5742 and then Has_Discriminants
(Parent_Type
)
5744 Inherit_Discrims
:= True;
5745 Set_Has_Discriminants
5746 (Derived_Type
, True);
5747 Set_Discriminant_Constraint
5748 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
5751 -- The following test is true for private types (remember
5752 -- transformation 5. is not applied to those) and in an error
5755 if Constraint_Present
then
5756 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5759 -- For now mark a new derived type as constrained only if it has no
5760 -- discriminants. At the end of Build_Derived_Record_Type we properly
5761 -- set this flag in the case of private extensions. See comments in
5762 -- point 9. just before body of Build_Derived_Record_Type.
5766 not (Inherit_Discrims
5767 or else Has_Unknown_Discriminants
(Derived_Type
)));
5770 -- STEP 3: initialize fields of derived type
5772 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
5773 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
5775 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
5776 -- but cannot be interfaces
5778 if not Private_Extension
5779 and then Ekind
(Derived_Type
) /= E_Private_Type
5780 and then Ekind
(Derived_Type
) /= E_Limited_Private_Type
5782 Set_Is_Interface
(Derived_Type
, Interface_Present
(Type_Def
));
5783 Set_Abstract_Interfaces
(Derived_Type
, No_Elist
);
5786 -- Fields inherited from the Parent_Type
5789 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
5790 Set_Has_Specified_Layout
5791 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
5792 Set_Is_Limited_Composite
5793 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
5794 Set_Is_Limited_Record
5795 (Derived_Type
, Is_Limited_Record
(Parent_Type
));
5796 Set_Is_Private_Composite
5797 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
5799 -- Fields inherited from the Parent_Base
5801 Set_Has_Controlled_Component
5802 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
5803 Set_Has_Non_Standard_Rep
5804 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
5805 Set_Has_Primitive_Operations
5806 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
5808 -- Direct controlled types do not inherit Finalize_Storage_Only flag
5810 if not Is_Controlled
(Parent_Type
) then
5811 Set_Finalize_Storage_Only
5812 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
5815 -- Set fields for private derived types
5817 if Is_Private_Type
(Derived_Type
) then
5818 Set_Depends_On_Private
(Derived_Type
, True);
5819 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
5821 -- Inherit fields from non private record types. If this is the
5822 -- completion of a derivation from a private type, the parent itself
5823 -- is private, and the attributes come from its full view, which must
5827 if Is_Private_Type
(Parent_Base
)
5828 and then not Is_Record_Type
(Parent_Base
)
5830 Set_Component_Alignment
5831 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
5833 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
5835 Set_Component_Alignment
5836 (Derived_Type
, Component_Alignment
(Parent_Base
));
5839 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
5843 -- Set fields for tagged types
5846 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
5848 -- All tagged types defined in Ada.Finalization are controlled
5850 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
5851 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
5852 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
5854 Set_Is_Controlled
(Derived_Type
);
5856 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
5859 Make_Class_Wide_Type
(Derived_Type
);
5860 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
5862 if Has_Discriminants
(Derived_Type
)
5863 and then Constraint_Present
5865 Set_Stored_Constraint
5866 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Base
, Discs
));
5869 -- Ada 2005 (AI-251): Look for the partial view of tagged types
5870 -- declared in the private part. This will be used 1) to check that
5871 -- the set of interfaces in both views is equal, and 2) to complete
5872 -- the derivation of subprograms covering interfaces.
5874 Tagged_Partial_View
:= Empty
;
5876 if Has_Private_Declaration
(Derived_Type
) then
5877 Tagged_Partial_View
:= Next_Entity
(Derived_Type
);
5879 exit when Has_Private_Declaration
(Tagged_Partial_View
)
5880 and then Full_View
(Tagged_Partial_View
) = Derived_Type
;
5882 Next_Entity
(Tagged_Partial_View
);
5886 -- Ada 2005 (AI-251): Collect the whole list of implemented
5889 if Ada_Version
>= Ada_05
then
5890 Set_Abstract_Interfaces
(Derived_Type
, New_Elmt_List
);
5892 if Nkind
(N
) = N_Private_Extension_Declaration
then
5893 Collect_Interfaces
(N
, Derived_Type
);
5895 Collect_Interfaces
(Type_Definition
(N
), Derived_Type
);
5898 -- Check that the full view and the partial view agree
5899 -- in the set of implemented interfaces
5901 if Has_Private_Declaration
(Derived_Type
)
5902 and then Present
(Abstract_Interfaces
(Derived_Type
))
5903 and then not Is_Empty_Elmt_List
5904 (Abstract_Interfaces
(Derived_Type
))
5907 N_Partial
: constant Node_Id
:= Parent
(Tagged_Partial_View
);
5908 N_Full
: constant Node_Id
:= Parent
(Derived_Type
);
5910 Iface_Partial
: Entity_Id
;
5911 Iface_Full
: Entity_Id
;
5912 Num_Ifaces_Partial
: Natural := 0;
5913 Num_Ifaces_Full
: Natural := 0;
5914 Same_Interfaces
: Boolean := True;
5917 if Nkind
(N_Partial
) /= N_Private_Extension_Declaration
then
5919 ("(Ada 2005) interfaces only allowed in private"
5920 & " extension declarations", N_Partial
);
5923 -- Count the interfaces implemented by the partial view
5925 if Nkind
(N_Partial
) = N_Private_Extension_Declaration
5926 and then not Is_Empty_List
(Interface_List
(N_Partial
))
5928 Iface_Partial
:= First
(Interface_List
(N_Partial
));
5929 while Present
(Iface_Partial
) loop
5930 Num_Ifaces_Partial
:= Num_Ifaces_Partial
+ 1;
5931 Next
(Iface_Partial
);
5935 -- Take into account the case in which the partial
5936 -- view is a directly derived from an interface
5938 if Is_Interface
(Etype
5939 (Defining_Identifier
(N_Partial
)))
5941 Num_Ifaces_Partial
:= Num_Ifaces_Partial
+ 1;
5944 -- Count the interfaces implemented by the full view
5946 if not Is_Empty_List
(Interface_List
5947 (Type_Definition
(N_Full
)))
5949 Iface_Full
:= First
(Interface_List
5950 (Type_Definition
(N_Full
)));
5951 while Present
(Iface_Full
) loop
5952 Num_Ifaces_Full
:= Num_Ifaces_Full
+ 1;
5957 -- Take into account the case in which the full
5958 -- view is a directly derived from an interface
5960 if Is_Interface
(Etype
5961 (Defining_Identifier
(N_Full
)))
5963 Num_Ifaces_Full
:= Num_Ifaces_Full
+ 1;
5966 if Num_Ifaces_Full
> 0
5967 and then Num_Ifaces_Full
= Num_Ifaces_Partial
5969 -- Check that the full-view and the private-view have
5970 -- the same list of interfaces.
5972 Iface_Full
:= First
(Interface_List
5973 (Type_Definition
(N_Full
)));
5974 while Present
(Iface_Full
) loop
5975 Iface_Partial
:= First
(Interface_List
(N_Partial
));
5976 while Present
(Iface_Partial
)
5977 and then Etype
(Iface_Partial
) /= Etype
(Iface_Full
)
5979 Next
(Iface_Partial
);
5982 -- If not found we check if the partial view is a
5983 -- direct derivation of the interface.
5985 if not Present
(Iface_Partial
)
5987 Etype
(Tagged_Partial_View
) /= Etype
(Iface_Full
)
5989 Same_Interfaces
:= False;
5997 if Num_Ifaces_Partial
/= Num_Ifaces_Full
5998 or else not Same_Interfaces
6001 ("(Ada 2005) full declaration and private declaration"
6002 & " must have the same list of interfaces",
6010 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
6011 Set_Has_Non_Standard_Rep
6012 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6015 -- STEP 4: Inherit components from the parent base and constrain them.
6016 -- Apply the second transformation described in point 6. above.
6018 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
6019 or else not Has_Discriminants
(Parent_Type
)
6020 or else not Is_Constrained
(Parent_Type
)
6024 Constrs
:= Discriminant_Constraint
(Parent_Type
);
6027 Assoc_List
:= Inherit_Components
(N
,
6028 Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
6030 -- STEP 5a: Copy the parent record declaration for untagged types
6032 if not Is_Tagged
then
6034 -- Discriminant_Constraint (Derived_Type) has been properly
6035 -- constructed. Save it and temporarily set it to Empty because we
6036 -- do not want the call to New_Copy_Tree below to mess this list.
6038 if Has_Discriminants
(Derived_Type
) then
6039 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
6040 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
6042 Save_Discr_Constr
:= No_Elist
;
6045 -- Save the Etype field of Derived_Type. It is correctly set now,
6046 -- but the call to New_Copy tree may remap it to point to itself,
6047 -- which is not what we want. Ditto for the Next_Entity field.
6049 Save_Etype
:= Etype
(Derived_Type
);
6050 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
6052 -- Assoc_List maps all stored discriminants in the Parent_Base to
6053 -- stored discriminants in the Derived_Type. It is fundamental that
6054 -- no types or itypes with discriminants other than the stored
6055 -- discriminants appear in the entities declared inside
6056 -- Derived_Type, since the back end cannot deal with it.
6060 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
6062 -- Restore the fields saved prior to the New_Copy_Tree call
6063 -- and compute the stored constraint.
6065 Set_Etype
(Derived_Type
, Save_Etype
);
6066 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
6068 if Has_Discriminants
(Derived_Type
) then
6069 Set_Discriminant_Constraint
6070 (Derived_Type
, Save_Discr_Constr
);
6071 Set_Stored_Constraint
6072 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Type
, Discs
));
6073 Replace_Components
(Derived_Type
, New_Decl
);
6076 -- Insert the new derived type declaration
6078 Rewrite
(N
, New_Decl
);
6080 -- STEP 5b: Complete the processing for record extensions in generics
6082 -- There is no completion for record extensions declared in the
6083 -- parameter part of a generic, so we need to complete processing for
6084 -- these generic record extensions here. The Record_Type_Definition call
6085 -- will change the Ekind of the components from E_Void to E_Component.
6087 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
6088 Record_Type_Definition
(Empty
, Derived_Type
);
6090 -- STEP 5c: Process the record extension for non private tagged types
6092 elsif not Private_Extension
then
6094 -- Add the _parent field in the derived type
6096 Expand_Record_Extension
(Derived_Type
, Type_Def
);
6098 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
6099 -- implemented interfaces if we are in expansion mode
6101 if Expander_Active
then
6102 Add_Interface_Tag_Components
(N
, Derived_Type
);
6105 -- Analyze the record extension
6107 Record_Type_Definition
6108 (Record_Extension_Part
(Type_Def
), Derived_Type
);
6113 if Etype
(Derived_Type
) = Any_Type
then
6117 -- Set delayed freeze and then derive subprograms, we need to do
6118 -- this in this order so that derived subprograms inherit the
6119 -- derived freeze if necessary.
6121 Set_Has_Delayed_Freeze
(Derived_Type
);
6123 if Derive_Subps
then
6125 -- Ada 2005 (AI-251): Check if this tagged type implements abstract
6128 Has_Interfaces
:= False;
6130 if Is_Tagged_Type
(Derived_Type
) then
6138 or else (Present
(Abstract_Interfaces
(E
))
6140 not Is_Empty_Elmt_List
(Abstract_Interfaces
(E
)))
6142 Has_Interfaces
:= True;
6146 exit when Etype
(E
) = E
6148 -- Protect the frontend against wrong source
6150 or else Etype
(E
) = Derived_Type
;
6157 -- Ada 2005 (AI-251): Keep separate the management of tagged types
6158 -- implementing interfaces
6160 if not Is_Tagged_Type
(Derived_Type
)
6161 or else not Has_Interfaces
6163 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6166 -- Ada 2005 (AI-251): Complete the decoration of tagged private
6167 -- types that implement interfaces
6169 if Present
(Tagged_Partial_View
) then
6171 (Parent_Type
, Derived_Type
, Predefined_Prims_Only
=> True);
6173 Complete_Subprograms_Derivation
6174 (Partial_View
=> Tagged_Partial_View
,
6175 Derived_Type
=> Derived_Type
);
6177 -- Ada 2005 (AI-251): Derive the interface subprograms of all the
6178 -- implemented interfaces and check if some of the subprograms
6179 -- inherited from the ancestor cover some interface subprogram.
6182 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6185 Subp_Elmt
: Elmt_Id
;
6186 First_Iface_Elmt
: Elmt_Id
;
6187 Iface_Subp_Elmt
: Elmt_Id
;
6189 Iface_Subp
: Entity_Id
;
6190 Is_Interface_Subp
: Boolean;
6193 -- Ada 2005 (AI-251): Remember the entity corresponding to
6194 -- the last inherited primitive operation. This is required
6195 -- to check if some of the inherited subprograms covers some
6196 -- of the new interfaces.
6198 Last_Inherited_Prim_Op
:= No_Elmt
;
6201 First_Elmt
(Primitive_Operations
(Derived_Type
));
6202 while Present
(Subp_Elmt
) loop
6203 Last_Inherited_Prim_Op
:= Subp_Elmt
;
6204 Next_Elmt
(Subp_Elmt
);
6207 -- Ada 2005 (AI-251): Derive subprograms in abstract
6210 Derive_Interface_Subprograms
(Derived_Type
);
6212 -- Ada 2005 (AI-251): Check if some of the inherited
6213 -- subprograms cover some of the new interfaces.
6215 if Present
(Last_Inherited_Prim_Op
) then
6216 First_Iface_Elmt
:= Next_Elmt
(Last_Inherited_Prim_Op
);
6217 Iface_Subp_Elmt
:= First_Iface_Elmt
;
6218 while Present
(Iface_Subp_Elmt
) loop
6219 Subp_Elmt
:= First_Elmt
(Primitive_Operations
6221 while Subp_Elmt
/= First_Iface_Elmt
loop
6222 Subp
:= Node
(Subp_Elmt
);
6223 Iface_Subp
:= Node
(Iface_Subp_Elmt
);
6225 Is_Interface_Subp
:=
6226 Present
(Alias
(Subp
))
6227 and then Present
(DTC_Entity
(Alias
(Subp
)))
6228 and then Is_Interface
(Scope
6232 if Chars
(Subp
) = Chars
(Iface_Subp
)
6233 and then not Is_Interface_Subp
6234 and then not Is_Abstract
(Subp
)
6235 and then Type_Conformant
(Iface_Subp
, Subp
)
6237 Check_Dispatching_Operation
6239 Old_Subp
=> Iface_Subp
);
6241 -- Traverse the list of aliased subprograms
6248 while Present
(Alias
(E
)) loop
6252 Set_Alias
(Subp
, E
);
6255 Set_Has_Delayed_Freeze
(Subp
);
6259 Next_Elmt
(Subp_Elmt
);
6262 Next_Elmt
(Iface_Subp_Elmt
);
6270 -- If we have a private extension which defines a constrained derived
6271 -- type mark as constrained here after we have derived subprograms. See
6272 -- comment on point 9. just above the body of Build_Derived_Record_Type.
6274 if Private_Extension
and then Inherit_Discrims
then
6275 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
6276 Set_Is_Constrained
(Derived_Type
, True);
6277 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
6279 elsif Is_Constrained
(Parent_Type
) then
6281 (Derived_Type
, True);
6282 Set_Discriminant_Constraint
6283 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
6287 -- Update the class_wide type, which shares the now-completed
6288 -- entity list with its specific type.
6292 (Class_Wide_Type
(Derived_Type
), First_Entity
(Derived_Type
));
6294 (Class_Wide_Type
(Derived_Type
), Last_Entity
(Derived_Type
));
6297 end Build_Derived_Record_Type
;
6299 ------------------------
6300 -- Build_Derived_Type --
6301 ------------------------
6303 procedure Build_Derived_Type
6305 Parent_Type
: Entity_Id
;
6306 Derived_Type
: Entity_Id
;
6307 Is_Completion
: Boolean;
6308 Derive_Subps
: Boolean := True)
6310 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
6313 -- Set common attributes
6315 Set_Scope
(Derived_Type
, Current_Scope
);
6317 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
6318 Set_Etype
(Derived_Type
, Parent_Base
);
6319 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
6321 Set_Size_Info
(Derived_Type
, Parent_Type
);
6322 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
6323 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
6324 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
6326 -- The derived type inherits the representation clauses of the parent.
6327 -- However, for a private type that is completed by a derivation, there
6328 -- may be operation attributes that have been specified already (stream
6329 -- attributes and External_Tag) and those must be provided. Finally,
6330 -- if the partial view is a private extension, the representation items
6331 -- of the parent have been inherited already, and should not be chained
6332 -- twice to the derived type.
6334 if Is_Tagged_Type
(Parent_Type
)
6335 and then Present
(First_Rep_Item
(Derived_Type
))
6337 -- The existing items are either operational items or items inherited
6338 -- from a private extension declaration.
6342 Found
: Boolean := False;
6345 Rep
:= First_Rep_Item
(Derived_Type
);
6346 while Present
(Rep
) loop
6347 if Rep
= First_Rep_Item
(Parent_Type
) then
6351 Rep
:= Next_Rep_Item
(Rep
);
6357 (First_Rep_Item
(Derived_Type
), First_Rep_Item
(Parent_Type
));
6362 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
6365 case Ekind
(Parent_Type
) is
6366 when Numeric_Kind
=>
6367 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
6370 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
6374 | Class_Wide_Kind
=>
6375 Build_Derived_Record_Type
6376 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
6379 when Enumeration_Kind
=>
6380 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
6383 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
6385 when Incomplete_Or_Private_Kind
=>
6386 Build_Derived_Private_Type
6387 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
6389 -- For discriminated types, the derivation includes deriving
6390 -- primitive operations. For others it is done below.
6392 if Is_Tagged_Type
(Parent_Type
)
6393 or else Has_Discriminants
(Parent_Type
)
6394 or else (Present
(Full_View
(Parent_Type
))
6395 and then Has_Discriminants
(Full_View
(Parent_Type
)))
6400 when Concurrent_Kind
=>
6401 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
6404 raise Program_Error
;
6407 if Etype
(Derived_Type
) = Any_Type
then
6411 -- Set delayed freeze and then derive subprograms, we need to do this
6412 -- in this order so that derived subprograms inherit the derived freeze
6415 Set_Has_Delayed_Freeze
(Derived_Type
);
6416 if Derive_Subps
then
6417 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6420 Set_Has_Primitive_Operations
6421 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
6422 end Build_Derived_Type
;
6424 -----------------------
6425 -- Build_Discriminal --
6426 -----------------------
6428 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
6429 D_Minal
: Entity_Id
;
6430 CR_Disc
: Entity_Id
;
6433 -- A discriminal has the same name as the discriminant
6436 Make_Defining_Identifier
(Sloc
(Discrim
),
6437 Chars
=> Chars
(Discrim
));
6439 Set_Ekind
(D_Minal
, E_In_Parameter
);
6440 Set_Mechanism
(D_Minal
, Default_Mechanism
);
6441 Set_Etype
(D_Minal
, Etype
(Discrim
));
6443 Set_Discriminal
(Discrim
, D_Minal
);
6444 Set_Discriminal_Link
(D_Minal
, Discrim
);
6446 -- For task types, build at once the discriminants of the corresponding
6447 -- record, which are needed if discriminants are used in entry defaults
6448 -- and in family bounds.
6450 if Is_Concurrent_Type
(Current_Scope
)
6451 or else Is_Limited_Type
(Current_Scope
)
6453 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
6455 Set_Ekind
(CR_Disc
, E_In_Parameter
);
6456 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
6457 Set_Etype
(CR_Disc
, Etype
(Discrim
));
6458 Set_CR_Discriminant
(Discrim
, CR_Disc
);
6460 end Build_Discriminal
;
6462 ------------------------------------
6463 -- Build_Discriminant_Constraints --
6464 ------------------------------------
6466 function Build_Discriminant_Constraints
6469 Derived_Def
: Boolean := False) return Elist_Id
6471 C
: constant Node_Id
:= Constraint
(Def
);
6472 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
6474 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
6475 -- Saves the expression corresponding to a given discriminant in T
6477 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
6478 -- Return the Position number within array Discr_Expr of a discriminant
6479 -- D within the discriminant list of the discriminated type T.
6485 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
6489 Disc
:= First_Discriminant
(T
);
6490 for J
in Discr_Expr
'Range loop
6495 Next_Discriminant
(Disc
);
6498 -- Note: Since this function is called on discriminants that are
6499 -- known to belong to the discriminated type, falling through the
6500 -- loop with no match signals an internal compiler error.
6502 raise Program_Error
;
6505 -- Declarations local to Build_Discriminant_Constraints
6509 Elist
: constant Elist_Id
:= New_Elmt_List
;
6517 Discrim_Present
: Boolean := False;
6519 -- Start of processing for Build_Discriminant_Constraints
6522 -- The following loop will process positional associations only.
6523 -- For a positional association, the (single) discriminant is
6524 -- implicitly specified by position, in textual order (RM 3.7.2).
6526 Discr
:= First_Discriminant
(T
);
6527 Constr
:= First
(Constraints
(C
));
6529 for D
in Discr_Expr
'Range loop
6530 exit when Nkind
(Constr
) = N_Discriminant_Association
;
6533 Error_Msg_N
("too few discriminants given in constraint", C
);
6534 return New_Elmt_List
;
6536 elsif Nkind
(Constr
) = N_Range
6537 or else (Nkind
(Constr
) = N_Attribute_Reference
6539 Attribute_Name
(Constr
) = Name_Range
)
6542 ("a range is not a valid discriminant constraint", Constr
);
6543 Discr_Expr
(D
) := Error
;
6546 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
6547 Discr_Expr
(D
) := Constr
;
6550 Next_Discriminant
(Discr
);
6554 if No
(Discr
) and then Present
(Constr
) then
6555 Error_Msg_N
("too many discriminants given in constraint", Constr
);
6556 return New_Elmt_List
;
6559 -- Named associations can be given in any order, but if both positional
6560 -- and named associations are used in the same discriminant constraint,
6561 -- then positional associations must occur first, at their normal
6562 -- position. Hence once a named association is used, the rest of the
6563 -- discriminant constraint must use only named associations.
6565 while Present
(Constr
) loop
6567 -- Positional association forbidden after a named association
6569 if Nkind
(Constr
) /= N_Discriminant_Association
then
6570 Error_Msg_N
("positional association follows named one", Constr
);
6571 return New_Elmt_List
;
6573 -- Otherwise it is a named association
6576 -- E records the type of the discriminants in the named
6577 -- association. All the discriminants specified in the same name
6578 -- association must have the same type.
6582 -- Search the list of discriminants in T to see if the simple name
6583 -- given in the constraint matches any of them.
6585 Id
:= First
(Selector_Names
(Constr
));
6586 while Present
(Id
) loop
6589 -- If Original_Discriminant is present, we are processing a
6590 -- generic instantiation and this is an instance node. We need
6591 -- to find the name of the corresponding discriminant in the
6592 -- actual record type T and not the name of the discriminant in
6593 -- the generic formal. Example:
6596 -- type G (D : int) is private;
6598 -- subtype W is G (D => 1);
6600 -- type Rec (X : int) is record ... end record;
6601 -- package Q is new P (G => Rec);
6603 -- At the point of the instantiation, formal type G is Rec
6604 -- and therefore when reanalyzing "subtype W is G (D => 1);"
6605 -- which really looks like "subtype W is Rec (D => 1);" at
6606 -- the point of instantiation, we want to find the discriminant
6607 -- that corresponds to D in Rec, ie X.
6609 if Present
(Original_Discriminant
(Id
)) then
6610 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
6614 Discr
:= First_Discriminant
(T
);
6615 while Present
(Discr
) loop
6616 if Chars
(Discr
) = Chars
(Id
) then
6621 Next_Discriminant
(Discr
);
6625 Error_Msg_N
("& does not match any discriminant", Id
);
6626 return New_Elmt_List
;
6628 -- The following is only useful for the benefit of generic
6629 -- instances but it does not interfere with other
6630 -- processing for the non-generic case so we do it in all
6631 -- cases (for generics this statement is executed when
6632 -- processing the generic definition, see comment at the
6633 -- beginning of this if statement).
6636 Set_Original_Discriminant
(Id
, Discr
);
6640 Position
:= Pos_Of_Discr
(T
, Discr
);
6642 if Present
(Discr_Expr
(Position
)) then
6643 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
6646 -- Each discriminant specified in the same named association
6647 -- must be associated with a separate copy of the
6648 -- corresponding expression.
6650 if Present
(Next
(Id
)) then
6651 Expr
:= New_Copy_Tree
(Expression
(Constr
));
6652 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
6654 Expr
:= Expression
(Constr
);
6657 Discr_Expr
(Position
) := Expr
;
6658 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
6661 -- A discriminant association with more than one discriminant
6662 -- name is only allowed if the named discriminants are all of
6663 -- the same type (RM 3.7.1(8)).
6666 E
:= Base_Type
(Etype
(Discr
));
6668 elsif Base_Type
(Etype
(Discr
)) /= E
then
6670 ("all discriminants in an association " &
6671 "must have the same type", Id
);
6681 -- A discriminant constraint must provide exactly one value for each
6682 -- discriminant of the type (RM 3.7.1(8)).
6684 for J
in Discr_Expr
'Range loop
6685 if No
(Discr_Expr
(J
)) then
6686 Error_Msg_N
("too few discriminants given in constraint", C
);
6687 return New_Elmt_List
;
6691 -- Determine if there are discriminant expressions in the constraint
6693 for J
in Discr_Expr
'Range loop
6694 if Denotes_Discriminant
(Discr_Expr
(J
), Check_Protected
=> True) then
6695 Discrim_Present
:= True;
6699 -- Build an element list consisting of the expressions given in the
6700 -- discriminant constraint and apply the appropriate checks. The list
6701 -- is constructed after resolving any named discriminant associations
6702 -- and therefore the expressions appear in the textual order of the
6705 Discr
:= First_Discriminant
(T
);
6706 for J
in Discr_Expr
'Range loop
6707 if Discr_Expr
(J
) /= Error
then
6709 Append_Elmt
(Discr_Expr
(J
), Elist
);
6711 -- If any of the discriminant constraints is given by a
6712 -- discriminant and we are in a derived type declaration we
6713 -- have a discriminant renaming. Establish link between new
6714 -- and old discriminant.
6716 if Denotes_Discriminant
(Discr_Expr
(J
)) then
6718 Set_Corresponding_Discriminant
6719 (Entity
(Discr_Expr
(J
)), Discr
);
6722 -- Force the evaluation of non-discriminant expressions.
6723 -- If we have found a discriminant in the constraint 3.4(26)
6724 -- and 3.8(18) demand that no range checks are performed are
6725 -- after evaluation. If the constraint is for a component
6726 -- definition that has a per-object constraint, expressions are
6727 -- evaluated but not checked either. In all other cases perform
6731 if Discrim_Present
then
6734 elsif Nkind
(Parent
(Parent
(Def
))) = N_Component_Declaration
6736 Has_Per_Object_Constraint
6737 (Defining_Identifier
(Parent
(Parent
(Def
))))
6741 elsif Is_Access_Type
(Etype
(Discr
)) then
6742 Apply_Constraint_Check
(Discr_Expr
(J
), Etype
(Discr
));
6745 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
6748 Force_Evaluation
(Discr_Expr
(J
));
6751 -- Check that the designated type of an access discriminant's
6752 -- expression is not a class-wide type unless the discriminant's
6753 -- designated type is also class-wide.
6755 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
6756 and then not Is_Class_Wide_Type
6757 (Designated_Type
(Etype
(Discr
)))
6758 and then Etype
(Discr_Expr
(J
)) /= Any_Type
6759 and then Is_Class_Wide_Type
6760 (Designated_Type
(Etype
(Discr_Expr
(J
))))
6762 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
6766 Next_Discriminant
(Discr
);
6770 end Build_Discriminant_Constraints
;
6772 ---------------------------------
6773 -- Build_Discriminated_Subtype --
6774 ---------------------------------
6776 procedure Build_Discriminated_Subtype
6780 Related_Nod
: Node_Id
;
6781 For_Access
: Boolean := False)
6783 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
6784 Constrained
: constant Boolean
6786 and then not Is_Empty_Elmt_List
(Elist
)
6787 and then not Is_Class_Wide_Type
(T
))
6788 or else Is_Constrained
(T
);
6791 if Ekind
(T
) = E_Record_Type
then
6793 Set_Ekind
(Def_Id
, E_Private_Subtype
);
6794 Set_Is_For_Access_Subtype
(Def_Id
, True);
6796 Set_Ekind
(Def_Id
, E_Record_Subtype
);
6799 elsif Ekind
(T
) = E_Task_Type
then
6800 Set_Ekind
(Def_Id
, E_Task_Subtype
);
6802 elsif Ekind
(T
) = E_Protected_Type
then
6803 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
6805 elsif Is_Private_Type
(T
) then
6806 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
6808 elsif Is_Class_Wide_Type
(T
) then
6809 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
6812 -- Incomplete type. attach subtype to list of dependents, to be
6813 -- completed with full view of parent type, unless is it the
6814 -- designated subtype of a record component within an init_proc.
6815 -- This last case arises for a component of an access type whose
6816 -- designated type is incomplete (e.g. a Taft Amendment type).
6817 -- The designated subtype is within an inner scope, and needs no
6818 -- elaboration, because only the access type is needed in the
6819 -- initialization procedure.
6821 Set_Ekind
(Def_Id
, Ekind
(T
));
6823 if For_Access
and then Within_Init_Proc
then
6826 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
6830 Set_Etype
(Def_Id
, T
);
6831 Init_Size_Align
(Def_Id
);
6832 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
6833 Set_Is_Constrained
(Def_Id
, Constrained
);
6835 Set_First_Entity
(Def_Id
, First_Entity
(T
));
6836 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
6837 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
6839 if Is_Tagged_Type
(T
) then
6840 Set_Is_Tagged_Type
(Def_Id
);
6841 Make_Class_Wide_Type
(Def_Id
);
6844 Set_Stored_Constraint
(Def_Id
, No_Elist
);
6847 Set_Discriminant_Constraint
(Def_Id
, Elist
);
6848 Set_Stored_Constraint_From_Discriminant_Constraint
(Def_Id
);
6851 if Is_Tagged_Type
(T
) then
6852 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
6853 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
6856 -- Subtypes introduced by component declarations do not need to be
6857 -- marked as delayed, and do not get freeze nodes, because the semantics
6858 -- verifies that the parents of the subtypes are frozen before the
6859 -- enclosing record is frozen.
6861 if not Is_Type
(Scope
(Def_Id
)) then
6862 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
6864 if Is_Private_Type
(T
)
6865 and then Present
(Full_View
(T
))
6867 Conditional_Delay
(Def_Id
, Full_View
(T
));
6869 Conditional_Delay
(Def_Id
, T
);
6873 if Is_Record_Type
(T
) then
6874 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
6877 and then not Is_Empty_Elmt_List
(Elist
)
6878 and then not For_Access
6880 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
6881 elsif not For_Access
then
6882 Set_Cloned_Subtype
(Def_Id
, T
);
6886 end Build_Discriminated_Subtype
;
6888 ------------------------
6889 -- Build_Scalar_Bound --
6890 ------------------------
6892 function Build_Scalar_Bound
6895 Der_T
: Entity_Id
) return Node_Id
6897 New_Bound
: Entity_Id
;
6900 -- Note: not clear why this is needed, how can the original bound
6901 -- be unanalyzed at this point? and if it is, what business do we
6902 -- have messing around with it? and why is the base type of the
6903 -- parent type the right type for the resolution. It probably is
6904 -- not! It is OK for the new bound we are creating, but not for
6905 -- the old one??? Still if it never happens, no problem!
6907 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
6909 if Nkind
(Bound
) = N_Integer_Literal
6910 or else Nkind
(Bound
) = N_Real_Literal
6912 New_Bound
:= New_Copy
(Bound
);
6913 Set_Etype
(New_Bound
, Der_T
);
6914 Set_Analyzed
(New_Bound
);
6916 elsif Is_Entity_Name
(Bound
) then
6917 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
6919 -- The following is almost certainly wrong. What business do we have
6920 -- relocating a node (Bound) that is presumably still attached to
6921 -- the tree elsewhere???
6924 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
6927 Set_Etype
(New_Bound
, Der_T
);
6929 end Build_Scalar_Bound
;
6931 --------------------------------
6932 -- Build_Underlying_Full_View --
6933 --------------------------------
6935 procedure Build_Underlying_Full_View
6940 Loc
: constant Source_Ptr
:= Sloc
(N
);
6941 Subt
: constant Entity_Id
:=
6942 Make_Defining_Identifier
6943 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
6950 procedure Set_Discriminant_Name
(Id
: Node_Id
);
6951 -- If the derived type has discriminants, they may rename discriminants
6952 -- of the parent. When building the full view of the parent, we need to
6953 -- recover the names of the original discriminants if the constraint is
6954 -- given by named associations.
6956 ---------------------------
6957 -- Set_Discriminant_Name --
6958 ---------------------------
6960 procedure Set_Discriminant_Name
(Id
: Node_Id
) is
6964 Set_Original_Discriminant
(Id
, Empty
);
6966 if Has_Discriminants
(Typ
) then
6967 Disc
:= First_Discriminant
(Typ
);
6968 while Present
(Disc
) loop
6969 if Chars
(Disc
) = Chars
(Id
)
6970 and then Present
(Corresponding_Discriminant
(Disc
))
6972 Set_Chars
(Id
, Chars
(Corresponding_Discriminant
(Disc
)));
6974 Next_Discriminant
(Disc
);
6977 end Set_Discriminant_Name
;
6979 -- Start of processing for Build_Underlying_Full_View
6982 if Nkind
(N
) = N_Full_Type_Declaration
then
6983 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
6985 elsif Nkind
(N
) = N_Subtype_Declaration
then
6986 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
6988 elsif Nkind
(N
) = N_Component_Declaration
then
6991 (Constraint
(Subtype_Indication
(Component_Definition
(N
))));
6994 raise Program_Error
;
6997 C
:= First
(Constraints
(Constr
));
6998 while Present
(C
) loop
6999 if Nkind
(C
) = N_Discriminant_Association
then
7000 Id
:= First
(Selector_Names
(C
));
7001 while Present
(Id
) loop
7002 Set_Discriminant_Name
(Id
);
7011 Make_Subtype_Declaration
(Loc
,
7012 Defining_Identifier
=> Subt
,
7013 Subtype_Indication
=>
7014 Make_Subtype_Indication
(Loc
,
7015 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
7016 Constraint
=> New_Copy_Tree
(Constr
)));
7018 -- If this is a component subtype for an outer itype, it is not
7019 -- a list member, so simply set the parent link for analysis: if
7020 -- the enclosing type does not need to be in a declarative list,
7021 -- neither do the components.
7023 if Is_List_Member
(N
)
7024 and then Nkind
(N
) /= N_Component_Declaration
7026 Insert_Before
(N
, Indic
);
7028 Set_Parent
(Indic
, Parent
(N
));
7032 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
7033 end Build_Underlying_Full_View
;
7035 -------------------------------
7036 -- Check_Abstract_Overriding --
7037 -------------------------------
7039 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
7046 Op_List
:= Primitive_Operations
(T
);
7048 -- Loop to check primitive operations
7050 Elmt
:= First_Elmt
(Op_List
);
7051 while Present
(Elmt
) loop
7052 Subp
:= Node
(Elmt
);
7054 -- Special exception, do not complain about failure to override the
7055 -- stream routines _Input and _Output, as well as the primitive
7056 -- operations used in dispatching selects since we always provide
7057 -- automatic overridings for these subprograms.
7059 if Is_Abstract
(Subp
)
7060 and then not Is_TSS
(Subp
, TSS_Stream_Input
)
7061 and then not Is_TSS
(Subp
, TSS_Stream_Output
)
7062 and then not Is_Abstract
(T
)
7063 and then Chars
(Subp
) /= Name_uDisp_Asynchronous_Select
7064 and then Chars
(Subp
) /= Name_uDisp_Conditional_Select
7065 and then Chars
(Subp
) /= Name_uDisp_Get_Prim_Op_Kind
7066 and then Chars
(Subp
) /= Name_uDisp_Timed_Select
7068 if Present
(Alias
(Subp
)) then
7070 -- Only perform the check for a derived subprogram when
7071 -- the type has an explicit record extension. This avoids
7072 -- incorrectly flagging abstract subprograms for the case
7073 -- of a type without an extension derived from a formal type
7074 -- with a tagged actual (can occur within a private part).
7076 Type_Def
:= Type_Definition
(Parent
(T
));
7077 if Nkind
(Type_Def
) = N_Derived_Type_Definition
7078 and then Present
(Record_Extension_Part
(Type_Def
))
7081 ("type must be declared abstract or & overridden",
7084 -- Traverse the whole chain of aliased subprograms to
7085 -- complete the error notification. This is useful for
7086 -- traceability of the chain of entities when the subprogram
7087 -- corresponds with interface subprogram (that may be
7088 -- defined in another package)
7090 if Ada_Version
>= Ada_05
7091 and then Present
(Alias
(Subp
))
7098 while Present
(Alias
(E
)) loop
7099 Error_Msg_Sloc
:= Sloc
(E
);
7100 Error_Msg_NE
("\& has been inherited #", T
, Subp
);
7104 Error_Msg_Sloc
:= Sloc
(E
);
7106 ("\& has been inherited from subprogram #", T
, Subp
);
7110 -- Ada 2005 (AI-345): Protected or task type implementing
7111 -- abstract interfaces.
7113 elsif Is_Concurrent_Record_Type
(T
)
7114 and then Present
(Abstract_Interfaces
(T
))
7117 ("interface subprogram & must be overridden",
7122 ("abstract subprogram not allowed for type&",
7125 ("nonabstract type has abstract subprogram&",
7132 end Check_Abstract_Overriding
;
7134 ------------------------------------------------
7135 -- Check_Access_Discriminant_Requires_Limited --
7136 ------------------------------------------------
7138 procedure Check_Access_Discriminant_Requires_Limited
7143 -- A discriminant_specification for an access discriminant shall appear
7144 -- only in the declaration for a task or protected type, or for a type
7145 -- with the reserved word 'limited' in its definition or in one of its
7146 -- ancestors. (RM 3.7(10))
7148 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
7149 and then not Is_Concurrent_Type
(Current_Scope
)
7150 and then not Is_Concurrent_Record_Type
(Current_Scope
)
7151 and then not Is_Limited_Record
(Current_Scope
)
7152 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
7155 ("access discriminants allowed only for limited types", Loc
);
7157 end Check_Access_Discriminant_Requires_Limited
;
7159 -----------------------------------
7160 -- Check_Aliased_Component_Types --
7161 -----------------------------------
7163 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
7167 -- ??? Also need to check components of record extensions, but not
7168 -- components of protected types (which are always limited).
7170 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
7171 -- types to be unconstrained. This is safe because it is illegal to
7172 -- create access subtypes to such types with explicit discriminant
7175 if not Is_Limited_Type
(T
) then
7176 if Ekind
(T
) = E_Record_Type
then
7177 C
:= First_Component
(T
);
7178 while Present
(C
) loop
7180 and then Has_Discriminants
(Etype
(C
))
7181 and then not Is_Constrained
(Etype
(C
))
7182 and then not In_Instance
7183 and then Ada_Version
< Ada_05
7186 ("aliased component must be constrained ('R'M 3.6(11))",
7193 elsif Ekind
(T
) = E_Array_Type
then
7194 if Has_Aliased_Components
(T
)
7195 and then Has_Discriminants
(Component_Type
(T
))
7196 and then not Is_Constrained
(Component_Type
(T
))
7197 and then not In_Instance
7200 ("aliased component type must be constrained ('R'M 3.6(11))",
7205 end Check_Aliased_Component_Types
;
7207 ----------------------
7208 -- Check_Completion --
7209 ----------------------
7211 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
7214 procedure Post_Error
;
7215 -- Post error message for lack of completion for entity E
7221 procedure Post_Error
is
7223 if not Comes_From_Source
(E
) then
7225 if Ekind
(E
) = E_Task_Type
7226 or else Ekind
(E
) = E_Protected_Type
7228 -- It may be an anonymous protected type created for a
7229 -- single variable. Post error on variable, if present.
7235 Var
:= First_Entity
(Current_Scope
);
7236 while Present
(Var
) loop
7237 exit when Etype
(Var
) = E
7238 and then Comes_From_Source
(Var
);
7243 if Present
(Var
) then
7250 -- If a generated entity has no completion, then either previous
7251 -- semantic errors have disabled the expansion phase, or else we had
7252 -- missing subunits, or else we are compiling without expan- sion,
7253 -- or else something is very wrong.
7255 if not Comes_From_Source
(E
) then
7257 (Serious_Errors_Detected
> 0
7258 or else Configurable_Run_Time_Violations
> 0
7259 or else Subunits_Missing
7260 or else not Expander_Active
);
7263 -- Here for source entity
7266 -- Here if no body to post the error message, so we post the error
7267 -- on the declaration that has no completion. This is not really
7268 -- the right place to post it, think about this later ???
7270 if No
(Body_Id
) then
7273 ("missing full declaration for }", Parent
(E
), E
);
7276 ("missing body for &", Parent
(E
), E
);
7279 -- Package body has no completion for a declaration that appears
7280 -- in the corresponding spec. Post error on the body, with a
7281 -- reference to the non-completed declaration.
7284 Error_Msg_Sloc
:= Sloc
(E
);
7288 ("missing full declaration for }!", Body_Id
, E
);
7290 elsif Is_Overloadable
(E
)
7291 and then Current_Entity_In_Scope
(E
) /= E
7293 -- It may be that the completion is mistyped and appears
7294 -- as a distinct overloading of the entity.
7297 Candidate
: constant Entity_Id
:=
7298 Current_Entity_In_Scope
(E
);
7299 Decl
: constant Node_Id
:=
7300 Unit_Declaration_Node
(Candidate
);
7303 if Is_Overloadable
(Candidate
)
7304 and then Ekind
(Candidate
) = Ekind
(E
)
7305 and then Nkind
(Decl
) = N_Subprogram_Body
7306 and then Acts_As_Spec
(Decl
)
7308 Check_Type_Conformant
(Candidate
, E
);
7311 Error_Msg_NE
("missing body for & declared#!",
7316 Error_Msg_NE
("missing body for & declared#!",
7323 -- Start processing for Check_Completion
7326 E
:= First_Entity
(Current_Scope
);
7327 while Present
(E
) loop
7328 if Is_Intrinsic_Subprogram
(E
) then
7331 -- The following situation requires special handling: a child
7332 -- unit that appears in the context clause of the body of its
7335 -- procedure Parent.Child (...);
7337 -- with Parent.Child;
7338 -- package body Parent is
7340 -- Here Parent.Child appears as a local entity, but should not
7341 -- be flagged as requiring completion, because it is a
7342 -- compilation unit.
7344 elsif Ekind
(E
) = E_Function
7345 or else Ekind
(E
) = E_Procedure
7346 or else Ekind
(E
) = E_Generic_Function
7347 or else Ekind
(E
) = E_Generic_Procedure
7349 if not Has_Completion
(E
)
7350 and then not Is_Abstract
(E
)
7351 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7353 and then Chars
(E
) /= Name_uSize
7358 elsif Is_Entry
(E
) then
7359 if not Has_Completion
(E
) and then
7360 (Ekind
(Scope
(E
)) = E_Protected_Object
7361 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
7366 elsif Is_Package
(E
) then
7367 if Unit_Requires_Body
(E
) then
7368 if not Has_Completion
(E
)
7369 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7375 elsif not Is_Child_Unit
(E
) then
7376 May_Need_Implicit_Body
(E
);
7379 elsif Ekind
(E
) = E_Incomplete_Type
7380 and then No
(Underlying_Type
(E
))
7384 elsif (Ekind
(E
) = E_Task_Type
or else
7385 Ekind
(E
) = E_Protected_Type
)
7386 and then not Has_Completion
(E
)
7390 -- A single task declared in the current scope is a constant, verify
7391 -- that the body of its anonymous type is in the same scope. If the
7392 -- task is defined elsewhere, this may be a renaming declaration for
7393 -- which no completion is needed.
7395 elsif Ekind
(E
) = E_Constant
7396 and then Ekind
(Etype
(E
)) = E_Task_Type
7397 and then not Has_Completion
(Etype
(E
))
7398 and then Scope
(Etype
(E
)) = Current_Scope
7402 elsif Ekind
(E
) = E_Protected_Object
7403 and then not Has_Completion
(Etype
(E
))
7407 elsif Ekind
(E
) = E_Record_Type
then
7408 if Is_Tagged_Type
(E
) then
7409 Check_Abstract_Overriding
(E
);
7412 Check_Aliased_Component_Types
(E
);
7414 elsif Ekind
(E
) = E_Array_Type
then
7415 Check_Aliased_Component_Types
(E
);
7421 end Check_Completion
;
7423 ----------------------------
7424 -- Check_Delta_Expression --
7425 ----------------------------
7427 procedure Check_Delta_Expression
(E
: Node_Id
) is
7429 if not (Is_Real_Type
(Etype
(E
))) then
7430 Wrong_Type
(E
, Any_Real
);
7432 elsif not Is_OK_Static_Expression
(E
) then
7433 Flag_Non_Static_Expr
7434 ("non-static expression used for delta value!", E
);
7436 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
7437 Error_Msg_N
("delta expression must be positive", E
);
7443 -- If any of above errors occurred, then replace the incorrect
7444 -- expression by the real 0.1, which should prevent further errors.
7447 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
7448 Analyze_And_Resolve
(E
, Standard_Float
);
7449 end Check_Delta_Expression
;
7451 -----------------------------
7452 -- Check_Digits_Expression --
7453 -----------------------------
7455 procedure Check_Digits_Expression
(E
: Node_Id
) is
7457 if not (Is_Integer_Type
(Etype
(E
))) then
7458 Wrong_Type
(E
, Any_Integer
);
7460 elsif not Is_OK_Static_Expression
(E
) then
7461 Flag_Non_Static_Expr
7462 ("non-static expression used for digits value!", E
);
7464 elsif Expr_Value
(E
) <= 0 then
7465 Error_Msg_N
("digits value must be greater than zero", E
);
7471 -- If any of above errors occurred, then replace the incorrect
7472 -- expression by the integer 1, which should prevent further errors.
7474 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
7475 Analyze_And_Resolve
(E
, Standard_Integer
);
7477 end Check_Digits_Expression
;
7479 --------------------------
7480 -- Check_Initialization --
7481 --------------------------
7483 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
7485 if (Is_Limited_Type
(T
)
7486 or else Is_Limited_Composite
(T
))
7487 and then not In_Instance
7488 and then not In_Inlined_Body
7490 -- Ada 2005 (AI-287): Relax the strictness of the front-end in
7491 -- case of limited aggregates and extension aggregates.
7493 if Ada_Version
>= Ada_05
7494 and then (Nkind
(Exp
) = N_Aggregate
7495 or else Nkind
(Exp
) = N_Extension_Aggregate
)
7500 ("cannot initialize entities of limited type", Exp
);
7501 Explain_Limited_Type
(T
, Exp
);
7504 end Check_Initialization
;
7506 ------------------------------------
7507 -- Check_Or_Process_Discriminants --
7508 ------------------------------------
7510 -- If an incomplete or private type declaration was already given for the
7511 -- type, the discriminants may have already been processed if they were
7512 -- present on the incomplete declaration. In this case a full conformance
7513 -- check is performed otherwise just process them.
7515 procedure Check_Or_Process_Discriminants
7518 Prev
: Entity_Id
:= Empty
)
7521 if Has_Discriminants
(T
) then
7523 -- Make the discriminants visible to component declarations
7530 D
:= First_Discriminant
(T
);
7531 while Present
(D
) loop
7532 Prev
:= Current_Entity
(D
);
7533 Set_Current_Entity
(D
);
7534 Set_Is_Immediately_Visible
(D
);
7535 Set_Homonym
(D
, Prev
);
7537 -- Ada 2005 (AI-230): Access discriminant allowed in
7538 -- non-limited record types.
7540 if Ada_Version
< Ada_05
then
7542 -- This restriction gets applied to the full type here. It
7543 -- has already been applied earlier to the partial view.
7545 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
7548 Next_Discriminant
(D
);
7552 elsif Present
(Discriminant_Specifications
(N
)) then
7553 Process_Discriminants
(N
, Prev
);
7555 end Check_Or_Process_Discriminants
;
7557 ----------------------
7558 -- Check_Real_Bound --
7559 ----------------------
7561 procedure Check_Real_Bound
(Bound
: Node_Id
) is
7563 if not Is_Real_Type
(Etype
(Bound
)) then
7565 ("bound in real type definition must be of real type", Bound
);
7567 elsif not Is_OK_Static_Expression
(Bound
) then
7568 Flag_Non_Static_Expr
7569 ("non-static expression used for real type bound!", Bound
);
7576 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
7578 Resolve
(Bound
, Standard_Float
);
7579 end Check_Real_Bound
;
7581 ------------------------
7582 -- Collect_Interfaces --
7583 ------------------------
7585 procedure Collect_Interfaces
(N
: Node_Id
; Derived_Type
: Entity_Id
) is
7588 procedure Add_Interface
(Iface
: Entity_Id
);
7589 -- Add one interface
7595 procedure Add_Interface
(Iface
: Entity_Id
) is
7599 Elmt
:= First_Elmt
(Abstract_Interfaces
(Derived_Type
));
7600 while Present
(Elmt
) and then Node
(Elmt
) /= Iface
loop
7604 if not Present
(Elmt
) then
7605 Append_Elmt
(Node
=> Iface
,
7606 To
=> Abstract_Interfaces
(Derived_Type
));
7610 -- Start of processing for Add_Interface
7613 pragma Assert
(False
7614 or else Nkind
(N
) = N_Derived_Type_Definition
7615 or else Nkind
(N
) = N_Record_Definition
7616 or else Nkind
(N
) = N_Private_Extension_Declaration
);
7618 -- Traverse the graph of ancestor interfaces
7620 if Is_Non_Empty_List
(Interface_List
(N
)) then
7621 Intf
:= First
(Interface_List
(N
));
7622 while Present
(Intf
) loop
7624 -- Protect against wrong uses. For example:
7625 -- type I is interface;
7626 -- type O is tagged null record;
7627 -- type Wrong is new I and O with null record; -- ERROR
7629 if Is_Interface
(Etype
(Intf
)) then
7631 -- Do not add the interface when the derived type already
7632 -- implements this interface
7634 if not Interface_Present_In_Ancestor
(Derived_Type
,
7638 (Type_Definition
(Parent
(Etype
(Intf
))),
7640 Add_Interface
(Etype
(Intf
));
7647 end Collect_Interfaces
;
7649 ------------------------------
7650 -- Complete_Private_Subtype --
7651 ------------------------------
7653 procedure Complete_Private_Subtype
7656 Full_Base
: Entity_Id
;
7657 Related_Nod
: Node_Id
)
7659 Save_Next_Entity
: Entity_Id
;
7660 Save_Homonym
: Entity_Id
;
7663 -- Set semantic attributes for (implicit) private subtype completion.
7664 -- If the full type has no discriminants, then it is a copy of the full
7665 -- view of the base. Otherwise, it is a subtype of the base with a
7666 -- possible discriminant constraint. Save and restore the original
7667 -- Next_Entity field of full to ensure that the calls to Copy_Node
7668 -- do not corrupt the entity chain.
7670 -- Note that the type of the full view is the same entity as the type of
7671 -- the partial view. In this fashion, the subtype has access to the
7672 -- correct view of the parent.
7674 Save_Next_Entity
:= Next_Entity
(Full
);
7675 Save_Homonym
:= Homonym
(Priv
);
7677 case Ekind
(Full_Base
) is
7678 when E_Record_Type |
7684 Copy_Node
(Priv
, Full
);
7686 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
7687 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
7688 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
7691 Copy_Node
(Full_Base
, Full
);
7692 Set_Chars
(Full
, Chars
(Priv
));
7693 Conditional_Delay
(Full
, Priv
);
7694 Set_Sloc
(Full
, Sloc
(Priv
));
7697 Set_Next_Entity
(Full
, Save_Next_Entity
);
7698 Set_Homonym
(Full
, Save_Homonym
);
7699 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
7701 -- Set common attributes for all subtypes
7703 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
7705 -- The Etype of the full view is inconsistent. Gigi needs to see the
7706 -- structural full view, which is what the current scheme gives:
7707 -- the Etype of the full view is the etype of the full base. However,
7708 -- if the full base is a derived type, the full view then looks like
7709 -- a subtype of the parent, not a subtype of the full base. If instead
7712 -- Set_Etype (Full, Full_Base);
7714 -- then we get inconsistencies in the front-end (confusion between
7715 -- views). Several outstanding bugs are related to this ???
7717 Set_Is_First_Subtype
(Full
, False);
7718 Set_Scope
(Full
, Scope
(Priv
));
7719 Set_Size_Info
(Full
, Full_Base
);
7720 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
7721 Set_Is_Itype
(Full
);
7723 -- A subtype of a private-type-without-discriminants, whose full-view
7724 -- has discriminants with default expressions, is not constrained!
7726 if not Has_Discriminants
(Priv
) then
7727 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
7729 if Has_Discriminants
(Full_Base
) then
7730 Set_Discriminant_Constraint
7731 (Full
, Discriminant_Constraint
(Full_Base
));
7733 -- The partial view may have been indefinite, the full view
7736 Set_Has_Unknown_Discriminants
7737 (Full
, Has_Unknown_Discriminants
(Full_Base
));
7741 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
7742 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
7744 -- Freeze the private subtype entity if its parent is delayed, and not
7745 -- already frozen. We skip this processing if the type is an anonymous
7746 -- subtype of a record component, or is the corresponding record of a
7747 -- protected type, since ???
7749 if not Is_Type
(Scope
(Full
)) then
7750 Set_Has_Delayed_Freeze
(Full
,
7751 Has_Delayed_Freeze
(Full_Base
)
7752 and then (not Is_Frozen
(Full_Base
)));
7755 Set_Freeze_Node
(Full
, Empty
);
7756 Set_Is_Frozen
(Full
, False);
7757 Set_Full_View
(Priv
, Full
);
7759 if Has_Discriminants
(Full
) then
7760 Set_Stored_Constraint_From_Discriminant_Constraint
(Full
);
7761 Set_Stored_Constraint
(Priv
, Stored_Constraint
(Full
));
7763 if Has_Unknown_Discriminants
(Full
) then
7764 Set_Discriminant_Constraint
(Full
, No_Elist
);
7768 if Ekind
(Full_Base
) = E_Record_Type
7769 and then Has_Discriminants
(Full_Base
)
7770 and then Has_Discriminants
(Priv
) -- might not, if errors
7771 and then not Has_Unknown_Discriminants
(Priv
)
7772 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
7774 Create_Constrained_Components
7775 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
7777 -- If the full base is itself derived from private, build a congruent
7778 -- subtype of its underlying type, for use by the back end. For a
7779 -- constrained record component, the declaration cannot be placed on
7780 -- the component list, but it must nevertheless be built an analyzed, to
7781 -- supply enough information for Gigi to compute the size of component.
7783 elsif Ekind
(Full_Base
) in Private_Kind
7784 and then Is_Derived_Type
(Full_Base
)
7785 and then Has_Discriminants
(Full_Base
)
7786 and then (Ekind
(Current_Scope
) /= E_Record_Subtype
)
7788 if not Is_Itype
(Priv
)
7790 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
7792 Build_Underlying_Full_View
7793 (Parent
(Priv
), Full
, Etype
(Full_Base
));
7795 elsif Nkind
(Related_Nod
) = N_Component_Declaration
then
7796 Build_Underlying_Full_View
(Related_Nod
, Full
, Etype
(Full_Base
));
7799 elsif Is_Record_Type
(Full_Base
) then
7801 -- Show Full is simply a renaming of Full_Base
7803 Set_Cloned_Subtype
(Full
, Full_Base
);
7806 -- It is unsafe to share to bounds of a scalar type, because the Itype
7807 -- is elaborated on demand, and if a bound is non-static then different
7808 -- orders of elaboration in different units will lead to different
7809 -- external symbols.
7811 if Is_Scalar_Type
(Full_Base
) then
7812 Set_Scalar_Range
(Full
,
7813 Make_Range
(Sloc
(Related_Nod
),
7815 Duplicate_Subexpr_No_Checks
(Type_Low_Bound
(Full_Base
)),
7817 Duplicate_Subexpr_No_Checks
(Type_High_Bound
(Full_Base
))));
7819 -- This completion inherits the bounds of the full parent, but if
7820 -- the parent is an unconstrained floating point type, so is the
7823 if Is_Floating_Point_Type
(Full_Base
) then
7824 Set_Includes_Infinities
7825 (Scalar_Range
(Full
), Has_Infinities
(Full_Base
));
7829 -- ??? It seems that a lot of fields are missing that should be copied
7830 -- from Full_Base to Full. Here are some that are introduced in a
7831 -- non-disruptive way but a cleanup is necessary.
7833 if Is_Tagged_Type
(Full_Base
) then
7834 Set_Is_Tagged_Type
(Full
);
7835 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
7836 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Full_Base
));
7838 -- If this is a subtype of a protected or task type, constrain its
7839 -- corresponding record, unless this is a subtype without constraints,
7840 -- i.e. a simple renaming as with an actual subtype in an instance.
7842 elsif Is_Concurrent_Type
(Full_Base
) then
7843 if Has_Discriminants
(Full
)
7844 and then Present
(Corresponding_Record_Type
(Full_Base
))
7846 not Is_Empty_Elmt_List
(Discriminant_Constraint
(Full
))
7848 Set_Corresponding_Record_Type
(Full
,
7849 Constrain_Corresponding_Record
7850 (Full
, Corresponding_Record_Type
(Full_Base
),
7851 Related_Nod
, Full_Base
));
7854 Set_Corresponding_Record_Type
(Full
,
7855 Corresponding_Record_Type
(Full_Base
));
7858 end Complete_Private_Subtype
;
7860 -------------------------------------
7861 -- Complete_Subprograms_Derivation --
7862 -------------------------------------
7864 procedure Complete_Subprograms_Derivation
7865 (Partial_View
: Entity_Id
;
7866 Derived_Type
: Entity_Id
)
7868 Result
: constant Elist_Id
:= New_Elmt_List
;
7872 Prim_Op
: Entity_Id
;
7876 if Is_Tagged_Type
(Partial_View
) then
7877 Elmt_P
:= First_Elmt
(Primitive_Operations
(Partial_View
));
7882 -- Inherit primitives declared with the partial-view
7884 while Present
(Elmt_P
) loop
7885 Prim_Op
:= Node
(Elmt_P
);
7887 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
7888 while Present
(Elmt_D
) loop
7889 if Node
(Elmt_D
) = Prim_Op
then
7898 Append_Elmt
(Prim_Op
, Result
);
7900 -- Search for entries associated with abstract interfaces that
7901 -- have been covered by this primitive
7903 Elmt_D
:= First_Elmt
(Primitive_Operations
(Derived_Type
));
7904 while Present
(Elmt_D
) loop
7907 if Chars
(E
) = Chars
(Prim_Op
)
7908 and then Is_Abstract
(E
)
7909 and then Present
(Alias
(E
))
7910 and then Present
(DTC_Entity
(Alias
(E
)))
7911 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(E
))))
7913 Remove_Elmt
(Primitive_Operations
(Derived_Type
), Elmt_D
);
7923 -- Append the entities of the full-view to the list of primitives
7926 Elmt_D
:= First_Elmt
(Result
);
7927 while Present
(Elmt_D
) loop
7928 Append_Elmt
(Node
(Elmt_D
), Primitive_Operations
(Derived_Type
));
7931 end Complete_Subprograms_Derivation
;
7933 ----------------------------
7934 -- Constant_Redeclaration --
7935 ----------------------------
7937 procedure Constant_Redeclaration
7942 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
7943 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
7946 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
7947 -- If deferred constant is an access type initialized with an allocator,
7948 -- check whether there is an illegal recursion in the definition,
7949 -- through a default value of some record subcomponent. This is normally
7950 -- detected when generating init procs, but requires this additional
7951 -- mechanism when expansion is disabled.
7953 ---------------------------------
7954 -- Check_Recursive_Declaration --
7955 ---------------------------------
7957 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
7961 if Is_Record_Type
(Typ
) then
7962 Comp
:= First_Component
(Typ
);
7963 while Present
(Comp
) loop
7964 if Comes_From_Source
(Comp
) then
7965 if Present
(Expression
(Parent
(Comp
)))
7966 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
7967 and then Entity
(Expression
(Parent
(Comp
))) = Prev
7969 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
7971 ("illegal circularity with declaration for&#",
7975 elsif Is_Record_Type
(Etype
(Comp
)) then
7976 Check_Recursive_Declaration
(Etype
(Comp
));
7980 Next_Component
(Comp
);
7983 end Check_Recursive_Declaration
;
7985 -- Start of processing for Constant_Redeclaration
7988 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
7989 if Nkind
(Object_Definition
7990 (Parent
(Prev
))) = N_Subtype_Indication
7992 -- Find type of new declaration. The constraints of the two
7993 -- views must match statically, but there is no point in
7994 -- creating an itype for the full view.
7996 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
7997 Find_Type
(Subtype_Mark
(Obj_Def
));
7998 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
8001 Find_Type
(Obj_Def
);
8002 New_T
:= Entity
(Obj_Def
);
8008 -- The full view may impose a constraint, even if the partial
8009 -- view does not, so construct the subtype.
8011 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
8016 -- Current declaration is illegal, diagnosed below in Enter_Name
8022 -- If previous full declaration exists, or if a homograph is present,
8023 -- let Enter_Name handle it, either with an error, or with the removal
8024 -- of an overridden implicit subprogram.
8026 if Ekind
(Prev
) /= E_Constant
8027 or else Present
(Expression
(Parent
(Prev
)))
8028 or else Present
(Full_View
(Prev
))
8032 -- Verify that types of both declarations match, or else that both types
8033 -- are anonymous access types whose designated subtypes statically match
8034 -- (as allowed in Ada 2005 by AI-385).
8036 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
)
8038 (Ekind
(Etype
(Prev
)) /= E_Anonymous_Access_Type
8039 or else Ekind
(Etype
(New_T
)) /= E_Anonymous_Access_Type
8040 or else not Subtypes_Statically_Match
8041 (Designated_Type
(Etype
(Prev
)),
8042 Designated_Type
(Etype
(New_T
))))
8044 Error_Msg_Sloc
:= Sloc
(Prev
);
8045 Error_Msg_N
("type does not match declaration#", N
);
8046 Set_Full_View
(Prev
, Id
);
8047 Set_Etype
(Id
, Any_Type
);
8049 -- If so, process the full constant declaration
8052 Set_Full_View
(Prev
, Id
);
8053 Set_Is_Public
(Id
, Is_Public
(Prev
));
8054 Set_Is_Internal
(Id
);
8055 Append_Entity
(Id
, Current_Scope
);
8057 -- Check ALIASED present if present before (RM 7.4(7))
8059 if Is_Aliased
(Prev
)
8060 and then not Aliased_Present
(N
)
8062 Error_Msg_Sloc
:= Sloc
(Prev
);
8063 Error_Msg_N
("ALIASED required (see declaration#)", N
);
8066 -- Check that placement is in private part and that the incomplete
8067 -- declaration appeared in the visible part.
8069 if Ekind
(Current_Scope
) = E_Package
8070 and then not In_Private_Part
(Current_Scope
)
8072 Error_Msg_Sloc
:= Sloc
(Prev
);
8073 Error_Msg_N
("full constant for declaration#"
8074 & " must be in private part", N
);
8076 elsif Ekind
(Current_Scope
) = E_Package
8077 and then List_Containing
(Parent
(Prev
))
8078 /= Visible_Declarations
8079 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
8082 ("deferred constant must be declared in visible part",
8086 if Is_Access_Type
(T
)
8087 and then Nkind
(Expression
(N
)) = N_Allocator
8089 Check_Recursive_Declaration
(Designated_Type
(T
));
8092 end Constant_Redeclaration
;
8094 ----------------------
8095 -- Constrain_Access --
8096 ----------------------
8098 procedure Constrain_Access
8099 (Def_Id
: in out Entity_Id
;
8101 Related_Nod
: Node_Id
)
8103 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8104 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
8105 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
8106 Constraint_OK
: Boolean := True;
8108 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean;
8109 -- Simple predicate to test for defaulted discriminants
8110 -- Shouldn't this be in sem_util???
8112 ---------------------------------
8113 -- Has_Defaulted_Discriminants --
8114 ---------------------------------
8116 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean is
8118 return Has_Discriminants
(Typ
)
8119 and then Present
(First_Discriminant
(Typ
))
8121 (Discriminant_Default_Value
(First_Discriminant
(Typ
)));
8122 end Has_Defaulted_Discriminants
;
8124 -- Start of processing for Constrain_Access
8127 if Is_Array_Type
(Desig_Type
) then
8128 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
8130 elsif (Is_Record_Type
(Desig_Type
)
8131 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
8132 and then not Is_Constrained
(Desig_Type
)
8134 -- ??? The following code is a temporary kludge to ignore a
8135 -- discriminant constraint on access type if it is constraining
8136 -- the current record. Avoid creating the implicit subtype of the
8137 -- record we are currently compiling since right now, we cannot
8138 -- handle these. For now, just return the access type itself.
8140 if Desig_Type
= Current_Scope
8141 and then No
(Def_Id
)
8143 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
8144 Def_Id
:= Entity
(Subtype_Mark
(S
));
8146 -- This call added to ensure that the constraint is analyzed
8147 -- (needed for a B test). Note that we still return early from
8148 -- this procedure to avoid recursive processing. ???
8150 Constrain_Discriminated_Type
8151 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
8155 if Ekind
(T
) = E_General_Access_Type
8156 and then Has_Private_Declaration
(Desig_Type
)
8157 and then In_Open_Scopes
(Scope
(Desig_Type
))
8159 -- Enforce rule that the constraint is illegal if there is
8160 -- an unconstrained view of the designated type. This means
8161 -- that the partial view (either a private type declaration or
8162 -- a derivation from a private type) has no discriminants.
8163 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
8164 -- by ACATS B371001).
8165 -- Rule updated for Ada 2005: the private type is said to have
8166 -- a constrained partial view, given that objects of the type
8170 Pack
: constant Node_Id
:=
8171 Unit_Declaration_Node
(Scope
(Desig_Type
));
8176 if Nkind
(Pack
) = N_Package_Declaration
then
8177 Decls
:= Visible_Declarations
(Specification
(Pack
));
8178 Decl
:= First
(Decls
);
8179 while Present
(Decl
) loop
8180 if (Nkind
(Decl
) = N_Private_Type_Declaration
8182 Chars
(Defining_Identifier
(Decl
)) =
8186 (Nkind
(Decl
) = N_Full_Type_Declaration
8188 Chars
(Defining_Identifier
(Decl
)) =
8190 and then Is_Derived_Type
(Desig_Type
)
8192 Has_Private_Declaration
(Etype
(Desig_Type
)))
8194 if No
(Discriminant_Specifications
(Decl
)) then
8196 ("cannot constrain general access type if " &
8197 "designated type has constrained partial view",
8210 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
8211 For_Access
=> True);
8213 elsif (Is_Task_Type
(Desig_Type
)
8214 or else Is_Protected_Type
(Desig_Type
))
8215 and then not Is_Constrained
(Desig_Type
)
8217 Constrain_Concurrent
8218 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
8221 Error_Msg_N
("invalid constraint on access type", S
);
8222 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
8223 Constraint_OK
:= False;
8227 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
8229 Set_Ekind
(Def_Id
, E_Access_Subtype
);
8232 if Constraint_OK
then
8233 Set_Etype
(Def_Id
, Base_Type
(T
));
8235 if Is_Private_Type
(Desig_Type
) then
8236 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
8239 Set_Etype
(Def_Id
, Any_Type
);
8242 Set_Size_Info
(Def_Id
, T
);
8243 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
8244 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
8245 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8246 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
8248 Conditional_Delay
(Def_Id
, T
);
8250 -- AI-363 : Subtypes of general access types whose designated types have
8251 -- default discriminants are disallowed. In instances, the rule has to
8252 -- be checked against the actual, of which T is the subtype. In a
8253 -- generic body, the rule is checked assuming that the actual type has
8254 -- defaulted discriminants.
8256 if Ada_Version
>= Ada_05
then
8257 if Ekind
(Base_Type
(T
)) = E_General_Access_Type
8258 and then Has_Defaulted_Discriminants
(Desig_Type
)
8261 ("access subype of general access type not allowed", S
);
8262 Error_Msg_N
("\ when discriminants have defaults", S
);
8264 elsif Is_Access_Type
(T
)
8265 and then Is_Generic_Type
(Desig_Type
)
8266 and then Has_Discriminants
(Desig_Type
)
8267 and then In_Package_Body
(Current_Scope
)
8269 Error_Msg_N
("access subtype not allowed in generic body", S
);
8271 ("\ wben designated type is a discriminated formal", S
);
8274 end Constrain_Access
;
8276 ---------------------
8277 -- Constrain_Array --
8278 ---------------------
8280 procedure Constrain_Array
8281 (Def_Id
: in out Entity_Id
;
8283 Related_Nod
: Node_Id
;
8284 Related_Id
: Entity_Id
;
8287 C
: constant Node_Id
:= Constraint
(SI
);
8288 Number_Of_Constraints
: Nat
:= 0;
8291 Constraint_OK
: Boolean := True;
8294 T
:= Entity
(Subtype_Mark
(SI
));
8296 if Ekind
(T
) in Access_Kind
then
8297 T
:= Designated_Type
(T
);
8300 -- If an index constraint follows a subtype mark in a subtype indication
8301 -- then the type or subtype denoted by the subtype mark must not already
8302 -- impose an index constraint. The subtype mark must denote either an
8303 -- unconstrained array type or an access type whose designated type
8304 -- is such an array type... (RM 3.6.1)
8306 if Is_Constrained
(T
) then
8308 ("array type is already constrained", Subtype_Mark
(SI
));
8309 Constraint_OK
:= False;
8312 S
:= First
(Constraints
(C
));
8313 while Present
(S
) loop
8314 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
8318 -- In either case, the index constraint must provide a discrete
8319 -- range for each index of the array type and the type of each
8320 -- discrete range must be the same as that of the corresponding
8321 -- index. (RM 3.6.1)
8323 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
8324 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
8325 Constraint_OK
:= False;
8328 S
:= First
(Constraints
(C
));
8329 Index
:= First_Index
(T
);
8332 -- Apply constraints to each index type
8334 for J
in 1 .. Number_Of_Constraints
loop
8335 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
8345 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
8346 Set_Parent
(Def_Id
, Related_Nod
);
8349 Set_Ekind
(Def_Id
, E_Array_Subtype
);
8352 Set_Size_Info
(Def_Id
, (T
));
8353 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8354 Set_Etype
(Def_Id
, Base_Type
(T
));
8356 if Constraint_OK
then
8357 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
8359 Set_First_Index
(Def_Id
, First_Index
(T
));
8362 Set_Is_Constrained
(Def_Id
, True);
8363 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
8364 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8366 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
8367 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
8369 -- Build a freeze node if parent still needs one. Also, make sure
8370 -- that the Depends_On_Private status is set (explanation ???)
8371 -- and also that a conditional delay is set.
8373 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
8374 Conditional_Delay
(Def_Id
, T
);
8376 end Constrain_Array
;
8378 ------------------------------
8379 -- Constrain_Component_Type --
8380 ------------------------------
8382 function Constrain_Component_Type
8384 Constrained_Typ
: Entity_Id
;
8385 Related_Node
: Node_Id
;
8387 Constraints
: Elist_Id
) return Entity_Id
8389 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
8390 Compon_Type
: constant Entity_Id
:= Etype
(Comp
);
8392 function Build_Constrained_Array_Type
8393 (Old_Type
: Entity_Id
) return Entity_Id
;
8394 -- If Old_Type is an array type, one of whose indices is constrained
8395 -- by a discriminant, build an Itype whose constraint replaces the
8396 -- discriminant with its value in the constraint.
8398 function Build_Constrained_Discriminated_Type
8399 (Old_Type
: Entity_Id
) return Entity_Id
;
8400 -- Ditto for record components
8402 function Build_Constrained_Access_Type
8403 (Old_Type
: Entity_Id
) return Entity_Id
;
8404 -- Ditto for access types. Makes use of previous two functions, to
8405 -- constrain designated type.
8407 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
8408 -- T is an array or discriminated type, C is a list of constraints
8409 -- that apply to T. This routine builds the constrained subtype.
8411 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
8412 -- Returns True if Expr is a discriminant
8414 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
8415 -- Find the value of discriminant Discrim in Constraint
8417 -----------------------------------
8418 -- Build_Constrained_Access_Type --
8419 -----------------------------------
8421 function Build_Constrained_Access_Type
8422 (Old_Type
: Entity_Id
) return Entity_Id
8424 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
8426 Desig_Subtype
: Entity_Id
;
8430 -- if the original access type was not embedded in the enclosing
8431 -- type definition, there is no need to produce a new access
8432 -- subtype. In fact every access type with an explicit constraint
8433 -- generates an itype whose scope is the enclosing record.
8435 if not Is_Type
(Scope
(Old_Type
)) then
8438 elsif Is_Array_Type
(Desig_Type
) then
8439 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
8441 elsif Has_Discriminants
(Desig_Type
) then
8443 -- This may be an access type to an enclosing record type for
8444 -- which we are constructing the constrained components. Return
8445 -- the enclosing record subtype. This is not always correct,
8446 -- but avoids infinite recursion. ???
8448 Desig_Subtype
:= Any_Type
;
8450 for J
in reverse 0 .. Scope_Stack
.Last
loop
8451 Scop
:= Scope_Stack
.Table
(J
).Entity
;
8454 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
8456 Desig_Subtype
:= Scop
;
8459 exit when not Is_Type
(Scop
);
8462 if Desig_Subtype
= Any_Type
then
8464 Build_Constrained_Discriminated_Type
(Desig_Type
);
8471 if Desig_Subtype
/= Desig_Type
then
8473 -- The Related_Node better be here or else we won't be able
8474 -- to attach new itypes to a node in the tree.
8476 pragma Assert
(Present
(Related_Node
));
8478 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
8480 Set_Etype
(Itype
, Base_Type
(Old_Type
));
8481 Set_Size_Info
(Itype
, (Old_Type
));
8482 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
8483 Set_Depends_On_Private
(Itype
, Has_Private_Component
8485 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
8488 -- The new itype needs freezing when it depends on a not frozen
8489 -- type and the enclosing subtype needs freezing.
8491 if Has_Delayed_Freeze
(Constrained_Typ
)
8492 and then not Is_Frozen
(Constrained_Typ
)
8494 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
8502 end Build_Constrained_Access_Type
;
8504 ----------------------------------
8505 -- Build_Constrained_Array_Type --
8506 ----------------------------------
8508 function Build_Constrained_Array_Type
8509 (Old_Type
: Entity_Id
) return Entity_Id
8513 Old_Index
: Node_Id
;
8514 Range_Node
: Node_Id
;
8515 Constr_List
: List_Id
;
8517 Need_To_Create_Itype
: Boolean := False;
8520 Old_Index
:= First_Index
(Old_Type
);
8521 while Present
(Old_Index
) loop
8522 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8524 if Is_Discriminant
(Lo_Expr
)
8525 or else Is_Discriminant
(Hi_Expr
)
8527 Need_To_Create_Itype
:= True;
8530 Next_Index
(Old_Index
);
8533 if Need_To_Create_Itype
then
8534 Constr_List
:= New_List
;
8536 Old_Index
:= First_Index
(Old_Type
);
8537 while Present
(Old_Index
) loop
8538 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8540 if Is_Discriminant
(Lo_Expr
) then
8541 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
8544 if Is_Discriminant
(Hi_Expr
) then
8545 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
8550 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
8552 Append
(Range_Node
, To
=> Constr_List
);
8554 Next_Index
(Old_Index
);
8557 return Build_Subtype
(Old_Type
, Constr_List
);
8562 end Build_Constrained_Array_Type
;
8564 ------------------------------------------
8565 -- Build_Constrained_Discriminated_Type --
8566 ------------------------------------------
8568 function Build_Constrained_Discriminated_Type
8569 (Old_Type
: Entity_Id
) return Entity_Id
8572 Constr_List
: List_Id
;
8573 Old_Constraint
: Elmt_Id
;
8575 Need_To_Create_Itype
: Boolean := False;
8578 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8579 while Present
(Old_Constraint
) loop
8580 Expr
:= Node
(Old_Constraint
);
8582 if Is_Discriminant
(Expr
) then
8583 Need_To_Create_Itype
:= True;
8586 Next_Elmt
(Old_Constraint
);
8589 if Need_To_Create_Itype
then
8590 Constr_List
:= New_List
;
8592 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8593 while Present
(Old_Constraint
) loop
8594 Expr
:= Node
(Old_Constraint
);
8596 if Is_Discriminant
(Expr
) then
8597 Expr
:= Get_Discr_Value
(Expr
);
8600 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
8602 Next_Elmt
(Old_Constraint
);
8605 return Build_Subtype
(Old_Type
, Constr_List
);
8610 end Build_Constrained_Discriminated_Type
;
8616 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
8618 Subtyp_Decl
: Node_Id
;
8620 Btyp
: Entity_Id
:= Base_Type
(T
);
8623 -- The Related_Node better be here or else we won't be able to
8624 -- attach new itypes to a node in the tree.
8626 pragma Assert
(Present
(Related_Node
));
8628 -- If the view of the component's type is incomplete or private
8629 -- with unknown discriminants, then the constraint must be applied
8630 -- to the full type.
8632 if Has_Unknown_Discriminants
(Btyp
)
8633 and then Present
(Underlying_Type
(Btyp
))
8635 Btyp
:= Underlying_Type
(Btyp
);
8639 Make_Subtype_Indication
(Loc
,
8640 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
8641 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
8643 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
8646 Make_Subtype_Declaration
(Loc
,
8647 Defining_Identifier
=> Def_Id
,
8648 Subtype_Indication
=> Indic
);
8650 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
8652 -- Itypes must be analyzed with checks off (see package Itypes)
8654 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
8659 ---------------------
8660 -- Get_Discr_Value --
8661 ---------------------
8663 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
8669 -- The discriminant may be declared for the type, in which case we
8670 -- find it by iterating over the list of discriminants. If the
8671 -- discriminant is inherited from a parent type, it appears as the
8672 -- corresponding discriminant of the current type. This will be the
8673 -- case when constraining an inherited component whose constraint is
8674 -- given by a discriminant of the parent.
8676 D
:= First_Discriminant
(Typ
);
8677 E
:= First_Elmt
(Constraints
);
8678 while Present
(D
) loop
8679 if D
= Entity
(Discrim
)
8680 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
8685 Next_Discriminant
(D
);
8689 -- The corresponding_Discriminant mechanism is incomplete, because
8690 -- the correspondence between new and old discriminants is not one
8691 -- to one: one new discriminant can constrain several old ones. In
8692 -- that case, scan sequentially the stored_constraint, the list of
8693 -- discriminants of the parents, and the constraints.
8695 if Is_Derived_Type
(Typ
)
8696 and then Present
(Stored_Constraint
(Typ
))
8697 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
8699 D
:= First_Discriminant
(Etype
(Typ
));
8700 E
:= First_Elmt
(Constraints
);
8701 G
:= First_Elmt
(Stored_Constraint
(Typ
));
8702 while Present
(D
) loop
8703 if D
= Entity
(Discrim
) then
8707 Next_Discriminant
(D
);
8713 -- Something is wrong if we did not find the value
8715 raise Program_Error
;
8716 end Get_Discr_Value
;
8718 ---------------------
8719 -- Is_Discriminant --
8720 ---------------------
8722 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
8723 Discrim_Scope
: Entity_Id
;
8726 if Denotes_Discriminant
(Expr
) then
8727 Discrim_Scope
:= Scope
(Entity
(Expr
));
8729 -- Either we have a reference to one of Typ's discriminants,
8731 pragma Assert
(Discrim_Scope
= Typ
8733 -- or to the discriminants of the parent type, in the case
8734 -- of a derivation of a tagged type with variants.
8736 or else Discrim_Scope
= Etype
(Typ
)
8737 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
8739 -- or same as above for the case where the discriminants
8740 -- were declared in Typ's private view.
8742 or else (Is_Private_Type
(Discrim_Scope
)
8743 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8745 -- or else we are deriving from the full view and the
8746 -- discriminant is declared in the private entity.
8748 or else (Is_Private_Type
(Typ
)
8749 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8751 -- or we have a class-wide type, in which case make sure the
8752 -- discriminant found belongs to the root type.
8754 or else (Is_Class_Wide_Type
(Typ
)
8755 and then Etype
(Typ
) = Discrim_Scope
));
8760 -- In all other cases we have something wrong
8763 end Is_Discriminant
;
8765 -- Start of processing for Constrain_Component_Type
8768 if Nkind
(Parent
(Comp
)) = N_Component_Declaration
8769 and then Comes_From_Source
(Parent
(Comp
))
8770 and then Comes_From_Source
8771 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8774 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8778 elsif Is_Array_Type
(Compon_Type
) then
8779 return Build_Constrained_Array_Type
(Compon_Type
);
8781 elsif Has_Discriminants
(Compon_Type
) then
8782 return Build_Constrained_Discriminated_Type
(Compon_Type
);
8784 elsif Is_Access_Type
(Compon_Type
) then
8785 return Build_Constrained_Access_Type
(Compon_Type
);
8790 end Constrain_Component_Type
;
8792 --------------------------
8793 -- Constrain_Concurrent --
8794 --------------------------
8796 -- For concurrent types, the associated record value type carries the same
8797 -- discriminants, so when we constrain a concurrent type, we must constrain
8798 -- the value type as well.
8800 procedure Constrain_Concurrent
8801 (Def_Id
: in out Entity_Id
;
8803 Related_Nod
: Node_Id
;
8804 Related_Id
: Entity_Id
;
8807 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
8811 if Ekind
(T_Ent
) in Access_Kind
then
8812 T_Ent
:= Designated_Type
(T_Ent
);
8815 T_Val
:= Corresponding_Record_Type
(T_Ent
);
8817 if Present
(T_Val
) then
8820 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8823 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8825 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8826 Set_Corresponding_Record_Type
(Def_Id
,
8827 Constrain_Corresponding_Record
8828 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
8831 -- If there is no associated record, expansion is disabled and this
8832 -- is a generic context. Create a subtype in any case, so that
8833 -- semantic analysis can proceed.
8836 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8839 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8841 end Constrain_Concurrent
;
8843 ------------------------------------
8844 -- Constrain_Corresponding_Record --
8845 ------------------------------------
8847 function Constrain_Corresponding_Record
8848 (Prot_Subt
: Entity_Id
;
8849 Corr_Rec
: Entity_Id
;
8850 Related_Nod
: Node_Id
;
8851 Related_Id
: Entity_Id
) return Entity_Id
8853 T_Sub
: constant Entity_Id
:=
8854 Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
8857 Set_Etype
(T_Sub
, Corr_Rec
);
8858 Init_Size_Align
(T_Sub
);
8859 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
8860 Set_Is_Constrained
(T_Sub
, True);
8861 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
8862 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
8864 Conditional_Delay
(T_Sub
, Corr_Rec
);
8866 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
8867 Set_Discriminant_Constraint
8868 (T_Sub
, Discriminant_Constraint
(Prot_Subt
));
8869 Set_Stored_Constraint_From_Discriminant_Constraint
(T_Sub
);
8870 Create_Constrained_Components
8871 (T_Sub
, Related_Nod
, Corr_Rec
, Discriminant_Constraint
(T_Sub
));
8874 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
8877 end Constrain_Corresponding_Record
;
8879 -----------------------
8880 -- Constrain_Decimal --
8881 -----------------------
8883 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
8884 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8885 C
: constant Node_Id
:= Constraint
(S
);
8886 Loc
: constant Source_Ptr
:= Sloc
(C
);
8887 Range_Expr
: Node_Id
;
8888 Digits_Expr
: Node_Id
;
8893 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
8895 if Nkind
(C
) = N_Range_Constraint
then
8896 Range_Expr
:= Range_Expression
(C
);
8897 Digits_Val
:= Digits_Value
(T
);
8900 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
8901 Digits_Expr
:= Digits_Expression
(C
);
8902 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
8904 Check_Digits_Expression
(Digits_Expr
);
8905 Digits_Val
:= Expr_Value
(Digits_Expr
);
8907 if Digits_Val
> Digits_Value
(T
) then
8909 ("digits expression is incompatible with subtype", C
);
8910 Digits_Val
:= Digits_Value
(T
);
8913 if Present
(Range_Constraint
(C
)) then
8914 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
8916 Range_Expr
:= Empty
;
8920 Set_Etype
(Def_Id
, Base_Type
(T
));
8921 Set_Size_Info
(Def_Id
, (T
));
8922 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8923 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
8924 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
8925 Set_Small_Value
(Def_Id
, Small_Value
(T
));
8926 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
8927 Set_Digits_Value
(Def_Id
, Digits_Val
);
8929 -- Manufacture range from given digits value if no range present
8931 if No
(Range_Expr
) then
8932 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
8936 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
8938 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
8941 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
8942 Set_Discrete_RM_Size
(Def_Id
);
8944 -- Unconditionally delay the freeze, since we cannot set size
8945 -- information in all cases correctly until the freeze point.
8947 Set_Has_Delayed_Freeze
(Def_Id
);
8948 end Constrain_Decimal
;
8950 ----------------------------------
8951 -- Constrain_Discriminated_Type --
8952 ----------------------------------
8954 procedure Constrain_Discriminated_Type
8955 (Def_Id
: Entity_Id
;
8957 Related_Nod
: Node_Id
;
8958 For_Access
: Boolean := False)
8960 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8963 Elist
: Elist_Id
:= New_Elmt_List
;
8965 procedure Fixup_Bad_Constraint
;
8966 -- This is called after finding a bad constraint, and after having
8967 -- posted an appropriate error message. The mission is to leave the
8968 -- entity T in as reasonable state as possible!
8970 --------------------------
8971 -- Fixup_Bad_Constraint --
8972 --------------------------
8974 procedure Fixup_Bad_Constraint
is
8976 -- Set a reasonable Ekind for the entity. For an incomplete type,
8977 -- we can't do much, but for other types, we can set the proper
8978 -- corresponding subtype kind.
8980 if Ekind
(T
) = E_Incomplete_Type
then
8981 Set_Ekind
(Def_Id
, Ekind
(T
));
8983 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
8986 Set_Etype
(Def_Id
, Any_Type
);
8987 Set_Error_Posted
(Def_Id
);
8988 end Fixup_Bad_Constraint
;
8990 -- Start of processing for Constrain_Discriminated_Type
8993 C
:= Constraint
(S
);
8995 -- A discriminant constraint is only allowed in a subtype indication,
8996 -- after a subtype mark. This subtype mark must denote either a type
8997 -- with discriminants, or an access type whose designated type is a
8998 -- type with discriminants. A discriminant constraint specifies the
8999 -- values of these discriminants (RM 3.7.2(5)).
9001 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
9003 if Ekind
(T
) in Access_Kind
then
9004 T
:= Designated_Type
(T
);
9007 -- Check that the type has visible discriminants. The type may be
9008 -- a private type with unknown discriminants whose full view has
9009 -- discriminants which are invisible.
9011 if not Has_Discriminants
(T
)
9013 (Has_Unknown_Discriminants
(T
)
9014 and then Is_Private_Type
(T
))
9016 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
9017 Fixup_Bad_Constraint
;
9020 elsif Is_Constrained
(E
)
9021 or else (Ekind
(E
) = E_Class_Wide_Subtype
9022 and then Present
(Discriminant_Constraint
(E
)))
9024 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
9025 Fixup_Bad_Constraint
;
9029 -- T may be an unconstrained subtype (e.g. a generic actual).
9030 -- Constraint applies to the base type.
9034 Elist
:= Build_Discriminant_Constraints
(T
, S
);
9036 -- If the list returned was empty we had an error in building the
9037 -- discriminant constraint. We have also already signalled an error
9038 -- in the incomplete type case
9040 if Is_Empty_Elmt_List
(Elist
) then
9041 Fixup_Bad_Constraint
;
9045 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
9046 end Constrain_Discriminated_Type
;
9048 ---------------------------
9049 -- Constrain_Enumeration --
9050 ---------------------------
9052 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
9053 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9054 C
: constant Node_Id
:= Constraint
(S
);
9057 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9059 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
9061 Set_Etype
(Def_Id
, Base_Type
(T
));
9062 Set_Size_Info
(Def_Id
, (T
));
9063 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9064 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9066 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9068 Set_Discrete_RM_Size
(Def_Id
);
9069 end Constrain_Enumeration
;
9071 ----------------------
9072 -- Constrain_Float --
9073 ----------------------
9075 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
9076 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9082 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
9084 Set_Etype
(Def_Id
, Base_Type
(T
));
9085 Set_Size_Info
(Def_Id
, (T
));
9086 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9088 -- Process the constraint
9090 C
:= Constraint
(S
);
9092 -- Digits constraint present
9094 if Nkind
(C
) = N_Digits_Constraint
then
9095 Check_Restriction
(No_Obsolescent_Features
, C
);
9097 if Warn_On_Obsolescent_Feature
then
9099 ("subtype digits constraint is an " &
9100 "obsolescent feature ('R'M 'J.3(8))?", C
);
9103 D
:= Digits_Expression
(C
);
9104 Analyze_And_Resolve
(D
, Any_Integer
);
9105 Check_Digits_Expression
(D
);
9106 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
9108 -- Check that digits value is in range. Obviously we can do this
9109 -- at compile time, but it is strictly a runtime check, and of
9110 -- course there is an ACVC test that checks this!
9112 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
9113 Error_Msg_Uint_1
:= Digits_Value
(T
);
9114 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
9116 Make_Raise_Constraint_Error
(Sloc
(D
),
9117 Reason
=> CE_Range_Check_Failed
);
9118 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9121 C
:= Range_Constraint
(C
);
9123 -- No digits constraint present
9126 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
9129 -- Range constraint present
9131 if Nkind
(C
) = N_Range_Constraint
then
9132 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9134 -- No range constraint present
9137 pragma Assert
(No
(C
));
9138 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9141 Set_Is_Constrained
(Def_Id
);
9142 end Constrain_Float
;
9144 ---------------------
9145 -- Constrain_Index --
9146 ---------------------
9148 procedure Constrain_Index
9151 Related_Nod
: Node_Id
;
9152 Related_Id
: Entity_Id
;
9157 R
: Node_Id
:= Empty
;
9158 T
: constant Entity_Id
:= Etype
(Index
);
9161 if Nkind
(S
) = N_Range
9163 (Nkind
(S
) = N_Attribute_Reference
9164 and then Attribute_Name
(S
) = Name_Range
)
9166 -- A Range attribute will transformed into N_Range by Resolve
9172 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
);
9174 if not Error_Posted
(S
)
9176 (Nkind
(S
) /= N_Range
9177 or else not Covers
(T
, (Etype
(Low_Bound
(S
))))
9178 or else not Covers
(T
, (Etype
(High_Bound
(S
)))))
9180 if Base_Type
(T
) /= Any_Type
9181 and then Etype
(Low_Bound
(S
)) /= Any_Type
9182 and then Etype
(High_Bound
(S
)) /= Any_Type
9184 Error_Msg_N
("range expected", S
);
9188 elsif Nkind
(S
) = N_Subtype_Indication
then
9190 -- The parser has verified that this is a discrete indication
9192 Resolve_Discrete_Subtype_Indication
(S
, T
);
9193 R
:= Range_Expression
(Constraint
(S
));
9195 elsif Nkind
(S
) = N_Discriminant_Association
then
9197 -- Syntactically valid in subtype indication
9199 Error_Msg_N
("invalid index constraint", S
);
9200 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9203 -- Subtype_Mark case, no anonymous subtypes to construct
9208 if Is_Entity_Name
(S
) then
9209 if not Is_Type
(Entity
(S
)) then
9210 Error_Msg_N
("expect subtype mark for index constraint", S
);
9212 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
9213 Wrong_Type
(S
, Base_Type
(T
));
9219 Error_Msg_N
("invalid index constraint", S
);
9220 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9226 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
9228 Set_Etype
(Def_Id
, Base_Type
(T
));
9230 if Is_Modular_Integer_Type
(T
) then
9231 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9233 elsif Is_Integer_Type
(T
) then
9234 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9237 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9238 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9241 Set_Size_Info
(Def_Id
, (T
));
9242 Set_RM_Size
(Def_Id
, RM_Size
(T
));
9243 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9245 Set_Scalar_Range
(Def_Id
, R
);
9247 Set_Etype
(S
, Def_Id
);
9248 Set_Discrete_RM_Size
(Def_Id
);
9249 end Constrain_Index
;
9251 -----------------------
9252 -- Constrain_Integer --
9253 -----------------------
9255 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
9256 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9257 C
: constant Node_Id
:= Constraint
(S
);
9260 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9262 if Is_Modular_Integer_Type
(T
) then
9263 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9265 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9268 Set_Etype
(Def_Id
, Base_Type
(T
));
9269 Set_Size_Info
(Def_Id
, (T
));
9270 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9271 Set_Discrete_RM_Size
(Def_Id
);
9272 end Constrain_Integer
;
9274 ------------------------------
9275 -- Constrain_Ordinary_Fixed --
9276 ------------------------------
9278 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
9279 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9285 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
9286 Set_Etype
(Def_Id
, Base_Type
(T
));
9287 Set_Size_Info
(Def_Id
, (T
));
9288 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9289 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9291 -- Process the constraint
9293 C
:= Constraint
(S
);
9295 -- Delta constraint present
9297 if Nkind
(C
) = N_Delta_Constraint
then
9298 Check_Restriction
(No_Obsolescent_Features
, C
);
9300 if Warn_On_Obsolescent_Feature
then
9302 ("subtype delta constraint is an " &
9303 "obsolescent feature ('R'M 'J.3(7))?");
9306 D
:= Delta_Expression
(C
);
9307 Analyze_And_Resolve
(D
, Any_Real
);
9308 Check_Delta_Expression
(D
);
9309 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
9311 -- Check that delta value is in range. Obviously we can do this
9312 -- at compile time, but it is strictly a runtime check, and of
9313 -- course there is an ACVC test that checks this!
9315 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
9316 Error_Msg_N
("?delta value is too small", D
);
9318 Make_Raise_Constraint_Error
(Sloc
(D
),
9319 Reason
=> CE_Range_Check_Failed
);
9320 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9323 C
:= Range_Constraint
(C
);
9325 -- No delta constraint present
9328 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9331 -- Range constraint present
9333 if Nkind
(C
) = N_Range_Constraint
then
9334 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9336 -- No range constraint present
9339 pragma Assert
(No
(C
));
9340 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9344 Set_Discrete_RM_Size
(Def_Id
);
9346 -- Unconditionally delay the freeze, since we cannot set size
9347 -- information in all cases correctly until the freeze point.
9349 Set_Has_Delayed_Freeze
(Def_Id
);
9350 end Constrain_Ordinary_Fixed
;
9352 ---------------------------
9353 -- Convert_Scalar_Bounds --
9354 ---------------------------
9356 procedure Convert_Scalar_Bounds
9358 Parent_Type
: Entity_Id
;
9359 Derived_Type
: Entity_Id
;
9362 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
9369 Lo
:= Build_Scalar_Bound
9370 (Type_Low_Bound
(Derived_Type
),
9371 Parent_Type
, Implicit_Base
);
9373 Hi
:= Build_Scalar_Bound
9374 (Type_High_Bound
(Derived_Type
),
9375 Parent_Type
, Implicit_Base
);
9382 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
9384 Set_Parent
(Rng
, N
);
9385 Set_Scalar_Range
(Derived_Type
, Rng
);
9387 -- Analyze the bounds
9389 Analyze_And_Resolve
(Lo
, Implicit_Base
);
9390 Analyze_And_Resolve
(Hi
, Implicit_Base
);
9392 -- Analyze the range itself, except that we do not analyze it if
9393 -- the bounds are real literals, and we have a fixed-point type.
9394 -- The reason for this is that we delay setting the bounds in this
9395 -- case till we know the final Small and Size values (see circuit
9396 -- in Freeze.Freeze_Fixed_Point_Type for further details).
9398 if Is_Fixed_Point_Type
(Parent_Type
)
9399 and then Nkind
(Lo
) = N_Real_Literal
9400 and then Nkind
(Hi
) = N_Real_Literal
9404 -- Here we do the analysis of the range
9406 -- Note: we do this manually, since if we do a normal Analyze and
9407 -- Resolve call, there are problems with the conversions used for
9408 -- the derived type range.
9411 Set_Etype
(Rng
, Implicit_Base
);
9412 Set_Analyzed
(Rng
, True);
9414 end Convert_Scalar_Bounds
;
9420 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
) is
9422 -- Initialize new full declaration entity by copying the pertinent
9423 -- fields of the corresponding private declaration entity.
9425 -- We temporarily set Ekind to a value appropriate for a type to
9426 -- avoid assert failures in Einfo from checking for setting type
9427 -- attributes on something that is not a type. Ekind (Priv) is an
9428 -- appropriate choice, since it allowed the attributes to be set
9429 -- in the first place. This Ekind value will be modified later.
9431 Set_Ekind
(Full
, Ekind
(Priv
));
9433 -- Also set Etype temporarily to Any_Type, again, in the absence
9434 -- of errors, it will be properly reset, and if there are errors,
9435 -- then we want a value of Any_Type to remain.
9437 Set_Etype
(Full
, Any_Type
);
9439 -- Now start copying attributes
9441 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
9443 if Has_Discriminants
(Full
) then
9444 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
9445 Set_Stored_Constraint
(Full
, Stored_Constraint
(Priv
));
9448 Set_First_Rep_Item
(Full
, First_Rep_Item
(Priv
));
9449 Set_Homonym
(Full
, Homonym
(Priv
));
9450 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
9451 Set_Is_Public
(Full
, Is_Public
(Priv
));
9452 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
9453 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
9455 Conditional_Delay
(Full
, Priv
);
9457 if Is_Tagged_Type
(Full
) then
9458 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
9460 if Priv
= Base_Type
(Priv
) then
9461 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
9465 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
9466 Set_Treat_As_Volatile
(Full
, Treat_As_Volatile
(Priv
));
9467 Set_Scope
(Full
, Scope
(Priv
));
9468 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
9469 Set_First_Entity
(Full
, First_Entity
(Priv
));
9470 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
9472 -- If access types have been recorded for later handling, keep them in
9473 -- the full view so that they get handled when the full view freeze
9474 -- node is expanded.
9476 if Present
(Freeze_Node
(Priv
))
9477 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
9479 Ensure_Freeze_Node
(Full
);
9480 Set_Access_Types_To_Process
9481 (Freeze_Node
(Full
),
9482 Access_Types_To_Process
(Freeze_Node
(Priv
)));
9485 -- Swap the two entities. Now Privat is the full type entity and
9486 -- Full is the private one. They will be swapped back at the end
9487 -- of the private part. This swapping ensures that the entity that
9488 -- is visible in the private part is the full declaration.
9490 Exchange_Entities
(Priv
, Full
);
9491 Append_Entity
(Full
, Scope
(Full
));
9494 -------------------------------------
9495 -- Copy_Array_Base_Type_Attributes --
9496 -------------------------------------
9498 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
9500 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
9501 Set_Component_Type
(T1
, Component_Type
(T2
));
9502 Set_Component_Size
(T1
, Component_Size
(T2
));
9503 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
9504 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
9505 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
9506 Set_Has_Task
(T1
, Has_Task
(T2
));
9507 Set_Is_Packed
(T1
, Is_Packed
(T2
));
9508 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
9509 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
9510 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
9511 end Copy_Array_Base_Type_Attributes
;
9513 -----------------------------------
9514 -- Copy_Array_Subtype_Attributes --
9515 -----------------------------------
9517 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
9519 Set_Size_Info
(T1
, T2
);
9521 Set_First_Index
(T1
, First_Index
(T2
));
9522 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
9523 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
9524 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
9525 Set_Treat_As_Volatile
(T1
, Treat_As_Volatile
(T2
));
9526 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
9527 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
9528 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
9529 Set_Convention
(T1
, Convention
(T2
));
9530 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
9531 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
9532 end Copy_Array_Subtype_Attributes
;
9534 -----------------------------------
9535 -- Create_Constrained_Components --
9536 -----------------------------------
9538 procedure Create_Constrained_Components
9540 Decl_Node
: Node_Id
;
9542 Constraints
: Elist_Id
)
9544 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
9545 Comp_List
: constant Elist_Id
:= New_Elmt_List
;
9546 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
9547 Assoc_List
: constant List_Id
:= New_List
;
9548 Discr_Val
: Elmt_Id
;
9552 Is_Static
: Boolean := True;
9554 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
9555 -- Collect parent type components that do not appear in a variant part
9557 procedure Create_All_Components
;
9558 -- Iterate over Comp_List to create the components of the subtype
9560 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
9561 -- Creates a new component from Old_Compon, copying all the fields from
9562 -- it, including its Etype, inserts the new component in the Subt entity
9563 -- chain and returns the new component.
9565 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
9566 -- If true, and discriminants are static, collect only components from
9567 -- variants selected by discriminant values.
9569 ------------------------------
9570 -- Collect_Fixed_Components --
9571 ------------------------------
9573 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
9575 -- Build association list for discriminants, and find components of the
9576 -- variant part selected by the values of the discriminants.
9578 Old_C
:= First_Discriminant
(Typ
);
9579 Discr_Val
:= First_Elmt
(Constraints
);
9580 while Present
(Old_C
) loop
9581 Append_To
(Assoc_List
,
9582 Make_Component_Association
(Loc
,
9583 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
9584 Expression
=> New_Copy
(Node
(Discr_Val
))));
9586 Next_Elmt
(Discr_Val
);
9587 Next_Discriminant
(Old_C
);
9590 -- The tag, and the possible parent and controller components
9591 -- are unconditionally in the subtype.
9593 if Is_Tagged_Type
(Typ
)
9594 or else Has_Controlled_Component
(Typ
)
9596 Old_C
:= First_Component
(Typ
);
9597 while Present
(Old_C
) loop
9598 if Chars
((Old_C
)) = Name_uTag
9599 or else Chars
((Old_C
)) = Name_uParent
9600 or else Chars
((Old_C
)) = Name_uController
9602 Append_Elmt
(Old_C
, Comp_List
);
9605 Next_Component
(Old_C
);
9608 end Collect_Fixed_Components
;
9610 ---------------------------
9611 -- Create_All_Components --
9612 ---------------------------
9614 procedure Create_All_Components
is
9618 Comp
:= First_Elmt
(Comp_List
);
9619 while Present
(Comp
) loop
9620 Old_C
:= Node
(Comp
);
9621 New_C
:= Create_Component
(Old_C
);
9625 Constrain_Component_Type
9626 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9627 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9631 end Create_All_Components
;
9633 ----------------------
9634 -- Create_Component --
9635 ----------------------
9637 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
9638 New_Compon
: constant Entity_Id
:= New_Copy
(Old_Compon
);
9641 -- Set the parent so we have a proper link for freezing etc. This
9642 -- is not a real parent pointer, since of course our parent does
9643 -- not own up to us and reference us, we are an illegitimate
9644 -- child of the original parent!
9646 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
9648 -- We do not want this node marked as Comes_From_Source, since
9649 -- otherwise it would get first class status and a separate
9650 -- cross-reference line would be generated. Illegitimate
9651 -- children do not rate such recognition.
9653 Set_Comes_From_Source
(New_Compon
, False);
9655 -- But it is a real entity, and a birth certificate must be
9656 -- properly registered by entering it into the entity list.
9658 Enter_Name
(New_Compon
);
9660 end Create_Component
;
9662 -----------------------
9663 -- Is_Variant_Record --
9664 -----------------------
9666 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
9668 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
9669 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
9670 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
9672 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
9673 end Is_Variant_Record
;
9675 -- Start of processing for Create_Constrained_Components
9678 pragma Assert
(Subt
/= Base_Type
(Subt
));
9679 pragma Assert
(Typ
= Base_Type
(Typ
));
9681 Set_First_Entity
(Subt
, Empty
);
9682 Set_Last_Entity
(Subt
, Empty
);
9684 -- Check whether constraint is fully static, in which case we can
9685 -- optimize the list of components.
9687 Discr_Val
:= First_Elmt
(Constraints
);
9688 while Present
(Discr_Val
) loop
9689 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
9694 Next_Elmt
(Discr_Val
);
9699 -- Inherit the discriminants of the parent type
9701 Old_C
:= First_Discriminant
(Typ
);
9702 while Present
(Old_C
) loop
9703 New_C
:= Create_Component
(Old_C
);
9704 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9705 Next_Discriminant
(Old_C
);
9709 and then Is_Variant_Record
(Typ
)
9711 Collect_Fixed_Components
(Typ
);
9715 Component_List
(Type_Definition
(Parent
(Typ
))),
9716 Governed_By
=> Assoc_List
,
9718 Report_Errors
=> Errors
);
9719 pragma Assert
(not Errors
);
9721 Create_All_Components
;
9723 -- If the subtype declaration is created for a tagged type derivation
9724 -- with constraints, we retrieve the record definition of the parent
9725 -- type to select the components of the proper variant.
9728 and then Is_Tagged_Type
(Typ
)
9729 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
9731 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
9732 and then Is_Variant_Record
(Parent_Type
)
9734 Collect_Fixed_Components
(Typ
);
9738 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
9739 Governed_By
=> Assoc_List
,
9741 Report_Errors
=> Errors
);
9742 pragma Assert
(not Errors
);
9744 -- If the tagged derivation has a type extension, collect all the
9745 -- new components therein.
9748 (Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
9750 Old_C
:= First_Component
(Typ
);
9751 while Present
(Old_C
) loop
9752 if Original_Record_Component
(Old_C
) = Old_C
9753 and then Chars
(Old_C
) /= Name_uTag
9754 and then Chars
(Old_C
) /= Name_uParent
9755 and then Chars
(Old_C
) /= Name_uController
9757 Append_Elmt
(Old_C
, Comp_List
);
9760 Next_Component
(Old_C
);
9764 Create_All_Components
;
9767 -- If discriminants are not static, or if this is a multi-level type
9768 -- extension, we have to include all components of the parent type.
9770 Old_C
:= First_Component
(Typ
);
9771 while Present
(Old_C
) loop
9772 New_C
:= Create_Component
(Old_C
);
9776 Constrain_Component_Type
9777 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9778 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9780 Next_Component
(Old_C
);
9785 end Create_Constrained_Components
;
9787 ------------------------------------------
9788 -- Decimal_Fixed_Point_Type_Declaration --
9789 ------------------------------------------
9791 procedure Decimal_Fixed_Point_Type_Declaration
9795 Loc
: constant Source_Ptr
:= Sloc
(Def
);
9796 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
9797 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
9798 Implicit_Base
: Entity_Id
;
9804 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
9807 Check_Restriction
(No_Fixed_Point
, Def
);
9809 -- Create implicit base type
9812 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
9813 Set_Etype
(Implicit_Base
, Implicit_Base
);
9815 -- Analyze and process delta expression
9817 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
9819 Check_Delta_Expression
(Delta_Expr
);
9820 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
9822 -- Check delta is power of 10, and determine scale value from it
9828 Scale_Val
:= Uint_0
;
9831 if Val
< Ureal_1
then
9832 while Val
< Ureal_1
loop
9833 Val
:= Val
* Ureal_10
;
9834 Scale_Val
:= Scale_Val
+ 1;
9837 if Scale_Val
> 18 then
9838 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
9839 Scale_Val
:= UI_From_Int
(+18);
9843 while Val
> Ureal_1
loop
9844 Val
:= Val
/ Ureal_10
;
9845 Scale_Val
:= Scale_Val
- 1;
9848 if Scale_Val
< -18 then
9849 Error_Msg_N
("scale is less than minimum value of -18", Def
);
9850 Scale_Val
:= UI_From_Int
(-18);
9854 if Val
/= Ureal_1
then
9855 Error_Msg_N
("delta expression must be a power of 10", Def
);
9856 Delta_Val
:= Ureal_10
** (-Scale_Val
);
9860 -- Set delta, scale and small (small = delta for decimal type)
9862 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
9863 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
9864 Set_Small_Value
(Implicit_Base
, Delta_Val
);
9866 -- Analyze and process digits expression
9868 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
9869 Check_Digits_Expression
(Digs_Expr
);
9870 Digs_Val
:= Expr_Value
(Digs_Expr
);
9872 if Digs_Val
> 18 then
9873 Digs_Val
:= UI_From_Int
(+18);
9874 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
9877 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
9878 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
9880 -- Set range of base type from digits value for now. This will be
9881 -- expanded to represent the true underlying base range by Freeze.
9883 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
9885 -- Set size to zero for now, size will be set at freeze time. We have
9886 -- to do this for ordinary fixed-point, because the size depends on
9887 -- the specified small, and we might as well do the same for decimal
9890 Init_Size_Align
(Implicit_Base
);
9892 -- If there are bounds given in the declaration use them as the
9893 -- bounds of the first named subtype.
9895 if Present
(Real_Range_Specification
(Def
)) then
9897 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
9898 Low
: constant Node_Id
:= Low_Bound
(RRS
);
9899 High
: constant Node_Id
:= High_Bound
(RRS
);
9904 Analyze_And_Resolve
(Low
, Any_Real
);
9905 Analyze_And_Resolve
(High
, Any_Real
);
9906 Check_Real_Bound
(Low
);
9907 Check_Real_Bound
(High
);
9908 Low_Val
:= Expr_Value_R
(Low
);
9909 High_Val
:= Expr_Value_R
(High
);
9911 if Low_Val
< (-Bound_Val
) then
9913 ("range low bound too small for digits value", Low
);
9914 Low_Val
:= -Bound_Val
;
9917 if High_Val
> Bound_Val
then
9919 ("range high bound too large for digits value", High
);
9920 High_Val
:= Bound_Val
;
9923 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
9926 -- If no explicit range, use range that corresponds to given
9927 -- digits value. This will end up as the final range for the
9931 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
9934 -- Complete entity for first subtype
9936 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
9937 Set_Etype
(T
, Implicit_Base
);
9938 Set_Size_Info
(T
, Implicit_Base
);
9939 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
9940 Set_Digits_Value
(T
, Digs_Val
);
9941 Set_Delta_Value
(T
, Delta_Val
);
9942 Set_Small_Value
(T
, Delta_Val
);
9943 Set_Scale_Value
(T
, Scale_Val
);
9944 Set_Is_Constrained
(T
);
9945 end Decimal_Fixed_Point_Type_Declaration
;
9947 ---------------------------------
9948 -- Derive_Interface_Subprogram --
9949 ---------------------------------
9951 procedure Derive_Interface_Subprograms
(Derived_Type
: Entity_Id
) is
9953 procedure Do_Derivation
(T
: Entity_Id
);
9954 -- This inner subprograms is used to climb to the ancestors.
9955 -- It is needed to add the derivations to the Derived_Type.
9957 procedure Do_Derivation
(T
: Entity_Id
) is
9958 Etyp
: constant Entity_Id
:= Etype
(T
);
9963 and then Is_Interface
(Etyp
)
9965 Do_Derivation
(Etyp
);
9968 if Present
(Abstract_Interfaces
(T
))
9969 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(T
))
9971 AI
:= First_Elmt
(Abstract_Interfaces
(T
));
9972 while Present
(AI
) loop
9974 (Parent_Type
=> Node
(AI
),
9975 Derived_Type
=> Derived_Type
,
9976 No_Predefined_Prims
=> True);
9984 Do_Derivation
(Derived_Type
);
9986 -- At this point the list of primitive operations of Derived_Type
9987 -- contains the entities corresponding to all the subprograms of all the
9988 -- implemented interfaces. If N interfaces have subprograms with the
9989 -- same profile we have N entities in this list because each one must be
9990 -- allocated in its corresponding virtual table.
9992 -- Its alias attribute references its original interface subprogram.
9993 -- When overridden, the alias attribute is later saved in the
9994 -- Abstract_Interface_Alias attribute.
9996 end Derive_Interface_Subprograms
;
9998 -----------------------
9999 -- Derive_Subprogram --
10000 -----------------------
10002 procedure Derive_Subprogram
10003 (New_Subp
: in out Entity_Id
;
10004 Parent_Subp
: Entity_Id
;
10005 Derived_Type
: Entity_Id
;
10006 Parent_Type
: Entity_Id
;
10007 Actual_Subp
: Entity_Id
:= Empty
)
10009 Formal
: Entity_Id
;
10010 New_Formal
: Entity_Id
;
10011 Visible_Subp
: Entity_Id
:= Parent_Subp
;
10013 function Is_Private_Overriding
return Boolean;
10014 -- If Subp is a private overriding of a visible operation, the in-
10015 -- herited operation derives from the overridden op (even though
10016 -- its body is the overriding one) and the inherited operation is
10017 -- visible now. See sem_disp to see the details of the handling of
10018 -- the overridden subprogram, which is removed from the list of
10019 -- primitive operations of the type. The overridden subprogram is
10020 -- saved locally in Visible_Subp, and used to diagnose abstract
10021 -- operations that need overriding in the derived type.
10023 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
10024 -- When the type is an anonymous access type, create a new access type
10025 -- designating the derived type.
10027 procedure Set_Derived_Name
;
10028 -- This procedure sets the appropriate Chars name for New_Subp. This
10029 -- is normally just a copy of the parent name. An exception arises for
10030 -- type support subprograms, where the name is changed to reflect the
10031 -- name of the derived type, e.g. if type foo is derived from type bar,
10032 -- then a procedure barDA is derived with a name fooDA.
10034 ---------------------------
10035 -- Is_Private_Overriding --
10036 ---------------------------
10038 function Is_Private_Overriding
return Boolean is
10042 -- The visible operation that is overridden is a homonym of the
10043 -- parent subprogram. We scan the homonym chain to find the one
10044 -- whose alias is the subprogram we are deriving.
10046 Prev
:= Current_Entity
(Parent_Subp
);
10047 while Present
(Prev
) loop
10048 if Is_Dispatching_Operation
(Parent_Subp
)
10049 and then Present
(Prev
)
10050 and then Ekind
(Prev
) = Ekind
(Parent_Subp
)
10051 and then Alias
(Prev
) = Parent_Subp
10052 and then Scope
(Parent_Subp
) = Scope
(Prev
)
10054 (not Is_Hidden
(Prev
)
10057 -- Ada 2005 (AI-251): Entities associated with overridden
10058 -- interface subprograms are always marked as hidden; in
10059 -- this case the field abstract_interface_alias references
10060 -- the original entity (cf. override_dispatching_operation).
10062 (Atree
.Present
(Abstract_Interface_Alias
(Prev
))
10063 and then not Is_Hidden
(Abstract_Interface_Alias
(Prev
))))
10065 Visible_Subp
:= Prev
;
10069 Prev
:= Homonym
(Prev
);
10073 end Is_Private_Overriding
;
10079 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
10080 Acc_Type
: Entity_Id
;
10082 Par
: constant Node_Id
:= Parent
(Derived_Type
);
10085 -- When the type is an anonymous access type, create a new access
10086 -- type designating the derived type. This itype must be elaborated
10087 -- at the point of the derivation, not on subsequent calls that may
10088 -- be out of the proper scope for Gigi, so we insert a reference to
10089 -- it after the derivation.
10091 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
10093 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
10096 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
10097 and then Present
(Full_View
(Desig_Typ
))
10098 and then not Is_Private_Type
(Parent_Type
)
10100 Desig_Typ
:= Full_View
(Desig_Typ
);
10103 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
) then
10104 Acc_Type
:= New_Copy
(Etype
(Id
));
10105 Set_Etype
(Acc_Type
, Acc_Type
);
10106 Set_Scope
(Acc_Type
, New_Subp
);
10108 -- Compute size of anonymous access type
10110 if Is_Array_Type
(Desig_Typ
)
10111 and then not Is_Constrained
(Desig_Typ
)
10113 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
10115 Init_Size
(Acc_Type
, System_Address_Size
);
10118 Init_Alignment
(Acc_Type
);
10119 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
10121 Set_Etype
(New_Id
, Acc_Type
);
10122 Set_Scope
(New_Id
, New_Subp
);
10124 -- Create a reference to it
10126 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
10127 Set_Itype
(IR
, Acc_Type
);
10128 Insert_After
(Parent
(Derived_Type
), IR
);
10131 Set_Etype
(New_Id
, Etype
(Id
));
10135 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
10137 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
10138 and then Present
(Full_View
(Etype
(Id
)))
10140 Base_Type
(Full_View
(Etype
(Id
))) = Base_Type
(Parent_Type
))
10142 -- Constraint checks on formals are generated during expansion,
10143 -- based on the signature of the original subprogram. The bounds
10144 -- of the derived type are not relevant, and thus we can use
10145 -- the base type for the formals. However, the return type may be
10146 -- used in a context that requires that the proper static bounds
10147 -- be used (a case statement, for example) and for those cases
10148 -- we must use the derived type (first subtype), not its base.
10150 -- If the derived_type_definition has no constraints, we know that
10151 -- the derived type has the same constraints as the first subtype
10152 -- of the parent, and we can also use it rather than its base,
10153 -- which can lead to more efficient code.
10155 if Etype
(Id
) = Parent_Type
then
10156 if Is_Scalar_Type
(Parent_Type
)
10158 Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
)
10160 Set_Etype
(New_Id
, Derived_Type
);
10162 elsif Nkind
(Par
) = N_Full_Type_Declaration
10164 Nkind
(Type_Definition
(Par
)) = N_Derived_Type_Definition
10167 (Subtype_Indication
(Type_Definition
(Par
)))
10169 Set_Etype
(New_Id
, Derived_Type
);
10172 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10176 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10180 Set_Etype
(New_Id
, Etype
(Id
));
10184 ----------------------
10185 -- Set_Derived_Name --
10186 ----------------------
10188 procedure Set_Derived_Name
is
10189 Nm
: constant TSS_Name_Type
:= Get_TSS_Name
(Parent_Subp
);
10191 if Nm
= TSS_Null
then
10192 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
10194 Set_Chars
(New_Subp
, Make_TSS_Name
(Base_Type
(Derived_Type
), Nm
));
10196 end Set_Derived_Name
;
10198 -- Start of processing for Derive_Subprogram
10202 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
10203 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
10205 -- Check whether the inherited subprogram is a private operation that
10206 -- should be inherited but not yet made visible. Such subprograms can
10207 -- become visible at a later point (e.g., the private part of a public
10208 -- child unit) via Declare_Inherited_Private_Subprograms. If the
10209 -- following predicate is true, then this is not such a private
10210 -- operation and the subprogram simply inherits the name of the parent
10211 -- subprogram. Note the special check for the names of controlled
10212 -- operations, which are currently exempted from being inherited with
10213 -- a hidden name because they must be findable for generation of
10214 -- implicit run-time calls.
10216 if not Is_Hidden
(Parent_Subp
)
10217 or else Is_Internal
(Parent_Subp
)
10218 or else Is_Private_Overriding
10219 or else Is_Internal_Name
(Chars
(Parent_Subp
))
10220 or else Chars
(Parent_Subp
) = Name_Initialize
10221 or else Chars
(Parent_Subp
) = Name_Adjust
10222 or else Chars
(Parent_Subp
) = Name_Finalize
10226 -- If parent is hidden, this can be a regular derivation if the
10227 -- parent is immediately visible in a non-instantiating context,
10228 -- or if we are in the private part of an instance. This test
10229 -- should still be refined ???
10231 -- The test for In_Instance_Not_Visible avoids inheriting the derived
10232 -- operation as a non-visible operation in cases where the parent
10233 -- subprogram might not be visible now, but was visible within the
10234 -- original generic, so it would be wrong to make the inherited
10235 -- subprogram non-visible now. (Not clear if this test is fully
10236 -- correct; are there any cases where we should declare the inherited
10237 -- operation as not visible to avoid it being overridden, e.g., when
10238 -- the parent type is a generic actual with private primitives ???)
10240 -- (they should be treated the same as other private inherited
10241 -- subprograms, but it's not clear how to do this cleanly). ???
10243 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
10244 and then Is_Immediately_Visible
(Parent_Subp
)
10245 and then not In_Instance
)
10246 or else In_Instance_Not_Visible
10250 -- The type is inheriting a private operation, so enter
10251 -- it with a special name so it can't be overridden.
10254 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
10257 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
10258 Replace_Type
(Parent_Subp
, New_Subp
);
10259 Conditional_Delay
(New_Subp
, Parent_Subp
);
10261 Formal
:= First_Formal
(Parent_Subp
);
10262 while Present
(Formal
) loop
10263 New_Formal
:= New_Copy
(Formal
);
10265 -- Normally we do not go copying parents, but in the case of
10266 -- formals, we need to link up to the declaration (which is the
10267 -- parameter specification), and it is fine to link up to the
10268 -- original formal's parameter specification in this case.
10270 Set_Parent
(New_Formal
, Parent
(Formal
));
10272 Append_Entity
(New_Formal
, New_Subp
);
10274 Replace_Type
(Formal
, New_Formal
);
10275 Next_Formal
(Formal
);
10278 -- If this derivation corresponds to a tagged generic actual, then
10279 -- primitive operations rename those of the actual. Otherwise the
10280 -- primitive operations rename those of the parent type, If the
10281 -- parent renames an intrinsic operator, so does the new subprogram.
10282 -- We except concatenation, which is always properly typed, and does
10283 -- not get expanded as other intrinsic operations.
10285 if No
(Actual_Subp
) then
10286 if Is_Intrinsic_Subprogram
(Parent_Subp
) then
10287 Set_Is_Intrinsic_Subprogram
(New_Subp
);
10289 if Present
(Alias
(Parent_Subp
))
10290 and then Chars
(Parent_Subp
) /= Name_Op_Concat
10292 Set_Alias
(New_Subp
, Alias
(Parent_Subp
));
10294 Set_Alias
(New_Subp
, Parent_Subp
);
10298 Set_Alias
(New_Subp
, Parent_Subp
);
10302 Set_Alias
(New_Subp
, Actual_Subp
);
10305 -- Derived subprograms of a tagged type must inherit the convention
10306 -- of the parent subprogram (a requirement of AI-117). Derived
10307 -- subprograms of untagged types simply get convention Ada by default.
10309 if Is_Tagged_Type
(Derived_Type
) then
10310 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
10313 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
10314 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
10316 if Ekind
(Parent_Subp
) = E_Procedure
then
10317 Set_Is_Valued_Procedure
10318 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
10321 -- A derived function with a controlling result is abstract. If the
10322 -- Derived_Type is a nonabstract formal generic derived type, then
10323 -- inherited operations are not abstract: the required check is done at
10324 -- instantiation time. If the derivation is for a generic actual, the
10325 -- function is not abstract unless the actual is.
10327 if Is_Generic_Type
(Derived_Type
)
10328 and then not Is_Abstract
(Derived_Type
)
10332 elsif Is_Abstract
(Alias
(New_Subp
))
10333 or else (Is_Tagged_Type
(Derived_Type
)
10334 and then Etype
(New_Subp
) = Derived_Type
10335 and then No
(Actual_Subp
))
10337 Set_Is_Abstract
(New_Subp
);
10339 -- Finally, if the parent type is abstract we must verify that all
10340 -- inherited operations are either non-abstract or overridden, or
10341 -- that the derived type itself is abstract (this check is performed
10342 -- at the end of a package declaration, in Check_Abstract_Overriding).
10343 -- A private overriding in the parent type will not be visible in the
10344 -- derivation if we are not in an inner package or in a child unit of
10345 -- the parent type, in which case the abstractness of the inherited
10346 -- operation is carried to the new subprogram.
10348 elsif Is_Abstract
(Parent_Type
)
10349 and then not In_Open_Scopes
(Scope
(Parent_Type
))
10350 and then Is_Private_Overriding
10351 and then Is_Abstract
(Visible_Subp
)
10353 Set_Alias
(New_Subp
, Visible_Subp
);
10354 Set_Is_Abstract
(New_Subp
);
10357 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
10359 -- Check for case of a derived subprogram for the instantiation of a
10360 -- formal derived tagged type, if so mark the subprogram as dispatching
10361 -- and inherit the dispatching attributes of the parent subprogram. The
10362 -- derived subprogram is effectively renaming of the actual subprogram,
10363 -- so it needs to have the same attributes as the actual.
10365 if Present
(Actual_Subp
)
10366 and then Is_Dispatching_Operation
(Parent_Subp
)
10368 Set_Is_Dispatching_Operation
(New_Subp
);
10369 if Present
(DTC_Entity
(Parent_Subp
)) then
10370 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
10371 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
10375 -- Indicate that a derived subprogram does not require a body and that
10376 -- it does not require processing of default expressions.
10378 Set_Has_Completion
(New_Subp
);
10379 Set_Default_Expressions_Processed
(New_Subp
);
10381 if Ekind
(New_Subp
) = E_Function
then
10382 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
10384 end Derive_Subprogram
;
10386 ------------------------
10387 -- Derive_Subprograms --
10388 ------------------------
10390 procedure Derive_Subprograms
10391 (Parent_Type
: Entity_Id
;
10392 Derived_Type
: Entity_Id
;
10393 Generic_Actual
: Entity_Id
:= Empty
;
10394 No_Predefined_Prims
: Boolean := False;
10395 Predefined_Prims_Only
: Boolean := False)
10397 Op_List
: constant Elist_Id
:=
10398 Collect_Primitive_Operations
(Parent_Type
);
10399 Act_List
: Elist_Id
;
10400 Act_Elmt
: Elmt_Id
;
10402 Is_Predef
: Boolean;
10404 New_Subp
: Entity_Id
:= Empty
;
10405 Parent_Base
: Entity_Id
;
10408 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
10409 and then Has_Discriminants
(Parent_Type
)
10410 and then Present
(Full_View
(Parent_Type
))
10412 Parent_Base
:= Full_View
(Parent_Type
);
10414 Parent_Base
:= Parent_Type
;
10417 if Present
(Generic_Actual
) then
10418 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
10419 Act_Elmt
:= First_Elmt
(Act_List
);
10421 Act_Elmt
:= No_Elmt
;
10424 -- Literals are derived earlier in the process of building the derived
10425 -- type, and are skipped here.
10427 Elmt
:= First_Elmt
(Op_List
);
10428 while Present
(Elmt
) loop
10429 Subp
:= Node
(Elmt
);
10431 if Ekind
(Subp
) /= E_Enumeration_Literal
then
10433 Is_Dispatching_Operation
(Subp
)
10434 and then Is_Predefined_Dispatching_Operation
(Subp
);
10436 if No_Predefined_Prims
and then Is_Predef
then
10439 elsif Predefined_Prims_Only
and then not Is_Predef
then
10442 elsif No
(Generic_Actual
) then
10444 (New_Subp
, Subp
, Derived_Type
, Parent_Base
);
10447 Derive_Subprogram
(New_Subp
, Subp
,
10448 Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
10449 Next_Elmt
(Act_Elmt
);
10455 end Derive_Subprograms
;
10457 --------------------------------
10458 -- Derived_Standard_Character --
10459 --------------------------------
10461 procedure Derived_Standard_Character
10463 Parent_Type
: Entity_Id
;
10464 Derived_Type
: Entity_Id
)
10466 Loc
: constant Source_Ptr
:= Sloc
(N
);
10467 Def
: constant Node_Id
:= Type_Definition
(N
);
10468 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10469 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
10470 Implicit_Base
: constant Entity_Id
:=
10472 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
10478 Discard_Node
(Process_Subtype
(Indic
, N
));
10480 Set_Etype
(Implicit_Base
, Parent_Base
);
10481 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
10482 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
10484 Set_Is_Character_Type
(Implicit_Base
, True);
10485 Set_Has_Delayed_Freeze
(Implicit_Base
);
10487 -- The bounds of the implicit base are the bounds of the parent base.
10488 -- Note that their type is the parent base.
10490 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
10491 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
10493 Set_Scalar_Range
(Implicit_Base
,
10496 High_Bound
=> Hi
));
10498 Conditional_Delay
(Derived_Type
, Parent_Type
);
10500 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
10501 Set_Etype
(Derived_Type
, Implicit_Base
);
10502 Set_Size_Info
(Derived_Type
, Parent_Type
);
10504 if Unknown_RM_Size
(Derived_Type
) then
10505 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
10508 Set_Is_Character_Type
(Derived_Type
, True);
10510 if Nkind
(Indic
) /= N_Subtype_Indication
then
10512 -- If no explicit constraint, the bounds are those
10513 -- of the parent type.
10515 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
10516 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
10517 Set_Scalar_Range
(Derived_Type
, Make_Range
(Loc
, Lo
, Hi
));
10520 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
10522 -- Because the implicit base is used in the conversion of the bounds,
10523 -- we have to freeze it now. This is similar to what is done for
10524 -- numeric types, and it equally suspicious, but otherwise a non-
10525 -- static bound will have a reference to an unfrozen type, which is
10526 -- rejected by Gigi (???).
10528 Freeze_Before
(N
, Implicit_Base
);
10529 end Derived_Standard_Character
;
10531 ------------------------------
10532 -- Derived_Type_Declaration --
10533 ------------------------------
10535 procedure Derived_Type_Declaration
10538 Is_Completion
: Boolean)
10540 Def
: constant Node_Id
:= Type_Definition
(N
);
10541 Iface_Def
: Node_Id
;
10542 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10543 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
10544 Parent_Type
: Entity_Id
;
10545 Parent_Scope
: Entity_Id
;
10548 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean;
10549 -- Check whether the parent type is a generic formal, or derives
10550 -- directly or indirectly from one.
10552 ------------------------
10553 -- Comes_From_Generic --
10554 ------------------------
10556 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean is
10558 if Is_Generic_Type
(Typ
) then
10561 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
10564 elsif Is_Private_Type
(Typ
)
10565 and then Present
(Full_View
(Typ
))
10566 and then Is_Generic_Type
(Root_Type
(Full_View
(Typ
)))
10570 elsif Is_Generic_Actual_Type
(Typ
) then
10576 end Comes_From_Generic
;
10578 -- Start of processing for Derived_Type_Declaration
10581 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
10583 -- Ada 2005 (AI-251): In case of interface derivation check that the
10584 -- parent is also an interface.
10586 if Interface_Present
(Def
) then
10587 if not Is_Interface
(Parent_Type
) then
10588 Error_Msg_NE
("(Ada 2005) & must be an interface",
10589 Indic
, Parent_Type
);
10592 Iface_Def
:= Type_Definition
(Parent
(Parent_Type
));
10594 -- Ada 2005 (AI-251): Limited interfaces can only inherit from
10595 -- other limited interfaces.
10597 if Limited_Present
(Def
) then
10598 if Limited_Present
(Iface_Def
) then
10601 elsif Protected_Present
(Iface_Def
) then
10602 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10603 " inherit from protected interface", Indic
);
10605 elsif Synchronized_Present
(Iface_Def
) then
10606 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10607 " inherit from synchronized interface", Indic
);
10609 elsif Task_Present
(Iface_Def
) then
10610 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10611 " inherit from task interface", Indic
);
10614 Error_Msg_N
("(Ada 2005) limited interface cannot" &
10615 " inherit from non-limited interface", Indic
);
10618 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
10619 -- from non-limited or limited interfaces.
10621 elsif not Protected_Present
(Def
)
10622 and then not Synchronized_Present
(Def
)
10623 and then not Task_Present
(Def
)
10625 if Limited_Present
(Iface_Def
) then
10628 elsif Protected_Present
(Iface_Def
) then
10629 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10630 " inherit from protected interface", Indic
);
10632 elsif Synchronized_Present
(Iface_Def
) then
10633 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10634 " inherit from synchronized interface", Indic
);
10636 elsif Task_Present
(Iface_Def
) then
10637 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
10638 " inherit from task interface", Indic
);
10647 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
10650 if Is_Tagged_Type
(Parent_Type
)
10651 and then Is_Non_Empty_List
(Interface_List
(Def
))
10658 Intf
:= First
(Interface_List
(Def
));
10659 while Present
(Intf
) loop
10660 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
10662 if not Is_Interface
(T
) then
10663 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
10671 if Parent_Type
= Any_Type
10672 or else Etype
(Parent_Type
) = Any_Type
10673 or else (Is_Class_Wide_Type
(Parent_Type
)
10674 and then Etype
(Parent_Type
) = T
)
10676 -- If Parent_Type is undefined or illegal, make new type into a
10677 -- subtype of Any_Type, and set a few attributes to prevent cascaded
10678 -- errors. If this is a self-definition, emit error now.
10681 or else T
= Etype
(Parent_Type
)
10683 Error_Msg_N
("type cannot be used in its own definition", Indic
);
10686 Set_Ekind
(T
, Ekind
(Parent_Type
));
10687 Set_Etype
(T
, Any_Type
);
10688 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
10690 if Is_Tagged_Type
(T
) then
10691 Set_Primitive_Operations
(T
, New_Elmt_List
);
10697 -- Only composite types other than array types are allowed to have
10700 if Present
(Discriminant_Specifications
(N
))
10701 and then (Is_Elementary_Type
(Parent_Type
)
10702 or else Is_Array_Type
(Parent_Type
))
10703 and then not Error_Posted
(N
)
10706 ("elementary or array type cannot have discriminants",
10707 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
10708 Set_Has_Discriminants
(T
, False);
10711 -- In Ada 83, a derived type defined in a package specification cannot
10712 -- be used for further derivation until the end of its visible part.
10713 -- Note that derivation in the private part of the package is allowed.
10715 if Ada_Version
= Ada_83
10716 and then Is_Derived_Type
(Parent_Type
)
10717 and then In_Visible_Part
(Scope
(Parent_Type
))
10719 if Ada_Version
= Ada_83
and then Comes_From_Source
(Indic
) then
10721 ("(Ada 83): premature use of type for derivation", Indic
);
10725 -- Check for early use of incomplete or private type
10727 if Ekind
(Parent_Type
) = E_Void
10728 or else Ekind
(Parent_Type
) = E_Incomplete_Type
10730 Error_Msg_N
("premature derivation of incomplete type", Indic
);
10733 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
10734 and then not Comes_From_Generic
(Parent_Type
))
10735 or else Has_Private_Component
(Parent_Type
)
10737 -- The ancestor type of a formal type can be incomplete, in which
10738 -- case only the operations of the partial view are available in
10739 -- the generic. Subsequent checks may be required when the full
10740 -- view is analyzed, to verify that derivation from a tagged type
10741 -- has an extension.
10743 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
10746 elsif No
(Underlying_Type
(Parent_Type
))
10747 or else Has_Private_Component
(Parent_Type
)
10750 ("premature derivation of derived or private type", Indic
);
10752 -- Flag the type itself as being in error, this prevents some
10753 -- nasty problems with subsequent uses of the malformed type.
10755 Set_Error_Posted
(T
);
10757 -- Check that within the immediate scope of an untagged partial
10758 -- view it's illegal to derive from the partial view if the
10759 -- full view is tagged. (7.3(7))
10761 -- We verify that the Parent_Type is a partial view by checking
10762 -- that it is not a Full_Type_Declaration (i.e. a private type or
10763 -- private extension declaration), to distinguish a partial view
10764 -- from a derivation from a private type which also appears as
10767 elsif Present
(Full_View
(Parent_Type
))
10768 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
10769 and then not Is_Tagged_Type
(Parent_Type
)
10770 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
10772 Parent_Scope
:= Scope
(T
);
10773 while Present
(Parent_Scope
)
10774 and then Parent_Scope
/= Standard_Standard
10776 if Parent_Scope
= Scope
(Parent_Type
) then
10778 ("premature derivation from type with tagged full view",
10782 Parent_Scope
:= Scope
(Parent_Scope
);
10787 -- Check that form of derivation is appropriate
10789 Taggd
:= Is_Tagged_Type
(Parent_Type
);
10791 -- Perhaps the parent type should be changed to the class-wide type's
10792 -- specific type in this case to prevent cascading errors ???
10794 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
10795 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
10799 if Present
(Extension
) and then not Taggd
then
10801 ("type derived from untagged type cannot have extension", Indic
);
10803 elsif No
(Extension
) and then Taggd
then
10805 -- If this declaration is within a private part (or body) of a
10806 -- generic instantiation then the derivation is allowed (the parent
10807 -- type can only appear tagged in this case if it's a generic actual
10808 -- type, since it would otherwise have been rejected in the analysis
10809 -- of the generic template).
10811 if not Is_Generic_Actual_Type
(Parent_Type
)
10812 or else In_Visible_Part
(Scope
(Parent_Type
))
10815 ("type derived from tagged type must have extension", Indic
);
10819 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
10820 end Derived_Type_Declaration
;
10822 ----------------------------------
10823 -- Enumeration_Type_Declaration --
10824 ----------------------------------
10826 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
10833 -- Create identifier node representing lower bound
10835 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
10836 L
:= First
(Literals
(Def
));
10837 Set_Chars
(B_Node
, Chars
(L
));
10838 Set_Entity
(B_Node
, L
);
10839 Set_Etype
(B_Node
, T
);
10840 Set_Is_Static_Expression
(B_Node
, True);
10842 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
10843 Set_Low_Bound
(R_Node
, B_Node
);
10845 Set_Ekind
(T
, E_Enumeration_Type
);
10846 Set_First_Literal
(T
, L
);
10848 Set_Is_Constrained
(T
);
10852 -- Loop through literals of enumeration type setting pos and rep values
10853 -- except that if the Ekind is already set, then it means that the
10854 -- literal was already constructed (case of a derived type declaration
10855 -- and we should not disturb the Pos and Rep values.
10857 while Present
(L
) loop
10858 if Ekind
(L
) /= E_Enumeration_Literal
then
10859 Set_Ekind
(L
, E_Enumeration_Literal
);
10860 Set_Enumeration_Pos
(L
, Ev
);
10861 Set_Enumeration_Rep
(L
, Ev
);
10862 Set_Is_Known_Valid
(L
, True);
10866 New_Overloaded_Entity
(L
);
10867 Generate_Definition
(L
);
10868 Set_Convention
(L
, Convention_Intrinsic
);
10870 if Nkind
(L
) = N_Defining_Character_Literal
then
10871 Set_Is_Character_Type
(T
, True);
10878 -- Now create a node representing upper bound
10880 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
10881 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
10882 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
10883 Set_Etype
(B_Node
, T
);
10884 Set_Is_Static_Expression
(B_Node
, True);
10886 Set_High_Bound
(R_Node
, B_Node
);
10887 Set_Scalar_Range
(T
, R_Node
);
10888 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
10889 Set_Enum_Esize
(T
);
10891 -- Set Discard_Names if configuration pragma set, or if there is
10892 -- a parameterless pragma in the current declarative region
10894 if Global_Discard_Names
10895 or else Discard_Names
(Scope
(T
))
10897 Set_Discard_Names
(T
);
10900 -- Process end label if there is one
10902 if Present
(Def
) then
10903 Process_End_Label
(Def
, 'e', T
);
10905 end Enumeration_Type_Declaration
;
10907 ---------------------------------
10908 -- Expand_To_Stored_Constraint --
10909 ---------------------------------
10911 function Expand_To_Stored_Constraint
10913 Constraint
: Elist_Id
) return Elist_Id
10915 Explicitly_Discriminated_Type
: Entity_Id
;
10916 Expansion
: Elist_Id
;
10917 Discriminant
: Entity_Id
;
10919 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
10920 -- Find the nearest type that actually specifies discriminants
10922 ---------------------------------
10923 -- Type_With_Explicit_Discrims --
10924 ---------------------------------
10926 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
10927 Typ
: constant E
:= Base_Type
(Id
);
10930 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
10931 if Present
(Full_View
(Typ
)) then
10932 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
10936 if Has_Discriminants
(Typ
) then
10941 if Etype
(Typ
) = Typ
then
10943 elsif Has_Discriminants
(Typ
) then
10946 return Type_With_Explicit_Discrims
(Etype
(Typ
));
10949 end Type_With_Explicit_Discrims
;
10951 -- Start of processing for Expand_To_Stored_Constraint
10955 or else Is_Empty_Elmt_List
(Constraint
)
10960 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
10962 if No
(Explicitly_Discriminated_Type
) then
10966 Expansion
:= New_Elmt_List
;
10969 First_Stored_Discriminant
(Explicitly_Discriminated_Type
);
10970 while Present
(Discriminant
) loop
10972 Get_Discriminant_Value
(
10973 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
10975 Next_Stored_Discriminant
(Discriminant
);
10979 end Expand_To_Stored_Constraint
;
10981 --------------------
10982 -- Find_Type_Name --
10983 --------------------
10985 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
10986 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
10988 New_Id
: Entity_Id
;
10989 Prev_Par
: Node_Id
;
10992 -- Find incomplete declaration, if one was given
10994 Prev
:= Current_Entity_In_Scope
(Id
);
10996 if Present
(Prev
) then
10998 -- Previous declaration exists. Error if not incomplete/private case
10999 -- except if previous declaration is implicit, etc. Enter_Name will
11000 -- emit error if appropriate.
11002 Prev_Par
:= Parent
(Prev
);
11004 if not Is_Incomplete_Or_Private_Type
(Prev
) then
11008 elsif Nkind
(N
) /= N_Full_Type_Declaration
11009 and then Nkind
(N
) /= N_Task_Type_Declaration
11010 and then Nkind
(N
) /= N_Protected_Type_Declaration
11012 -- Completion must be a full type declarations (RM 7.3(4))
11014 Error_Msg_Sloc
:= Sloc
(Prev
);
11015 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
11017 -- Set scope of Id to avoid cascaded errors. Entity is never
11018 -- examined again, except when saving globals in generics.
11020 Set_Scope
(Id
, Current_Scope
);
11023 -- Case of full declaration of incomplete type
11025 elsif Ekind
(Prev
) = E_Incomplete_Type
then
11027 -- Indicate that the incomplete declaration has a matching full
11028 -- declaration. The defining occurrence of the incomplete
11029 -- declaration remains the visible one, and the procedure
11030 -- Get_Full_View dereferences it whenever the type is used.
11032 if Present
(Full_View
(Prev
)) then
11033 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11036 Set_Full_View
(Prev
, Id
);
11037 Append_Entity
(Id
, Current_Scope
);
11038 Set_Is_Public
(Id
, Is_Public
(Prev
));
11039 Set_Is_Internal
(Id
);
11042 -- Case of full declaration of private type
11045 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
11046 if Etype
(Prev
) /= Prev
then
11048 -- Prev is a private subtype or a derived type, and needs
11051 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11054 elsif Ekind
(Prev
) = E_Private_Type
11056 (Nkind
(N
) = N_Task_Type_Declaration
11057 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11060 ("completion of nonlimited type cannot be limited", N
);
11063 -- Ada 2005 (AI-251): Private extension declaration of a
11064 -- task type. This case arises with tasks implementing interfaces
11066 elsif Nkind
(N
) = N_Task_Type_Declaration
11067 or else Nkind
(N
) = N_Protected_Type_Declaration
11071 elsif Nkind
(N
) /= N_Full_Type_Declaration
11072 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
11075 ("full view of private extension must be an extension", N
);
11077 elsif not (Abstract_Present
(Parent
(Prev
)))
11078 and then Abstract_Present
(Type_Definition
(N
))
11081 ("full view of non-abstract extension cannot be abstract", N
);
11084 if not In_Private_Part
(Current_Scope
) then
11086 ("declaration of full view must appear in private part", N
);
11089 Copy_And_Swap
(Prev
, Id
);
11090 Set_Has_Private_Declaration
(Prev
);
11091 Set_Has_Private_Declaration
(Id
);
11093 -- If no error, propagate freeze_node from private to full view.
11094 -- It may have been generated for an early operational item.
11096 if Present
(Freeze_Node
(Id
))
11097 and then Serious_Errors_Detected
= 0
11098 and then No
(Full_View
(Id
))
11100 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
11101 Set_Freeze_Node
(Id
, Empty
);
11102 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
11105 Set_Full_View
(Id
, Prev
);
11109 -- Verify that full declaration conforms to incomplete one
11111 if Is_Incomplete_Or_Private_Type
(Prev
)
11112 and then Present
(Discriminant_Specifications
(Prev_Par
))
11114 if Present
(Discriminant_Specifications
(N
)) then
11115 if Ekind
(Prev
) = E_Incomplete_Type
then
11116 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
11118 Check_Discriminant_Conformance
(N
, Prev
, Id
);
11123 ("missing discriminants in full type declaration", N
);
11125 -- To avoid cascaded errors on subsequent use, share the
11126 -- discriminants of the partial view.
11128 Set_Discriminant_Specifications
(N
,
11129 Discriminant_Specifications
(Prev_Par
));
11133 -- A prior untagged private type can have an associated class-wide
11134 -- type due to use of the class attribute, and in this case also the
11135 -- full type is required to be tagged.
11138 and then (Is_Tagged_Type
(Prev
)
11139 or else Present
(Class_Wide_Type
(Prev
)))
11140 and then (Nkind
(N
) /= N_Task_Type_Declaration
11141 and then Nkind
(N
) /= N_Protected_Type_Declaration
)
11143 -- The full declaration is either a tagged record or an
11144 -- extension otherwise this is an error
11146 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
11147 if not Tagged_Present
(Type_Definition
(N
)) then
11149 ("full declaration of } must be tagged", Prev
, Id
);
11150 Set_Is_Tagged_Type
(Id
);
11151 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11154 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
11155 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
11157 "full declaration of } must be a record extension",
11159 Set_Is_Tagged_Type
(Id
);
11160 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11165 ("full declaration of } must be a tagged type", Prev
, Id
);
11173 -- New type declaration
11178 end Find_Type_Name
;
11180 -------------------------
11181 -- Find_Type_Of_Object --
11182 -------------------------
11184 function Find_Type_Of_Object
11185 (Obj_Def
: Node_Id
;
11186 Related_Nod
: Node_Id
) return Entity_Id
11188 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
11189 P
: Node_Id
:= Parent
(Obj_Def
);
11194 -- If the parent is a component_definition node we climb to the
11195 -- component_declaration node
11197 if Nkind
(P
) = N_Component_Definition
then
11201 -- Case of an anonymous array subtype
11203 if Def_Kind
= N_Constrained_Array_Definition
11204 or else Def_Kind
= N_Unconstrained_Array_Definition
11207 Array_Type_Declaration
(T
, Obj_Def
);
11209 -- Create an explicit subtype whenever possible
11211 elsif Nkind
(P
) /= N_Component_Declaration
11212 and then Def_Kind
= N_Subtype_Indication
11214 -- Base name of subtype on object name, which will be unique in
11215 -- the current scope.
11217 -- If this is a duplicate declaration, return base type, to avoid
11218 -- generating duplicate anonymous types.
11220 if Error_Posted
(P
) then
11221 Analyze
(Subtype_Mark
(Obj_Def
));
11222 return Entity
(Subtype_Mark
(Obj_Def
));
11227 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
11229 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
11231 Insert_Action
(Obj_Def
,
11232 Make_Subtype_Declaration
(Sloc
(P
),
11233 Defining_Identifier
=> T
,
11234 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
11236 -- This subtype may need freezing, and this will not be done
11237 -- automatically if the object declaration is not in declarative
11238 -- part. Since this is an object declaration, the type cannot always
11239 -- be frozen here. Deferred constants do not freeze their type
11240 -- (which often enough will be private).
11242 if Nkind
(P
) = N_Object_Declaration
11243 and then Constant_Present
(P
)
11244 and then No
(Expression
(P
))
11248 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
11251 -- Ada 2005 AI-406: the object definition in an object declaration
11252 -- can be an access definition.
11254 elsif Def_Kind
= N_Access_Definition
then
11255 T
:= Access_Definition
(Related_Nod
, Obj_Def
);
11256 Set_Is_Local_Anonymous_Access
(T
);
11258 -- comment here, what cases ???
11261 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
11265 end Find_Type_Of_Object
;
11267 --------------------------------
11268 -- Find_Type_Of_Subtype_Indic --
11269 --------------------------------
11271 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
11275 -- Case of subtype mark with a constraint
11277 if Nkind
(S
) = N_Subtype_Indication
then
11278 Find_Type
(Subtype_Mark
(S
));
11279 Typ
:= Entity
(Subtype_Mark
(S
));
11282 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
11285 ("incorrect constraint for this kind of type", Constraint
(S
));
11286 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11289 -- Otherwise we have a subtype mark without a constraint
11291 elsif Error_Posted
(S
) then
11292 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
11300 if Typ
= Standard_Wide_Character
11301 or else Typ
= Standard_Wide_Wide_Character
11302 or else Typ
= Standard_Wide_String
11303 or else Typ
= Standard_Wide_Wide_String
11305 Check_Restriction
(No_Wide_Characters
, S
);
11309 end Find_Type_Of_Subtype_Indic
;
11311 -------------------------------------
11312 -- Floating_Point_Type_Declaration --
11313 -------------------------------------
11315 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11316 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
11318 Base_Typ
: Entity_Id
;
11319 Implicit_Base
: Entity_Id
;
11322 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
11323 -- Find if given digits value allows derivation from specified type
11325 ---------------------
11326 -- Can_Derive_From --
11327 ---------------------
11329 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
11330 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
11333 if Digs_Val
> Digits_Value
(E
) then
11337 if Present
(Spec
) then
11338 if Expr_Value_R
(Type_Low_Bound
(E
)) >
11339 Expr_Value_R
(Low_Bound
(Spec
))
11344 if Expr_Value_R
(Type_High_Bound
(E
)) <
11345 Expr_Value_R
(High_Bound
(Spec
))
11352 end Can_Derive_From
;
11354 -- Start of processing for Floating_Point_Type_Declaration
11357 Check_Restriction
(No_Floating_Point
, Def
);
11359 -- Create an implicit base type
11362 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
11364 -- Analyze and verify digits value
11366 Analyze_And_Resolve
(Digs
, Any_Integer
);
11367 Check_Digits_Expression
(Digs
);
11368 Digs_Val
:= Expr_Value
(Digs
);
11370 -- Process possible range spec and find correct type to derive from
11372 Process_Real_Range_Specification
(Def
);
11374 if Can_Derive_From
(Standard_Short_Float
) then
11375 Base_Typ
:= Standard_Short_Float
;
11376 elsif Can_Derive_From
(Standard_Float
) then
11377 Base_Typ
:= Standard_Float
;
11378 elsif Can_Derive_From
(Standard_Long_Float
) then
11379 Base_Typ
:= Standard_Long_Float
;
11380 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
11381 Base_Typ
:= Standard_Long_Long_Float
;
11383 -- If we can't derive from any existing type, use long_long_float
11384 -- and give appropriate message explaining the problem.
11387 Base_Typ
:= Standard_Long_Long_Float
;
11389 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
11390 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
11391 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
11395 ("range too large for any predefined type",
11396 Real_Range_Specification
(Def
));
11400 -- If there are bounds given in the declaration use them as the bounds
11401 -- of the type, otherwise use the bounds of the predefined base type
11402 -- that was chosen based on the Digits value.
11404 if Present
(Real_Range_Specification
(Def
)) then
11405 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
11406 Set_Is_Constrained
(T
);
11408 -- The bounds of this range must be converted to machine numbers
11409 -- in accordance with RM 4.9(38).
11411 Bound
:= Type_Low_Bound
(T
);
11413 if Nkind
(Bound
) = N_Real_Literal
then
11415 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11416 Set_Is_Machine_Number
(Bound
);
11419 Bound
:= Type_High_Bound
(T
);
11421 if Nkind
(Bound
) = N_Real_Literal
then
11423 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
11424 Set_Is_Machine_Number
(Bound
);
11428 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
11431 -- Complete definition of implicit base and declared first subtype
11433 Set_Etype
(Implicit_Base
, Base_Typ
);
11435 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
11436 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
11437 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
11438 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
11439 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
11440 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
11442 Set_Ekind
(T
, E_Floating_Point_Subtype
);
11443 Set_Etype
(T
, Implicit_Base
);
11445 Set_Size_Info
(T
, (Implicit_Base
));
11446 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
11447 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
11448 Set_Digits_Value
(T
, Digs_Val
);
11449 end Floating_Point_Type_Declaration
;
11451 ----------------------------
11452 -- Get_Discriminant_Value --
11453 ----------------------------
11455 -- This is the situation:
11457 -- There is a non-derived type
11459 -- type T0 (Dx, Dy, Dz...)
11461 -- There are zero or more levels of derivation, with each derivation
11462 -- either purely inheriting the discriminants, or defining its own.
11464 -- type Ti is new Ti-1
11466 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
11468 -- subtype Ti is ...
11470 -- The subtype issue is avoided by the use of Original_Record_Component,
11471 -- and the fact that derived subtypes also derive the constraints.
11473 -- This chain leads back from
11475 -- Typ_For_Constraint
11477 -- Typ_For_Constraint has discriminants, and the value for each
11478 -- discriminant is given by its corresponding Elmt of Constraints.
11480 -- Discriminant is some discriminant in this hierarchy
11482 -- We need to return its value
11484 -- We do this by recursively searching each level, and looking for
11485 -- Discriminant. Once we get to the bottom, we start backing up
11486 -- returning the value for it which may in turn be a discriminant
11487 -- further up, so on the backup we continue the substitution.
11489 function Get_Discriminant_Value
11490 (Discriminant
: Entity_Id
;
11491 Typ_For_Constraint
: Entity_Id
;
11492 Constraint
: Elist_Id
) return Node_Id
11494 function Search_Derivation_Levels
11496 Discrim_Values
: Elist_Id
;
11497 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
;
11498 -- This is the routine that performs the recursive search of levels
11499 -- as described above.
11501 ------------------------------
11502 -- Search_Derivation_Levels --
11503 ------------------------------
11505 function Search_Derivation_Levels
11507 Discrim_Values
: Elist_Id
;
11508 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
11512 Result
: Node_Or_Entity_Id
;
11513 Result_Entity
: Node_Id
;
11516 -- If inappropriate type, return Error, this happens only in
11517 -- cascaded error situations, and we want to avoid a blow up.
11519 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
11523 -- Look deeper if possible. Use Stored_Constraints only for
11524 -- untagged types. For tagged types use the given constraint.
11525 -- This asymmetry needs explanation???
11527 if not Stored_Discrim_Values
11528 and then Present
(Stored_Constraint
(Ti
))
11529 and then not Is_Tagged_Type
(Ti
)
11532 Search_Derivation_Levels
(Ti
, Stored_Constraint
(Ti
), True);
11535 Td
: constant Entity_Id
:= Etype
(Ti
);
11539 Result
:= Discriminant
;
11542 if Present
(Stored_Constraint
(Ti
)) then
11544 Search_Derivation_Levels
11545 (Td
, Stored_Constraint
(Ti
), True);
11548 Search_Derivation_Levels
11549 (Td
, Discrim_Values
, Stored_Discrim_Values
);
11555 -- Extra underlying places to search, if not found above. For
11556 -- concurrent types, the relevant discriminant appears in the
11557 -- corresponding record. For a type derived from a private type
11558 -- without discriminant, the full view inherits the discriminants
11559 -- of the full view of the parent.
11561 if Result
= Discriminant
then
11562 if Is_Concurrent_Type
(Ti
)
11563 and then Present
(Corresponding_Record_Type
(Ti
))
11566 Search_Derivation_Levels
(
11567 Corresponding_Record_Type
(Ti
),
11569 Stored_Discrim_Values
);
11571 elsif Is_Private_Type
(Ti
)
11572 and then not Has_Discriminants
(Ti
)
11573 and then Present
(Full_View
(Ti
))
11574 and then Etype
(Full_View
(Ti
)) /= Ti
11577 Search_Derivation_Levels
(
11580 Stored_Discrim_Values
);
11584 -- If Result is not a (reference to a) discriminant, return it,
11585 -- otherwise set Result_Entity to the discriminant.
11587 if Nkind
(Result
) = N_Defining_Identifier
then
11588 pragma Assert
(Result
= Discriminant
);
11589 Result_Entity
:= Result
;
11592 if not Denotes_Discriminant
(Result
) then
11596 Result_Entity
:= Entity
(Result
);
11599 -- See if this level of derivation actually has discriminants
11600 -- because tagged derivations can add them, hence the lower
11601 -- levels need not have any.
11603 if not Has_Discriminants
(Ti
) then
11607 -- Scan Ti's discriminants for Result_Entity,
11608 -- and return its corresponding value, if any.
11610 Result_Entity
:= Original_Record_Component
(Result_Entity
);
11612 Assoc
:= First_Elmt
(Discrim_Values
);
11614 if Stored_Discrim_Values
then
11615 Disc
:= First_Stored_Discriminant
(Ti
);
11617 Disc
:= First_Discriminant
(Ti
);
11620 while Present
(Disc
) loop
11621 pragma Assert
(Present
(Assoc
));
11623 if Original_Record_Component
(Disc
) = Result_Entity
then
11624 return Node
(Assoc
);
11629 if Stored_Discrim_Values
then
11630 Next_Stored_Discriminant
(Disc
);
11632 Next_Discriminant
(Disc
);
11636 -- Could not find it
11639 end Search_Derivation_Levels
;
11641 Result
: Node_Or_Entity_Id
;
11643 -- Start of processing for Get_Discriminant_Value
11646 -- ??? This routine is a gigantic mess and will be deleted. For the
11647 -- time being just test for the trivial case before calling recurse.
11649 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
11655 D
:= First_Discriminant
(Typ_For_Constraint
);
11656 E
:= First_Elmt
(Constraint
);
11657 while Present
(D
) loop
11658 if Chars
(D
) = Chars
(Discriminant
) then
11662 Next_Discriminant
(D
);
11668 Result
:= Search_Derivation_Levels
11669 (Typ_For_Constraint
, Constraint
, False);
11671 -- ??? hack to disappear when this routine is gone
11673 if Nkind
(Result
) = N_Defining_Identifier
then
11679 D
:= First_Discriminant
(Typ_For_Constraint
);
11680 E
:= First_Elmt
(Constraint
);
11681 while Present
(D
) loop
11682 if Corresponding_Discriminant
(D
) = Discriminant
then
11686 Next_Discriminant
(D
);
11692 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
11694 end Get_Discriminant_Value
;
11696 --------------------------
11697 -- Has_Range_Constraint --
11698 --------------------------
11700 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
11701 C
: constant Node_Id
:= Constraint
(N
);
11704 if Nkind
(C
) = N_Range_Constraint
then
11707 elsif Nkind
(C
) = N_Digits_Constraint
then
11709 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
11711 Present
(Range_Constraint
(C
));
11713 elsif Nkind
(C
) = N_Delta_Constraint
then
11714 return Present
(Range_Constraint
(C
));
11719 end Has_Range_Constraint
;
11721 ------------------------
11722 -- Inherit_Components --
11723 ------------------------
11725 function Inherit_Components
11727 Parent_Base
: Entity_Id
;
11728 Derived_Base
: Entity_Id
;
11729 Is_Tagged
: Boolean;
11730 Inherit_Discr
: Boolean;
11731 Discs
: Elist_Id
) return Elist_Id
11733 Assoc_List
: constant Elist_Id
:= New_Elmt_List
;
11735 procedure Inherit_Component
11736 (Old_C
: Entity_Id
;
11737 Plain_Discrim
: Boolean := False;
11738 Stored_Discrim
: Boolean := False);
11739 -- Inherits component Old_C from Parent_Base to the Derived_Base. If
11740 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
11741 -- True, Old_C is a stored discriminant. If they are both false then
11742 -- Old_C is a regular component.
11744 -----------------------
11745 -- Inherit_Component --
11746 -----------------------
11748 procedure Inherit_Component
11749 (Old_C
: Entity_Id
;
11750 Plain_Discrim
: Boolean := False;
11751 Stored_Discrim
: Boolean := False)
11753 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
11755 Discrim
: Entity_Id
;
11756 Corr_Discrim
: Entity_Id
;
11759 pragma Assert
(not Is_Tagged
or else not Stored_Discrim
);
11761 Set_Parent
(New_C
, Parent
(Old_C
));
11763 -- Regular discriminants and components must be inserted
11764 -- in the scope of the Derived_Base. Do it here.
11766 if not Stored_Discrim
then
11767 Enter_Name
(New_C
);
11770 -- For tagged types the Original_Record_Component must point to
11771 -- whatever this field was pointing to in the parent type. This has
11772 -- already been achieved by the call to New_Copy above.
11774 if not Is_Tagged
then
11775 Set_Original_Record_Component
(New_C
, New_C
);
11778 -- If we have inherited a component then see if its Etype contains
11779 -- references to Parent_Base discriminants. In this case, replace
11780 -- these references with the constraints given in Discs. We do not
11781 -- do this for the partial view of private types because this is
11782 -- not needed (only the components of the full view will be used
11783 -- for code generation) and cause problem. We also avoid this
11784 -- transformation in some error situations.
11786 if Ekind
(New_C
) = E_Component
then
11787 if (Is_Private_Type
(Derived_Base
)
11788 and then not Is_Generic_Type
(Derived_Base
))
11789 or else (Is_Empty_Elmt_List
(Discs
)
11790 and then not Expander_Active
)
11792 Set_Etype
(New_C
, Etype
(Old_C
));
11796 Constrain_Component_Type
11797 (Old_C
, Derived_Base
, N
, Parent_Base
, Discs
));
11801 -- In derived tagged types it is illegal to reference a non
11802 -- discriminant component in the parent type. To catch this, mark
11803 -- these components with an Ekind of E_Void. This will be reset in
11804 -- Record_Type_Definition after processing the record extension of
11805 -- the derived type.
11807 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
11808 Set_Ekind
(New_C
, E_Void
);
11811 if Plain_Discrim
then
11812 Set_Corresponding_Discriminant
(New_C
, Old_C
);
11813 Build_Discriminal
(New_C
);
11815 -- If we are explicitly inheriting a stored discriminant it will be
11816 -- completely hidden.
11818 elsif Stored_Discrim
then
11819 Set_Corresponding_Discriminant
(New_C
, Empty
);
11820 Set_Discriminal
(New_C
, Empty
);
11821 Set_Is_Completely_Hidden
(New_C
);
11823 -- Set the Original_Record_Component of each discriminant in the
11824 -- derived base to point to the corresponding stored that we just
11827 Discrim
:= First_Discriminant
(Derived_Base
);
11828 while Present
(Discrim
) loop
11829 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
11831 -- Corr_Discrim could be missing in an error situation
11833 if Present
(Corr_Discrim
)
11834 and then Original_Record_Component
(Corr_Discrim
) = Old_C
11836 Set_Original_Record_Component
(Discrim
, New_C
);
11839 Next_Discriminant
(Discrim
);
11842 Append_Entity
(New_C
, Derived_Base
);
11845 if not Is_Tagged
then
11846 Append_Elmt
(Old_C
, Assoc_List
);
11847 Append_Elmt
(New_C
, Assoc_List
);
11849 end Inherit_Component
;
11851 -- Variables local to Inherit_Component
11853 Loc
: constant Source_Ptr
:= Sloc
(N
);
11855 Parent_Discrim
: Entity_Id
;
11856 Stored_Discrim
: Entity_Id
;
11858 Component
: Entity_Id
;
11860 -- Start of processing for Inherit_Components
11863 if not Is_Tagged
then
11864 Append_Elmt
(Parent_Base
, Assoc_List
);
11865 Append_Elmt
(Derived_Base
, Assoc_List
);
11868 -- Inherit parent discriminants if needed
11870 if Inherit_Discr
then
11871 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
11872 while Present
(Parent_Discrim
) loop
11873 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
11874 Next_Discriminant
(Parent_Discrim
);
11878 -- Create explicit stored discrims for untagged types when necessary
11880 if not Has_Unknown_Discriminants
(Derived_Base
)
11881 and then Has_Discriminants
(Parent_Base
)
11882 and then not Is_Tagged
11885 or else First_Discriminant
(Parent_Base
) /=
11886 First_Stored_Discriminant
(Parent_Base
))
11888 Stored_Discrim
:= First_Stored_Discriminant
(Parent_Base
);
11889 while Present
(Stored_Discrim
) loop
11890 Inherit_Component
(Stored_Discrim
, Stored_Discrim
=> True);
11891 Next_Stored_Discriminant
(Stored_Discrim
);
11895 -- See if we can apply the second transformation for derived types, as
11896 -- explained in point 6. in the comments above Build_Derived_Record_Type
11897 -- This is achieved by appending Derived_Base discriminants into Discs,
11898 -- which has the side effect of returning a non empty Discs list to the
11899 -- caller of Inherit_Components, which is what we want. This must be
11900 -- done for private derived types if there are explicit stored
11901 -- discriminants, to ensure that we can retrieve the values of the
11902 -- constraints provided in the ancestors.
11905 and then Is_Empty_Elmt_List
(Discs
)
11906 and then Present
(First_Discriminant
(Derived_Base
))
11908 (not Is_Private_Type
(Derived_Base
)
11909 or else Is_Completely_Hidden
11910 (First_Stored_Discriminant
(Derived_Base
))
11911 or else Is_Generic_Type
(Derived_Base
))
11913 D
:= First_Discriminant
(Derived_Base
);
11914 while Present
(D
) loop
11915 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
11916 Next_Discriminant
(D
);
11920 -- Finally, inherit non-discriminant components unless they are not
11921 -- visible because defined or inherited from the full view of the
11922 -- parent. Don't inherit the _parent field of the parent type.
11924 Component
:= First_Entity
(Parent_Base
);
11925 while Present
(Component
) loop
11927 -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
11928 -- interfaces of the parent
11930 if Ekind
(Component
) = E_Component
11931 and then Is_Tag
(Component
)
11932 and then Etype
(Component
) = RTE
(RE_Interface_Tag
)
11936 elsif Ekind
(Component
) /= E_Component
11937 or else Chars
(Component
) = Name_uParent
11941 -- If the derived type is within the parent type's declarative
11942 -- region, then the components can still be inherited even though
11943 -- they aren't visible at this point. This can occur for cases
11944 -- such as within public child units where the components must
11945 -- become visible upon entering the child unit's private part.
11947 elsif not Is_Visible_Component
(Component
)
11948 and then not In_Open_Scopes
(Scope
(Parent_Base
))
11952 elsif Ekind
(Derived_Base
) = E_Private_Type
11953 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
11958 Inherit_Component
(Component
);
11961 Next_Entity
(Component
);
11964 -- For tagged derived types, inherited discriminants cannot be used in
11965 -- component declarations of the record extension part. To achieve this
11966 -- we mark the inherited discriminants as not visible.
11968 if Is_Tagged
and then Inherit_Discr
then
11969 D
:= First_Discriminant
(Derived_Base
);
11970 while Present
(D
) loop
11971 Set_Is_Immediately_Visible
(D
, False);
11972 Next_Discriminant
(D
);
11977 end Inherit_Components
;
11979 ------------------------------
11980 -- Is_Valid_Constraint_Kind --
11981 ------------------------------
11983 function Is_Valid_Constraint_Kind
11984 (T_Kind
: Type_Kind
;
11985 Constraint_Kind
: Node_Kind
) return Boolean
11989 when Enumeration_Kind |
11991 return Constraint_Kind
= N_Range_Constraint
;
11993 when Decimal_Fixed_Point_Kind
=>
11995 Constraint_Kind
= N_Digits_Constraint
11997 Constraint_Kind
= N_Range_Constraint
;
11999 when Ordinary_Fixed_Point_Kind
=>
12001 Constraint_Kind
= N_Delta_Constraint
12003 Constraint_Kind
= N_Range_Constraint
;
12007 Constraint_Kind
= N_Digits_Constraint
12009 Constraint_Kind
= N_Range_Constraint
;
12016 E_Incomplete_Type |
12019 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
12022 return True; -- Error will be detected later
12024 end Is_Valid_Constraint_Kind
;
12026 --------------------------
12027 -- Is_Visible_Component --
12028 --------------------------
12030 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
12031 Original_Comp
: Entity_Id
:= Empty
;
12032 Original_Scope
: Entity_Id
;
12033 Type_Scope
: Entity_Id
;
12035 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean;
12036 -- Check whether parent type of inherited component is declared locally,
12037 -- possibly within a nested package or instance. The current scope is
12038 -- the derived record itself.
12040 -------------------
12041 -- Is_Local_Type --
12042 -------------------
12044 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean is
12048 Scop
:= Scope
(Typ
);
12049 while Present
(Scop
)
12050 and then Scop
/= Standard_Standard
12052 if Scop
= Scope
(Current_Scope
) then
12056 Scop
:= Scope
(Scop
);
12062 -- Start of processing for Is_Visible_Component
12065 if Ekind
(C
) = E_Component
12066 or else Ekind
(C
) = E_Discriminant
12068 Original_Comp
:= Original_Record_Component
(C
);
12071 if No
(Original_Comp
) then
12073 -- Premature usage, or previous error
12078 Original_Scope
:= Scope
(Original_Comp
);
12079 Type_Scope
:= Scope
(Base_Type
(Scope
(C
)));
12082 -- This test only concerns tagged types
12084 if not Is_Tagged_Type
(Original_Scope
) then
12087 -- If it is _Parent or _Tag, there is no visibility issue
12089 elsif not Comes_From_Source
(Original_Comp
) then
12092 -- If we are in the body of an instantiation, the component is visible
12093 -- even when the parent type (possibly defined in an enclosing unit or
12094 -- in a parent unit) might not.
12096 elsif In_Instance_Body
then
12099 -- Discriminants are always visible
12101 elsif Ekind
(Original_Comp
) = E_Discriminant
12102 and then not Has_Unknown_Discriminants
(Original_Scope
)
12106 -- If the component has been declared in an ancestor which is currently
12107 -- a private type, then it is not visible. The same applies if the
12108 -- component's containing type is not in an open scope and the original
12109 -- component's enclosing type is a visible full type of a private type
12110 -- (which can occur in cases where an attempt is being made to reference
12111 -- a component in a sibling package that is inherited from a visible
12112 -- component of a type in an ancestor package; the component in the
12113 -- sibling package should not be visible even though the component it
12114 -- inherited from is visible). This does not apply however in the case
12115 -- where the scope of the type is a private child unit, or when the
12116 -- parent comes from a local package in which the ancestor is currently
12117 -- visible. The latter suppression of visibility is needed for cases
12118 -- that are tested in B730006.
12120 elsif Is_Private_Type
(Original_Scope
)
12122 (not Is_Private_Descendant
(Type_Scope
)
12123 and then not In_Open_Scopes
(Type_Scope
)
12124 and then Has_Private_Declaration
(Original_Scope
))
12126 -- If the type derives from an entity in a formal package, there
12127 -- are no additional visible components.
12129 if Nkind
(Original_Node
(Unit_Declaration_Node
(Type_Scope
))) =
12130 N_Formal_Package_Declaration
12134 -- if we are not in the private part of the current package, there
12135 -- are no additional visible components.
12137 elsif Ekind
(Scope
(Current_Scope
)) = E_Package
12138 and then not In_Private_Part
(Scope
(Current_Scope
))
12143 Is_Child_Unit
(Cunit_Entity
(Current_Sem_Unit
))
12144 and then Is_Local_Type
(Type_Scope
);
12147 -- There is another weird way in which a component may be invisible
12148 -- when the private and the full view are not derived from the same
12149 -- ancestor. Here is an example :
12151 -- type A1 is tagged record F1 : integer; end record;
12152 -- type A2 is new A1 with record F2 : integer; end record;
12153 -- type T is new A1 with private;
12155 -- type T is new A2 with null record;
12157 -- In this case, the full view of T inherits F1 and F2 but the private
12158 -- view inherits only F1
12162 Ancestor
: Entity_Id
:= Scope
(C
);
12166 if Ancestor
= Original_Scope
then
12168 elsif Ancestor
= Etype
(Ancestor
) then
12172 Ancestor
:= Etype
(Ancestor
);
12178 end Is_Visible_Component
;
12180 --------------------------
12181 -- Make_Class_Wide_Type --
12182 --------------------------
12184 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
12185 CW_Type
: Entity_Id
;
12187 Next_E
: Entity_Id
;
12190 -- The class wide type can have been defined by the partial view in
12191 -- which case everything is already done
12193 if Present
(Class_Wide_Type
(T
)) then
12198 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
12200 -- Inherit root type characteristics
12202 CW_Name
:= Chars
(CW_Type
);
12203 Next_E
:= Next_Entity
(CW_Type
);
12204 Copy_Node
(T
, CW_Type
);
12205 Set_Comes_From_Source
(CW_Type
, False);
12206 Set_Chars
(CW_Type
, CW_Name
);
12207 Set_Parent
(CW_Type
, Parent
(T
));
12208 Set_Next_Entity
(CW_Type
, Next_E
);
12209 Set_Has_Delayed_Freeze
(CW_Type
);
12211 -- Customize the class-wide type: It has no prim. op., it cannot be
12212 -- abstract and its Etype points back to the specific root type.
12214 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
12215 Set_Is_Tagged_Type
(CW_Type
, True);
12216 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
12217 Set_Is_Abstract
(CW_Type
, False);
12218 Set_Is_Constrained
(CW_Type
, False);
12219 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
12220 Init_Size_Align
(CW_Type
);
12222 if Ekind
(T
) = E_Class_Wide_Subtype
then
12223 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
12225 Set_Etype
(CW_Type
, T
);
12228 -- If this is the class_wide type of a constrained subtype, it does
12229 -- not have discriminants.
12231 Set_Has_Discriminants
(CW_Type
,
12232 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
12234 Set_Has_Unknown_Discriminants
(CW_Type
, True);
12235 Set_Class_Wide_Type
(T
, CW_Type
);
12236 Set_Equivalent_Type
(CW_Type
, Empty
);
12238 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
12240 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
12241 end Make_Class_Wide_Type
;
12247 procedure Make_Index
12249 Related_Nod
: Node_Id
;
12250 Related_Id
: Entity_Id
:= Empty
;
12251 Suffix_Index
: Nat
:= 1)
12255 Def_Id
: Entity_Id
:= Empty
;
12256 Found
: Boolean := False;
12259 -- For a discrete range used in a constrained array definition and
12260 -- defined by a range, an implicit conversion to the predefined type
12261 -- INTEGER is assumed if each bound is either a numeric literal, a named
12262 -- number, or an attribute, and the type of both bounds (prior to the
12263 -- implicit conversion) is the type universal_integer. Otherwise, both
12264 -- bounds must be of the same discrete type, other than universal
12265 -- integer; this type must be determinable independently of the
12266 -- context, but using the fact that the type must be discrete and that
12267 -- both bounds must have the same type.
12269 -- Character literals also have a universal type in the absence of
12270 -- of additional context, and are resolved to Standard_Character.
12272 if Nkind
(I
) = N_Range
then
12274 -- The index is given by a range constraint. The bounds are known
12275 -- to be of a consistent type.
12277 if not Is_Overloaded
(I
) then
12280 -- If the bounds are universal, choose the specific predefined
12283 if T
= Universal_Integer
then
12284 T
:= Standard_Integer
;
12286 elsif T
= Any_Character
then
12288 if Ada_Version
>= Ada_95
then
12290 ("ambiguous character literals (could be Wide_Character)",
12294 T
:= Standard_Character
;
12301 Ind
: Interp_Index
;
12305 Get_First_Interp
(I
, Ind
, It
);
12306 while Present
(It
.Typ
) loop
12307 if Is_Discrete_Type
(It
.Typ
) then
12310 and then not Covers
(It
.Typ
, T
)
12311 and then not Covers
(T
, It
.Typ
)
12313 Error_Msg_N
("ambiguous bounds in discrete range", I
);
12321 Get_Next_Interp
(Ind
, It
);
12324 if T
= Any_Type
then
12325 Error_Msg_N
("discrete type required for range", I
);
12326 Set_Etype
(I
, Any_Type
);
12329 elsif T
= Universal_Integer
then
12330 T
:= Standard_Integer
;
12335 if not Is_Discrete_Type
(T
) then
12336 Error_Msg_N
("discrete type required for range", I
);
12337 Set_Etype
(I
, Any_Type
);
12341 if Nkind
(Low_Bound
(I
)) = N_Attribute_Reference
12342 and then Attribute_Name
(Low_Bound
(I
)) = Name_First
12343 and then Is_Entity_Name
(Prefix
(Low_Bound
(I
)))
12344 and then Is_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12345 and then Is_Discrete_Type
(Entity
(Prefix
(Low_Bound
(I
))))
12347 -- The type of the index will be the type of the prefix, as long
12348 -- as the upper bound is 'Last of the same type.
12350 Def_Id
:= Entity
(Prefix
(Low_Bound
(I
)));
12352 if Nkind
(High_Bound
(I
)) /= N_Attribute_Reference
12353 or else Attribute_Name
(High_Bound
(I
)) /= Name_Last
12354 or else not Is_Entity_Name
(Prefix
(High_Bound
(I
)))
12355 or else Entity
(Prefix
(High_Bound
(I
))) /= Def_Id
12362 Process_Range_Expr_In_Decl
(R
, T
);
12364 elsif Nkind
(I
) = N_Subtype_Indication
then
12366 -- The index is given by a subtype with a range constraint
12368 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
12370 if not Is_Discrete_Type
(T
) then
12371 Error_Msg_N
("discrete type required for range", I
);
12372 Set_Etype
(I
, Any_Type
);
12376 R
:= Range_Expression
(Constraint
(I
));
12379 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
12381 elsif Nkind
(I
) = N_Attribute_Reference
then
12383 -- The parser guarantees that the attribute is a RANGE attribute
12385 -- If the node denotes the range of a type mark, that is also the
12386 -- resulting type, and we do no need to create an Itype for it.
12388 if Is_Entity_Name
(Prefix
(I
))
12389 and then Comes_From_Source
(I
)
12390 and then Is_Type
(Entity
(Prefix
(I
)))
12391 and then Is_Discrete_Type
(Entity
(Prefix
(I
)))
12393 Def_Id
:= Entity
(Prefix
(I
));
12396 Analyze_And_Resolve
(I
);
12400 -- If none of the above, must be a subtype. We convert this to a
12401 -- range attribute reference because in the case of declared first
12402 -- named subtypes, the types in the range reference can be different
12403 -- from the type of the entity. A range attribute normalizes the
12404 -- reference and obtains the correct types for the bounds.
12406 -- This transformation is in the nature of an expansion, is only
12407 -- done if expansion is active. In particular, it is not done on
12408 -- formal generic types, because we need to retain the name of the
12409 -- original index for instantiation purposes.
12412 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
12413 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
12414 Set_Etype
(I
, Any_Integer
);
12418 -- The type mark may be that of an incomplete type. It is only
12419 -- now that we can get the full view, previous analysis does
12420 -- not look specifically for a type mark.
12422 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
12423 Set_Etype
(I
, Entity
(I
));
12424 Def_Id
:= Entity
(I
);
12426 if not Is_Discrete_Type
(Def_Id
) then
12427 Error_Msg_N
("discrete type required for index", I
);
12428 Set_Etype
(I
, Any_Type
);
12433 if Expander_Active
then
12435 Make_Attribute_Reference
(Sloc
(I
),
12436 Attribute_Name
=> Name_Range
,
12437 Prefix
=> Relocate_Node
(I
)));
12439 -- The original was a subtype mark that does not freeze. This
12440 -- means that the rewritten version must not freeze either.
12442 Set_Must_Not_Freeze
(I
);
12443 Set_Must_Not_Freeze
(Prefix
(I
));
12445 -- Is order critical??? if so, document why, if not
12446 -- use Analyze_And_Resolve
12453 -- If expander is inactive, type is legal, nothing else to construct
12460 if not Is_Discrete_Type
(T
) then
12461 Error_Msg_N
("discrete type required for range", I
);
12462 Set_Etype
(I
, Any_Type
);
12465 elsif T
= Any_Type
then
12466 Set_Etype
(I
, Any_Type
);
12470 -- We will now create the appropriate Itype to describe the range, but
12471 -- first a check. If we originally had a subtype, then we just label
12472 -- the range with this subtype. Not only is there no need to construct
12473 -- a new subtype, but it is wrong to do so for two reasons:
12475 -- 1. A legality concern, if we have a subtype, it must not freeze,
12476 -- and the Itype would cause freezing incorrectly
12478 -- 2. An efficiency concern, if we created an Itype, it would not be
12479 -- recognized as the same type for the purposes of eliminating
12480 -- checks in some circumstances.
12482 -- We signal this case by setting the subtype entity in Def_Id
12484 if No
(Def_Id
) then
12486 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
12487 Set_Etype
(Def_Id
, Base_Type
(T
));
12489 if Is_Signed_Integer_Type
(T
) then
12490 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
12492 elsif Is_Modular_Integer_Type
(T
) then
12493 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
12496 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
12497 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
12498 Set_First_Literal
(Def_Id
, First_Literal
(T
));
12501 Set_Size_Info
(Def_Id
, (T
));
12502 Set_RM_Size
(Def_Id
, RM_Size
(T
));
12503 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
12505 Set_Scalar_Range
(Def_Id
, R
);
12506 Conditional_Delay
(Def_Id
, T
);
12508 -- In the subtype indication case, if the immediate parent of the
12509 -- new subtype is non-static, then the subtype we create is non-
12510 -- static, even if its bounds are static.
12512 if Nkind
(I
) = N_Subtype_Indication
12513 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
12515 Set_Is_Non_Static_Subtype
(Def_Id
);
12519 -- Final step is to label the index with this constructed type
12521 Set_Etype
(I
, Def_Id
);
12524 ------------------------------
12525 -- Modular_Type_Declaration --
12526 ------------------------------
12528 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
12529 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
12532 procedure Set_Modular_Size
(Bits
: Int
);
12533 -- Sets RM_Size to Bits, and Esize to normal word size above this
12535 ----------------------
12536 -- Set_Modular_Size --
12537 ----------------------
12539 procedure Set_Modular_Size
(Bits
: Int
) is
12541 Set_RM_Size
(T
, UI_From_Int
(Bits
));
12546 elsif Bits
<= 16 then
12547 Init_Esize
(T
, 16);
12549 elsif Bits
<= 32 then
12550 Init_Esize
(T
, 32);
12553 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
12555 end Set_Modular_Size
;
12557 -- Start of processing for Modular_Type_Declaration
12560 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
12562 Set_Ekind
(T
, E_Modular_Integer_Type
);
12563 Init_Alignment
(T
);
12564 Set_Is_Constrained
(T
);
12566 if not Is_OK_Static_Expression
(Mod_Expr
) then
12567 Flag_Non_Static_Expr
12568 ("non-static expression used for modular type bound!", Mod_Expr
);
12569 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
12571 M_Val
:= Expr_Value
(Mod_Expr
);
12575 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
12576 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
12579 Set_Modulus
(T
, M_Val
);
12581 -- Create bounds for the modular type based on the modulus given in
12582 -- the type declaration and then analyze and resolve those bounds.
12584 Set_Scalar_Range
(T
,
12585 Make_Range
(Sloc
(Mod_Expr
),
12587 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
12589 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
12591 -- Properly analyze the literals for the range. We do this manually
12592 -- because we can't go calling Resolve, since we are resolving these
12593 -- bounds with the type, and this type is certainly not complete yet!
12595 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
12596 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
12597 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
12598 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
12600 -- Loop through powers of two to find number of bits required
12602 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
12606 if M_Val
= 2 ** Bits
then
12607 Set_Modular_Size
(Bits
);
12612 elsif M_Val
< 2 ** Bits
then
12613 Set_Non_Binary_Modulus
(T
);
12615 if Bits
> System_Max_Nonbinary_Modulus_Power
then
12616 Error_Msg_Uint_1
:=
12617 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
12619 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
12620 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
12624 -- In the non-binary case, set size as per RM 13.3(55)
12626 Set_Modular_Size
(Bits
);
12633 -- If we fall through, then the size exceed System.Max_Binary_Modulus
12634 -- so we just signal an error and set the maximum size.
12636 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
12637 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
12639 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
12640 Init_Alignment
(T
);
12642 end Modular_Type_Declaration
;
12644 --------------------------
12645 -- New_Concatenation_Op --
12646 --------------------------
12648 procedure New_Concatenation_Op
(Typ
: Entity_Id
) is
12649 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
12652 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
12653 -- Create abbreviated declaration for the formal of a predefined
12654 -- Operator 'Op' of type 'Typ'
12656 --------------------
12657 -- Make_Op_Formal --
12658 --------------------
12660 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
12661 Formal
: Entity_Id
;
12663 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
12664 Set_Etype
(Formal
, Typ
);
12665 Set_Mechanism
(Formal
, Default_Mechanism
);
12667 end Make_Op_Formal
;
12669 -- Start of processing for New_Concatenation_Op
12672 Op
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Concat
);
12674 Set_Ekind
(Op
, E_Operator
);
12675 Set_Scope
(Op
, Current_Scope
);
12676 Set_Etype
(Op
, Typ
);
12677 Set_Homonym
(Op
, Get_Name_Entity_Id
(Name_Op_Concat
));
12678 Set_Is_Immediately_Visible
(Op
);
12679 Set_Is_Intrinsic_Subprogram
(Op
);
12680 Set_Has_Completion
(Op
);
12681 Append_Entity
(Op
, Current_Scope
);
12683 Set_Name_Entity_Id
(Name_Op_Concat
, Op
);
12685 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
12686 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
12687 end New_Concatenation_Op
;
12689 -------------------------------------------
12690 -- Ordinary_Fixed_Point_Type_Declaration --
12691 -------------------------------------------
12693 procedure Ordinary_Fixed_Point_Type_Declaration
12697 Loc
: constant Source_Ptr
:= Sloc
(Def
);
12698 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
12699 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
12700 Implicit_Base
: Entity_Id
;
12707 Check_Restriction
(No_Fixed_Point
, Def
);
12709 -- Create implicit base type
12712 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
12713 Set_Etype
(Implicit_Base
, Implicit_Base
);
12715 -- Analyze and process delta expression
12717 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
12719 Check_Delta_Expression
(Delta_Expr
);
12720 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
12722 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
12724 -- Compute default small from given delta, which is the largest power
12725 -- of two that does not exceed the given delta value.
12735 if Delta_Val
< Ureal_1
then
12736 while Delta_Val
< Tmp
loop
12737 Tmp
:= Tmp
/ Ureal_2
;
12738 Scale
:= Scale
+ 1;
12743 Tmp
:= Tmp
* Ureal_2
;
12744 exit when Tmp
> Delta_Val
;
12745 Scale
:= Scale
- 1;
12749 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
12752 Set_Small_Value
(Implicit_Base
, Small_Val
);
12754 -- If no range was given, set a dummy range
12756 if RRS
<= Empty_Or_Error
then
12757 Low_Val
:= -Small_Val
;
12758 High_Val
:= Small_Val
;
12760 -- Otherwise analyze and process given range
12764 Low
: constant Node_Id
:= Low_Bound
(RRS
);
12765 High
: constant Node_Id
:= High_Bound
(RRS
);
12768 Analyze_And_Resolve
(Low
, Any_Real
);
12769 Analyze_And_Resolve
(High
, Any_Real
);
12770 Check_Real_Bound
(Low
);
12771 Check_Real_Bound
(High
);
12773 -- Obtain and set the range
12775 Low_Val
:= Expr_Value_R
(Low
);
12776 High_Val
:= Expr_Value_R
(High
);
12778 if Low_Val
> High_Val
then
12779 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
12784 -- The range for both the implicit base and the declared first subtype
12785 -- cannot be set yet, so we use the special routine Set_Fixed_Range to
12786 -- set a temporary range in place. Note that the bounds of the base
12787 -- type will be widened to be symmetrical and to fill the available
12788 -- bits when the type is frozen.
12790 -- We could do this with all discrete types, and probably should, but
12791 -- we absolutely have to do it for fixed-point, since the end-points
12792 -- of the range and the size are determined by the small value, which
12793 -- could be reset before the freeze point.
12795 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
12796 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
12798 Init_Size_Align
(Implicit_Base
);
12800 -- Complete definition of first subtype
12802 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
12803 Set_Etype
(T
, Implicit_Base
);
12804 Init_Size_Align
(T
);
12805 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
12806 Set_Small_Value
(T
, Small_Val
);
12807 Set_Delta_Value
(T
, Delta_Val
);
12808 Set_Is_Constrained
(T
);
12810 end Ordinary_Fixed_Point_Type_Declaration
;
12812 ----------------------------------------
12813 -- Prepare_Private_Subtype_Completion --
12814 ----------------------------------------
12816 procedure Prepare_Private_Subtype_Completion
12818 Related_Nod
: Node_Id
)
12820 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
12821 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
12825 if Present
(Full_B
) then
12827 -- The Base_Type is already completed, we can complete the subtype
12828 -- now. We have to create a new entity with the same name, Thus we
12829 -- can't use Create_Itype.
12831 -- This is messy, should be fixed ???
12833 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
12834 Set_Is_Itype
(Full
);
12835 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
12836 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
12839 -- The parent subtype may be private, but the base might not, in some
12840 -- nested instances. In that case, the subtype does not need to be
12841 -- exchanged. It would still be nice to make private subtypes and their
12842 -- bases consistent at all times ???
12844 if Is_Private_Type
(Id_B
) then
12845 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
12848 end Prepare_Private_Subtype_Completion
;
12850 ---------------------------
12851 -- Process_Discriminants --
12852 ---------------------------
12854 procedure Process_Discriminants
12856 Prev
: Entity_Id
:= Empty
)
12858 Elist
: constant Elist_Id
:= New_Elmt_List
;
12861 Discr_Number
: Uint
;
12862 Discr_Type
: Entity_Id
;
12863 Default_Present
: Boolean := False;
12864 Default_Not_Present
: Boolean := False;
12867 -- A composite type other than an array type can have discriminants.
12868 -- Discriminants of non-limited types must have a discrete type.
12869 -- On entry, the current scope is the composite type.
12871 -- The discriminants are initially entered into the scope of the type
12872 -- via Enter_Name with the default Ekind of E_Void to prevent premature
12873 -- use, as explained at the end of this procedure.
12875 Discr
:= First
(Discriminant_Specifications
(N
));
12876 while Present
(Discr
) loop
12877 Enter_Name
(Defining_Identifier
(Discr
));
12879 -- For navigation purposes we add a reference to the discriminant
12880 -- in the entity for the type. If the current declaration is a
12881 -- completion, place references on the partial view. Otherwise the
12882 -- type is the current scope.
12884 if Present
(Prev
) then
12886 -- The references go on the partial view, if present. If the
12887 -- partial view has discriminants, the references have been
12888 -- generated already.
12890 if not Has_Discriminants
(Prev
) then
12891 Generate_Reference
(Prev
, Defining_Identifier
(Discr
), 'd');
12895 (Current_Scope
, Defining_Identifier
(Discr
), 'd');
12898 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
12899 Discr_Type
:= Access_Definition
(N
, Discriminant_Type
(Discr
));
12901 -- Ada 2005 (AI-230): Access discriminants are now allowed for
12902 -- nonlimited types, and are treated like other components of
12903 -- anonymous access types in terms of accessibility.
12905 if not Is_Concurrent_Type
(Current_Scope
)
12906 and then not Is_Concurrent_Record_Type
(Current_Scope
)
12907 and then not Is_Limited_Record
(Current_Scope
)
12908 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
12910 Set_Is_Local_Anonymous_Access
(Discr_Type
);
12913 -- Ada 2005 (AI-254)
12915 if Present
(Access_To_Subprogram_Definition
12916 (Discriminant_Type
(Discr
)))
12917 and then Protected_Present
(Access_To_Subprogram_Definition
12918 (Discriminant_Type
(Discr
)))
12921 Replace_Anonymous_Access_To_Protected_Subprogram
12922 (Discr
, Discr_Type
);
12926 Find_Type
(Discriminant_Type
(Discr
));
12927 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
12929 if Error_Posted
(Discriminant_Type
(Discr
)) then
12930 Discr_Type
:= Any_Type
;
12934 if Is_Access_Type
(Discr_Type
) then
12936 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
12939 if Ada_Version
< Ada_05
then
12940 Check_Access_Discriminant_Requires_Limited
12941 (Discr
, Discriminant_Type
(Discr
));
12944 if Ada_Version
= Ada_83
and then Comes_From_Source
(Discr
) then
12946 ("(Ada 83) access discriminant not allowed", Discr
);
12949 elsif not Is_Discrete_Type
(Discr_Type
) then
12950 Error_Msg_N
("discriminants must have a discrete or access type",
12951 Discriminant_Type
(Discr
));
12954 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
12956 -- If a discriminant specification includes the assignment compound
12957 -- delimiter followed by an expression, the expression is the default
12958 -- expression of the discriminant; the default expression must be of
12959 -- the type of the discriminant. (RM 3.7.1) Since this expression is
12960 -- a default expression, we do the special preanalysis, since this
12961 -- expression does not freeze (see "Handling of Default and Per-
12962 -- Object Expressions" in spec of package Sem).
12964 if Present
(Expression
(Discr
)) then
12965 Analyze_Per_Use_Expression
(Expression
(Discr
), Discr_Type
);
12967 if Nkind
(N
) = N_Formal_Type_Declaration
then
12969 ("discriminant defaults not allowed for formal type",
12970 Expression
(Discr
));
12972 -- Tagged types cannot have defaulted discriminants, but a
12973 -- non-tagged private type with defaulted discriminants
12974 -- can have a tagged completion.
12976 elsif Is_Tagged_Type
(Current_Scope
)
12977 and then Comes_From_Source
(N
)
12980 ("discriminants of tagged type cannot have defaults",
12981 Expression
(Discr
));
12984 Default_Present
:= True;
12985 Append_Elmt
(Expression
(Discr
), Elist
);
12987 -- Tag the defining identifiers for the discriminants with
12988 -- their corresponding default expressions from the tree.
12990 Set_Discriminant_Default_Value
12991 (Defining_Identifier
(Discr
), Expression
(Discr
));
12995 Default_Not_Present
:= True;
12998 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
12999 -- Discr_Type but with the null-exclusion attribute
13001 if Ada_Version
>= Ada_05
then
13003 -- Ada 2005 (AI-231): Static checks
13005 if Can_Never_Be_Null
(Discr_Type
) then
13006 Null_Exclusion_Static_Checks
(Discr
);
13008 elsif Is_Access_Type
(Discr_Type
)
13009 and then Null_Exclusion_Present
(Discr
)
13011 -- No need to check itypes because in their case this check
13012 -- was done at their point of creation
13014 and then not Is_Itype
(Discr_Type
)
13016 if Can_Never_Be_Null
(Discr_Type
) then
13018 ("(Ada 2005) already a null-excluding type", Discr
);
13021 Set_Etype
(Defining_Identifier
(Discr
),
13022 Create_Null_Excluding_Itype
13024 Related_Nod
=> Discr
));
13032 -- An element list consisting of the default expressions of the
13033 -- discriminants is constructed in the above loop and used to set
13034 -- the Discriminant_Constraint attribute for the type. If an object
13035 -- is declared of this (record or task) type without any explicit
13036 -- discriminant constraint given, this element list will form the
13037 -- actual parameters for the corresponding initialization procedure
13040 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
13041 Set_Stored_Constraint
(Current_Scope
, No_Elist
);
13043 -- Default expressions must be provided either for all or for none
13044 -- of the discriminants of a discriminant part. (RM 3.7.1)
13046 if Default_Present
and then Default_Not_Present
then
13048 ("incomplete specification of defaults for discriminants", N
);
13051 -- The use of the name of a discriminant is not allowed in default
13052 -- expressions of a discriminant part if the specification of the
13053 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
13055 -- To detect this, the discriminant names are entered initially with an
13056 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
13057 -- attempt to use a void entity (for example in an expression that is
13058 -- type-checked) produces the error message: premature usage. Now after
13059 -- completing the semantic analysis of the discriminant part, we can set
13060 -- the Ekind of all the discriminants appropriately.
13062 Discr
:= First
(Discriminant_Specifications
(N
));
13063 Discr_Number
:= Uint_1
;
13064 while Present
(Discr
) loop
13065 Id
:= Defining_Identifier
(Discr
);
13066 Set_Ekind
(Id
, E_Discriminant
);
13067 Init_Component_Location
(Id
);
13069 Set_Discriminant_Number
(Id
, Discr_Number
);
13071 -- Make sure this is always set, even in illegal programs
13073 Set_Corresponding_Discriminant
(Id
, Empty
);
13075 -- Initialize the Original_Record_Component to the entity itself.
13076 -- Inherit_Components will propagate the right value to
13077 -- discriminants in derived record types.
13079 Set_Original_Record_Component
(Id
, Id
);
13081 -- Create the discriminal for the discriminant
13083 Build_Discriminal
(Id
);
13086 Discr_Number
:= Discr_Number
+ 1;
13089 Set_Has_Discriminants
(Current_Scope
);
13090 end Process_Discriminants
;
13092 -----------------------
13093 -- Process_Full_View --
13094 -----------------------
13096 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
13097 Priv_Parent
: Entity_Id
;
13098 Full_Parent
: Entity_Id
;
13099 Full_Indic
: Node_Id
;
13101 function Find_Interface_In_Descendant
13102 (Typ
: Entity_Id
) return Entity_Id
;
13103 -- Find an implemented interface in the derivation chain of Typ
13105 ----------------------------------
13106 -- Find_Interface_In_Descendant --
13107 ----------------------------------
13109 function Find_Interface_In_Descendant
13110 (Typ
: Entity_Id
) return Entity_Id
13116 while T
/= Etype
(T
) loop
13117 if Is_Interface
(Etype
(T
)) then
13123 -- Protect us against erroneous code that has a large
13124 -- chain of circularity dependencies
13130 end Find_Interface_In_Descendant
;
13132 -- Start of processing for Process_Full_View
13135 -- First some sanity checks that must be done after semantic
13136 -- decoration of the full view and thus cannot be placed with other
13137 -- similar checks in Find_Type_Name
13139 if not Is_Limited_Type
(Priv_T
)
13140 and then (Is_Limited_Type
(Full_T
)
13141 or else Is_Limited_Composite
(Full_T
))
13144 ("completion of nonlimited type cannot be limited", Full_T
);
13145 Explain_Limited_Type
(Full_T
, Full_T
);
13147 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
13149 ("completion of nonabstract type cannot be abstract", Full_T
);
13151 elsif Is_Tagged_Type
(Priv_T
)
13152 and then Is_Limited_Type
(Priv_T
)
13153 and then not Is_Limited_Type
(Full_T
)
13155 -- GNAT allow its own definition of Limited_Controlled to disobey
13156 -- this rule in order in ease the implementation. The next test is
13157 -- safe because Root_Controlled is defined in a private system child
13159 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
13160 Set_Is_Limited_Composite
(Full_T
);
13163 ("completion of limited tagged type must be limited", Full_T
);
13166 elsif Is_Generic_Type
(Priv_T
) then
13167 Error_Msg_N
("generic type cannot have a completion", Full_T
);
13170 -- Ada 2005 (AI-396): A full view shall be a descendant of an
13171 -- interface type if and only if the corresponding partial view
13172 -- (if any) is also a descendant of the interface type, or if
13173 -- the partial view is untagged.
13175 if Ada_Version
>= Ada_05
13176 and then Is_Tagged_Type
(Full_T
)
13180 Iface_Def
: Node_Id
;
13183 Iface
:= Find_Interface_In_Descendant
(Full_T
);
13185 if Present
(Iface
) then
13186 Iface_Def
:= Type_Definition
(Parent
(Iface
));
13189 -- The full view derives from an interface descendant, but the
13190 -- partial view does not share the same tagged type.
13193 and then Is_Tagged_Type
(Priv_T
)
13194 and then Etype
(Full_T
) /= Etype
(Priv_T
)
13196 Error_Msg_N
("(Ada 2005) tagged partial view cannot be " &
13197 "completed by a type that implements an " &
13198 "interface", Priv_T
);
13201 -- The full view derives from a limited, protected,
13202 -- synchronized or task interface descendant, but the
13203 -- partial view is not labeled as limited.
13206 and then (Limited_Present
(Iface_Def
)
13207 or Protected_Present
(Iface_Def
)
13208 or Synchronized_Present
(Iface_Def
)
13209 or Task_Present
(Iface_Def
))
13210 and then not Limited_Present
(Parent
(Priv_T
))
13212 Error_Msg_N
("(Ada 2005) non-limited private type cannot be " &
13213 "completed by a limited type", Priv_T
);
13218 if Is_Tagged_Type
(Priv_T
)
13219 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
13220 and then Is_Derived_Type
(Full_T
)
13222 Priv_Parent
:= Etype
(Priv_T
);
13224 -- The full view of a private extension may have been transformed
13225 -- into an unconstrained derived type declaration and a subtype
13226 -- declaration (see build_derived_record_type for details).
13228 if Nkind
(N
) = N_Subtype_Declaration
then
13229 Full_Indic
:= Subtype_Indication
(N
);
13230 Full_Parent
:= Etype
(Base_Type
(Full_T
));
13232 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
13233 Full_Parent
:= Etype
(Full_T
);
13236 -- Check that the parent type of the full type is a descendant of
13237 -- the ancestor subtype given in the private extension. If either
13238 -- entity has an Etype equal to Any_Type then we had some previous
13239 -- error situation [7.3(8)].
13241 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
13244 elsif not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
) then
13246 -- Ada 2005 (AI-251): No error needed if the immediate
13247 -- ancestor of the partial view is an interface
13251 -- type PT1 is new I1 with private;
13253 -- type PT1 is new T and I1 with null record;
13255 if Is_Interface
(Base_Type
(Priv_Parent
)) then
13260 ("parent of full type must descend from parent"
13261 & " of private extension", Full_Indic
);
13264 -- Check the rules of 7.3(10): if the private extension inherits
13265 -- known discriminants, then the full type must also inherit those
13266 -- discriminants from the same (ancestor) type, and the parent
13267 -- subtype of the full type must be constrained if and only if
13268 -- the ancestor subtype of the private extension is constrained.
13270 elsif not Present
(Discriminant_Specifications
(Parent
(Priv_T
)))
13271 and then not Has_Unknown_Discriminants
(Priv_T
)
13272 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
13275 Priv_Indic
: constant Node_Id
:=
13276 Subtype_Indication
(Parent
(Priv_T
));
13278 Priv_Constr
: constant Boolean :=
13279 Is_Constrained
(Priv_Parent
)
13281 Nkind
(Priv_Indic
) = N_Subtype_Indication
13282 or else Is_Constrained
(Entity
(Priv_Indic
));
13284 Full_Constr
: constant Boolean :=
13285 Is_Constrained
(Full_Parent
)
13287 Nkind
(Full_Indic
) = N_Subtype_Indication
13288 or else Is_Constrained
(Entity
(Full_Indic
));
13290 Priv_Discr
: Entity_Id
;
13291 Full_Discr
: Entity_Id
;
13294 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
13295 Full_Discr
:= First_Discriminant
(Full_Parent
);
13296 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
13297 if Original_Record_Component
(Priv_Discr
) =
13298 Original_Record_Component
(Full_Discr
)
13300 Corresponding_Discriminant
(Priv_Discr
) =
13301 Corresponding_Discriminant
(Full_Discr
)
13308 Next_Discriminant
(Priv_Discr
);
13309 Next_Discriminant
(Full_Discr
);
13312 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
13314 ("full view must inherit discriminants of the parent type"
13315 & " used in the private extension", Full_Indic
);
13317 elsif Priv_Constr
and then not Full_Constr
then
13319 ("parent subtype of full type must be constrained",
13322 elsif Full_Constr
and then not Priv_Constr
then
13324 ("parent subtype of full type must be unconstrained",
13329 -- Check the rules of 7.3(12): if a partial view has neither known
13330 -- or unknown discriminants, then the full type declaration shall
13331 -- define a definite subtype.
13333 elsif not Has_Unknown_Discriminants
(Priv_T
)
13334 and then not Has_Discriminants
(Priv_T
)
13335 and then not Is_Constrained
(Full_T
)
13338 ("full view must define a constrained type if partial view"
13339 & " has no discriminants", Full_T
);
13342 -- ??????? Do we implement the following properly ?????
13343 -- If the ancestor subtype of a private extension has constrained
13344 -- discriminants, then the parent subtype of the full view shall
13345 -- impose a statically matching constraint on those discriminants
13349 -- For untagged types, verify that a type without discriminants
13350 -- is not completed with an unconstrained type.
13352 if not Is_Indefinite_Subtype
(Priv_T
)
13353 and then Is_Indefinite_Subtype
(Full_T
)
13355 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
13359 -- Ada 2005 AI-363: if the full view has discriminants with
13360 -- defaults, it is illegal to declare constrained access subtypes
13361 -- whose designated type is the current type. This allows objects
13362 -- of the type that are declared in the heap to be unconstrained.
13364 if not Has_Unknown_Discriminants
(Priv_T
)
13365 and then not Has_Discriminants
(Priv_T
)
13366 and then Has_Discriminants
(Full_T
)
13369 (Discriminant_Default_Value
(First_Discriminant
(Full_T
)))
13371 Set_Has_Constrained_Partial_View
(Full_T
);
13372 Set_Has_Constrained_Partial_View
(Priv_T
);
13375 -- Create a full declaration for all its subtypes recorded in
13376 -- Private_Dependents and swap them similarly to the base type. These
13377 -- are subtypes that have been define before the full declaration of
13378 -- the private type. We also swap the entry in Private_Dependents list
13379 -- so we can properly restore the private view on exit from the scope.
13382 Priv_Elmt
: Elmt_Id
;
13387 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
13388 while Present
(Priv_Elmt
) loop
13389 Priv
:= Node
(Priv_Elmt
);
13391 if Ekind
(Priv
) = E_Private_Subtype
13392 or else Ekind
(Priv
) = E_Limited_Private_Subtype
13393 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
13395 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
13396 Set_Is_Itype
(Full
);
13397 Set_Parent
(Full
, Parent
(Priv
));
13398 Set_Associated_Node_For_Itype
(Full
, N
);
13400 -- Now we need to complete the private subtype, but since the
13401 -- base type has already been swapped, we must also swap the
13402 -- subtypes (and thus, reverse the arguments in the call to
13403 -- Complete_Private_Subtype).
13405 Copy_And_Swap
(Priv
, Full
);
13406 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
13407 Replace_Elmt
(Priv_Elmt
, Full
);
13410 Next_Elmt
(Priv_Elmt
);
13414 -- If the private view was tagged, copy the new Primitive
13415 -- operations from the private view to the full view.
13417 if Is_Tagged_Type
(Full_T
) then
13419 Priv_List
: Elist_Id
;
13420 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
13423 D_Type
: Entity_Id
;
13426 if Is_Tagged_Type
(Priv_T
) then
13427 Priv_List
:= Primitive_Operations
(Priv_T
);
13429 P1
:= First_Elmt
(Priv_List
);
13430 while Present
(P1
) loop
13433 -- Transfer explicit primitives, not those inherited from
13434 -- parent of partial view, which will be re-inherited on
13437 if Comes_From_Source
(Prim
) then
13438 P2
:= First_Elmt
(Full_List
);
13439 while Present
(P2
) and then Node
(P2
) /= Prim
loop
13443 -- If not found, that is a new one
13446 Append_Elmt
(Prim
, Full_List
);
13454 -- In this case the partial view is untagged, so here we
13455 -- locate all of the earlier primitives that need to be
13456 -- treated as dispatching (those that appear between the two
13457 -- views). Note that these additional operations must all be
13458 -- new operations (any earlier operations that override
13459 -- inherited operations of the full view will already have
13460 -- been inserted in the primitives list and marked as
13461 -- dispatching by Check_Operation_From_Private_View. Note that
13462 -- implicit "/=" operators are excluded from being added to
13463 -- the primitives list since they shouldn't be treated as
13464 -- dispatching (tagged "/=" is handled specially).
13466 Prim
:= Next_Entity
(Full_T
);
13467 while Present
(Prim
) and then Prim
/= Priv_T
loop
13468 if Ekind
(Prim
) = E_Procedure
13470 Ekind
(Prim
) = E_Function
13473 D_Type
:= Find_Dispatching_Type
(Prim
);
13476 and then (Chars
(Prim
) /= Name_Op_Ne
13477 or else Comes_From_Source
(Prim
))
13479 Check_Controlling_Formals
(Full_T
, Prim
);
13481 if not Is_Dispatching_Operation
(Prim
) then
13482 Append_Elmt
(Prim
, Full_List
);
13483 Set_Is_Dispatching_Operation
(Prim
, True);
13484 Set_DT_Position
(Prim
, No_Uint
);
13487 elsif Is_Dispatching_Operation
(Prim
)
13488 and then D_Type
/= Full_T
13491 -- Verify that it is not otherwise controlled by
13492 -- a formal or a return value of type T.
13494 Check_Controlling_Formals
(D_Type
, Prim
);
13498 Next_Entity
(Prim
);
13502 -- For the tagged case, the two views can share the same
13503 -- Primitive Operation list and the same class wide type.
13504 -- Update attributes of the class-wide type which depend on
13505 -- the full declaration.
13507 if Is_Tagged_Type
(Priv_T
) then
13508 Set_Primitive_Operations
(Priv_T
, Full_List
);
13509 Set_Class_Wide_Type
13510 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
13512 -- Any other attributes should be propagated to C_W ???
13514 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
13519 end Process_Full_View
;
13521 -----------------------------------
13522 -- Process_Incomplete_Dependents --
13523 -----------------------------------
13525 procedure Process_Incomplete_Dependents
13527 Full_T
: Entity_Id
;
13530 Inc_Elmt
: Elmt_Id
;
13531 Priv_Dep
: Entity_Id
;
13532 New_Subt
: Entity_Id
;
13534 Disc_Constraint
: Elist_Id
;
13537 if No
(Private_Dependents
(Inc_T
)) then
13541 -- Itypes that may be generated by the completion of an incomplete
13542 -- subtype are not used by the back-end and not attached to the tree.
13543 -- They are created only for constraint-checking purposes.
13545 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
13546 while Present
(Inc_Elmt
) loop
13547 Priv_Dep
:= Node
(Inc_Elmt
);
13549 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
13551 -- An Access_To_Subprogram type may have a return type or a
13552 -- parameter type that is incomplete. Replace with the full view.
13554 if Etype
(Priv_Dep
) = Inc_T
then
13555 Set_Etype
(Priv_Dep
, Full_T
);
13559 Formal
: Entity_Id
;
13562 Formal
:= First_Formal
(Priv_Dep
);
13563 while Present
(Formal
) loop
13564 if Etype
(Formal
) = Inc_T
then
13565 Set_Etype
(Formal
, Full_T
);
13568 Next_Formal
(Formal
);
13572 elsif Is_Overloadable
(Priv_Dep
) then
13574 -- A protected operation is never dispatching: only its
13575 -- wrapper operation (which has convention Ada) is.
13577 if Is_Tagged_Type
(Full_T
)
13578 and then Convention
(Priv_Dep
) /= Convention_Protected
13581 -- Subprogram has an access parameter whose designated type
13582 -- was incomplete. Reexamine declaration now, because it may
13583 -- be a primitive operation of the full type.
13585 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
13586 Set_Is_Dispatching_Operation
(Priv_Dep
);
13587 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
13590 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
13592 -- Can happen during processing of a body before the completion
13593 -- of a TA type. Ignore, because spec is also on dependent list.
13597 -- Dependent is a subtype
13600 -- We build a new subtype indication using the full view of the
13601 -- incomplete parent. The discriminant constraints have been
13602 -- elaborated already at the point of the subtype declaration.
13604 New_Subt
:= Create_Itype
(E_Void
, N
);
13606 if Has_Discriminants
(Full_T
) then
13607 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
13609 Disc_Constraint
:= No_Elist
;
13612 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
13613 Set_Full_View
(Priv_Dep
, New_Subt
);
13616 Next_Elmt
(Inc_Elmt
);
13618 end Process_Incomplete_Dependents
;
13620 --------------------------------
13621 -- Process_Range_Expr_In_Decl --
13622 --------------------------------
13624 procedure Process_Range_Expr_In_Decl
13627 Check_List
: List_Id
:= Empty_List
;
13628 R_Check_Off
: Boolean := False)
13631 R_Checks
: Check_Result
;
13632 Type_Decl
: Node_Id
;
13633 Def_Id
: Entity_Id
;
13636 Analyze_And_Resolve
(R
, Base_Type
(T
));
13638 if Nkind
(R
) = N_Range
then
13639 Lo
:= Low_Bound
(R
);
13640 Hi
:= High_Bound
(R
);
13642 -- If there were errors in the declaration, try and patch up some
13643 -- common mistakes in the bounds. The cases handled are literals
13644 -- which are Integer where the expected type is Real and vice versa.
13645 -- These corrections allow the compilation process to proceed further
13646 -- along since some basic assumptions of the format of the bounds
13649 if Etype
(R
) = Any_Type
then
13651 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
13653 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
13655 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
13657 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
13659 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
13661 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
13663 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
13665 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
13672 -- If the bounds of the range have been mistakenly given as string
13673 -- literals (perhaps in place of character literals), then an error
13674 -- has already been reported, but we rewrite the string literal as a
13675 -- bound of the range's type to avoid blowups in later processing
13676 -- that looks at static values.
13678 if Nkind
(Lo
) = N_String_Literal
then
13680 Make_Attribute_Reference
(Sloc
(Lo
),
13681 Attribute_Name
=> Name_First
,
13682 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
13683 Analyze_And_Resolve
(Lo
);
13686 if Nkind
(Hi
) = N_String_Literal
then
13688 Make_Attribute_Reference
(Sloc
(Hi
),
13689 Attribute_Name
=> Name_First
,
13690 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
13691 Analyze_And_Resolve
(Hi
);
13694 -- If bounds aren't scalar at this point then exit, avoiding
13695 -- problems with further processing of the range in this procedure.
13697 if not Is_Scalar_Type
(Etype
(Lo
)) then
13701 -- Resolve (actually Sem_Eval) has checked that the bounds are in
13702 -- then range of the base type. Here we check whether the bounds
13703 -- are in the range of the subtype itself. Note that if the bounds
13704 -- represent the null range the Constraint_Error exception should
13707 -- ??? The following code should be cleaned up as follows
13709 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
13710 -- is done in the call to Range_Check (R, T); below
13712 -- 2. The use of R_Check_Off should be investigated and possibly
13713 -- removed, this would clean up things a bit.
13715 if Is_Null_Range
(Lo
, Hi
) then
13719 -- Capture values of bounds and generate temporaries for them
13720 -- if needed, before applying checks, since checks may cause
13721 -- duplication of the expression without forcing evaluation.
13723 if Expander_Active
then
13724 Force_Evaluation
(Lo
);
13725 Force_Evaluation
(Hi
);
13728 -- We use a flag here instead of suppressing checks on the
13729 -- type because the type we check against isn't necessarily
13730 -- the place where we put the check.
13732 if not R_Check_Off
then
13733 R_Checks
:= Range_Check
(R
, T
);
13735 -- Look up tree to find an appropriate insertion point.
13736 -- This seems really junk code, and very brittle, couldn't
13737 -- we just use an insert actions call of some kind ???
13739 Type_Decl
:= Parent
(R
);
13740 while Present
(Type_Decl
) and then not
13741 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
13743 Nkind
(Type_Decl
) = N_Subtype_Declaration
13745 Nkind
(Type_Decl
) = N_Loop_Statement
13747 Nkind
(Type_Decl
) = N_Task_Type_Declaration
13749 Nkind
(Type_Decl
) = N_Single_Task_Declaration
13751 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
13753 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
13755 Type_Decl
:= Parent
(Type_Decl
);
13758 -- Why would Type_Decl not be present??? Without this test,
13759 -- short regression tests fail.
13761 if Present
(Type_Decl
) then
13763 -- Case of loop statement (more comments ???)
13765 if Nkind
(Type_Decl
) = N_Loop_Statement
then
13770 Indic
:= Parent
(R
);
13771 while Present
(Indic
) and then not
13772 (Nkind
(Indic
) = N_Subtype_Indication
)
13774 Indic
:= Parent
(Indic
);
13777 if Present
(Indic
) then
13778 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
13780 Insert_Range_Checks
13786 Do_Before
=> True);
13790 -- All other cases (more comments ???)
13793 Def_Id
:= Defining_Identifier
(Type_Decl
);
13795 if (Ekind
(Def_Id
) = E_Record_Type
13796 and then Depends_On_Discriminant
(R
))
13798 (Ekind
(Def_Id
) = E_Protected_Type
13799 and then Has_Discriminants
(Def_Id
))
13801 Append_Range_Checks
13802 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
13805 Insert_Range_Checks
13806 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
13814 elsif Expander_Active
then
13815 Get_Index_Bounds
(R
, Lo
, Hi
);
13816 Force_Evaluation
(Lo
);
13817 Force_Evaluation
(Hi
);
13819 end Process_Range_Expr_In_Decl
;
13821 --------------------------------------
13822 -- Process_Real_Range_Specification --
13823 --------------------------------------
13825 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
13826 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
13829 Err
: Boolean := False;
13831 procedure Analyze_Bound
(N
: Node_Id
);
13832 -- Analyze and check one bound
13834 -------------------
13835 -- Analyze_Bound --
13836 -------------------
13838 procedure Analyze_Bound
(N
: Node_Id
) is
13840 Analyze_And_Resolve
(N
, Any_Real
);
13842 if not Is_OK_Static_Expression
(N
) then
13843 Flag_Non_Static_Expr
13844 ("bound in real type definition is not static!", N
);
13849 -- Start of processing for Process_Real_Range_Specification
13852 if Present
(Spec
) then
13853 Lo
:= Low_Bound
(Spec
);
13854 Hi
:= High_Bound
(Spec
);
13855 Analyze_Bound
(Lo
);
13856 Analyze_Bound
(Hi
);
13858 -- If error, clear away junk range specification
13861 Set_Real_Range_Specification
(Def
, Empty
);
13864 end Process_Real_Range_Specification
;
13866 ---------------------
13867 -- Process_Subtype --
13868 ---------------------
13870 function Process_Subtype
13872 Related_Nod
: Node_Id
;
13873 Related_Id
: Entity_Id
:= Empty
;
13874 Suffix
: Character := ' ') return Entity_Id
13877 Def_Id
: Entity_Id
;
13878 Error_Node
: Node_Id
;
13879 Full_View_Id
: Entity_Id
;
13880 Subtype_Mark_Id
: Entity_Id
;
13882 May_Have_Null_Exclusion
: Boolean;
13884 procedure Check_Incomplete
(T
: Entity_Id
);
13885 -- Called to verify that an incomplete type is not used prematurely
13887 ----------------------
13888 -- Check_Incomplete --
13889 ----------------------
13891 procedure Check_Incomplete
(T
: Entity_Id
) is
13893 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
then
13894 Error_Msg_N
("invalid use of type before its full declaration", T
);
13896 end Check_Incomplete
;
13898 -- Start of processing for Process_Subtype
13901 -- Case of no constraints present
13903 if Nkind
(S
) /= N_Subtype_Indication
then
13906 Check_Incomplete
(S
);
13909 -- Ada 2005 (AI-231): Static check
13911 if Ada_Version
>= Ada_05
13912 and then Present
(P
)
13913 and then Null_Exclusion_Present
(P
)
13914 and then Nkind
(P
) /= N_Access_To_Object_Definition
13915 and then not Is_Access_Type
(Entity
(S
))
13918 ("(Ada 2005) the null-exclusion part requires an access type",
13922 May_Have_Null_Exclusion
:=
13923 Nkind
(P
) = N_Access_Definition
13924 or else Nkind
(P
) = N_Access_Function_Definition
13925 or else Nkind
(P
) = N_Access_Procedure_Definition
13926 or else Nkind
(P
) = N_Access_To_Object_Definition
13927 or else Nkind
(P
) = N_Allocator
13928 or else Nkind
(P
) = N_Component_Definition
13929 or else Nkind
(P
) = N_Derived_Type_Definition
13930 or else Nkind
(P
) = N_Discriminant_Specification
13931 or else Nkind
(P
) = N_Object_Declaration
13932 or else Nkind
(P
) = N_Parameter_Specification
13933 or else Nkind
(P
) = N_Subtype_Declaration
;
13935 -- Create an Itype that is a duplicate of Entity (S) but with the
13936 -- null-exclusion attribute
13938 if May_Have_Null_Exclusion
13939 and then Is_Access_Type
(Entity
(S
))
13940 and then Null_Exclusion_Present
(P
)
13942 -- No need to check the case of an access to object definition.
13943 -- It is correct to define double not-null pointers.
13945 -- type Not_Null_Int_Ptr is not null access Integer;
13946 -- type Acc is not null access Not_Null_Int_Ptr;
13948 and then Nkind
(P
) /= N_Access_To_Object_Definition
13950 if Can_Never_Be_Null
(Entity
(S
)) then
13951 case Nkind
(Related_Nod
) is
13952 when N_Full_Type_Declaration
=>
13953 if Nkind
(Type_Definition
(Related_Nod
))
13954 in N_Array_Type_Definition
13958 (Component_Definition
13959 (Type_Definition
(Related_Nod
)));
13962 Subtype_Indication
(Type_Definition
(Related_Nod
));
13965 when N_Subtype_Declaration
=>
13966 Error_Node
:= Subtype_Indication
(Related_Nod
);
13968 when N_Object_Declaration
=>
13969 Error_Node
:= Object_Definition
(Related_Nod
);
13971 when N_Component_Declaration
=>
13973 Subtype_Indication
(Component_Definition
(Related_Nod
));
13976 pragma Assert
(False);
13977 Error_Node
:= Related_Nod
;
13981 ("(Ada 2005) already a null-excluding type", Error_Node
);
13985 Create_Null_Excluding_Itype
13987 Related_Nod
=> P
));
13988 Set_Entity
(S
, Etype
(S
));
13993 -- Case of constraint present, so that we have an N_Subtype_Indication
13994 -- node (this node is created only if constraints are present).
13998 Find_Type
(Subtype_Mark
(S
));
14000 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
14002 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
14004 Is_Itype
(Defining_Identifier
(Parent
(S
))))
14006 Check_Incomplete
(Subtype_Mark
(S
));
14010 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
14012 -- Explicit subtype declaration case
14014 if Nkind
(P
) = N_Subtype_Declaration
then
14015 Def_Id
:= Defining_Identifier
(P
);
14017 -- Explicit derived type definition case
14019 elsif Nkind
(P
) = N_Derived_Type_Definition
then
14020 Def_Id
:= Defining_Identifier
(Parent
(P
));
14022 -- Implicit case, the Def_Id must be created as an implicit type.
14023 -- The one exception arises in the case of concurrent types, array
14024 -- and access types, where other subsidiary implicit types may be
14025 -- created and must appear before the main implicit type. In these
14026 -- cases we leave Def_Id set to Empty as a signal that Create_Itype
14027 -- has not yet been called to create Def_Id.
14030 if Is_Array_Type
(Subtype_Mark_Id
)
14031 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
14032 or else Is_Access_Type
(Subtype_Mark_Id
)
14036 -- For the other cases, we create a new unattached Itype,
14037 -- and set the indication to ensure it gets attached later.
14041 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14045 -- If the kind of constraint is invalid for this kind of type,
14046 -- then give an error, and then pretend no constraint was given.
14048 if not Is_Valid_Constraint_Kind
14049 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
14052 ("incorrect constraint for this kind of type", Constraint
(S
));
14054 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
14056 -- Set Ekind of orphan itype, to prevent cascaded errors
14058 if Present
(Def_Id
) then
14059 Set_Ekind
(Def_Id
, Ekind
(Any_Type
));
14062 -- Make recursive call, having got rid of the bogus constraint
14064 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
14067 -- Remaining processing depends on type
14069 case Ekind
(Subtype_Mark_Id
) is
14070 when Access_Kind
=>
14071 Constrain_Access
(Def_Id
, S
, Related_Nod
);
14074 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
14076 when Decimal_Fixed_Point_Kind
=>
14077 Constrain_Decimal
(Def_Id
, S
);
14079 when Enumeration_Kind
=>
14080 Constrain_Enumeration
(Def_Id
, S
);
14082 when Ordinary_Fixed_Point_Kind
=>
14083 Constrain_Ordinary_Fixed
(Def_Id
, S
);
14086 Constrain_Float
(Def_Id
, S
);
14088 when Integer_Kind
=>
14089 Constrain_Integer
(Def_Id
, S
);
14091 when E_Record_Type |
14094 E_Incomplete_Type
=>
14095 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14097 when Private_Kind
=>
14098 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
14099 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
14101 -- In case of an invalid constraint prevent further processing
14102 -- since the type constructed is missing expected fields.
14104 if Etype
(Def_Id
) = Any_Type
then
14108 -- If the full view is that of a task with discriminants,
14109 -- we must constrain both the concurrent type and its
14110 -- corresponding record type. Otherwise we will just propagate
14111 -- the constraint to the full view, if available.
14113 if Present
(Full_View
(Subtype_Mark_Id
))
14114 and then Has_Discriminants
(Subtype_Mark_Id
)
14115 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
14118 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
14120 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
14121 Constrain_Concurrent
(Full_View_Id
, S
,
14122 Related_Nod
, Related_Id
, Suffix
);
14123 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
14124 Set_Full_View
(Def_Id
, Full_View_Id
);
14127 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
14130 when Concurrent_Kind
=>
14131 Constrain_Concurrent
(Def_Id
, S
,
14132 Related_Nod
, Related_Id
, Suffix
);
14135 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
14138 -- Size and Convention are always inherited from the base type
14140 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
14141 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
14145 end Process_Subtype
;
14147 -----------------------------
14148 -- Record_Type_Declaration --
14149 -----------------------------
14151 procedure Record_Type_Declaration
14156 Loc
: constant Source_Ptr
:= Sloc
(N
);
14157 Def
: constant Node_Id
:= Type_Definition
(N
);
14158 Inc_T
: Entity_Id
:= Empty
;
14160 Is_Tagged
: Boolean;
14161 Tag_Comp
: Entity_Id
;
14163 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
);
14164 -- Ada 2005 AI-382: an access component in a record declaration can
14165 -- refer to the enclosing record, in which case it denotes the type
14166 -- itself, and not the current instance of the type. We create an
14167 -- anonymous access type for the component, and flag it as an access
14168 -- to a component, so that accessibility checks are properly performed
14169 -- on it. The declaration of the access type is placed ahead of that
14170 -- of the record, to prevent circular order-of-elaboration issues in
14171 -- Gigi. We create an incomplete type for the record declaration, which
14172 -- is the designated type of the anonymous access.
14174 procedure Make_Incomplete_Type_Declaration
;
14175 -- If the record type contains components that include an access to the
14176 -- current record, create an incomplete type declaration for the record,
14177 -- to be used as the designated type of the anonymous access. This is
14178 -- done only once, and only if there is no previous partial view of the
14181 ----------------------------------
14182 -- Check_Anonymous_Access_Types --
14183 ----------------------------------
14185 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
) is
14186 Anon_Access
: Entity_Id
;
14190 Type_Def
: Node_Id
;
14192 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean;
14193 -- Check whether an access definition includes a reference to
14194 -- the enclosing record type. The reference can be a subtype
14195 -- mark in the access definition itself, or a 'Class attribute
14196 -- reference, or recursively a reference appearing in a parameter
14197 -- type in an access_to_subprogram definition.
14203 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean is
14207 if No
(Access_To_Subprogram_Definition
(Acc_Def
)) then
14208 Subt
:= Subtype_Mark
(Acc_Def
);
14210 if Nkind
(Subt
) = N_Identifier
then
14211 return Chars
(Subt
) = Chars
(T
);
14212 elsif Nkind
(Subt
) = N_Attribute_Reference
14213 and then Attribute_Name
(Subt
) = Name_Class
14215 return (Chars
(Prefix
(Subt
))) = Chars
(T
);
14221 -- Component is an access_to_subprogram: examine its formals
14224 Param_Spec
: Node_Id
;
14229 (Parameter_Specifications
14230 (Access_To_Subprogram_Definition
(Acc_Def
)));
14231 while Present
(Param_Spec
) loop
14232 if Nkind
(Parameter_Type
(Param_Spec
))
14233 = N_Access_Definition
14234 and then Mentions_T
(Parameter_Type
(Param_Spec
))
14247 -- Start of processing for Check_Anonymous_Access_Types
14250 if No
(Comp_List
) then
14254 Comp
:= First
(Component_Items
(Comp_List
));
14255 while Present
(Comp
) loop
14256 if Nkind
(Comp
) = N_Component_Declaration
14258 Present
(Access_Definition
(Component_Definition
(Comp
)))
14260 Mentions_T
(Access_Definition
(Component_Definition
(Comp
)))
14263 Access_To_Subprogram_Definition
14264 (Access_Definition
(Component_Definition
(Comp
)));
14266 Make_Incomplete_Type_Declaration
;
14268 Make_Defining_Identifier
(Loc
,
14269 Chars
=> New_Internal_Name
('S'));
14271 -- Create a declaration for the anonymous access type: either
14272 -- an access_to_object or an access_to_subprogram.
14274 if Present
(Acc_Def
) then
14275 if Nkind
(Acc_Def
) = N_Access_Function_Definition
then
14277 Make_Access_Function_Definition
(Loc
,
14278 Parameter_Specifications
=>
14279 Parameter_Specifications
(Acc_Def
),
14280 Result_Definition
=> Result_Definition
(Acc_Def
));
14283 Make_Access_Procedure_Definition
(Loc
,
14284 Parameter_Specifications
=>
14285 Parameter_Specifications
(Acc_Def
));
14290 Make_Access_To_Object_Definition
(Loc
,
14291 Subtype_Indication
=>
14295 (Component_Definition
(Comp
)))));
14298 Decl
:= Make_Full_Type_Declaration
(Loc
,
14299 Defining_Identifier
=> Anon_Access
,
14300 Type_Definition
=> Type_Def
);
14302 Insert_Before
(N
, Decl
);
14305 Set_Access_Definition
(Component_Definition
(Comp
), Empty
);
14306 Set_Subtype_Indication
(Component_Definition
(Comp
),
14307 New_Occurrence_Of
(Anon_Access
, Loc
));
14308 Set_Ekind
(Anon_Access
, E_Anonymous_Access_Type
);
14309 Set_Is_Local_Anonymous_Access
(Anon_Access
);
14315 if Present
(Variant_Part
(Comp_List
)) then
14319 V
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
14320 while Present
(V
) loop
14321 Check_Anonymous_Access_Types
(Component_List
(V
));
14322 Next_Non_Pragma
(V
);
14326 end Check_Anonymous_Access_Types
;
14328 --------------------------------------
14329 -- Make_Incomplete_Type_Declaration --
14330 --------------------------------------
14332 procedure Make_Incomplete_Type_Declaration
is
14337 -- If there is a previous partial view, no need to create a new one
14342 elsif No
(Inc_T
) then
14343 Inc_T
:= Make_Defining_Identifier
(Loc
, Chars
(T
));
14344 Decl
:= Make_Incomplete_Type_Declaration
(Loc
, Inc_T
);
14346 -- Type has already been inserted into the current scope.
14347 -- Remove it, and add incomplete declaration for type, so
14348 -- that subsequent anonymous access types can use it.
14350 H
:= Current_Entity
(T
);
14353 Set_Name_Entity_Id
(Chars
(T
), Empty
);
14356 and then Homonym
(H
) /= T
14361 Set_Homonym
(H
, Homonym
(T
));
14364 Insert_Before
(N
, Decl
);
14366 Set_Full_View
(Inc_T
, T
);
14368 if Tagged_Present
(Def
) then
14369 Make_Class_Wide_Type
(Inc_T
);
14370 Set_Class_Wide_Type
(T
, Class_Wide_Type
(Inc_T
));
14373 end Make_Incomplete_Type_Declaration
;
14375 -- Start of processing for Record_Type_Declaration
14378 -- These flags must be initialized before calling Process_Discriminants
14379 -- because this routine makes use of them.
14381 Set_Ekind
(T
, E_Record_Type
);
14383 Init_Size_Align
(T
);
14384 Set_Abstract_Interfaces
(T
, No_Elist
);
14385 Set_Stored_Constraint
(T
, No_Elist
);
14389 if Ada_Version
< Ada_05
14390 or else not Interface_Present
(Def
)
14392 -- The flag Is_Tagged_Type might have already been set by
14393 -- Find_Type_Name if it detected an error for declaration T. This
14394 -- arises in the case of private tagged types where the full view
14395 -- omits the word tagged.
14398 Tagged_Present
(Def
)
14399 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
14401 Set_Is_Tagged_Type
(T
, Is_Tagged
);
14402 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
14404 -- Type is abstract if full declaration carries keyword, or if
14405 -- previous partial view did.
14407 Set_Is_Abstract
(T
, Is_Abstract
(T
)
14408 or else Abstract_Present
(Def
));
14412 Set_Is_Tagged_Type
(T
);
14414 Set_Is_Limited_Record
(T
, Limited_Present
(Def
)
14415 or else Task_Present
(Def
)
14416 or else Protected_Present
(Def
));
14418 -- Type is abstract if full declaration carries keyword, or if
14419 -- previous partial view did.
14421 Set_Is_Abstract
(T
);
14422 Set_Is_Interface
(T
);
14425 -- First pass: if there are self-referential access components,
14426 -- create the required anonymous access type declarations, and if
14427 -- need be an incomplete type declaration for T itself.
14429 Check_Anonymous_Access_Types
(Component_List
(Def
));
14431 -- Ada 2005 (AI-251): Complete the initialization of attributes
14432 -- associated with abstract interfaces and decorate the names in the
14433 -- list of ancestor interfaces (if any).
14435 if Ada_Version
>= Ada_05
14436 and then Present
(Interface_List
(Def
))
14440 Iface_Def
: Node_Id
;
14441 Iface_Typ
: Entity_Id
;
14443 Iface
:= First
(Interface_List
(Def
));
14444 while Present
(Iface
) loop
14445 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
14446 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
14448 if not Is_Interface
(Iface_Typ
) then
14449 Error_Msg_NE
("(Ada 2005) & must be an interface",
14453 -- "The declaration of a specific descendant of an
14454 -- interface type freezes the interface type" RM 13.14
14456 Freeze_Before
(N
, Iface_Typ
);
14458 -- Ada 2005 (AI-345): Protected interfaces can only
14459 -- inherit from limited, synchronized or protected
14462 if Protected_Present
(Def
) then
14463 if Limited_Present
(Iface_Def
)
14464 or else Synchronized_Present
(Iface_Def
)
14465 or else Protected_Present
(Iface_Def
)
14469 elsif Task_Present
(Iface_Def
) then
14470 Error_Msg_N
("(Ada 2005) protected interface cannot"
14471 & " inherit from task interface", Iface
);
14474 Error_Msg_N
("(Ada 2005) protected interface cannot"
14475 & " inherit from non-limited interface", Iface
);
14478 -- Ada 2005 (AI-345): Synchronized interfaces can only
14479 -- inherit from limited and synchronized.
14481 elsif Synchronized_Present
(Def
) then
14482 if Limited_Present
(Iface_Def
)
14483 or else Synchronized_Present
(Iface_Def
)
14487 elsif Protected_Present
(Iface_Def
) then
14488 Error_Msg_N
("(Ada 2005) synchronized interface " &
14489 "cannot inherit from protected interface", Iface
);
14491 elsif Task_Present
(Iface_Def
) then
14492 Error_Msg_N
("(Ada 2005) synchronized interface " &
14493 "cannot inherit from task interface", Iface
);
14496 Error_Msg_N
("(Ada 2005) synchronized interface " &
14497 "cannot inherit from non-limited interface",
14501 -- Ada 2005 (AI-345): Task interfaces can only inherit
14502 -- from limited, synchronized or task interfaces.
14504 elsif Task_Present
(Def
) then
14505 if Limited_Present
(Iface_Def
)
14506 or else Synchronized_Present
(Iface_Def
)
14507 or else Task_Present
(Iface_Def
)
14511 elsif Protected_Present
(Iface_Def
) then
14512 Error_Msg_N
("(Ada 2005) task interface cannot" &
14513 " inherit from protected interface", Iface
);
14516 Error_Msg_N
("(Ada 2005) task interface cannot" &
14517 " inherit from non-limited interface", Iface
);
14525 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
14526 Collect_Interfaces
(Type_Definition
(N
), T
);
14530 -- Records constitute a scope for the component declarations within.
14531 -- The scope is created prior to the processing of these declarations.
14532 -- Discriminants are processed first, so that they are visible when
14533 -- processing the other components. The Ekind of the record type itself
14534 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
14536 -- Enter record scope
14540 -- If an incomplete or private type declaration was already given for
14541 -- the type, then this scope already exists, and the discriminants have
14542 -- been declared within. We must verify that the full declaration
14543 -- matches the incomplete one.
14545 Check_Or_Process_Discriminants
(N
, T
, Prev
);
14547 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
14548 Set_Has_Delayed_Freeze
(T
, True);
14550 -- For tagged types add a manually analyzed component corresponding
14551 -- to the component _tag, the corresponding piece of tree will be
14552 -- expanded as part of the freezing actions if it is not a CPP_Class.
14556 -- Do not add the tag unless we are in expansion mode
14558 if Expander_Active
then
14559 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
14560 Enter_Name
(Tag_Comp
);
14562 Set_Is_Tag
(Tag_Comp
);
14563 Set_Is_Aliased
(Tag_Comp
);
14564 Set_Ekind
(Tag_Comp
, E_Component
);
14565 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
14566 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
14567 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
14568 Init_Component_Location
(Tag_Comp
);
14570 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
14571 -- implemented interfaces
14573 Add_Interface_Tag_Components
(N
, T
);
14576 Make_Class_Wide_Type
(T
);
14577 Set_Primitive_Operations
(T
, New_Elmt_List
);
14580 -- We must suppress range checks when processing the components
14581 -- of a record in the presence of discriminants, since we don't
14582 -- want spurious checks to be generated during their analysis, but
14583 -- must reset the Suppress_Range_Checks flags after having processed
14584 -- the record definition.
14586 if Has_Discriminants
(T
) and then not Range_Checks_Suppressed
(T
) then
14587 Set_Kill_Range_Checks
(T
, True);
14588 Record_Type_Definition
(Def
, Prev
);
14589 Set_Kill_Range_Checks
(T
, False);
14591 Record_Type_Definition
(Def
, Prev
);
14594 -- Exit from record scope
14600 and then not Is_Empty_List
(Interface_List
(Def
))
14602 -- Ada 2005 (AI-251): Derive the interface subprograms of all the
14603 -- implemented interfaces and check if some of the subprograms
14604 -- inherited from the ancestor cover some interface subprogram.
14606 Derive_Interface_Subprograms
(T
);
14608 end Record_Type_Declaration
;
14610 ----------------------------
14611 -- Record_Type_Definition --
14612 ----------------------------
14614 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
) is
14615 Component
: Entity_Id
;
14616 Ctrl_Components
: Boolean := False;
14617 Final_Storage_Only
: Boolean;
14621 if Ekind
(Prev_T
) = E_Incomplete_Type
then
14622 T
:= Full_View
(Prev_T
);
14627 Final_Storage_Only
:= not Is_Controlled
(T
);
14629 -- If the component list of a record type is defined by the reserved
14630 -- word null and there is no discriminant part, then the record type has
14631 -- no components and all records of the type are null records (RM 3.7)
14632 -- This procedure is also called to process the extension part of a
14633 -- record extension, in which case the current scope may have inherited
14637 or else No
(Component_List
(Def
))
14638 or else Null_Present
(Component_List
(Def
))
14643 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
14645 if Present
(Variant_Part
(Component_List
(Def
))) then
14646 Analyze
(Variant_Part
(Component_List
(Def
)));
14650 -- After completing the semantic analysis of the record definition,
14651 -- record components, both new and inherited, are accessible. Set
14652 -- their kind accordingly.
14654 Component
:= First_Entity
(Current_Scope
);
14655 while Present
(Component
) loop
14656 if Ekind
(Component
) = E_Void
then
14657 Set_Ekind
(Component
, E_Component
);
14658 Init_Component_Location
(Component
);
14661 if Has_Task
(Etype
(Component
)) then
14665 if Ekind
(Component
) /= E_Component
then
14668 elsif Has_Controlled_Component
(Etype
(Component
))
14669 or else (Chars
(Component
) /= Name_uParent
14670 and then Is_Controlled
(Etype
(Component
)))
14672 Set_Has_Controlled_Component
(T
, True);
14673 Final_Storage_Only
:= Final_Storage_Only
14674 and then Finalize_Storage_Only
(Etype
(Component
));
14675 Ctrl_Components
:= True;
14678 Next_Entity
(Component
);
14681 -- A type is Finalize_Storage_Only only if all its controlled
14682 -- components are so.
14684 if Ctrl_Components
then
14685 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
14688 -- Place reference to end record on the proper entity, which may
14689 -- be a partial view.
14691 if Present
(Def
) then
14692 Process_End_Label
(Def
, 'e', Prev_T
);
14694 end Record_Type_Definition
;
14696 ------------------------
14697 -- Replace_Components --
14698 ------------------------
14700 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
14701 function Process
(N
: Node_Id
) return Traverse_Result
;
14707 function Process
(N
: Node_Id
) return Traverse_Result
is
14711 if Nkind
(N
) = N_Discriminant_Specification
then
14712 Comp
:= First_Discriminant
(Typ
);
14713 while Present
(Comp
) loop
14714 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
14715 Set_Defining_Identifier
(N
, Comp
);
14719 Next_Discriminant
(Comp
);
14722 elsif Nkind
(N
) = N_Component_Declaration
then
14723 Comp
:= First_Component
(Typ
);
14724 while Present
(Comp
) loop
14725 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
14726 Set_Defining_Identifier
(N
, Comp
);
14730 Next_Component
(Comp
);
14737 procedure Replace
is new Traverse_Proc
(Process
);
14739 -- Start of processing for Replace_Components
14743 end Replace_Components
;
14745 -------------------------------
14746 -- Set_Completion_Referenced --
14747 -------------------------------
14749 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
14751 -- If in main unit, mark entity that is a completion as referenced,
14752 -- warnings go on the partial view when needed.
14754 if In_Extended_Main_Source_Unit
(E
) then
14755 Set_Referenced
(E
);
14757 end Set_Completion_Referenced
;
14759 ---------------------
14760 -- Set_Fixed_Range --
14761 ---------------------
14763 -- The range for fixed-point types is complicated by the fact that we
14764 -- do not know the exact end points at the time of the declaration. This
14765 -- is true for three reasons:
14767 -- A size clause may affect the fudging of the end-points
14768 -- A small clause may affect the values of the end-points
14769 -- We try to include the end-points if it does not affect the size
14771 -- This means that the actual end-points must be established at the point
14772 -- when the type is frozen. Meanwhile, we first narrow the range as
14773 -- permitted (so that it will fit if necessary in a small specified size),
14774 -- and then build a range subtree with these narrowed bounds.
14776 -- Set_Fixed_Range constructs the range from real literal values, and sets
14777 -- the range as the Scalar_Range of the given fixed-point type entity.
14779 -- The parent of this range is set to point to the entity so that it is
14780 -- properly hooked into the tree (unlike normal Scalar_Range entries for
14781 -- other scalar types, which are just pointers to the range in the
14782 -- original tree, this would otherwise be an orphan).
14784 -- The tree is left unanalyzed. When the type is frozen, the processing
14785 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
14786 -- analyzed, and uses this as an indication that it should complete
14787 -- work on the range (it will know the final small and size values).
14789 procedure Set_Fixed_Range
14795 S
: constant Node_Id
:=
14797 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
14798 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
14801 Set_Scalar_Range
(E
, S
);
14803 end Set_Fixed_Range
;
14805 ----------------------------------
14806 -- Set_Scalar_Range_For_Subtype --
14807 ----------------------------------
14809 procedure Set_Scalar_Range_For_Subtype
14810 (Def_Id
: Entity_Id
;
14814 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
14817 Set_Scalar_Range
(Def_Id
, R
);
14819 -- We need to link the range into the tree before resolving it so
14820 -- that types that are referenced, including importantly the subtype
14821 -- itself, are properly frozen (Freeze_Expression requires that the
14822 -- expression be properly linked into the tree). Of course if it is
14823 -- already linked in, then we do not disturb the current link.
14825 if No
(Parent
(R
)) then
14826 Set_Parent
(R
, Def_Id
);
14829 -- Reset the kind of the subtype during analysis of the range, to
14830 -- catch possible premature use in the bounds themselves.
14832 Set_Ekind
(Def_Id
, E_Void
);
14833 Process_Range_Expr_In_Decl
(R
, Subt
);
14834 Set_Ekind
(Def_Id
, Kind
);
14836 end Set_Scalar_Range_For_Subtype
;
14838 --------------------------------------------------------
14839 -- Set_Stored_Constraint_From_Discriminant_Constraint --
14840 --------------------------------------------------------
14842 procedure Set_Stored_Constraint_From_Discriminant_Constraint
14846 -- Make sure set if encountered during Expand_To_Stored_Constraint
14848 Set_Stored_Constraint
(E
, No_Elist
);
14850 -- Give it the right value
14852 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
14853 Set_Stored_Constraint
(E
,
14854 Expand_To_Stored_Constraint
(E
, Discriminant_Constraint
(E
)));
14856 end Set_Stored_Constraint_From_Discriminant_Constraint
;
14858 -------------------------------------
14859 -- Signed_Integer_Type_Declaration --
14860 -------------------------------------
14862 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
14863 Implicit_Base
: Entity_Id
;
14864 Base_Typ
: Entity_Id
;
14867 Errs
: Boolean := False;
14871 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
14872 -- Determine whether given bounds allow derivation from specified type
14874 procedure Check_Bound
(Expr
: Node_Id
);
14875 -- Check bound to make sure it is integral and static. If not, post
14876 -- appropriate error message and set Errs flag
14878 ---------------------
14879 -- Can_Derive_From --
14880 ---------------------
14882 -- Note we check both bounds against both end values, to deal with
14883 -- strange types like ones with a range of 0 .. -12341234.
14885 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
14886 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
14887 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
14889 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
14891 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
14892 end Can_Derive_From
;
14898 procedure Check_Bound
(Expr
: Node_Id
) is
14900 -- If a range constraint is used as an integer type definition, each
14901 -- bound of the range must be defined by a static expression of some
14902 -- integer type, but the two bounds need not have the same integer
14903 -- type (Negative bounds are allowed.) (RM 3.5.4)
14905 if not Is_Integer_Type
(Etype
(Expr
)) then
14907 ("integer type definition bounds must be of integer type", Expr
);
14910 elsif not Is_OK_Static_Expression
(Expr
) then
14911 Flag_Non_Static_Expr
14912 ("non-static expression used for integer type bound!", Expr
);
14915 -- The bounds are folded into literals, and we set their type to be
14916 -- universal, to avoid typing difficulties: we cannot set the type
14917 -- of the literal to the new type, because this would be a forward
14918 -- reference for the back end, and if the original type is user-
14919 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
14922 if Is_Entity_Name
(Expr
) then
14923 Fold_Uint
(Expr
, Expr_Value
(Expr
), True);
14926 Set_Etype
(Expr
, Universal_Integer
);
14930 -- Start of processing for Signed_Integer_Type_Declaration
14933 -- Create an anonymous base type
14936 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
14938 -- Analyze and check the bounds, they can be of any integer type
14940 Lo
:= Low_Bound
(Def
);
14941 Hi
:= High_Bound
(Def
);
14943 -- Arbitrarily use Integer as the type if either bound had an error
14945 if Hi
= Error
or else Lo
= Error
then
14946 Base_Typ
:= Any_Integer
;
14947 Set_Error_Posted
(T
, True);
14949 -- Here both bounds are OK expressions
14952 Analyze_And_Resolve
(Lo
, Any_Integer
);
14953 Analyze_And_Resolve
(Hi
, Any_Integer
);
14959 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
14960 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
14963 -- Find type to derive from
14965 Lo_Val
:= Expr_Value
(Lo
);
14966 Hi_Val
:= Expr_Value
(Hi
);
14968 if Can_Derive_From
(Standard_Short_Short_Integer
) then
14969 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
14971 elsif Can_Derive_From
(Standard_Short_Integer
) then
14972 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
14974 elsif Can_Derive_From
(Standard_Integer
) then
14975 Base_Typ
:= Base_Type
(Standard_Integer
);
14977 elsif Can_Derive_From
(Standard_Long_Integer
) then
14978 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
14980 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
14981 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
14984 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
14985 Error_Msg_N
("integer type definition bounds out of range", Def
);
14986 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
14987 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
14991 -- Complete both implicit base and declared first subtype entities
14993 Set_Etype
(Implicit_Base
, Base_Typ
);
14994 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
14995 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
14996 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
14997 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
14999 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
15000 Set_Etype
(T
, Implicit_Base
);
15002 Set_Size_Info
(T
, (Implicit_Base
));
15003 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
15004 Set_Scalar_Range
(T
, Def
);
15005 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
15006 Set_Is_Constrained
(T
);
15007 end Signed_Integer_Type_Declaration
;