1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Elists
; use Elists
;
31 with Einfo
; use Einfo
;
32 with Errout
; use Errout
;
33 with Eval_Fat
; use Eval_Fat
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Dist
; use Exp_Dist
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Exp_Util
; use Exp_Util
;
38 with Freeze
; use Freeze
;
39 with Itypes
; use Itypes
;
40 with Layout
; use Layout
;
42 with Lib
.Xref
; use Lib
.Xref
;
43 with Namet
; use Namet
;
44 with Nmake
; use Nmake
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Case
; use Sem_Case
;
51 with Sem_Cat
; use Sem_Cat
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch7
; use Sem_Ch7
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch13
; use Sem_Ch13
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Dist
; use Sem_Dist
;
58 with Sem_Elim
; use Sem_Elim
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Mech
; use Sem_Mech
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Smem
; use Sem_Smem
;
63 with Sem_Type
; use Sem_Type
;
64 with Sem_Util
; use Sem_Util
;
65 with Sem_Warn
; use Sem_Warn
;
66 with Stand
; use Stand
;
67 with Sinfo
; use Sinfo
;
68 with Snames
; use Snames
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Ttypes
; use Ttypes
;
72 with Uintp
; use Uintp
;
73 with Urealp
; use Urealp
;
75 package body Sem_Ch3
is
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 procedure Add_Interface_Tag_Components
(N
: Node_Id
; Typ
: Entity_Id
);
82 -- Ada 2005 (AI-251): Add the tag components corresponding to all the
83 -- abstract interface types implemented by a record type or a derived
86 procedure Build_Derived_Type
88 Parent_Type
: Entity_Id
;
89 Derived_Type
: Entity_Id
;
90 Is_Completion
: Boolean;
91 Derive_Subps
: Boolean := True);
92 -- Create and decorate a Derived_Type given the Parent_Type entity. N is
93 -- the N_Full_Type_Declaration node containing the derived type definition.
94 -- Parent_Type is the entity for the parent type in the derived type
95 -- definition and Derived_Type the actual derived type. Is_Completion must
96 -- be set to False if Derived_Type is the N_Defining_Identifier node in N
97 -- (ie Derived_Type = Defining_Identifier (N)). In this case N is not the
98 -- completion of a private type declaration. If Is_Completion is set to
99 -- True, N is the completion of a private type declaration and Derived_Type
100 -- is different from the defining identifier inside N (i.e. Derived_Type /=
101 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent
102 -- subprograms should be derived. The only case where this parameter is
103 -- False is when Build_Derived_Type is recursively called to process an
104 -- implicit derived full type for a type derived from a private type (in
105 -- that case the subprograms must only be derived for the private view of
108 -- ??? These flags need a bit of re-examination and re-documentation:
109 -- ??? are they both necessary (both seem related to the recursion)?
111 procedure Build_Derived_Access_Type
113 Parent_Type
: Entity_Id
;
114 Derived_Type
: Entity_Id
);
115 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
116 -- create an implicit base if the parent type is constrained or if the
117 -- subtype indication has a constraint.
119 procedure Build_Derived_Array_Type
121 Parent_Type
: Entity_Id
;
122 Derived_Type
: Entity_Id
);
123 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
124 -- create an implicit base if the parent type is constrained or if the
125 -- subtype indication has a constraint.
127 procedure Build_Derived_Concurrent_Type
129 Parent_Type
: Entity_Id
;
130 Derived_Type
: Entity_Id
);
131 -- Subsidiary procedure to Build_Derived_Type. For a derived task or
132 -- protected type, inherit entries and protected subprograms, check
133 -- legality of discriminant constraints if any.
135 procedure Build_Derived_Enumeration_Type
137 Parent_Type
: Entity_Id
;
138 Derived_Type
: Entity_Id
);
139 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
140 -- type, we must create a new list of literals. Types derived from
141 -- Character and Wide_Character are special-cased.
143 procedure Build_Derived_Numeric_Type
145 Parent_Type
: Entity_Id
;
146 Derived_Type
: Entity_Id
);
147 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
148 -- an anonymous base type, and propagate constraint to subtype if needed.
150 procedure Build_Derived_Private_Type
152 Parent_Type
: Entity_Id
;
153 Derived_Type
: Entity_Id
;
154 Is_Completion
: Boolean;
155 Derive_Subps
: Boolean := True);
156 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
157 -- because the parent may or may not have a completion, and the derivation
158 -- may itself be a completion.
160 procedure Build_Derived_Record_Type
162 Parent_Type
: Entity_Id
;
163 Derived_Type
: Entity_Id
;
164 Derive_Subps
: Boolean := True);
165 -- Subsidiary procedure for Build_Derived_Type and
166 -- Analyze_Private_Extension_Declaration used for tagged and untagged
167 -- record types. All parameters are as in Build_Derived_Type except that
168 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
169 -- N_Private_Extension_Declaration node. See the definition of this routine
170 -- for much more info. Derive_Subps indicates whether subprograms should
171 -- be derived from the parent type. The only case where Derive_Subps is
172 -- False is for an implicit derived full type for a type derived from a
173 -- private type (see Build_Derived_Type).
175 procedure Build_Discriminal
(Discrim
: Entity_Id
);
176 -- Create the discriminal corresponding to discriminant Discrim, that is
177 -- the parameter corresponding to Discrim to be used in initialization
178 -- procedures for the type where Discrim is a discriminant. Discriminals
179 -- are not used during semantic analysis, and are not fully defined
180 -- entities until expansion. Thus they are not given a scope until
181 -- initialization procedures are built.
183 function Build_Discriminant_Constraints
186 Derived_Def
: Boolean := False) return Elist_Id
;
187 -- Validate discriminant constraints, and return the list of the
188 -- constraints in order of discriminant declarations. T is the
189 -- discriminated unconstrained type. Def is the N_Subtype_Indication node
190 -- where the discriminants constraints for T are specified. Derived_Def is
191 -- True if we are building the discriminant constraints in a derived type
192 -- definition of the form "type D (...) is new T (xxx)". In this case T is
193 -- the parent type and Def is the constraint "(xxx)" on T and this routine
194 -- sets the Corresponding_Discriminant field of the discriminants in the
195 -- derived type D to point to the corresponding discriminants in the parent
198 procedure Build_Discriminated_Subtype
202 Related_Nod
: Node_Id
;
203 For_Access
: Boolean := False);
204 -- Subsidiary procedure to Constrain_Discriminated_Type and to
205 -- Process_Incomplete_Dependents. Given
207 -- T (a possibly discriminated base type)
208 -- Def_Id (a very partially built subtype for T),
210 -- the call completes Def_Id to be the appropriate E_*_Subtype.
212 -- The Elist is the list of discriminant constraints if any (it is set to
213 -- No_Elist if T is not a discriminated type, and to an empty list if
214 -- T has discriminants but there are no discriminant constraints). The
215 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
216 -- The For_Access says whether or not this subtype is really constraining
217 -- an access type. That is its sole purpose is the designated type of an
218 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
219 -- is built to avoid freezing T when the access subtype is frozen.
221 function Build_Scalar_Bound
224 Der_T
: Entity_Id
) return Node_Id
;
225 -- The bounds of a derived scalar type are conversions of the bounds of
226 -- the parent type. Optimize the representation if the bounds are literals.
227 -- Needs a more complete spec--what are the parameters exactly, and what
228 -- exactly is the returned value, and how is Bound affected???
230 procedure Build_Underlying_Full_View
234 -- If the completion of a private type is itself derived from a private
235 -- type, or if the full view of a private subtype is itself private, the
236 -- back-end has no way to compute the actual size of this type. We build
237 -- an internal subtype declaration of the proper parent type to convey
238 -- this information. This extra mechanism is needed because a full
239 -- view cannot itself have a full view (it would get clobbered during
242 procedure Check_Access_Discriminant_Requires_Limited
245 -- Check the restriction that the type to which an access discriminant
246 -- belongs must be a concurrent type or a descendant of a type with
247 -- the reserved word 'limited' in its declaration.
249 procedure Check_Delta_Expression
(E
: Node_Id
);
250 -- Check that the expression represented by E is suitable for use
251 -- as a delta expression, i.e. it is of real type and is static.
253 procedure Check_Digits_Expression
(E
: Node_Id
);
254 -- Check that the expression represented by E is suitable for use as
255 -- a digits expression, i.e. it is of integer type, positive and static.
257 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
);
258 -- Validate the initialization of an object declaration. T is the
259 -- required type, and Exp is the initialization expression.
261 procedure Check_Or_Process_Discriminants
264 Prev
: Entity_Id
:= Empty
);
265 -- If T is the full declaration of an incomplete or private type, check
266 -- the conformance of the discriminants, otherwise process them. Prev
267 -- is the entity of the partial declaration, if any.
269 procedure Check_Real_Bound
(Bound
: Node_Id
);
270 -- Check given bound for being of real type and static. If not, post an
271 -- appropriate message, and rewrite the bound with the real literal zero.
273 procedure Constant_Redeclaration
277 -- Various checks on legality of full declaration of deferred constant.
278 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
279 -- node. The caller has not yet set any attributes of this entity.
281 procedure Convert_Scalar_Bounds
283 Parent_Type
: Entity_Id
;
284 Derived_Type
: Entity_Id
;
286 -- For derived scalar types, convert the bounds in the type definition
287 -- to the derived type, and complete their analysis. Given a constraint
289 -- .. new T range Lo .. Hi;
290 -- Lo and Hi are analyzed and resolved with T'Base, the parent_type.
291 -- The bounds of the derived type (the anonymous base) are copies of
292 -- Lo and Hi. Finally, the bounds of the derived subtype are conversions
293 -- of those bounds to the derived_type, so that their typing is
296 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
);
297 -- Copies attributes from array base type T2 to array base type T1.
298 -- Copies only attributes that apply to base types, but not subtypes.
300 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
);
301 -- Copies attributes from array subtype T2 to array subtype T1. Copies
302 -- attributes that apply to both subtypes and base types.
304 procedure Create_Constrained_Components
308 Constraints
: Elist_Id
);
309 -- Build the list of entities for a constrained discriminated record
310 -- subtype. If a component depends on a discriminant, replace its subtype
311 -- using the discriminant values in the discriminant constraint.
312 -- Subt is the defining identifier for the subtype whose list of
313 -- constrained entities we will create. Decl_Node is the type declaration
314 -- node where we will attach all the itypes created. Typ is the base
315 -- discriminated type for the subtype Subt. Constraints is the list of
316 -- discriminant constraints for Typ.
318 function Constrain_Component_Type
320 Constrained_Typ
: Entity_Id
;
321 Related_Node
: Node_Id
;
323 Constraints
: Elist_Id
) return Entity_Id
;
324 -- Given a discriminated base type Typ, a list of discriminant constraint
325 -- Constraints for Typ and a component of Typ, with type Compon_Type,
326 -- create and return the type corresponding to Compon_type where all
327 -- discriminant references are replaced with the corresponding
328 -- constraint. If no discriminant references occur in Compon_Typ then
329 -- return it as is. Constrained_Typ is the final constrained subtype to
330 -- which the constrained Compon_Type belongs. Related_Node is the node
331 -- where we will attach all the itypes created.
333 procedure Constrain_Access
334 (Def_Id
: in out Entity_Id
;
336 Related_Nod
: Node_Id
);
337 -- Apply a list of constraints to an access type. If Def_Id is empty, it is
338 -- an anonymous type created for a subtype indication. In that case it is
339 -- created in the procedure and attached to Related_Nod.
341 procedure Constrain_Array
342 (Def_Id
: in out Entity_Id
;
344 Related_Nod
: Node_Id
;
345 Related_Id
: Entity_Id
;
347 -- Apply a list of index constraints to an unconstrained array type. The
348 -- first parameter is the entity for the resulting subtype. A value of
349 -- Empty for Def_Id indicates that an implicit type must be created, but
350 -- creation is delayed (and must be done by this procedure) because other
351 -- subsidiary implicit types must be created first (which is why Def_Id
352 -- is an in/out parameter). The second parameter is a subtype indication
353 -- node for the constrained array to be created (e.g. something of the
354 -- form string (1 .. 10)). Related_Nod gives the place where this type
355 -- has to be inserted in the tree. The Related_Id and Suffix parameters
356 -- are used to build the associated Implicit type name.
358 procedure Constrain_Concurrent
359 (Def_Id
: in out Entity_Id
;
361 Related_Nod
: Node_Id
;
362 Related_Id
: Entity_Id
;
364 -- Apply list of discriminant constraints to an unconstrained concurrent
367 -- SI is the N_Subtype_Indication node containing the constraint and
368 -- the unconstrained type to constrain.
370 -- Def_Id is the entity for the resulting constrained subtype. A value
371 -- of Empty for Def_Id indicates that an implicit type must be created,
372 -- but creation is delayed (and must be done by this procedure) because
373 -- other subsidiary implicit types must be created first (which is why
374 -- Def_Id is an in/out parameter).
376 -- Related_Nod gives the place where this type has to be inserted
379 -- The last two arguments are used to create its external name if needed.
381 function Constrain_Corresponding_Record
382 (Prot_Subt
: Entity_Id
;
383 Corr_Rec
: Entity_Id
;
384 Related_Nod
: Node_Id
;
385 Related_Id
: Entity_Id
) return Entity_Id
;
386 -- When constraining a protected type or task type with discriminants,
387 -- constrain the corresponding record with the same discriminant values.
389 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
);
390 -- Constrain a decimal fixed point type with a digits constraint and/or a
391 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
393 procedure Constrain_Discriminated_Type
396 Related_Nod
: Node_Id
;
397 For_Access
: Boolean := False);
398 -- Process discriminant constraints of composite type. Verify that values
399 -- have been provided for all discriminants, that the original type is
400 -- unconstrained, and that the types of the supplied expressions match
401 -- the discriminant types. The first three parameters are like in routine
402 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
405 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
);
406 -- Constrain an enumeration type with a range constraint. This is identical
407 -- to Constrain_Integer, but for the Ekind of the resulting subtype.
409 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
);
410 -- Constrain a floating point type with either a digits constraint
411 -- and/or a range constraint, building a E_Floating_Point_Subtype.
413 procedure Constrain_Index
416 Related_Nod
: Node_Id
;
417 Related_Id
: Entity_Id
;
420 -- Process an index constraint in a constrained array declaration. The
421 -- constraint can be a subtype name, or a range with or without an
422 -- explicit subtype mark. The index is the corresponding index of the
423 -- unconstrained array. The Related_Id and Suffix parameters are used to
424 -- build the associated Implicit type name.
426 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
);
427 -- Build subtype of a signed or modular integer type
429 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
);
430 -- Constrain an ordinary fixed point type with a range constraint, and
431 -- build an E_Ordinary_Fixed_Point_Subtype entity.
433 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
);
434 -- Copy the Priv entity into the entity of its full declaration
435 -- then swap the two entities in such a manner that the former private
436 -- type is now seen as a full type.
438 procedure Decimal_Fixed_Point_Type_Declaration
441 -- Create a new decimal fixed point type, and apply the constraint to
442 -- obtain a subtype of this new type.
444 procedure Complete_Private_Subtype
447 Full_Base
: Entity_Id
;
448 Related_Nod
: Node_Id
);
449 -- Complete the implicit full view of a private subtype by setting the
450 -- appropriate semantic fields. If the full view of the parent is a record
451 -- type, build constrained components of subtype.
453 procedure Derive_Interface_Subprograms
454 (Parent_Type
: Entity_Id
;
455 Tagged_Type
: Entity_Id
;
456 Ifaces_List
: Elist_Id
);
457 -- Ada 2005 (AI-251): Derive primitives of abstract interface types that
458 -- are not immediate ancestors of Tagged type and associate them their
459 -- aliased primitive. Ifaces_List contains the abstract interface
460 -- primitives that have been derived from Parent_Type.
462 procedure Derived_Standard_Character
464 Parent_Type
: Entity_Id
;
465 Derived_Type
: Entity_Id
);
466 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
467 -- derivations from types Standard.Character and Standard.Wide_Character.
469 procedure Derived_Type_Declaration
472 Is_Completion
: Boolean);
473 -- Process a derived type declaration. This routine will invoke
474 -- Build_Derived_Type to process the actual derived type definition.
475 -- Parameters N and Is_Completion have the same meaning as in
476 -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
477 -- defined in the N_Full_Type_Declaration node N, that is T is the derived
480 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
481 -- Insert each literal in symbol table, as an overloadable identifier. Each
482 -- enumeration type is mapped into a sequence of integers, and each literal
483 -- is defined as a constant with integer value. If any of the literals are
484 -- character literals, the type is a character type, which means that
485 -- strings are legal aggregates for arrays of components of the type.
487 function Expand_To_Stored_Constraint
489 Constraint
: Elist_Id
) return Elist_Id
;
490 -- Given a Constraint (i.e. a list of expressions) on the discriminants of
491 -- Typ, expand it into a constraint on the stored discriminants and return
492 -- the new list of expressions constraining the stored discriminants.
494 function Find_Type_Of_Object
496 Related_Nod
: Node_Id
) return Entity_Id
;
497 -- Get type entity for object referenced by Obj_Def, attaching the
498 -- implicit types generated to Related_Nod
500 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
501 -- Create a new float, and apply the constraint to obtain subtype of it
503 function Has_Range_Constraint
(N
: Node_Id
) return Boolean;
504 -- Given an N_Subtype_Indication node N, return True if a range constraint
505 -- is present, either directly, or as part of a digits or delta constraint.
506 -- In addition, a digits constraint in the decimal case returns True, since
507 -- it establishes a default range if no explicit range is present.
509 function Inherit_Components
511 Parent_Base
: Entity_Id
;
512 Derived_Base
: Entity_Id
;
514 Inherit_Discr
: Boolean;
515 Discs
: Elist_Id
) return Elist_Id
;
516 -- Called from Build_Derived_Record_Type to inherit the components of
517 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
518 -- For more information on derived types and component inheritance please
519 -- consult the comment above the body of Build_Derived_Record_Type.
521 -- N is the original derived type declaration
523 -- Is_Tagged is set if we are dealing with tagged types
525 -- If Inherit_Discr is set, Derived_Base inherits its discriminants
526 -- from Parent_Base, otherwise no discriminants are inherited.
528 -- Discs gives the list of constraints that apply to Parent_Base in the
529 -- derived type declaration. If Discs is set to No_Elist, then we have
530 -- the following situation:
532 -- type Parent (D1..Dn : ..) is [tagged] record ...;
533 -- type Derived is new Parent [with ...];
535 -- which gets treated as
537 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
539 -- For untagged types the returned value is an association list. The list
540 -- starts from the association (Parent_Base => Derived_Base), and then it
541 -- contains a sequence of the associations of the form
543 -- (Old_Component => New_Component),
545 -- where Old_Component is the Entity_Id of a component in Parent_Base
546 -- and New_Component is the Entity_Id of the corresponding component in
547 -- Derived_Base. For untagged records, this association list is needed when
548 -- copying the record declaration for the derived base. In the tagged case
549 -- the value returned is irrelevant.
551 function Is_Valid_Constraint_Kind
553 Constraint_Kind
: Node_Kind
) return Boolean;
554 -- Returns True if it is legal to apply the given kind of constraint to the
555 -- given kind of type (index constraint to an array type, for example).
557 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
558 -- Create new modular type. Verify that modulus is in bounds and is
559 -- a power of two (implementation restriction).
561 procedure New_Concatenation_Op
(Typ
: Entity_Id
);
562 -- Create an abbreviated declaration for an operator in order to
563 -- materialize concatenation on array types.
565 procedure Ordinary_Fixed_Point_Type_Declaration
568 -- Create a new ordinary fixed point type, and apply the constraint to
569 -- obtain subtype of it.
571 procedure Prepare_Private_Subtype_Completion
573 Related_Nod
: Node_Id
);
574 -- Id is a subtype of some private type. Creates the full declaration
575 -- associated with Id whenever possible, i.e. when the full declaration
576 -- of the base type is already known. Records each subtype into
577 -- Private_Dependents of the base type.
579 procedure Process_Incomplete_Dependents
583 -- Process all entities that depend on an incomplete type. There include
584 -- subtypes, subprogram types that mention the incomplete type in their
585 -- profiles, and subprogram with access parameters that designate the
588 -- Inc_T is the defining identifier of an incomplete type declaration, its
589 -- Ekind is E_Incomplete_Type.
591 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
593 -- Full_T is N's defining identifier.
595 -- Subtypes of incomplete types with discriminants are completed when the
596 -- parent type is. This is simpler than private subtypes, because they can
597 -- only appear in the same scope, and there is no need to exchange views.
598 -- Similarly, access_to_subprogram types may have a parameter or a return
599 -- type that is an incomplete type, and that must be replaced with the
602 -- If the full type is tagged, subprogram with access parameters that
603 -- designated the incomplete may be primitive operations of the full type,
604 -- and have to be processed accordingly.
606 procedure Process_Real_Range_Specification
(Def
: Node_Id
);
607 -- Given the type definition for a real type, this procedure processes
608 -- and checks the real range specification of this type definition if
609 -- one is present. If errors are found, error messages are posted, and
610 -- the Real_Range_Specification of Def is reset to Empty.
612 procedure Record_Type_Declaration
616 -- Process a record type declaration (for both untagged and tagged
617 -- records). Parameters T and N are exactly like in procedure
618 -- Derived_Type_Declaration, except that no flag Is_Completion is needed
619 -- for this routine. If this is the completion of an incomplete type
620 -- declaration, Prev is the entity of the incomplete declaration, used for
621 -- cross-referencing. Otherwise Prev = T.
623 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
);
624 -- This routine is used to process the actual record type definition
625 -- (both for untagged and tagged records). Def is a record type
626 -- definition node. This procedure analyzes the components in this
627 -- record type definition. Prev_T is the entity for the enclosing record
628 -- type. It is provided so that its Has_Task flag can be set if any of
629 -- the component have Has_Task set. If the declaration is the completion
630 -- of an incomplete type declaration, Prev_T is the original incomplete
631 -- type, whose full view is the record type.
633 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
);
634 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
635 -- build a copy of the declaration tree of the parent, and we create
636 -- independently the list of components for the derived type. Semantic
637 -- information uses the component entities, but record representation
638 -- clauses are validated on the declaration tree. This procedure replaces
639 -- discriminants and components in the declaration with those that have
640 -- been created by Inherit_Components.
642 procedure Set_Fixed_Range
647 -- Build a range node with the given bounds and set it as the Scalar_Range
648 -- of the given fixed-point type entity. Loc is the source location used
649 -- for the constructed range. See body for further details.
651 procedure Set_Scalar_Range_For_Subtype
655 -- This routine is used to set the scalar range field for a subtype given
656 -- Def_Id, the entity for the subtype, and R, the range expression for the
657 -- scalar range. Subt provides the parent subtype to be used to analyze,
658 -- resolve, and check the given range.
660 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
661 -- Create a new signed integer entity, and apply the constraint to obtain
662 -- the required first named subtype of this type.
664 procedure Set_Stored_Constraint_From_Discriminant_Constraint
666 -- E is some record type. This routine computes E's Stored_Constraint
667 -- from its Discriminant_Constraint.
669 -----------------------
670 -- Access_Definition --
671 -----------------------
673 function Access_Definition
674 (Related_Nod
: Node_Id
;
675 N
: Node_Id
) return Entity_Id
677 Loc
: constant Source_Ptr
:= Sloc
(Related_Nod
);
678 Anon_Type
: Entity_Id
;
679 Desig_Type
: Entity_Id
;
683 if Is_Entry
(Current_Scope
)
684 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
686 Error_Msg_N
("task entries cannot have access parameters", N
);
689 -- Ada 2005: for an object declaration the corresponding anonymous
690 -- type is declared in the current scope.
692 -- If the access definition is the return type of another access to
693 -- function, scope is the current one, because it is the one of the
694 -- current type declaration.
696 if Nkind
(Related_Nod
) = N_Object_Declaration
697 or else Nkind
(Related_Nod
) = N_Access_Function_Definition
701 (E_Anonymous_Access_Type
, Related_Nod
,
702 Scope_Id
=> Current_Scope
);
704 -- For the anonymous function result case, retrieve the scope of
705 -- the function specification's associated entity rather than using
706 -- the current scope. The current scope will be the function itself
707 -- if the formal part is currently being analyzed, but will be the
708 -- parent scope in the case of a parameterless function, and we
709 -- always want to use the function's parent scope.
711 elsif Nkind
(Related_Nod
) = N_Function_Specification
712 and then Nkind
(Parent
(N
)) /= N_Parameter_Specification
716 (E_Anonymous_Access_Type
, Related_Nod
,
717 Scope_Id
=> Scope
(Defining_Unit_Name
(Related_Nod
)));
720 -- For access formals, access components, and access
721 -- discriminants, the scope is that of the enclosing declaration,
725 (E_Anonymous_Access_Type
, Related_Nod
,
726 Scope_Id
=> Scope
(Current_Scope
));
730 and then Ada_Version
>= Ada_05
732 Error_Msg_N
("ALL is not permitted for anonymous access types", N
);
735 -- Ada 2005 (AI-254): In case of anonymous access to subprograms
736 -- call the corresponding semantic routine
738 if Present
(Access_To_Subprogram_Definition
(N
)) then
739 Access_Subprogram_Declaration
740 (T_Name
=> Anon_Type
,
741 T_Def
=> Access_To_Subprogram_Definition
(N
));
743 if Ekind
(Anon_Type
) = E_Access_Protected_Subprogram_Type
then
745 (Anon_Type
, E_Anonymous_Access_Protected_Subprogram_Type
);
748 (Anon_Type
, E_Anonymous_Access_Subprogram_Type
);
754 Find_Type
(Subtype_Mark
(N
));
755 Desig_Type
:= Entity
(Subtype_Mark
(N
));
757 Set_Directly_Designated_Type
758 (Anon_Type
, Desig_Type
);
759 Set_Etype
(Anon_Type
, Anon_Type
);
760 Init_Size_Align
(Anon_Type
);
761 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
763 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
764 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
765 -- if the null value is allowed. In Ada 95 the null value is never
768 if Ada_Version
>= Ada_05
then
769 Set_Can_Never_Be_Null
(Anon_Type
, Null_Exclusion_Present
(N
));
771 Set_Can_Never_Be_Null
(Anon_Type
, True);
774 -- The anonymous access type is as public as the discriminated type or
775 -- subprogram that defines it. It is imported (for back-end purposes)
776 -- if the designated type is.
778 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
780 -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
781 -- designated type comes from the limited view (for back-end purposes).
783 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
785 -- Ada 2005 (AI-231): Propagate the access-constant attribute
787 Set_Is_Access_Constant
(Anon_Type
, Constant_Present
(N
));
789 -- The context is either a subprogram declaration, object declaration,
790 -- or an access discriminant, in a private or a full type declaration.
791 -- In the case of a subprogram, if the designated type is incomplete,
792 -- the operation will be a primitive operation of the full type, to be
793 -- updated subsequently. If the type is imported through a limited_with
794 -- clause, the subprogram is not a primitive operation of the type
795 -- (which is declared elsewhere in some other scope).
797 if Ekind
(Desig_Type
) = E_Incomplete_Type
798 and then not From_With_Type
(Desig_Type
)
799 and then Is_Overloadable
(Current_Scope
)
801 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
802 Set_Has_Delayed_Freeze
(Current_Scope
);
805 -- Ada 2005: if the designated type is an interface that may contain
806 -- tasks, create a Master entity for the declaration. This must be done
807 -- before expansion of the full declaration, because the declaration
808 -- may include an expression that is an allocator, whose expansion needs
809 -- the proper Master for the created tasks.
811 if Nkind
(Related_Nod
) = N_Object_Declaration
812 and then Expander_Active
814 if Is_Interface
(Desig_Type
)
815 and then Is_Limited_Record
(Desig_Type
)
817 Build_Class_Wide_Master
(Anon_Type
);
819 -- Similarly, if the type is an anonymous access that designates
820 -- tasks, create a master entity for it in the current context.
822 elsif Has_Task
(Desig_Type
)
823 and then Comes_From_Source
(Related_Nod
)
825 if not Has_Master_Entity
(Current_Scope
) then
827 Make_Object_Declaration
(Loc
,
828 Defining_Identifier
=>
829 Make_Defining_Identifier
(Loc
, Name_uMaster
),
830 Constant_Present
=> True,
832 New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
834 Make_Explicit_Dereference
(Loc
,
835 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
837 Insert_Before
(Related_Nod
, Decl
);
840 Set_Master_Id
(Anon_Type
, Defining_Identifier
(Decl
));
841 Set_Has_Master_Entity
(Current_Scope
);
843 Build_Master_Renaming
(Related_Nod
, Anon_Type
);
849 end Access_Definition
;
851 -----------------------------------
852 -- Access_Subprogram_Declaration --
853 -----------------------------------
855 procedure Access_Subprogram_Declaration
859 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
863 Desig_Type
: constant Entity_Id
:=
864 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
867 -- Associate the Itype node with the inner full-type declaration
868 -- or subprogram spec. This is required to handle nested anonymous
869 -- declarations. For example:
872 -- (X : access procedure
873 -- (Y : access procedure
876 D_Ityp
:= Associated_Node_For_Itype
(Desig_Type
);
877 while Nkind
(D_Ityp
) /= N_Full_Type_Declaration
878 and then Nkind
(D_Ityp
) /= N_Procedure_Specification
879 and then Nkind
(D_Ityp
) /= N_Function_Specification
880 and then Nkind
(D_Ityp
) /= N_Object_Declaration
881 and then Nkind
(D_Ityp
) /= N_Object_Renaming_Declaration
882 and then Nkind
(D_Ityp
) /= N_Formal_Type_Declaration
884 D_Ityp
:= Parent
(D_Ityp
);
885 pragma Assert
(D_Ityp
/= Empty
);
888 Set_Associated_Node_For_Itype
(Desig_Type
, D_Ityp
);
890 if Nkind
(D_Ityp
) = N_Procedure_Specification
891 or else Nkind
(D_Ityp
) = N_Function_Specification
893 Set_Scope
(Desig_Type
, Scope
(Defining_Entity
(D_Ityp
)));
895 elsif Nkind
(D_Ityp
) = N_Full_Type_Declaration
896 or else Nkind
(D_Ityp
) = N_Object_Declaration
897 or else Nkind
(D_Ityp
) = N_Object_Renaming_Declaration
898 or else Nkind
(D_Ityp
) = N_Formal_Type_Declaration
900 Set_Scope
(Desig_Type
, Scope
(Defining_Identifier
(D_Ityp
)));
903 if Nkind
(T_Def
) = N_Access_Function_Definition
then
904 if Nkind
(Result_Definition
(T_Def
)) = N_Access_Definition
then
907 Access_Definition
(T_Def
, Result_Definition
(T_Def
)));
909 Analyze
(Result_Definition
(T_Def
));
910 Set_Etype
(Desig_Type
, Entity
(Result_Definition
(T_Def
)));
913 if not (Is_Type
(Etype
(Desig_Type
))) then
915 ("expect type in function specification",
916 Result_Definition
(T_Def
));
920 Set_Etype
(Desig_Type
, Standard_Void_Type
);
923 if Present
(Formals
) then
924 New_Scope
(Desig_Type
);
925 Process_Formals
(Formals
, Parent
(T_Def
));
927 -- A bit of a kludge here, End_Scope requires that the parent
928 -- pointer be set to something reasonable, but Itypes don't have
929 -- parent pointers. So we set it and then unset it ??? If and when
930 -- Itypes have proper parent pointers to their declarations, this
931 -- kludge can be removed.
933 Set_Parent
(Desig_Type
, T_Name
);
935 Set_Parent
(Desig_Type
, Empty
);
938 -- The return type and/or any parameter type may be incomplete. Mark
939 -- the subprogram_type as depending on the incomplete type, so that
940 -- it can be updated when the full type declaration is seen.
942 if Present
(Formals
) then
943 Formal
:= First_Formal
(Desig_Type
);
944 while Present
(Formal
) loop
945 if Ekind
(Formal
) /= E_In_Parameter
946 and then Nkind
(T_Def
) = N_Access_Function_Definition
948 Error_Msg_N
("functions can only have IN parameters", Formal
);
951 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
952 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
953 Set_Has_Delayed_Freeze
(Desig_Type
);
956 Next_Formal
(Formal
);
960 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
961 and then not Has_Delayed_Freeze
(Desig_Type
)
963 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
964 Set_Has_Delayed_Freeze
(Desig_Type
);
967 Check_Delayed_Subprogram
(Desig_Type
);
969 if Protected_Present
(T_Def
) then
970 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
971 Set_Convention
(Desig_Type
, Convention_Protected
);
973 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
976 Set_Etype
(T_Name
, T_Name
);
977 Init_Size_Align
(T_Name
);
978 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
980 -- Ada 2005 (AI-231): Propagate the null-excluding attribute
982 Set_Can_Never_Be_Null
(T_Name
, Null_Exclusion_Present
(T_Def
));
984 Check_Restriction
(No_Access_Subprograms
, T_Def
);
985 end Access_Subprogram_Declaration
;
987 ----------------------------
988 -- Access_Type_Declaration --
989 ----------------------------
991 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
992 S
: constant Node_Id
:= Subtype_Indication
(Def
);
993 P
: constant Node_Id
:= Parent
(Def
);
999 -- Check for permissible use of incomplete type
1001 if Nkind
(S
) /= N_Subtype_Indication
then
1004 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
1005 Set_Directly_Designated_Type
(T
, Entity
(S
));
1007 Set_Directly_Designated_Type
(T
,
1008 Process_Subtype
(S
, P
, T
, 'P'));
1012 Set_Directly_Designated_Type
(T
,
1013 Process_Subtype
(S
, P
, T
, 'P'));
1016 if All_Present
(Def
) or Constant_Present
(Def
) then
1017 Set_Ekind
(T
, E_General_Access_Type
);
1019 Set_Ekind
(T
, E_Access_Type
);
1022 if Base_Type
(Designated_Type
(T
)) = T
then
1023 Error_Msg_N
("access type cannot designate itself", S
);
1025 -- In Ada 2005, the type may have a limited view through some unit
1026 -- in its own context, allowing the following circularity that cannot
1027 -- be detected earlier
1029 elsif Is_Class_Wide_Type
(Designated_Type
(T
))
1030 and then Etype
(Designated_Type
(T
)) = T
1033 ("access type cannot designate its own classwide type", S
);
1035 -- Clean up indication of tagged status to prevent cascaded errors
1037 Set_Is_Tagged_Type
(T
, False);
1042 -- If the type has appeared already in a with_type clause, it is
1043 -- frozen and the pointer size is already set. Else, initialize.
1045 if not From_With_Type
(T
) then
1046 Init_Size_Align
(T
);
1049 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1051 Desig
:= Designated_Type
(T
);
1053 -- If designated type is an imported tagged type, indicate that the
1054 -- access type is also imported, and therefore restricted in its use.
1055 -- The access type may already be imported, so keep setting otherwise.
1057 -- Ada 2005 (AI-50217): If the non-limited view of the designated type
1058 -- is available, use it as the designated type of the access type, so
1059 -- that the back-end gets a usable entity.
1062 N_Desig
: Entity_Id
;
1065 if From_With_Type
(Desig
)
1066 and then Ekind
(Desig
) /= E_Access_Type
1068 Set_From_With_Type
(T
);
1070 if Is_Incomplete_Type
(Desig
) then
1071 N_Desig
:= Non_Limited_View
(Desig
);
1073 else pragma Assert
(Ekind
(Desig
) = E_Class_Wide_Type
);
1074 if From_With_Type
(Etype
(Desig
)) then
1075 N_Desig
:= Non_Limited_View
(Etype
(Desig
));
1077 N_Desig
:= Etype
(Desig
);
1081 pragma Assert
(Present
(N_Desig
));
1082 Set_Directly_Designated_Type
(T
, N_Desig
);
1086 -- Note that Has_Task is always false, since the access type itself
1087 -- is not a task type. See Einfo for more description on this point.
1088 -- Exactly the same consideration applies to Has_Controlled_Component.
1090 Set_Has_Task
(T
, False);
1091 Set_Has_Controlled_Component
(T
, False);
1093 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1096 Set_Can_Never_Be_Null
(T
, Null_Exclusion_Present
(Def
));
1097 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
1098 end Access_Type_Declaration
;
1100 ----------------------------------
1101 -- Add_Interface_Tag_Components --
1102 ----------------------------------
1104 procedure Add_Interface_Tag_Components
(N
: Node_Id
; Typ
: Entity_Id
) is
1105 Loc
: constant Source_Ptr
:= Sloc
(N
);
1112 procedure Add_Tag
(Iface
: Entity_Id
);
1113 -- Add tag for one of the progenitor interfaces
1119 procedure Add_Tag
(Iface
: Entity_Id
) is
1126 pragma Assert
(Is_Tagged_Type
(Iface
)
1127 and then Is_Interface
(Iface
));
1130 Make_Component_Definition
(Loc
,
1131 Aliased_Present
=> True,
1132 Subtype_Indication
=>
1133 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
));
1135 Tag
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1138 Make_Component_Declaration
(Loc
,
1139 Defining_Identifier
=> Tag
,
1140 Component_Definition
=> Def
);
1142 Analyze_Component_Declaration
(Decl
);
1144 Set_Analyzed
(Decl
);
1145 Set_Ekind
(Tag
, E_Component
);
1146 Set_Is_Limited_Record
(Tag
);
1148 Init_Component_Location
(Tag
);
1150 pragma Assert
(Is_Frozen
(Iface
));
1152 Set_DT_Entry_Count
(Tag
,
1153 DT_Entry_Count
(First_Entity
(Iface
)));
1155 if No
(Last_Tag
) then
1158 Insert_After
(Last_Tag
, Decl
);
1163 -- If the ancestor has discriminants we need to give special support
1164 -- to store the offset_to_top value of the secondary dispatch tables.
1165 -- For this purpose we add a supplementary component just after the
1166 -- field that contains the tag associated with each secondary DT.
1168 if Typ
/= Etype
(Typ
)
1169 and then Has_Discriminants
(Etype
(Typ
))
1172 Make_Component_Definition
(Loc
,
1173 Subtype_Indication
=>
1174 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
));
1177 Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
1180 Make_Component_Declaration
(Loc
,
1181 Defining_Identifier
=> Offset
,
1182 Component_Definition
=> Def
);
1184 Analyze_Component_Declaration
(Decl
);
1186 Set_Analyzed
(Decl
);
1187 Set_Ekind
(Offset
, E_Component
);
1188 Init_Component_Location
(Offset
);
1189 Insert_After
(Last_Tag
, Decl
);
1194 -- Start of processing for Add_Interface_Tag_Components
1197 if Ekind
(Typ
) /= E_Record_Type
1198 or else No
(Abstract_Interfaces
(Typ
))
1199 or else Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
))
1200 or else not RTE_Available
(RE_Interface_Tag
)
1205 if Present
(Abstract_Interfaces
(Typ
)) then
1207 -- Find the current last tag
1209 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1210 Ext
:= Record_Extension_Part
(Type_Definition
(N
));
1212 pragma Assert
(Nkind
(Type_Definition
(N
)) = N_Record_Definition
);
1213 Ext
:= Type_Definition
(N
);
1218 if not (Present
(Component_List
(Ext
))) then
1219 Set_Null_Present
(Ext
, False);
1221 Set_Component_List
(Ext
,
1222 Make_Component_List
(Loc
,
1223 Component_Items
=> L
,
1224 Null_Present
=> False));
1226 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
1227 L
:= Component_Items
1229 (Record_Extension_Part
1230 (Type_Definition
(N
))));
1232 L
:= Component_Items
1234 (Type_Definition
(N
)));
1237 -- Find the last tag component
1240 while Present
(Comp
) loop
1241 if Is_Tag
(Defining_Identifier
(Comp
)) then
1249 -- At this point L references the list of components and Last_Tag
1250 -- references the current last tag (if any). Now we add the tag
1251 -- corresponding with all the interfaces that are not implemented
1254 pragma Assert
(Present
1255 (First_Elmt
(Abstract_Interfaces
(Typ
))));
1257 Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1258 while Present
(Elmt
) loop
1259 Add_Tag
(Node
(Elmt
));
1263 end Add_Interface_Tag_Components
;
1265 -----------------------------------
1266 -- Analyze_Component_Declaration --
1267 -----------------------------------
1269 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
1270 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1274 function Contains_POC
(Constr
: Node_Id
) return Boolean;
1275 -- Determines whether a constraint uses the discriminant of a record
1276 -- type thus becoming a per-object constraint (POC).
1278 function Is_Known_Limited
(Typ
: Entity_Id
) return Boolean;
1279 -- Typ is the type of the current component, check whether this type is
1280 -- a limited type. Used to validate declaration against that of
1281 -- enclosing record.
1287 function Contains_POC
(Constr
: Node_Id
) return Boolean is
1289 case Nkind
(Constr
) is
1290 when N_Attribute_Reference
=>
1291 return Attribute_Name
(Constr
) = Name_Access
1293 Prefix
(Constr
) = Scope
(Entity
(Prefix
(Constr
)));
1295 when N_Discriminant_Association
=>
1296 return Denotes_Discriminant
(Expression
(Constr
));
1298 when N_Identifier
=>
1299 return Denotes_Discriminant
(Constr
);
1301 when N_Index_Or_Discriminant_Constraint
=>
1306 IDC
:= First
(Constraints
(Constr
));
1307 while Present
(IDC
) loop
1309 -- One per-object constraint is sufficient
1311 if Contains_POC
(IDC
) then
1322 return Denotes_Discriminant
(Low_Bound
(Constr
))
1324 Denotes_Discriminant
(High_Bound
(Constr
));
1326 when N_Range_Constraint
=>
1327 return Denotes_Discriminant
(Range_Expression
(Constr
));
1335 ----------------------
1336 -- Is_Known_Limited --
1337 ----------------------
1339 function Is_Known_Limited
(Typ
: Entity_Id
) return Boolean is
1340 P
: constant Entity_Id
:= Etype
(Typ
);
1341 R
: constant Entity_Id
:= Root_Type
(Typ
);
1344 if Is_Limited_Record
(Typ
) then
1347 -- If the root type is limited (and not a limited interface)
1348 -- so is the current type
1350 elsif Is_Limited_Record
(R
)
1352 (not Is_Interface
(R
)
1353 or else not Is_Limited_Interface
(R
))
1357 -- Else the type may have a limited interface progenitor, but a
1358 -- limited record parent.
1361 and then Is_Limited_Record
(P
)
1368 end Is_Known_Limited
;
1370 -- Start of processing for Analyze_Component_Declaration
1373 Generate_Definition
(Id
);
1376 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1377 T
:= Find_Type_Of_Object
1378 (Subtype_Indication
(Component_Definition
(N
)), N
);
1380 -- Ada 2005 (AI-230): Access Definition case
1383 pragma Assert
(Present
1384 (Access_Definition
(Component_Definition
(N
))));
1386 T
:= Access_Definition
1388 N
=> Access_Definition
(Component_Definition
(N
)));
1389 Set_Is_Local_Anonymous_Access
(T
);
1391 -- Ada 2005 (AI-254)
1393 if Present
(Access_To_Subprogram_Definition
1394 (Access_Definition
(Component_Definition
(N
))))
1395 and then Protected_Present
(Access_To_Subprogram_Definition
1397 (Component_Definition
(N
))))
1399 T
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
, T
);
1403 -- If the subtype is a constrained subtype of the enclosing record,
1404 -- (which must have a partial view) the back-end does not properly
1405 -- handle the recursion. Rewrite the component declaration with an
1406 -- explicit subtype indication, which is acceptable to Gigi. We can copy
1407 -- the tree directly because side effects have already been removed from
1408 -- discriminant constraints.
1410 if Ekind
(T
) = E_Access_Subtype
1411 and then Is_Entity_Name
(Subtype_Indication
(Component_Definition
(N
)))
1412 and then Comes_From_Source
(T
)
1413 and then Nkind
(Parent
(T
)) = N_Subtype_Declaration
1414 and then Etype
(Directly_Designated_Type
(T
)) = Current_Scope
1417 (Subtype_Indication
(Component_Definition
(N
)),
1418 New_Copy_Tree
(Subtype_Indication
(Parent
(T
))));
1419 T
:= Find_Type_Of_Object
1420 (Subtype_Indication
(Component_Definition
(N
)), N
);
1423 -- If the component declaration includes a default expression, then we
1424 -- check that the component is not of a limited type (RM 3.7(5)),
1425 -- and do the special preanalysis of the expression (see section on
1426 -- "Handling of Default and Per-Object Expressions" in the spec of
1429 if Present
(Expression
(N
)) then
1430 Analyze_Per_Use_Expression
(Expression
(N
), T
);
1431 Check_Initialization
(T
, Expression
(N
));
1433 if Ada_Version
>= Ada_05
1434 and then Is_Access_Type
(T
)
1435 and then Ekind
(T
) = E_Anonymous_Access_Type
1437 -- Check RM 3.9.2(9): "if the expected type for an expression is
1438 -- an anonymous access-to-specific tagged type, then the object
1439 -- designated by the expression shall not be dynamically tagged
1440 -- unless it is a controlling operand in a call on a dispatching
1443 if Is_Tagged_Type
(Directly_Designated_Type
(T
))
1445 Ekind
(Directly_Designated_Type
(T
)) /= E_Class_Wide_Type
1447 Ekind
(Directly_Designated_Type
(Etype
(Expression
(N
)))) =
1451 ("access to specific tagged type required ('R'M 3.9.2(9))",
1455 -- (Ada 2005: AI-230): Accessibility check for anonymous
1458 -- Missing barrier Ada_Version >= Ada_05???
1460 if Type_Access_Level
(Etype
(Expression
(N
))) >
1461 Type_Access_Level
(T
)
1464 ("expression has deeper access level than component " &
1465 "('R'M 3.10.2 (12.2))", Expression
(N
));
1470 -- The parent type may be a private view with unknown discriminants,
1471 -- and thus unconstrained. Regular components must be constrained.
1473 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
1474 if Is_Class_Wide_Type
(T
) then
1476 ("class-wide subtype with unknown discriminants" &
1477 " in component declaration",
1478 Subtype_Indication
(Component_Definition
(N
)));
1481 ("unconstrained subtype in component declaration",
1482 Subtype_Indication
(Component_Definition
(N
)));
1485 -- Components cannot be abstract, except for the special case of
1486 -- the _Parent field (case of extending an abstract tagged type)
1488 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
1489 Error_Msg_N
("type of a component cannot be abstract", N
);
1493 Set_Is_Aliased
(Id
, Aliased_Present
(Component_Definition
(N
)));
1495 -- The component declaration may have a per-object constraint, set
1496 -- the appropriate flag in the defining identifier of the subtype.
1498 if Present
(Subtype_Indication
(Component_Definition
(N
))) then
1500 Sindic
: constant Node_Id
:=
1501 Subtype_Indication
(Component_Definition
(N
));
1504 if Nkind
(Sindic
) = N_Subtype_Indication
1505 and then Present
(Constraint
(Sindic
))
1506 and then Contains_POC
(Constraint
(Sindic
))
1508 Set_Has_Per_Object_Constraint
(Id
);
1513 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1514 -- out some static checks.
1516 if Ada_Version
>= Ada_05
1517 and then Can_Never_Be_Null
(T
)
1519 Null_Exclusion_Static_Checks
(N
);
1522 -- If this component is private (or depends on a private type), flag the
1523 -- record type to indicate that some operations are not available.
1525 P
:= Private_Component
(T
);
1529 -- Check for circular definitions
1531 if P
= Any_Type
then
1532 Set_Etype
(Id
, Any_Type
);
1534 -- There is a gap in the visibility of operations only if the
1535 -- component type is not defined in the scope of the record type.
1537 elsif Scope
(P
) = Scope
(Current_Scope
) then
1540 elsif Is_Limited_Type
(P
) then
1541 Set_Is_Limited_Composite
(Current_Scope
);
1544 Set_Is_Private_Composite
(Current_Scope
);
1549 and then Is_Limited_Type
(T
)
1550 and then Chars
(Id
) /= Name_uParent
1551 and then Is_Tagged_Type
(Current_Scope
)
1553 if Is_Derived_Type
(Current_Scope
)
1554 and then not Is_Known_Limited
(Current_Scope
)
1557 ("extension of nonlimited type cannot have limited components",
1560 if Is_Interface
(Root_Type
(Current_Scope
)) then
1562 ("\limitedness is not inherited from limited interface", N
);
1564 ("\add LIMITED to type indication", N
);
1567 Explain_Limited_Type
(T
, N
);
1568 Set_Etype
(Id
, Any_Type
);
1569 Set_Is_Limited_Composite
(Current_Scope
, False);
1571 elsif not Is_Derived_Type
(Current_Scope
)
1572 and then not Is_Limited_Record
(Current_Scope
)
1573 and then not Is_Concurrent_Type
(Current_Scope
)
1576 ("nonlimited tagged type cannot have limited components", N
);
1577 Explain_Limited_Type
(T
, N
);
1578 Set_Etype
(Id
, Any_Type
);
1579 Set_Is_Limited_Composite
(Current_Scope
, False);
1583 Set_Original_Record_Component
(Id
, Id
);
1584 end Analyze_Component_Declaration
;
1586 --------------------------
1587 -- Analyze_Declarations --
1588 --------------------------
1590 procedure Analyze_Declarations
(L
: List_Id
) is
1592 Freeze_From
: Entity_Id
:= Empty
;
1593 Next_Node
: Node_Id
;
1596 -- Adjust D not to include implicit label declarations, since these
1597 -- have strange Sloc values that result in elaboration check problems.
1598 -- (They have the sloc of the label as found in the source, and that
1599 -- is ahead of the current declarative part).
1605 procedure Adjust_D
is
1607 while Present
(Prev
(D
))
1608 and then Nkind
(D
) = N_Implicit_Label_Declaration
1614 -- Start of processing for Analyze_Declarations
1618 while Present
(D
) loop
1620 -- Complete analysis of declaration
1623 Next_Node
:= Next
(D
);
1625 if No
(Freeze_From
) then
1626 Freeze_From
:= First_Entity
(Current_Scope
);
1629 -- At the end of a declarative part, freeze remaining entities
1630 -- declared in it. The end of the visible declarations of package
1631 -- specification is not the end of a declarative part if private
1632 -- declarations are present. The end of a package declaration is a
1633 -- freezing point only if it a library package. A task definition or
1634 -- protected type definition is not a freeze point either. Finally,
1635 -- we do not freeze entities in generic scopes, because there is no
1636 -- code generated for them and freeze nodes will be generated for
1639 -- The end of a package instantiation is not a freeze point, but
1640 -- for now we make it one, because the generic body is inserted
1641 -- (currently) immediately after. Generic instantiations will not
1642 -- be a freeze point once delayed freezing of bodies is implemented.
1643 -- (This is needed in any case for early instantiations ???).
1645 if No
(Next_Node
) then
1646 if Nkind
(Parent
(L
)) = N_Component_List
1647 or else Nkind
(Parent
(L
)) = N_Task_Definition
1648 or else Nkind
(Parent
(L
)) = N_Protected_Definition
1652 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
1653 if Nkind
(Parent
(L
)) = N_Package_Body
then
1654 Freeze_From
:= First_Entity
(Current_Scope
);
1658 Freeze_All
(Freeze_From
, D
);
1659 Freeze_From
:= Last_Entity
(Current_Scope
);
1661 elsif Scope
(Current_Scope
) /= Standard_Standard
1662 and then not Is_Child_Unit
(Current_Scope
)
1663 and then No
(Generic_Parent
(Parent
(L
)))
1667 elsif L
/= Visible_Declarations
(Parent
(L
))
1668 or else No
(Private_Declarations
(Parent
(L
)))
1669 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1672 Freeze_All
(Freeze_From
, D
);
1673 Freeze_From
:= Last_Entity
(Current_Scope
);
1676 -- If next node is a body then freeze all types before the body.
1677 -- An exception occurs for expander generated bodies, which can
1678 -- be recognized by their already being analyzed. The expander
1679 -- ensures that all types needed by these bodies have been frozen
1680 -- but it is not necessary to freeze all types (and would be wrong
1681 -- since it would not correspond to an RM defined freeze point).
1683 elsif not Analyzed
(Next_Node
)
1684 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1685 or else Nkind
(Next_Node
) = N_Entry_Body
1686 or else Nkind
(Next_Node
) = N_Package_Body
1687 or else Nkind
(Next_Node
) = N_Protected_Body
1688 or else Nkind
(Next_Node
) = N_Task_Body
1689 or else Nkind
(Next_Node
) in N_Body_Stub
)
1692 Freeze_All
(Freeze_From
, D
);
1693 Freeze_From
:= Last_Entity
(Current_Scope
);
1698 end Analyze_Declarations
;
1700 ----------------------------------
1701 -- Analyze_Incomplete_Type_Decl --
1702 ----------------------------------
1704 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1705 F
: constant Boolean := Is_Pure
(Current_Scope
);
1709 Generate_Definition
(Defining_Identifier
(N
));
1711 -- Process an incomplete declaration. The identifier must not have been
1712 -- declared already in the scope. However, an incomplete declaration may
1713 -- appear in the private part of a package, for a private type that has
1714 -- already been declared.
1716 -- In this case, the discriminants (if any) must match
1718 T
:= Find_Type_Name
(N
);
1720 Set_Ekind
(T
, E_Incomplete_Type
);
1721 Init_Size_Align
(T
);
1722 Set_Is_First_Subtype
(T
, True);
1725 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
1726 -- incomplete types.
1728 if Tagged_Present
(N
) then
1729 Set_Is_Tagged_Type
(T
);
1730 Make_Class_Wide_Type
(T
);
1731 Set_Primitive_Operations
(T
, New_Elmt_List
);
1736 Set_Stored_Constraint
(T
, No_Elist
);
1738 if Present
(Discriminant_Specifications
(N
)) then
1739 Process_Discriminants
(N
);
1744 -- If the type has discriminants, non-trivial subtypes may be be
1745 -- declared before the full view of the type. The full views of those
1746 -- subtypes will be built after the full view of the type.
1748 Set_Private_Dependents
(T
, New_Elmt_List
);
1750 end Analyze_Incomplete_Type_Decl
;
1752 -----------------------------------
1753 -- Analyze_Interface_Declaration --
1754 -----------------------------------
1756 procedure Analyze_Interface_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
1758 Set_Is_Tagged_Type
(T
);
1760 Set_Is_Limited_Record
(T
, Limited_Present
(Def
)
1761 or else Task_Present
(Def
)
1762 or else Protected_Present
(Def
)
1763 or else Synchronized_Present
(Def
));
1765 -- Type is abstract if full declaration carries keyword, or if
1766 -- previous partial view did.
1768 Set_Is_Abstract
(T
);
1769 Set_Is_Interface
(T
);
1771 Set_Is_Limited_Interface
(T
, Limited_Present
(Def
));
1772 Set_Is_Protected_Interface
(T
, Protected_Present
(Def
));
1773 Set_Is_Synchronized_Interface
(T
, Synchronized_Present
(Def
));
1774 Set_Is_Task_Interface
(T
, Task_Present
(Def
));
1775 Set_Abstract_Interfaces
(T
, New_Elmt_List
);
1776 Set_Primitive_Operations
(T
, New_Elmt_List
);
1777 end Analyze_Interface_Declaration
;
1779 -----------------------------
1780 -- Analyze_Itype_Reference --
1781 -----------------------------
1783 -- Nothing to do. This node is placed in the tree only for the benefit of
1784 -- back end processing, and has no effect on the semantic processing.
1786 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1788 pragma Assert
(Is_Itype
(Itype
(N
)));
1790 end Analyze_Itype_Reference
;
1792 --------------------------------
1793 -- Analyze_Number_Declaration --
1794 --------------------------------
1796 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1797 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1798 E
: constant Node_Id
:= Expression
(N
);
1800 Index
: Interp_Index
;
1804 Generate_Definition
(Id
);
1807 -- This is an optimization of a common case of an integer literal
1809 if Nkind
(E
) = N_Integer_Literal
then
1810 Set_Is_Static_Expression
(E
, True);
1811 Set_Etype
(E
, Universal_Integer
);
1813 Set_Etype
(Id
, Universal_Integer
);
1814 Set_Ekind
(Id
, E_Named_Integer
);
1815 Set_Is_Frozen
(Id
, True);
1819 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1821 -- Process expression, replacing error by integer zero, to avoid
1822 -- cascaded errors or aborts further along in the processing
1824 -- Replace Error by integer zero, which seems least likely to
1825 -- cause cascaded errors.
1828 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1829 Set_Error_Posted
(E
);
1834 -- Verify that the expression is static and numeric. If
1835 -- the expression is overloaded, we apply the preference
1836 -- rule that favors root numeric types.
1838 if not Is_Overloaded
(E
) then
1844 Get_First_Interp
(E
, Index
, It
);
1845 while Present
(It
.Typ
) loop
1846 if (Is_Integer_Type
(It
.Typ
)
1847 or else Is_Real_Type
(It
.Typ
))
1848 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1850 if T
= Any_Type
then
1853 elsif It
.Typ
= Universal_Real
1854 or else It
.Typ
= Universal_Integer
1856 -- Choose universal interpretation over any other
1863 Get_Next_Interp
(Index
, It
);
1867 if Is_Integer_Type
(T
) then
1869 Set_Etype
(Id
, Universal_Integer
);
1870 Set_Ekind
(Id
, E_Named_Integer
);
1872 elsif Is_Real_Type
(T
) then
1874 -- Because the real value is converted to universal_real, this is a
1875 -- legal context for a universal fixed expression.
1877 if T
= Universal_Fixed
then
1879 Loc
: constant Source_Ptr
:= Sloc
(N
);
1880 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1882 New_Occurrence_Of
(Universal_Real
, Loc
),
1883 Expression
=> Relocate_Node
(E
));
1890 elsif T
= Any_Fixed
then
1891 Error_Msg_N
("illegal context for mixed mode operation", E
);
1893 -- Expression is of the form : universal_fixed * integer. Try to
1894 -- resolve as universal_real.
1896 T
:= Universal_Real
;
1901 Set_Etype
(Id
, Universal_Real
);
1902 Set_Ekind
(Id
, E_Named_Real
);
1905 Wrong_Type
(E
, Any_Numeric
);
1909 Set_Ekind
(Id
, E_Constant
);
1910 Set_Never_Set_In_Source
(Id
, True);
1911 Set_Is_True_Constant
(Id
, True);
1915 if Nkind
(E
) = N_Integer_Literal
1916 or else Nkind
(E
) = N_Real_Literal
1918 Set_Etype
(E
, Etype
(Id
));
1921 if not Is_OK_Static_Expression
(E
) then
1922 Flag_Non_Static_Expr
1923 ("non-static expression used in number declaration!", E
);
1924 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1925 Set_Etype
(E
, Any_Type
);
1927 end Analyze_Number_Declaration
;
1929 --------------------------------
1930 -- Analyze_Object_Declaration --
1931 --------------------------------
1933 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1934 Loc
: constant Source_Ptr
:= Sloc
(N
);
1935 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1939 E
: Node_Id
:= Expression
(N
);
1940 -- E is set to Expression (N) throughout this routine. When
1941 -- Expression (N) is modified, E is changed accordingly.
1943 Prev_Entity
: Entity_Id
:= Empty
;
1945 function Count_Tasks
(T
: Entity_Id
) return Uint
;
1946 -- This function is called when a library level object of type is
1947 -- declared. It's function is to count the static number of tasks
1948 -- declared within the type (it is only called if Has_Tasks is set for
1949 -- T). As a side effect, if an array of tasks with non-static bounds or
1950 -- a variant record type is encountered, Check_Restrictions is called
1951 -- indicating the count is unknown.
1957 function Count_Tasks
(T
: Entity_Id
) return Uint
is
1963 if Is_Task_Type
(T
) then
1966 elsif Is_Record_Type
(T
) then
1967 if Has_Discriminants
(T
) then
1968 Check_Restriction
(Max_Tasks
, N
);
1973 C
:= First_Component
(T
);
1974 while Present
(C
) loop
1975 V
:= V
+ Count_Tasks
(Etype
(C
));
1982 elsif Is_Array_Type
(T
) then
1983 X
:= First_Index
(T
);
1984 V
:= Count_Tasks
(Component_Type
(T
));
1985 while Present
(X
) loop
1988 if not Is_Static_Subtype
(C
) then
1989 Check_Restriction
(Max_Tasks
, N
);
1992 V
:= V
* (UI_Max
(Uint_0
,
1993 Expr_Value
(Type_High_Bound
(C
)) -
1994 Expr_Value
(Type_Low_Bound
(C
)) + Uint_1
));
2007 -- Start of processing for Analyze_Object_Declaration
2010 -- There are three kinds of implicit types generated by an
2011 -- object declaration:
2013 -- 1. Those for generated by the original Object Definition
2015 -- 2. Those generated by the Expression
2017 -- 3. Those used to constrained the Object Definition with the
2018 -- expression constraints when it is unconstrained
2020 -- They must be generated in this order to avoid order of elaboration
2021 -- issues. Thus the first step (after entering the name) is to analyze
2022 -- the object definition.
2024 if Constant_Present
(N
) then
2025 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
2027 -- If homograph is an implicit subprogram, it is overridden by the
2028 -- current declaration.
2030 if Present
(Prev_Entity
)
2031 and then Is_Overloadable
(Prev_Entity
)
2032 and then Is_Inherited_Operation
(Prev_Entity
)
2034 Prev_Entity
:= Empty
;
2038 if Present
(Prev_Entity
) then
2039 Constant_Redeclaration
(Id
, N
, T
);
2041 Generate_Reference
(Prev_Entity
, Id
, 'c');
2042 Set_Completion_Referenced
(Id
);
2044 if Error_Posted
(N
) then
2046 -- Type mismatch or illegal redeclaration, Do not analyze
2047 -- expression to avoid cascaded errors.
2049 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2051 Set_Ekind
(Id
, E_Variable
);
2055 -- In the normal case, enter identifier at the start to catch premature
2056 -- usage in the initialization expression.
2059 Generate_Definition
(Id
);
2062 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2064 if Error_Posted
(Id
) then
2066 Set_Ekind
(Id
, E_Variable
);
2071 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2072 -- out some static checks
2074 if Ada_Version
>= Ada_05
2075 and then Can_Never_Be_Null
(T
)
2077 -- In case of aggregates we must also take care of the correct
2078 -- initialization of nested aggregates bug this is done at the
2079 -- point of the analysis of the aggregate (see sem_aggr.adb)
2081 if Present
(Expression
(N
))
2082 and then Nkind
(Expression
(N
)) = N_Aggregate
2088 Save_Typ
: constant Entity_Id
:= Etype
(Id
);
2090 Set_Etype
(Id
, T
); -- Temp. decoration for static checks
2091 Null_Exclusion_Static_Checks
(N
);
2092 Set_Etype
(Id
, Save_Typ
);
2097 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2099 -- If deferred constant, make sure context is appropriate. We detect
2100 -- a deferred constant as a constant declaration with no expression.
2101 -- A deferred constant can appear in a package body if its completion
2102 -- is by means of an interface pragma.
2104 if Constant_Present
(N
)
2107 if not Is_Package_Or_Generic_Package
(Current_Scope
) then
2109 ("invalid context for deferred constant declaration ('R'M 7.4)",
2112 ("\declaration requires an initialization expression",
2114 Set_Constant_Present
(N
, False);
2116 -- In Ada 83, deferred constant must be of private type
2118 elsif not Is_Private_Type
(T
) then
2119 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2121 ("(Ada 83) deferred constant must be private type", N
);
2125 -- If not a deferred constant, then object declaration freezes its type
2128 Check_Fully_Declared
(T
, N
);
2129 Freeze_Before
(N
, T
);
2132 -- If the object was created by a constrained array definition, then
2133 -- set the link in both the anonymous base type and anonymous subtype
2134 -- that are built to represent the array type to point to the object.
2136 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
2137 N_Constrained_Array_Definition
2139 Set_Related_Array_Object
(T
, Id
);
2140 Set_Related_Array_Object
(Base_Type
(T
), Id
);
2143 -- Special checks for protected objects not at library level
2145 if Is_Protected_Type
(T
)
2146 and then not Is_Library_Level_Entity
(Id
)
2148 Check_Restriction
(No_Local_Protected_Objects
, Id
);
2150 -- Protected objects with interrupt handlers must be at library level
2152 -- Ada 2005: this test is not needed (and the corresponding clause
2153 -- in the RM is removed) because accessibility checks are sufficient
2154 -- to make handlers not at the library level illegal.
2156 if Has_Interrupt_Handler
(T
)
2157 and then Ada_Version
< Ada_05
2160 ("interrupt object can only be declared at library level", Id
);
2164 -- The actual subtype of the object is the nominal subtype, unless
2165 -- the nominal one is unconstrained and obtained from the expression.
2169 -- Process initialization expression if present and not in error
2171 if Present
(E
) and then E
/= Error
then
2174 -- In case of errors detected in the analysis of the expression,
2175 -- decorate it with the expected type to avoid cascade errors
2177 if No
(Etype
(E
)) then
2181 -- If an initialization expression is present, then we set the
2182 -- Is_True_Constant flag. It will be reset if this is a variable
2183 -- and it is indeed modified.
2185 Set_Is_True_Constant
(Id
, True);
2187 -- If we are analyzing a constant declaration, set its completion
2188 -- flag after analyzing the expression.
2190 if Constant_Present
(N
) then
2191 Set_Has_Completion
(Id
);
2194 Set_Etype
(Id
, T
); -- may be overridden later on
2197 if not Assignment_OK
(N
) then
2198 Check_Initialization
(T
, E
);
2200 Check_Unset_Reference
(E
);
2202 -- If this is a variable, then set current value
2204 if not Constant_Present
(N
) then
2205 if Compile_Time_Known_Value
(E
) then
2206 Set_Current_Value
(Id
, E
);
2210 -- Check incorrect use of dynamically tagged expressions. Note
2211 -- the use of Is_Tagged_Type (T) which seems redundant but is in
2212 -- fact important to avoid spurious errors due to expanded code
2213 -- for dispatching functions over an anonymous access type
2215 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
2216 and then Is_Tagged_Type
(T
)
2217 and then not Is_Class_Wide_Type
(T
)
2219 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
2222 Apply_Scalar_Range_Check
(E
, T
);
2223 Apply_Static_Length_Check
(E
, T
);
2226 -- If the No_Streams restriction is set, check that the type of the
2227 -- object is not, and does not contain, any subtype derived from
2228 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
2229 -- Has_Stream just for efficiency reasons. There is no point in
2230 -- spending time on a Has_Stream check if the restriction is not set.
2232 if Restrictions
.Set
(No_Streams
) then
2233 if Has_Stream
(T
) then
2234 Check_Restriction
(No_Streams
, N
);
2238 -- Abstract type is never permitted for a variable or constant.
2239 -- Note: we inhibit this check for objects that do not come from
2240 -- source because there is at least one case (the expansion of
2241 -- x'class'input where x is abstract) where we legitimately
2242 -- generate an abstract object.
2244 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
2245 Error_Msg_N
("type of object cannot be abstract",
2246 Object_Definition
(N
));
2248 if Is_CPP_Class
(T
) then
2249 Error_Msg_NE
("\} may need a cpp_constructor",
2250 Object_Definition
(N
), T
);
2253 -- Case of unconstrained type
2255 elsif Is_Indefinite_Subtype
(T
) then
2257 -- Nothing to do in deferred constant case
2259 if Constant_Present
(N
) and then No
(E
) then
2262 -- Case of no initialization present
2265 if No_Initialization
(N
) then
2268 elsif Is_Class_Wide_Type
(T
) then
2270 ("initialization required in class-wide declaration ", N
);
2274 ("unconstrained subtype not allowed (need initialization)",
2275 Object_Definition
(N
));
2278 -- Case of initialization present but in error. Set initial
2279 -- expression as absent (but do not make above complaints)
2281 elsif E
= Error
then
2282 Set_Expression
(N
, Empty
);
2285 -- Case of initialization present
2288 -- Not allowed in Ada 83
2290 if not Constant_Present
(N
) then
2291 if Ada_Version
= Ada_83
2292 and then Comes_From_Source
(Object_Definition
(N
))
2295 ("(Ada 83) unconstrained variable not allowed",
2296 Object_Definition
(N
));
2300 -- Now we constrain the variable from the initializing expression
2302 -- If the expression is an aggregate, it has been expanded into
2303 -- individual assignments. Retrieve the actual type from the
2304 -- expanded construct.
2306 if Is_Array_Type
(T
)
2307 and then No_Initialization
(N
)
2308 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2313 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
2314 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
2317 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
2319 if Aliased_Present
(N
) then
2320 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2323 Freeze_Before
(N
, Act_T
);
2324 Freeze_Before
(N
, T
);
2327 elsif Is_Array_Type
(T
)
2328 and then No_Initialization
(N
)
2329 and then Nkind
(Original_Node
(E
)) = N_Aggregate
2331 if not Is_Entity_Name
(Object_Definition
(N
)) then
2333 Check_Compile_Time_Size
(Act_T
);
2335 if Aliased_Present
(N
) then
2336 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
2340 -- When the given object definition and the aggregate are specified
2341 -- independently, and their lengths might differ do a length check.
2342 -- This cannot happen if the aggregate is of the form (others =>...)
2344 if not Is_Constrained
(T
) then
2347 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
2349 -- Aggregate is statically illegal. Place back in declaration
2351 Set_Expression
(N
, E
);
2352 Set_No_Initialization
(N
, False);
2354 elsif T
= Etype
(E
) then
2357 elsif Nkind
(E
) = N_Aggregate
2358 and then Present
(Component_Associations
(E
))
2359 and then Present
(Choices
(First
(Component_Associations
(E
))))
2360 and then Nkind
(First
2361 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
2366 Apply_Length_Check
(E
, T
);
2369 -- If the type is limited unconstrained with defaulted discriminants
2370 -- and there is no expression, then the object is constrained by the
2371 -- defaults, so it is worthwhile building the corresponding subtype.
2373 elsif (Is_Limited_Record
(T
)
2374 or else Is_Concurrent_Type
(T
))
2375 and then not Is_Constrained
(T
)
2376 and then Has_Discriminants
(T
)
2379 Act_T
:= Build_Default_Subtype
(T
, N
);
2381 -- Ada 2005: a limited object may be initialized by means of an
2382 -- aggregate. If the type has default discriminants it has an
2383 -- unconstrained nominal type, Its actual subtype will be obtained
2384 -- from the aggregate, and not from the default discriminants.
2389 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
2391 elsif Present
(Underlying_Type
(T
))
2392 and then not Is_Constrained
(Underlying_Type
(T
))
2393 and then Has_Discriminants
(Underlying_Type
(T
))
2394 and then Nkind
(E
) = N_Function_Call
2395 and then Constant_Present
(N
)
2397 -- The back-end has problems with constants of a discriminated type
2398 -- with defaults, if the initial value is a function call. We
2399 -- generate an intermediate temporary for the result of the call.
2400 -- It is unclear why this should make it acceptable to gcc. ???
2402 Remove_Side_Effects
(E
);
2405 if T
= Standard_Wide_Character
or else T
= Standard_Wide_Wide_Character
2406 or else Root_Type
(T
) = Standard_Wide_String
2407 or else Root_Type
(T
) = Standard_Wide_Wide_String
2409 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
2412 -- Now establish the proper kind and type of the object
2414 if Constant_Present
(N
) then
2415 Set_Ekind
(Id
, E_Constant
);
2416 Set_Never_Set_In_Source
(Id
, True);
2417 Set_Is_True_Constant
(Id
, True);
2420 Set_Ekind
(Id
, E_Variable
);
2422 -- A variable is set as shared passive if it appears in a shared
2423 -- passive package, and is at the outer level. This is not done
2424 -- for entities generated during expansion, because those are
2425 -- always manipulated locally.
2427 if Is_Shared_Passive
(Current_Scope
)
2428 and then Is_Library_Level_Entity
(Id
)
2429 and then Comes_From_Source
(Id
)
2431 Set_Is_Shared_Passive
(Id
);
2432 Check_Shared_Var
(Id
, T
, N
);
2435 -- Case of no initializing expression present. If the type is not
2436 -- fully initialized, then we set Never_Set_In_Source, since this
2437 -- is a case of a potentially uninitialized object. Note that we
2438 -- do not consider access variables to be fully initialized for
2439 -- this purpose, since it still seems dubious if someone declares
2441 -- Note that we only do this for source declarations. If the object
2442 -- is declared by a generated declaration, we assume that it is not
2443 -- appropriate to generate warnings in that case.
2446 if (Is_Access_Type
(T
)
2447 or else not Is_Fully_Initialized_Type
(T
))
2448 and then Comes_From_Source
(N
)
2450 Set_Never_Set_In_Source
(Id
);
2455 Init_Alignment
(Id
);
2458 if Aliased_Present
(N
) then
2459 Set_Is_Aliased
(Id
);
2461 -- If the object is aliased and the type is unconstrained with
2462 -- defaulted discriminants and there is no expression, then the
2463 -- object is constrained by the defaults, so it is worthwhile
2464 -- building the corresponding subtype.
2466 -- Ada 2005 (AI-363): If the aliased object is discriminated and
2467 -- unconstrained, then only establish an actual subtype if the
2468 -- nominal subtype is indefinite. In definite cases the object is
2469 -- unconstrained in Ada 2005.
2472 and then Is_Record_Type
(T
)
2473 and then not Is_Constrained
(T
)
2474 and then Has_Discriminants
(T
)
2475 and then (Ada_Version
< Ada_05
or else Is_Indefinite_Subtype
(T
))
2477 Set_Actual_Subtype
(Id
, Build_Default_Subtype
(T
, N
));
2481 Set_Etype
(Id
, Act_T
);
2483 if Has_Controlled_Component
(Etype
(Id
))
2484 or else Is_Controlled
(Etype
(Id
))
2486 if not Is_Library_Level_Entity
(Id
) then
2487 Check_Restriction
(No_Nested_Finalization
, N
);
2489 Validate_Controlled_Object
(Id
);
2492 -- Generate a warning when an initialization causes an obvious ABE
2493 -- violation. If the init expression is a simple aggregate there
2494 -- shouldn't be any initialize/adjust call generated. This will be
2495 -- true as soon as aggregates are built in place when possible.
2497 -- ??? at the moment we do not generate warnings for temporaries
2498 -- created for those aggregates although Program_Error might be
2499 -- generated if compiled with -gnato.
2501 if Is_Controlled
(Etype
(Id
))
2502 and then Comes_From_Source
(Id
)
2505 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
2507 Implicit_Call
: Entity_Id
;
2508 pragma Warnings
(Off
, Implicit_Call
);
2509 -- ??? what is this for (never referenced!)
2511 function Is_Aggr
(N
: Node_Id
) return Boolean;
2512 -- Check that N is an aggregate
2518 function Is_Aggr
(N
: Node_Id
) return Boolean is
2520 case Nkind
(Original_Node
(N
)) is
2521 when N_Aggregate | N_Extension_Aggregate
=>
2524 when N_Qualified_Expression |
2526 N_Unchecked_Type_Conversion
=>
2527 return Is_Aggr
(Expression
(Original_Node
(N
)));
2535 -- If no underlying type, we already are in an error situation.
2536 -- Do not try to add a warning since we do not have access to
2539 if No
(Underlying_Type
(BT
)) then
2540 Implicit_Call
:= Empty
;
2542 -- A generic type does not have usable primitive operators.
2543 -- Initialization calls are built for instances.
2545 elsif Is_Generic_Type
(BT
) then
2546 Implicit_Call
:= Empty
;
2548 -- If the init expression is not an aggregate, an adjust call
2549 -- will be generated
2551 elsif Present
(E
) and then not Is_Aggr
(E
) then
2552 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
2554 -- If no init expression and we are not in the deferred
2555 -- constant case, an Initialize call will be generated
2557 elsif No
(E
) and then not Constant_Present
(N
) then
2558 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
2561 Implicit_Call
:= Empty
;
2567 if Has_Task
(Etype
(Id
)) then
2568 Check_Restriction
(No_Tasking
, N
);
2570 if Is_Library_Level_Entity
(Id
) then
2571 Check_Restriction
(Max_Tasks
, N
, Count_Tasks
(Etype
(Id
)));
2573 Check_Restriction
(Max_Tasks
, N
);
2574 Check_Restriction
(No_Task_Hierarchy
, N
);
2575 Check_Potentially_Blocking_Operation
(N
);
2578 -- A rather specialized test. If we see two tasks being declared
2579 -- of the same type in the same object declaration, and the task
2580 -- has an entry with an address clause, we know that program error
2581 -- will be raised at run-time since we can't have two tasks with
2582 -- entries at the same address.
2584 if Is_Task_Type
(Etype
(Id
)) and then More_Ids
(N
) then
2589 E
:= First_Entity
(Etype
(Id
));
2590 while Present
(E
) loop
2591 if Ekind
(E
) = E_Entry
2592 and then Present
(Get_Attribute_Definition_Clause
2593 (E
, Attribute_Address
))
2596 ("?more than one task with same entry address", N
);
2598 ("\?Program_Error will be raised at run time", N
);
2600 Make_Raise_Program_Error
(Loc
,
2601 Reason
=> PE_Duplicated_Entry_Address
));
2611 -- Some simple constant-propagation: if the expression is a constant
2612 -- string initialized with a literal, share the literal. This avoids
2616 and then Is_Entity_Name
(E
)
2617 and then Ekind
(Entity
(E
)) = E_Constant
2618 and then Base_Type
(Etype
(E
)) = Standard_String
2621 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
2624 and then Nkind
(Val
) = N_String_Literal
2626 Rewrite
(E
, New_Copy
(Val
));
2631 -- Another optimization: if the nominal subtype is unconstrained and
2632 -- the expression is a function call that returns an unconstrained
2633 -- type, rewrite the declaration as a renaming of the result of the
2634 -- call. The exceptions below are cases where the copy is expected,
2635 -- either by the back end (Aliased case) or by the semantics, as for
2636 -- initializing controlled types or copying tags for classwide types.
2639 and then Nkind
(E
) = N_Explicit_Dereference
2640 and then Nkind
(Original_Node
(E
)) = N_Function_Call
2641 and then not Is_Library_Level_Entity
(Id
)
2642 and then not Is_Constrained
(Underlying_Type
(T
))
2643 and then not Is_Aliased
(Id
)
2644 and then not Is_Class_Wide_Type
(T
)
2645 and then not Is_Controlled
(T
)
2646 and then not Has_Controlled_Component
(Base_Type
(T
))
2647 and then Expander_Active
2650 Make_Object_Renaming_Declaration
(Loc
,
2651 Defining_Identifier
=> Id
,
2652 Access_Definition
=> Empty
,
2653 Subtype_Mark
=> New_Occurrence_Of
2654 (Base_Type
(Etype
(Id
)), Loc
),
2657 Set_Renamed_Object
(Id
, E
);
2659 -- Force generation of debugging information for the constant and for
2660 -- the renamed function call.
2662 Set_Needs_Debug_Info
(Id
);
2663 Set_Needs_Debug_Info
(Entity
(Prefix
(E
)));
2666 if Present
(Prev_Entity
)
2667 and then Is_Frozen
(Prev_Entity
)
2668 and then not Error_Posted
(Id
)
2670 Error_Msg_N
("full constant declaration appears too late", N
);
2673 Check_Eliminated
(Id
);
2675 -- Deal with setting In_Private_Part flag if in private part
2677 if Ekind
(Scope
(Id
)) = E_Package
2678 and then In_Private_Part
(Scope
(Id
))
2680 Set_In_Private_Part
(Id
);
2682 end Analyze_Object_Declaration
;
2684 ---------------------------
2685 -- Analyze_Others_Choice --
2686 ---------------------------
2688 -- Nothing to do for the others choice node itself, the semantic analysis
2689 -- of the others choice will occur as part of the processing of the parent
2691 procedure Analyze_Others_Choice
(N
: Node_Id
) is
2692 pragma Warnings
(Off
, N
);
2695 end Analyze_Others_Choice
;
2697 --------------------------------
2698 -- Analyze_Per_Use_Expression --
2699 --------------------------------
2701 procedure Analyze_Per_Use_Expression
(N
: Node_Id
; T
: Entity_Id
) is
2702 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
2704 In_Default_Expression
:= True;
2705 Pre_Analyze_And_Resolve
(N
, T
);
2706 In_Default_Expression
:= Save_In_Default_Expression
;
2707 end Analyze_Per_Use_Expression
;
2709 -------------------------------------------
2710 -- Analyze_Private_Extension_Declaration --
2711 -------------------------------------------
2713 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
2714 T
: constant Entity_Id
:= Defining_Identifier
(N
);
2715 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
2716 Parent_Type
: Entity_Id
;
2717 Parent_Base
: Entity_Id
;
2720 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
2722 if Is_Non_Empty_List
(Interface_List
(N
)) then
2728 Intf
:= First
(Interface_List
(N
));
2729 while Present
(Intf
) loop
2730 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
2732 if not Is_Interface
(T
) then
2733 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
2741 Generate_Definition
(T
);
2744 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
2745 Parent_Base
:= Base_Type
(Parent_Type
);
2747 if Parent_Type
= Any_Type
2748 or else Etype
(Parent_Type
) = Any_Type
2750 Set_Ekind
(T
, Ekind
(Parent_Type
));
2751 Set_Etype
(T
, Any_Type
);
2754 elsif not Is_Tagged_Type
(Parent_Type
) then
2756 ("parent of type extension must be a tagged type ", Indic
);
2759 elsif Ekind
(Parent_Type
) = E_Void
2760 or else Ekind
(Parent_Type
) = E_Incomplete_Type
2762 Error_Msg_N
("premature derivation of incomplete type", Indic
);
2766 -- Perhaps the parent type should be changed to the class-wide type's
2767 -- specific type in this case to prevent cascading errors ???
2769 if Is_Class_Wide_Type
(Parent_Type
) then
2771 ("parent of type extension must not be a class-wide type", Indic
);
2775 if (not Is_Package_Or_Generic_Package
(Current_Scope
)
2776 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
2777 or else In_Private_Part
(Current_Scope
)
2780 Error_Msg_N
("invalid context for private extension", N
);
2783 -- Set common attributes
2785 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2786 Set_Scope
(T
, Current_Scope
);
2787 Set_Ekind
(T
, E_Record_Type_With_Private
);
2788 Init_Size_Align
(T
);
2790 Set_Etype
(T
, Parent_Base
);
2791 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
2793 Set_Convention
(T
, Convention
(Parent_Type
));
2794 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
2795 Set_Is_First_Subtype
(T
);
2796 Make_Class_Wide_Type
(T
);
2798 if Unknown_Discriminants_Present
(N
) then
2799 Set_Discriminant_Constraint
(T
, No_Elist
);
2802 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
2804 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten
2805 -- synchronized formal derived type.
2807 if Ada_Version
>= Ada_05
2808 and then Synchronized_Present
(N
)
2810 Set_Is_Limited_Record
(T
);
2812 -- Formal derived type case
2814 if Is_Generic_Type
(T
) then
2816 -- The parent must be a tagged limited type or a synchronized
2819 if (not Is_Tagged_Type
(Parent_Type
)
2820 or else not Is_Limited_Type
(Parent_Type
))
2822 (not Is_Interface
(Parent_Type
)
2823 or else not Is_Synchronized_Interface
(Parent_Type
))
2825 Error_Msg_NE
("parent type of & must be tagged limited " &
2826 "or synchronized", N
, T
);
2829 -- The progenitors (if any) must be limited or synchronized
2832 if Present
(Abstract_Interfaces
(T
)) then
2835 Iface_Elmt
: Elmt_Id
;
2838 Iface_Elmt
:= First_Elmt
(Abstract_Interfaces
(T
));
2839 while Present
(Iface_Elmt
) loop
2840 Iface
:= Node
(Iface_Elmt
);
2842 if not Is_Limited_Interface
(Iface
)
2843 and then not Is_Synchronized_Interface
(Iface
)
2845 Error_Msg_NE
("progenitor & must be limited " &
2846 "or synchronized", N
, Iface
);
2849 Next_Elmt
(Iface_Elmt
);
2854 -- Regular derived extension, the parent must be a limited or
2855 -- synchronized interface.
2858 if not Is_Interface
(Parent_Type
)
2859 or else (not Is_Limited_Interface
(Parent_Type
)
2861 not Is_Synchronized_Interface
(Parent_Type
))
2864 ("parent type of & must be limited interface", N
, T
);
2868 elsif Limited_Present
(N
) then
2869 Set_Is_Limited_Record
(T
);
2871 if not Is_Limited_Type
(Parent_Type
)
2873 (not Is_Interface
(Parent_Type
)
2874 or else not Is_Limited_Interface
(Parent_Type
))
2876 Error_Msg_NE
("parent type& of limited extension must be limited",
2880 end Analyze_Private_Extension_Declaration
;
2882 ---------------------------------
2883 -- Analyze_Subtype_Declaration --
2884 ---------------------------------
2886 procedure Analyze_Subtype_Declaration
2888 Skip
: Boolean := False)
2890 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2892 R_Checks
: Check_Result
;
2895 Generate_Definition
(Id
);
2896 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2897 Init_Size_Align
(Id
);
2899 -- The following guard condition on Enter_Name is to handle cases where
2900 -- the defining identifier has already been entered into the scope but
2901 -- the declaration as a whole needs to be analyzed.
2903 -- This case in particular happens for derived enumeration types. The
2904 -- derived enumeration type is processed as an inserted enumeration type
2905 -- declaration followed by a rewritten subtype declaration. The defining
2906 -- identifier, however, is entered into the name scope very early in the
2907 -- processing of the original type declaration and therefore needs to be
2908 -- avoided here, when the created subtype declaration is analyzed. (See
2909 -- Build_Derived_Types)
2911 -- This also happens when the full view of a private type is derived
2912 -- type with constraints. In this case the entity has been introduced
2913 -- in the private declaration.
2916 or else (Present
(Etype
(Id
))
2917 and then (Is_Private_Type
(Etype
(Id
))
2918 or else Is_Task_Type
(Etype
(Id
))
2919 or else Is_Rewrite_Substitution
(N
)))
2927 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2929 -- Inherit common attributes
2931 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2932 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2933 Set_Treat_As_Volatile
(Id
, Treat_As_Volatile
(T
));
2934 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2935 Set_Is_Ada_2005_Only
(Id
, Is_Ada_2005_Only
(T
));
2937 -- In the case where there is no constraint given in the subtype
2938 -- indication, Process_Subtype just returns the Subtype_Mark, so its
2939 -- semantic attributes must be established here.
2941 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2942 Set_Etype
(Id
, Base_Type
(T
));
2946 Set_Ekind
(Id
, E_Array_Subtype
);
2947 Copy_Array_Subtype_Attributes
(Id
, T
);
2949 when Decimal_Fixed_Point_Kind
=>
2950 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2951 Set_Digits_Value
(Id
, Digits_Value
(T
));
2952 Set_Delta_Value
(Id
, Delta_Value
(T
));
2953 Set_Scale_Value
(Id
, Scale_Value
(T
));
2954 Set_Small_Value
(Id
, Small_Value
(T
));
2955 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2956 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2957 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2958 Set_RM_Size
(Id
, RM_Size
(T
));
2960 when Enumeration_Kind
=>
2961 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2962 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2963 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2964 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2965 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2966 Set_RM_Size
(Id
, RM_Size
(T
));
2968 when Ordinary_Fixed_Point_Kind
=>
2969 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2970 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2971 Set_Small_Value
(Id
, Small_Value
(T
));
2972 Set_Delta_Value
(Id
, Delta_Value
(T
));
2973 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2974 Set_RM_Size
(Id
, RM_Size
(T
));
2977 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2978 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2979 Set_Digits_Value
(Id
, Digits_Value
(T
));
2980 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2982 when Signed_Integer_Kind
=>
2983 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2984 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2985 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2986 Set_RM_Size
(Id
, RM_Size
(T
));
2988 when Modular_Integer_Kind
=>
2989 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2990 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2991 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2992 Set_RM_Size
(Id
, RM_Size
(T
));
2994 when Class_Wide_Kind
=>
2995 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2996 Set_First_Entity
(Id
, First_Entity
(T
));
2997 Set_Last_Entity
(Id
, Last_Entity
(T
));
2998 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2999 Set_Cloned_Subtype
(Id
, T
);
3000 Set_Is_Tagged_Type
(Id
, True);
3001 Set_Has_Unknown_Discriminants
3004 if Ekind
(T
) = E_Class_Wide_Subtype
then
3005 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
3008 when E_Record_Type | E_Record_Subtype
=>
3009 Set_Ekind
(Id
, E_Record_Subtype
);
3011 if Ekind
(T
) = E_Record_Subtype
3012 and then Present
(Cloned_Subtype
(T
))
3014 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
3016 Set_Cloned_Subtype
(Id
, T
);
3019 Set_First_Entity
(Id
, First_Entity
(T
));
3020 Set_Last_Entity
(Id
, Last_Entity
(T
));
3021 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
3022 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3023 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
3024 Set_Has_Unknown_Discriminants
3025 (Id
, Has_Unknown_Discriminants
(T
));
3027 if Has_Discriminants
(T
) then
3028 Set_Discriminant_Constraint
3029 (Id
, Discriminant_Constraint
(T
));
3030 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3032 elsif Has_Unknown_Discriminants
(Id
) then
3033 Set_Discriminant_Constraint
(Id
, No_Elist
);
3036 if Is_Tagged_Type
(T
) then
3037 Set_Is_Tagged_Type
(Id
);
3038 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
3039 Set_Primitive_Operations
3040 (Id
, Primitive_Operations
(T
));
3041 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
3044 when Private_Kind
=>
3045 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
3046 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
3047 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3048 Set_First_Entity
(Id
, First_Entity
(T
));
3049 Set_Last_Entity
(Id
, Last_Entity
(T
));
3050 Set_Private_Dependents
(Id
, New_Elmt_List
);
3051 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
3052 Set_Has_Unknown_Discriminants
3053 (Id
, Has_Unknown_Discriminants
(T
));
3055 if Is_Tagged_Type
(T
) then
3056 Set_Is_Tagged_Type
(Id
);
3057 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
3058 Set_Primitive_Operations
3059 (Id
, Primitive_Operations
(T
));
3060 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
3063 -- In general the attributes of the subtype of a private type
3064 -- are the attributes of the partial view of parent. However,
3065 -- the full view may be a discriminated type, and the subtype
3066 -- must share the discriminant constraint to generate correct
3067 -- calls to initialization procedures.
3069 if Has_Discriminants
(T
) then
3070 Set_Discriminant_Constraint
3071 (Id
, Discriminant_Constraint
(T
));
3072 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3074 elsif Present
(Full_View
(T
))
3075 and then Has_Discriminants
(Full_View
(T
))
3077 Set_Discriminant_Constraint
3078 (Id
, Discriminant_Constraint
(Full_View
(T
)));
3079 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3081 -- This would seem semantically correct, but apparently
3082 -- confuses the back-end (4412-009). To be explained ???
3084 -- Set_Has_Discriminants (Id);
3087 Prepare_Private_Subtype_Completion
(Id
, N
);
3090 Set_Ekind
(Id
, E_Access_Subtype
);
3091 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3092 Set_Is_Access_Constant
3093 (Id
, Is_Access_Constant
(T
));
3094 Set_Directly_Designated_Type
3095 (Id
, Designated_Type
(T
));
3096 Set_Can_Never_Be_Null
(Id
, Can_Never_Be_Null
(T
));
3098 -- A Pure library_item must not contain the declaration of a
3099 -- named access type, except within a subprogram, generic
3100 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
3102 if Comes_From_Source
(Id
)
3103 and then In_Pure_Unit
3104 and then not In_Subprogram_Task_Protected_Unit
3107 ("named access types not allowed in pure unit", N
);
3110 when Concurrent_Kind
=>
3111 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
3112 Set_Corresponding_Record_Type
(Id
,
3113 Corresponding_Record_Type
(T
));
3114 Set_First_Entity
(Id
, First_Entity
(T
));
3115 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
3116 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
3117 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
3118 Set_Last_Entity
(Id
, Last_Entity
(T
));
3120 if Has_Discriminants
(T
) then
3121 Set_Discriminant_Constraint
(Id
,
3122 Discriminant_Constraint
(T
));
3123 Set_Stored_Constraint_From_Discriminant_Constraint
(Id
);
3126 when E_Incomplete_Type
=>
3127 if Ada_Version
>= Ada_05
then
3128 Set_Ekind
(Id
, E_Incomplete_Subtype
);
3130 -- Ada 2005 (AI-412): Decorate an incomplete subtype
3131 -- of an incomplete type visible through a limited
3134 if From_With_Type
(T
)
3135 and then Present
(Non_Limited_View
(T
))
3137 Set_From_With_Type
(Id
);
3138 Set_Non_Limited_View
(Id
, Non_Limited_View
(T
));
3140 -- Ada 2005 (AI-412): Add the regular incomplete subtype
3141 -- to the private dependents of the original incomplete
3142 -- type for future transformation.
3145 Append_Elmt
(Id
, Private_Dependents
(T
));
3148 -- If the subtype name denotes an incomplete type an error
3149 -- was already reported by Process_Subtype.
3152 Set_Etype
(Id
, Any_Type
);
3156 raise Program_Error
;
3160 if Etype
(Id
) = Any_Type
then
3164 -- Some common processing on all types
3166 Set_Size_Info
(Id
, T
);
3167 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
3171 Set_Is_Immediately_Visible
(Id
, True);
3172 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
3174 if Present
(Generic_Parent_Type
(N
))
3177 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
3179 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
3180 /= N_Formal_Private_Type_Definition
)
3182 if Is_Tagged_Type
(Id
) then
3183 if Is_Class_Wide_Type
(Id
) then
3184 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
3186 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
3189 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
3190 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
3194 if Is_Private_Type
(T
)
3195 and then Present
(Full_View
(T
))
3197 Conditional_Delay
(Id
, Full_View
(T
));
3199 -- The subtypes of components or subcomponents of protected types
3200 -- do not need freeze nodes, which would otherwise appear in the
3201 -- wrong scope (before the freeze node for the protected type). The
3202 -- proper subtypes are those of the subcomponents of the corresponding
3205 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
3206 and then Present
(Scope
(Scope
(Id
))) -- error defense!
3207 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
3209 Conditional_Delay
(Id
, T
);
3212 -- Check that constraint_error is raised for a scalar subtype
3213 -- indication when the lower or upper bound of a non-null range
3214 -- lies outside the range of the type mark.
3216 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
3217 if Is_Scalar_Type
(Etype
(Id
))
3218 and then Scalar_Range
(Id
) /=
3219 Scalar_Range
(Etype
(Subtype_Mark
3220 (Subtype_Indication
(N
))))
3224 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
3226 elsif Is_Array_Type
(Etype
(Id
))
3227 and then Present
(First_Index
(Id
))
3229 -- This really should be a subprogram that finds the indications
3232 if ((Nkind
(First_Index
(Id
)) = N_Identifier
3233 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
3234 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
3236 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
3239 Target_Typ
: constant Entity_Id
:=
3242 (Subtype_Mark
(Subtype_Indication
(N
)))));
3246 (Scalar_Range
(Etype
(First_Index
(Id
))),
3248 Etype
(First_Index
(Id
)),
3249 Defining_Identifier
(N
));
3255 Sloc
(Defining_Identifier
(N
)));
3261 Check_Eliminated
(Id
);
3262 end Analyze_Subtype_Declaration
;
3264 --------------------------------
3265 -- Analyze_Subtype_Indication --
3266 --------------------------------
3268 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
3269 T
: constant Entity_Id
:= Subtype_Mark
(N
);
3270 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
3277 Set_Etype
(N
, Etype
(R
));
3279 Set_Error_Posted
(R
);
3280 Set_Error_Posted
(T
);
3282 end Analyze_Subtype_Indication
;
3284 ------------------------------
3285 -- Analyze_Type_Declaration --
3286 ------------------------------
3288 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
3289 Def
: constant Node_Id
:= Type_Definition
(N
);
3290 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3294 Is_Remote
: constant Boolean :=
3295 (Is_Remote_Types
(Current_Scope
)
3296 or else Is_Remote_Call_Interface
(Current_Scope
))
3297 and then not (In_Private_Part
(Current_Scope
)
3299 In_Package_Body
(Current_Scope
));
3301 procedure Check_Ops_From_Incomplete_Type
;
3302 -- If there is a tagged incomplete partial view of the type, transfer
3303 -- its operations to the full view, and indicate that the type of the
3304 -- controlling parameter (s) is this full view.
3306 ------------------------------------
3307 -- Check_Ops_From_Incomplete_Type --
3308 ------------------------------------
3310 procedure Check_Ops_From_Incomplete_Type
is
3317 and then Ekind
(Prev
) = E_Incomplete_Type
3318 and then Is_Tagged_Type
(Prev
)
3319 and then Is_Tagged_Type
(T
)
3321 Elmt
:= First_Elmt
(Primitive_Operations
(Prev
));
3322 while Present
(Elmt
) loop
3324 Prepend_Elmt
(Op
, Primitive_Operations
(T
));
3326 Formal
:= First_Formal
(Op
);
3327 while Present
(Formal
) loop
3328 if Etype
(Formal
) = Prev
then
3329 Set_Etype
(Formal
, T
);
3332 Next_Formal
(Formal
);
3335 if Etype
(Op
) = Prev
then
3342 end Check_Ops_From_Incomplete_Type
;
3344 -- Start of processing for Analyze_Type_Declaration
3347 Prev
:= Find_Type_Name
(N
);
3349 -- The full view, if present, now points to the current type
3351 -- Ada 2005 (AI-50217): If the type was previously decorated when
3352 -- imported through a LIMITED WITH clause, it appears as incomplete
3353 -- but has no full view.
3355 if Ekind
(Prev
) = E_Incomplete_Type
3356 and then Present
(Full_View
(Prev
))
3358 T
:= Full_View
(Prev
);
3363 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
3365 -- We set the flag Is_First_Subtype here. It is needed to set the
3366 -- corresponding flag for the Implicit class-wide-type created
3367 -- during tagged types processing.
3369 Set_Is_First_Subtype
(T
, True);
3371 -- Only composite types other than array types are allowed to have
3376 -- For derived types, the rule will be checked once we've figured
3377 -- out the parent type.
3379 when N_Derived_Type_Definition
=>
3382 -- For record types, discriminants are allowed
3384 when N_Record_Definition
=>
3388 if Present
(Discriminant_Specifications
(N
)) then
3390 ("elementary or array type cannot have discriminants",
3392 (First
(Discriminant_Specifications
(N
))));
3396 -- Elaborate the type definition according to kind, and generate
3397 -- subsidiary (implicit) subtypes where needed. We skip this if it was
3398 -- already done (this happens during the reanalysis that follows a call
3399 -- to the high level optimizer).
3401 if not Analyzed
(T
) then
3406 when N_Access_To_Subprogram_Definition
=>
3407 Access_Subprogram_Declaration
(T
, Def
);
3409 -- If this is a remote access to subprogram, we must create the
3410 -- equivalent fat pointer type, and related subprograms.
3413 Process_Remote_AST_Declaration
(N
);
3416 -- Validate categorization rule against access type declaration
3417 -- usually a violation in Pure unit, Shared_Passive unit.
3419 Validate_Access_Type_Declaration
(T
, N
);
3421 when N_Access_To_Object_Definition
=>
3422 Access_Type_Declaration
(T
, Def
);
3424 -- Validate categorization rule against access type declaration
3425 -- usually a violation in Pure unit, Shared_Passive unit.
3427 Validate_Access_Type_Declaration
(T
, N
);
3429 -- If we are in a Remote_Call_Interface package and define
3430 -- a RACW, Read and Write attribute must be added.
3433 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
3435 Add_RACW_Features
(Def_Id
);
3438 -- Set no strict aliasing flag if config pragma seen
3440 if Opt
.No_Strict_Aliasing
then
3441 Set_No_Strict_Aliasing
(Base_Type
(Def_Id
));
3444 when N_Array_Type_Definition
=>
3445 Array_Type_Declaration
(T
, Def
);
3447 when N_Derived_Type_Definition
=>
3448 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
3450 when N_Enumeration_Type_Definition
=>
3451 Enumeration_Type_Declaration
(T
, Def
);
3453 when N_Floating_Point_Definition
=>
3454 Floating_Point_Type_Declaration
(T
, Def
);
3456 when N_Decimal_Fixed_Point_Definition
=>
3457 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
3459 when N_Ordinary_Fixed_Point_Definition
=>
3460 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
3462 when N_Signed_Integer_Type_Definition
=>
3463 Signed_Integer_Type_Declaration
(T
, Def
);
3465 when N_Modular_Type_Definition
=>
3466 Modular_Type_Declaration
(T
, Def
);
3468 when N_Record_Definition
=>
3469 Record_Type_Declaration
(T
, N
, Prev
);
3472 raise Program_Error
;
3477 if Etype
(T
) = Any_Type
then
3481 -- Some common processing for all types
3483 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
3484 Check_Ops_From_Incomplete_Type
;
3486 -- Both the declared entity, and its anonymous base type if one
3487 -- was created, need freeze nodes allocated.
3490 B
: constant Entity_Id
:= Base_Type
(T
);
3493 -- In the case where the base type is different from the first
3494 -- subtype, we pre-allocate a freeze node, and set the proper link
3495 -- to the first subtype. Freeze_Entity will use this preallocated
3496 -- freeze node when it freezes the entity.
3499 Ensure_Freeze_Node
(B
);
3500 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
3503 if not From_With_Type
(T
) then
3504 Set_Has_Delayed_Freeze
(T
);
3508 -- Case of T is the full declaration of some private type which has
3509 -- been swapped in Defining_Identifier (N).
3511 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
3512 Process_Full_View
(N
, T
, Def_Id
);
3514 -- Record the reference. The form of this is a little strange,
3515 -- since the full declaration has been swapped in. So the first
3516 -- parameter here represents the entity to which a reference is
3517 -- made which is the "real" entity, i.e. the one swapped in,
3518 -- and the second parameter provides the reference location.
3520 Generate_Reference
(T
, T
, 'c');
3521 Set_Completion_Referenced
(Def_Id
);
3523 -- For completion of incomplete type, process incomplete dependents
3524 -- and always mark the full type as referenced (it is the incomplete
3525 -- type that we get for any real reference).
3527 elsif Ekind
(Prev
) = E_Incomplete_Type
then
3528 Process_Incomplete_Dependents
(N
, T
, Prev
);
3529 Generate_Reference
(Prev
, Def_Id
, 'c');
3530 Set_Completion_Referenced
(Def_Id
);
3532 -- If not private type or incomplete type completion, this is a real
3533 -- definition of a new entity, so record it.
3536 Generate_Definition
(Def_Id
);
3539 Check_Eliminated
(Def_Id
);
3540 end Analyze_Type_Declaration
;
3542 --------------------------
3543 -- Analyze_Variant_Part --
3544 --------------------------
3546 procedure Analyze_Variant_Part
(N
: Node_Id
) is
3548 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
3549 -- Error routine invoked by the generic instantiation below when
3550 -- the variant part has a non static choice.
3552 procedure Process_Declarations
(Variant
: Node_Id
);
3553 -- Analyzes all the declarations associated with a Variant.
3554 -- Needed by the generic instantiation below.
3556 package Variant_Choices_Processing
is new
3557 Generic_Choices_Processing
3558 (Get_Alternatives
=> Variants
,
3559 Get_Choices
=> Discrete_Choices
,
3560 Process_Empty_Choice
=> No_OP
,
3561 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
3562 Process_Associated_Node
=> Process_Declarations
);
3563 use Variant_Choices_Processing
;
3564 -- Instantiation of the generic choice processing package
3566 -----------------------------
3567 -- Non_Static_Choice_Error --
3568 -----------------------------
3570 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
3572 Flag_Non_Static_Expr
3573 ("choice given in variant part is not static!", Choice
);
3574 end Non_Static_Choice_Error
;
3576 --------------------------
3577 -- Process_Declarations --
3578 --------------------------
3580 procedure Process_Declarations
(Variant
: Node_Id
) is
3582 if not Null_Present
(Component_List
(Variant
)) then
3583 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
3585 if Present
(Variant_Part
(Component_List
(Variant
))) then
3586 Analyze
(Variant_Part
(Component_List
(Variant
)));
3589 end Process_Declarations
;
3591 -- Variables local to Analyze_Case_Statement
3593 Discr_Name
: Node_Id
;
3594 Discr_Type
: Entity_Id
;
3596 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
3598 Dont_Care
: Boolean;
3599 Others_Present
: Boolean := False;
3601 -- Start of processing for Analyze_Variant_Part
3604 Discr_Name
:= Name
(N
);
3605 Analyze
(Discr_Name
);
3607 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
3608 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
3611 Discr_Type
:= Etype
(Entity
(Discr_Name
));
3613 if not Is_Discrete_Type
(Discr_Type
) then
3615 ("discriminant in a variant part must be of a discrete type",
3620 -- Call the instantiated Analyze_Choices which does the rest of the work
3623 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
3624 end Analyze_Variant_Part
;
3626 ----------------------------
3627 -- Array_Type_Declaration --
3628 ----------------------------
3630 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
3631 Component_Def
: constant Node_Id
:= Component_Definition
(Def
);
3632 Element_Type
: Entity_Id
;
3633 Implicit_Base
: Entity_Id
;
3635 Related_Id
: Entity_Id
:= Empty
;
3637 P
: constant Node_Id
:= Parent
(Def
);
3641 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3642 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
3644 Index
:= First
(Subtype_Marks
(Def
));
3647 -- Find proper names for the implicit types which may be public.
3648 -- in case of anonymous arrays we use the name of the first object
3649 -- of that type as prefix.
3652 Related_Id
:= Defining_Identifier
(P
);
3658 while Present
(Index
) loop
3661 -- Add a subtype declaration for each index of private array type
3662 -- declaration whose etype is also private. For example:
3665 -- type Index is private;
3667 -- type Table is array (Index) of ...
3670 -- This is currently required by the expander to generate the
3671 -- internally generated equality subprogram of records with variant
3672 -- parts in which the etype of some component is such private type.
3674 if Ekind
(Current_Scope
) = E_Package
3675 and then In_Private_Part
(Current_Scope
)
3676 and then Has_Private_Declaration
(Etype
(Index
))
3679 Loc
: constant Source_Ptr
:= Sloc
(Def
);
3685 Make_Defining_Identifier
(Loc
,
3686 Chars
=> New_Internal_Name
('T'));
3687 Set_Is_Internal
(New_E
);
3690 Make_Subtype_Declaration
(Loc
,
3691 Defining_Identifier
=> New_E
,
3692 Subtype_Indication
=>
3693 New_Occurrence_Of
(Etype
(Index
), Loc
));
3695 Insert_Before
(Parent
(Def
), Decl
);
3697 Set_Etype
(Index
, New_E
);
3699 -- If the index is a range the Entity attribute is not
3700 -- available. Example:
3703 -- type T is private;
3705 -- type T is new Natural;
3706 -- Table : array (T(1) .. T(10)) of Boolean;
3709 if Nkind
(Index
) /= N_Range
then
3710 Set_Entity
(Index
, New_E
);
3715 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
3717 Nb_Index
:= Nb_Index
+ 1;
3720 -- Process subtype indication if one is present
3722 if Present
(Subtype_Indication
(Component_Def
)) then
3725 (Subtype_Indication
(Component_Def
), P
, Related_Id
, 'C');
3727 -- Ada 2005 (AI-230): Access Definition case
3729 else pragma Assert
(Present
(Access_Definition
(Component_Def
)));
3730 Element_Type
:= Access_Definition
3731 (Related_Nod
=> Related_Id
,
3732 N
=> Access_Definition
(Component_Def
));
3733 Set_Is_Local_Anonymous_Access
(Element_Type
);
3735 -- Ada 2005 (AI-230): In case of components that are anonymous
3736 -- access types the level of accessibility depends on the enclosing
3739 Set_Scope
(Element_Type
, Current_Scope
); -- Ada 2005 (AI-230)
3741 -- Ada 2005 (AI-254)
3744 CD
: constant Node_Id
:=
3745 Access_To_Subprogram_Definition
3746 (Access_Definition
(Component_Def
));
3748 if Present
(CD
) and then Protected_Present
(CD
) then
3750 Replace_Anonymous_Access_To_Protected_Subprogram
3751 (Def
, Element_Type
);
3756 -- Constrained array case
3759 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
3762 if Nkind
(Def
) = N_Constrained_Array_Definition
then
3764 -- Establish Implicit_Base as unconstrained base type
3766 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
3768 Init_Size_Align
(Implicit_Base
);
3769 Set_Etype
(Implicit_Base
, Implicit_Base
);
3770 Set_Scope
(Implicit_Base
, Current_Scope
);
3771 Set_Has_Delayed_Freeze
(Implicit_Base
);
3773 -- The constrained array type is a subtype of the unconstrained one
3775 Set_Ekind
(T
, E_Array_Subtype
);
3776 Init_Size_Align
(T
);
3777 Set_Etype
(T
, Implicit_Base
);
3778 Set_Scope
(T
, Current_Scope
);
3779 Set_Is_Constrained
(T
, True);
3780 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
3781 Set_Has_Delayed_Freeze
(T
);
3783 -- Complete setup of implicit base type
3785 Set_First_Index
(Implicit_Base
, First_Index
(T
));
3786 Set_Component_Type
(Implicit_Base
, Element_Type
);
3787 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
3788 Set_Component_Size
(Implicit_Base
, Uint_0
);
3789 Set_Has_Controlled_Component
3790 (Implicit_Base
, Has_Controlled_Component
3793 Is_Controlled
(Element_Type
));
3794 Set_Finalize_Storage_Only
3795 (Implicit_Base
, Finalize_Storage_Only
3798 -- Unconstrained array case
3801 Set_Ekind
(T
, E_Array_Type
);
3802 Init_Size_Align
(T
);
3804 Set_Scope
(T
, Current_Scope
);
3805 Set_Component_Size
(T
, Uint_0
);
3806 Set_Is_Constrained
(T
, False);
3807 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
3808 Set_Has_Delayed_Freeze
(T
, True);
3809 Set_Has_Task
(T
, Has_Task
(Element_Type
));
3810 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
3813 Is_Controlled
(Element_Type
));
3814 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
3818 Set_Component_Type
(Base_Type
(T
), Element_Type
);
3820 if Aliased_Present
(Component_Definition
(Def
)) then
3821 Set_Has_Aliased_Components
(Etype
(T
));
3824 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
3825 -- array type to ensure that objects of this type are initialized.
3827 if Ada_Version
>= Ada_05
3828 and then Can_Never_Be_Null
(Element_Type
)
3830 Set_Can_Never_Be_Null
(T
);
3832 if Null_Exclusion_Present
(Component_Definition
(Def
))
3834 -- No need to check itypes because in their case this check
3835 -- was done at their point of creation
3837 and then not Is_Itype
(Element_Type
)
3840 ("null-exclusion cannot be applied to a null excluding type",
3841 Subtype_Indication
(Component_Definition
(Def
)));
3845 Priv
:= Private_Component
(Element_Type
);
3847 if Present
(Priv
) then
3849 -- Check for circular definitions
3851 if Priv
= Any_Type
then
3852 Set_Component_Type
(Etype
(T
), Any_Type
);
3854 -- There is a gap in the visibility of operations on the composite
3855 -- type only if the component type is defined in a different scope.
3857 elsif Scope
(Priv
) = Current_Scope
then
3860 elsif Is_Limited_Type
(Priv
) then
3861 Set_Is_Limited_Composite
(Etype
(T
));
3862 Set_Is_Limited_Composite
(T
);
3864 Set_Is_Private_Composite
(Etype
(T
));
3865 Set_Is_Private_Composite
(T
);
3869 -- Create a concatenation operator for the new type. Internal
3870 -- array types created for packed entities do not need such, they
3871 -- are compatible with the user-defined type.
3873 if Number_Dimensions
(T
) = 1
3874 and then not Is_Packed_Array_Type
(T
)
3876 New_Concatenation_Op
(T
);
3879 -- In the case of an unconstrained array the parser has already
3880 -- verified that all the indices are unconstrained but we still
3881 -- need to make sure that the element type is constrained.
3883 if Is_Indefinite_Subtype
(Element_Type
) then
3885 ("unconstrained element type in array declaration",
3886 Subtype_Indication
(Component_Def
));
3888 elsif Is_Abstract
(Element_Type
) then
3890 ("the type of a component cannot be abstract",
3891 Subtype_Indication
(Component_Def
));
3894 end Array_Type_Declaration
;
3896 ------------------------------------------------------
3897 -- Replace_Anonymous_Access_To_Protected_Subprogram --
3898 ------------------------------------------------------
3900 function Replace_Anonymous_Access_To_Protected_Subprogram
3902 Prev_E
: Entity_Id
) return Entity_Id
3904 Loc
: constant Source_Ptr
:= Sloc
(N
);
3906 Curr_Scope
: constant Scope_Stack_Entry
:=
3907 Scope_Stack
.Table
(Scope_Stack
.Last
);
3909 Anon
: constant Entity_Id
:=
3910 Make_Defining_Identifier
(Loc
,
3911 Chars
=> New_Internal_Name
('S'));
3919 Set_Is_Internal
(Anon
);
3922 when N_Component_Declaration |
3923 N_Unconstrained_Array_Definition |
3924 N_Constrained_Array_Definition
=>
3925 Comp
:= Component_Definition
(N
);
3926 Acc
:= Access_Definition
(Component_Definition
(N
));
3928 when N_Discriminant_Specification
=>
3929 Comp
:= Discriminant_Type
(N
);
3930 Acc
:= Discriminant_Type
(N
);
3932 when N_Parameter_Specification
=>
3933 Comp
:= Parameter_Type
(N
);
3934 Acc
:= Parameter_Type
(N
);
3937 raise Program_Error
;
3940 Decl
:= Make_Full_Type_Declaration
(Loc
,
3941 Defining_Identifier
=> Anon
,
3943 Copy_Separate_Tree
(Access_To_Subprogram_Definition
(Acc
)));
3945 Mark_Rewrite_Insertion
(Decl
);
3947 -- Insert the new declaration in the nearest enclosing scope
3950 while Present
(P
) and then not Has_Declarations
(P
) loop
3954 pragma Assert
(Present
(P
));
3956 if Nkind
(P
) = N_Package_Specification
then
3957 Prepend
(Decl
, Visible_Declarations
(P
));
3959 Prepend
(Decl
, Declarations
(P
));
3962 -- Replace the anonymous type with an occurrence of the new declaration.
3963 -- In all cases the rewritten node does not have the null-exclusion
3964 -- attribute because (if present) it was already inherited by the
3965 -- anonymous entity (Anon). Thus, in case of components we do not
3966 -- inherit this attribute.
3968 if Nkind
(N
) = N_Parameter_Specification
then
3969 Rewrite
(Comp
, New_Occurrence_Of
(Anon
, Loc
));
3970 Set_Etype
(Defining_Identifier
(N
), Anon
);
3971 Set_Null_Exclusion_Present
(N
, False);
3974 Make_Component_Definition
(Loc
,
3975 Subtype_Indication
=> New_Occurrence_Of
(Anon
, Loc
)));
3978 Mark_Rewrite_Insertion
(Comp
);
3980 -- Temporarily remove the current scope from the stack to add the new
3981 -- declarations to the enclosing scope
3983 Scope_Stack
.Decrement_Last
;
3985 Scope_Stack
.Append
(Curr_Scope
);
3987 Set_Original_Access_Type
(Anon
, Prev_E
);
3989 end Replace_Anonymous_Access_To_Protected_Subprogram
;
3991 -------------------------------
3992 -- Build_Derived_Access_Type --
3993 -------------------------------
3995 procedure Build_Derived_Access_Type
3997 Parent_Type
: Entity_Id
;
3998 Derived_Type
: Entity_Id
)
4000 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
4002 Desig_Type
: Entity_Id
;
4004 Discr_Con_Elist
: Elist_Id
;
4005 Discr_Con_El
: Elmt_Id
;
4009 -- Set the designated type so it is available in case this is
4010 -- an access to a self-referential type, e.g. a standard list
4011 -- type with a next pointer. Will be reset after subtype is built.
4013 Set_Directly_Designated_Type
4014 (Derived_Type
, Designated_Type
(Parent_Type
));
4016 Subt
:= Process_Subtype
(S
, N
);
4018 if Nkind
(S
) /= N_Subtype_Indication
4019 and then Subt
/= Base_Type
(Subt
)
4021 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
4024 if Ekind
(Derived_Type
) = E_Access_Subtype
then
4026 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4027 Ibase
: constant Entity_Id
:=
4028 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
4029 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
4030 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
4033 Copy_Node
(Pbase
, Ibase
);
4035 Set_Chars
(Ibase
, Svg_Chars
);
4036 Set_Next_Entity
(Ibase
, Svg_Next_E
);
4037 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
4038 Set_Scope
(Ibase
, Scope
(Derived_Type
));
4039 Set_Freeze_Node
(Ibase
, Empty
);
4040 Set_Is_Frozen
(Ibase
, False);
4041 Set_Comes_From_Source
(Ibase
, False);
4042 Set_Is_First_Subtype
(Ibase
, False);
4044 Set_Etype
(Ibase
, Pbase
);
4045 Set_Etype
(Derived_Type
, Ibase
);
4049 Set_Directly_Designated_Type
4050 (Derived_Type
, Designated_Type
(Subt
));
4052 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
4053 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
4054 Set_Size_Info
(Derived_Type
, Parent_Type
);
4055 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
4056 Set_Depends_On_Private
(Derived_Type
,
4057 Has_Private_Component
(Derived_Type
));
4058 Conditional_Delay
(Derived_Type
, Subt
);
4060 -- Ada 2005 (AI-231). Set the null-exclusion attribute
4062 if Null_Exclusion_Present
(Type_Definition
(N
))
4063 or else Can_Never_Be_Null
(Parent_Type
)
4065 Set_Can_Never_Be_Null
(Derived_Type
);
4068 -- Note: we do not copy the Storage_Size_Variable, since
4069 -- we always go to the root type for this information.
4071 -- Apply range checks to discriminants for derived record case
4072 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
4074 Desig_Type
:= Designated_Type
(Derived_Type
);
4075 if Is_Composite_Type
(Desig_Type
)
4076 and then (not Is_Array_Type
(Desig_Type
))
4077 and then Has_Discriminants
(Desig_Type
)
4078 and then Base_Type
(Desig_Type
) /= Desig_Type
4080 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
4081 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
4083 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
4084 while Present
(Discr_Con_El
) loop
4085 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
4086 Next_Elmt
(Discr_Con_El
);
4087 Next_Discriminant
(Discr
);
4090 end Build_Derived_Access_Type
;
4092 ------------------------------
4093 -- Build_Derived_Array_Type --
4094 ------------------------------
4096 procedure Build_Derived_Array_Type
4098 Parent_Type
: Entity_Id
;
4099 Derived_Type
: Entity_Id
)
4101 Loc
: constant Source_Ptr
:= Sloc
(N
);
4102 Tdef
: constant Node_Id
:= Type_Definition
(N
);
4103 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
4104 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4105 Implicit_Base
: Entity_Id
;
4106 New_Indic
: Node_Id
;
4108 procedure Make_Implicit_Base
;
4109 -- If the parent subtype is constrained, the derived type is a
4110 -- subtype of an implicit base type derived from the parent base.
4112 ------------------------
4113 -- Make_Implicit_Base --
4114 ------------------------
4116 procedure Make_Implicit_Base
is
4119 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
4121 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
4122 Set_Etype
(Implicit_Base
, Parent_Base
);
4124 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
4125 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
4127 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
4128 end Make_Implicit_Base
;
4130 -- Start of processing for Build_Derived_Array_Type
4133 if not Is_Constrained
(Parent_Type
) then
4134 if Nkind
(Indic
) /= N_Subtype_Indication
then
4135 Set_Ekind
(Derived_Type
, E_Array_Type
);
4137 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
4138 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
4140 Set_Has_Delayed_Freeze
(Derived_Type
, True);
4144 Set_Etype
(Derived_Type
, Implicit_Base
);
4147 Make_Subtype_Declaration
(Loc
,
4148 Defining_Identifier
=> Derived_Type
,
4149 Subtype_Indication
=>
4150 Make_Subtype_Indication
(Loc
,
4151 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
4152 Constraint
=> Constraint
(Indic
)));
4154 Rewrite
(N
, New_Indic
);
4159 if Nkind
(Indic
) /= N_Subtype_Indication
then
4162 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
4163 Set_Etype
(Derived_Type
, Implicit_Base
);
4164 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
4167 Error_Msg_N
("illegal constraint on constrained type", Indic
);
4171 -- If parent type is not a derived type itself, and is declared in
4172 -- closed scope (e.g. a subprogram), then we must explicitly introduce
4173 -- the new type's concatenation operator since Derive_Subprograms
4174 -- will not inherit the parent's operator. If the parent type is
4175 -- unconstrained, the operator is of the unconstrained base type.
4177 if Number_Dimensions
(Parent_Type
) = 1
4178 and then not Is_Limited_Type
(Parent_Type
)
4179 and then not Is_Derived_Type
(Parent_Type
)
4180 and then not Is_Package_Or_Generic_Package
4181 (Scope
(Base_Type
(Parent_Type
)))
4183 if not Is_Constrained
(Parent_Type
)
4184 and then Is_Constrained
(Derived_Type
)
4186 New_Concatenation_Op
(Implicit_Base
);
4188 New_Concatenation_Op
(Derived_Type
);
4191 end Build_Derived_Array_Type
;
4193 -----------------------------------
4194 -- Build_Derived_Concurrent_Type --
4195 -----------------------------------
4197 procedure Build_Derived_Concurrent_Type
4199 Parent_Type
: Entity_Id
;
4200 Derived_Type
: Entity_Id
)
4202 D_Constraint
: Node_Id
;
4203 Disc_Spec
: Node_Id
;
4204 Old_Disc
: Entity_Id
;
4205 New_Disc
: Entity_Id
;
4207 Constraint_Present
: constant Boolean :=
4208 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4209 = N_Subtype_Indication
;
4212 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
4214 if Is_Task_Type
(Parent_Type
) then
4215 Set_Storage_Size_Variable
(Derived_Type
,
4216 Storage_Size_Variable
(Parent_Type
));
4219 if Present
(Discriminant_Specifications
(N
)) then
4220 New_Scope
(Derived_Type
);
4221 Check_Or_Process_Discriminants
(N
, Derived_Type
);
4224 elsif Constraint_Present
then
4226 -- Build constrained subtype and derive from it
4229 Loc
: constant Source_Ptr
:= Sloc
(N
);
4230 Anon
: constant Entity_Id
:=
4231 Make_Defining_Identifier
(Loc
,
4232 New_External_Name
(Chars
(Derived_Type
), 'T'));
4237 Make_Subtype_Declaration
(Loc
,
4238 Defining_Identifier
=> Anon
,
4239 Subtype_Indication
=>
4240 Subtype_Indication
(Type_Definition
(N
)));
4241 Insert_Before
(N
, Decl
);
4244 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
4245 New_Occurrence_Of
(Anon
, Loc
));
4246 Set_Analyzed
(Derived_Type
, False);
4252 -- All attributes are inherited from parent. In particular,
4253 -- entries and the corresponding record type are the same.
4254 -- Discriminants may be renamed, and must be treated separately.
4256 Set_Has_Discriminants
4257 (Derived_Type
, Has_Discriminants
(Parent_Type
));
4258 Set_Corresponding_Record_Type
4259 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
4261 if Constraint_Present
then
4262 if not Has_Discriminants
(Parent_Type
) then
4263 Error_Msg_N
("untagged parent must have discriminants", N
);
4265 elsif Present
(Discriminant_Specifications
(N
)) then
4267 -- Verify that new discriminants are used to constrain old ones
4272 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
4274 Old_Disc
:= First_Discriminant
(Parent_Type
);
4275 New_Disc
:= First_Discriminant
(Derived_Type
);
4276 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
4277 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
4278 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
4281 Analyze
(Discriminant_Type
(Disc_Spec
));
4283 if not Subtypes_Statically_Compatible
(
4284 Etype
(Discriminant_Type
(Disc_Spec
)),
4288 ("not statically compatible with parent discriminant",
4289 Discriminant_Type
(Disc_Spec
));
4293 if Nkind
(D_Constraint
) = N_Identifier
4294 and then Chars
(D_Constraint
) /=
4295 Chars
(Defining_Identifier
(Disc_Spec
))
4297 Error_Msg_N
("new discriminants must constrain old ones",
4300 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
4303 Next_Discriminant
(Old_Disc
);
4304 Next_Discriminant
(New_Disc
);
4308 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
4309 Error_Msg_N
("discriminant mismatch in derivation", N
);
4314 elsif Present
(Discriminant_Specifications
(N
)) then
4316 ("missing discriminant constraint in untagged derivation",
4320 if Present
(Discriminant_Specifications
(N
)) then
4321 Old_Disc
:= First_Discriminant
(Parent_Type
);
4322 while Present
(Old_Disc
) loop
4324 if No
(Next_Entity
(Old_Disc
))
4325 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
4327 Set_Next_Entity
(Last_Entity
(Derived_Type
),
4328 Next_Entity
(Old_Disc
));
4332 Next_Discriminant
(Old_Disc
);
4336 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
4337 if Has_Discriminants
(Parent_Type
) then
4338 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4339 Set_Discriminant_Constraint
(
4340 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
4344 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
4346 Set_Has_Completion
(Derived_Type
);
4347 end Build_Derived_Concurrent_Type
;
4349 ------------------------------------
4350 -- Build_Derived_Enumeration_Type --
4351 ------------------------------------
4353 procedure Build_Derived_Enumeration_Type
4355 Parent_Type
: Entity_Id
;
4356 Derived_Type
: Entity_Id
)
4358 Loc
: constant Source_Ptr
:= Sloc
(N
);
4359 Def
: constant Node_Id
:= Type_Definition
(N
);
4360 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
4361 Implicit_Base
: Entity_Id
;
4362 Literal
: Entity_Id
;
4363 New_Lit
: Entity_Id
;
4364 Literals_List
: List_Id
;
4365 Type_Decl
: Node_Id
;
4367 Rang_Expr
: Node_Id
;
4370 -- Since types Standard.Character and Standard.Wide_Character do
4371 -- not have explicit literals lists we need to process types derived
4372 -- from them specially. This is handled by Derived_Standard_Character.
4373 -- If the parent type is a generic type, there are no literals either,
4374 -- and we construct the same skeletal representation as for the generic
4377 if Root_Type
(Parent_Type
) = Standard_Character
4378 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
4379 or else Root_Type
(Parent_Type
) = Standard_Wide_Wide_Character
4381 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
4383 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
4390 Make_Attribute_Reference
(Loc
,
4391 Attribute_Name
=> Name_First
,
4392 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4393 Set_Etype
(Lo
, Derived_Type
);
4396 Make_Attribute_Reference
(Loc
,
4397 Attribute_Name
=> Name_Last
,
4398 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
4399 Set_Etype
(Hi
, Derived_Type
);
4401 Set_Scalar_Range
(Derived_Type
,
4408 -- If a constraint is present, analyze the bounds to catch
4409 -- premature usage of the derived literals.
4411 if Nkind
(Indic
) = N_Subtype_Indication
4412 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
4414 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
4415 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
4418 -- Introduce an implicit base type for the derived type even
4419 -- if there is no constraint attached to it, since this seems
4420 -- closer to the Ada semantics. Build a full type declaration
4421 -- tree for the derived type using the implicit base type as
4422 -- the defining identifier. The build a subtype declaration
4423 -- tree which applies the constraint (if any) have it replace
4424 -- the derived type declaration.
4426 Literal
:= First_Literal
(Parent_Type
);
4427 Literals_List
:= New_List
;
4428 while Present
(Literal
)
4429 and then Ekind
(Literal
) = E_Enumeration_Literal
4431 -- Literals of the derived type have the same representation as
4432 -- those of the parent type, but this representation can be
4433 -- overridden by an explicit representation clause. Indicate
4434 -- that there is no explicit representation given yet. These
4435 -- derived literals are implicit operations of the new type,
4436 -- and can be overridden by explicit ones.
4438 if Nkind
(Literal
) = N_Defining_Character_Literal
then
4440 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
4442 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
4445 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
4446 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
4447 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
4448 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
4449 Set_Alias
(New_Lit
, Literal
);
4450 Set_Is_Known_Valid
(New_Lit
, True);
4452 Append
(New_Lit
, Literals_List
);
4453 Next_Literal
(Literal
);
4457 Make_Defining_Identifier
(Sloc
(Derived_Type
),
4458 New_External_Name
(Chars
(Derived_Type
), 'B'));
4460 -- Indicate the proper nature of the derived type. This must
4461 -- be done before analysis of the literals, to recognize cases
4462 -- when a literal may be hidden by a previous explicit function
4463 -- definition (cf. c83031a).
4465 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
4466 Set_Etype
(Derived_Type
, Implicit_Base
);
4469 Make_Full_Type_Declaration
(Loc
,
4470 Defining_Identifier
=> Implicit_Base
,
4471 Discriminant_Specifications
=> No_List
,
4473 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
4475 Mark_Rewrite_Insertion
(Type_Decl
);
4476 Insert_Before
(N
, Type_Decl
);
4477 Analyze
(Type_Decl
);
4479 -- After the implicit base is analyzed its Etype needs to be changed
4480 -- to reflect the fact that it is derived from the parent type which
4481 -- was ignored during analysis. We also set the size at this point.
4483 Set_Etype
(Implicit_Base
, Parent_Type
);
4485 Set_Size_Info
(Implicit_Base
, Parent_Type
);
4486 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
4487 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
4489 Set_Has_Non_Standard_Rep
4490 (Implicit_Base
, Has_Non_Standard_Rep
4492 Set_Has_Delayed_Freeze
(Implicit_Base
);
4494 -- Process the subtype indication including a validation check
4495 -- on the constraint, if any. If a constraint is given, its bounds
4496 -- must be implicitly converted to the new type.
4498 if Nkind
(Indic
) = N_Subtype_Indication
then
4500 R
: constant Node_Id
:=
4501 Range_Expression
(Constraint
(Indic
));
4504 if Nkind
(R
) = N_Range
then
4505 Hi
:= Build_Scalar_Bound
4506 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
4507 Lo
:= Build_Scalar_Bound
4508 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
4511 -- Constraint is a Range attribute. Replace with the
4512 -- explicit mention of the bounds of the prefix, which must
4515 Analyze
(Prefix
(R
));
4517 Convert_To
(Implicit_Base
,
4518 Make_Attribute_Reference
(Loc
,
4519 Attribute_Name
=> Name_Last
,
4521 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4524 Convert_To
(Implicit_Base
,
4525 Make_Attribute_Reference
(Loc
,
4526 Attribute_Name
=> Name_First
,
4528 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
4535 (Type_High_Bound
(Parent_Type
),
4536 Parent_Type
, Implicit_Base
);
4539 (Type_Low_Bound
(Parent_Type
),
4540 Parent_Type
, Implicit_Base
);
4548 -- If we constructed a default range for the case where no range
4549 -- was given, then the expressions in the range must not freeze
4550 -- since they do not correspond to expressions in the source.
4552 if Nkind
(Indic
) /= N_Subtype_Indication
then
4553 Set_Must_Not_Freeze
(Lo
);
4554 Set_Must_Not_Freeze
(Hi
);
4555 Set_Must_Not_Freeze
(Rang_Expr
);
4559 Make_Subtype_Declaration
(Loc
,
4560 Defining_Identifier
=> Derived_Type
,
4561 Subtype_Indication
=>
4562 Make_Subtype_Indication
(Loc
,
4563 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
4565 Make_Range_Constraint
(Loc
,
4566 Range_Expression
=> Rang_Expr
))));
4570 -- If pragma Discard_Names applies on the first subtype of the
4571 -- parent type, then it must be applied on this subtype as well.
4573 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
4574 Set_Discard_Names
(Derived_Type
);
4577 -- Apply a range check. Since this range expression doesn't have an
4578 -- Etype, we have to specifically pass the Source_Typ parameter. Is
4581 if Nkind
(Indic
) = N_Subtype_Indication
then
4582 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
4584 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
4587 end Build_Derived_Enumeration_Type
;
4589 --------------------------------
4590 -- Build_Derived_Numeric_Type --
4591 --------------------------------
4593 procedure Build_Derived_Numeric_Type
4595 Parent_Type
: Entity_Id
;
4596 Derived_Type
: Entity_Id
)
4598 Loc
: constant Source_Ptr
:= Sloc
(N
);
4599 Tdef
: constant Node_Id
:= Type_Definition
(N
);
4600 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
4601 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
4602 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
4603 N_Subtype_Indication
;
4604 Implicit_Base
: Entity_Id
;
4610 -- Process the subtype indication including a validation check on
4611 -- the constraint if any.
4613 Discard_Node
(Process_Subtype
(Indic
, N
));
4615 -- Introduce an implicit base type for the derived type even if there
4616 -- is no constraint attached to it, since this seems closer to the Ada
4620 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
4622 Set_Etype
(Implicit_Base
, Parent_Base
);
4623 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
4624 Set_Size_Info
(Implicit_Base
, Parent_Base
);
4625 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4626 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
4627 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
4629 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
4630 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
4633 Set_Has_Delayed_Freeze
(Implicit_Base
);
4635 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
4636 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
4638 Set_Scalar_Range
(Implicit_Base
,
4643 if Has_Infinities
(Parent_Base
) then
4644 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
4647 -- The Derived_Type, which is the entity of the declaration, is a
4648 -- subtype of the implicit base. Its Ekind is a subtype, even in the
4649 -- absence of an explicit constraint.
4651 Set_Etype
(Derived_Type
, Implicit_Base
);
4653 -- If we did not have a constraint, then the Ekind is set from the
4654 -- parent type (otherwise Process_Subtype has set the bounds)
4656 if No_Constraint
then
4657 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
4660 -- If we did not have a range constraint, then set the range from the
4661 -- parent type. Otherwise, the call to Process_Subtype has set the
4665 or else not Has_Range_Constraint
(Indic
)
4667 Set_Scalar_Range
(Derived_Type
,
4669 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
4670 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
4671 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
4673 if Has_Infinities
(Parent_Type
) then
4674 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
4678 -- Set remaining type-specific fields, depending on numeric type
4680 if Is_Modular_Integer_Type
(Parent_Type
) then
4681 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
4683 Set_Non_Binary_Modulus
4684 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
4686 elsif Is_Floating_Point_Type
(Parent_Type
) then
4688 -- Digits of base type is always copied from the digits value of
4689 -- the parent base type, but the digits of the derived type will
4690 -- already have been set if there was a constraint present.
4692 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4693 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
4695 if No_Constraint
then
4696 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
4699 elsif Is_Fixed_Point_Type
(Parent_Type
) then
4701 -- Small of base type and derived type are always copied from the
4702 -- parent base type, since smalls never change. The delta of the
4703 -- base type is also copied from the parent base type. However the
4704 -- delta of the derived type will have been set already if a
4705 -- constraint was present.
4707 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
4708 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
4709 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
4711 if No_Constraint
then
4712 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
4715 -- The scale and machine radix in the decimal case are always
4716 -- copied from the parent base type.
4718 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
4719 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
4720 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
4722 Set_Machine_Radix_10
4723 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
4724 Set_Machine_Radix_10
4725 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
4727 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
4729 if No_Constraint
then
4730 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
4733 -- the analysis of the subtype_indication sets the
4734 -- digits value of the derived type.
4741 -- The type of the bounds is that of the parent type, and they
4742 -- must be converted to the derived type.
4744 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
4746 -- The implicit_base should be frozen when the derived type is frozen,
4747 -- but note that it is used in the conversions of the bounds. For fixed
4748 -- types we delay the determination of the bounds until the proper
4749 -- freezing point. For other numeric types this is rejected by GCC, for
4750 -- reasons that are currently unclear (???), so we choose to freeze the
4751 -- implicit base now. In the case of integers and floating point types
4752 -- this is harmless because subsequent representation clauses cannot
4753 -- affect anything, but it is still baffling that we cannot use the
4754 -- same mechanism for all derived numeric types.
4756 -- There is a further complication: actually *some* representation
4757 -- clauses can affect the implicit base type. Namely, attribute
4758 -- definition clauses for stream-oriented attributes need to set the
4759 -- corresponding TSS entries on the base type, and this normally cannot
4760 -- be done after the base type is frozen, so the circuitry in
4761 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility and
4762 -- not use Set_TSS in this case.
4764 if Is_Fixed_Point_Type
(Parent_Type
) then
4765 Conditional_Delay
(Implicit_Base
, Parent_Type
);
4767 Freeze_Before
(N
, Implicit_Base
);
4769 end Build_Derived_Numeric_Type
;
4771 --------------------------------
4772 -- Build_Derived_Private_Type --
4773 --------------------------------
4775 procedure Build_Derived_Private_Type
4777 Parent_Type
: Entity_Id
;
4778 Derived_Type
: Entity_Id
;
4779 Is_Completion
: Boolean;
4780 Derive_Subps
: Boolean := True)
4782 Der_Base
: Entity_Id
;
4784 Full_Decl
: Node_Id
:= Empty
;
4785 Full_Der
: Entity_Id
;
4787 Last_Discr
: Entity_Id
;
4788 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
4789 Swapped
: Boolean := False;
4791 procedure Copy_And_Build
;
4792 -- Copy derived type declaration, replace parent with its full view,
4793 -- and analyze new declaration.
4795 --------------------
4796 -- Copy_And_Build --
4797 --------------------
4799 procedure Copy_And_Build
is
4803 if Ekind
(Parent_Type
) in Record_Kind
4805 (Ekind
(Parent_Type
) in Enumeration_Kind
4806 and then Root_Type
(Parent_Type
) /= Standard_Character
4807 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
4808 and then Root_Type
(Parent_Type
) /= Standard_Wide_Wide_Character
4809 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
4811 Full_N
:= New_Copy_Tree
(N
);
4812 Insert_After
(N
, Full_N
);
4813 Build_Derived_Type
(
4814 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4817 Build_Derived_Type
(
4818 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
4822 -- Start of processing for Build_Derived_Private_Type
4825 if Is_Tagged_Type
(Parent_Type
) then
4826 Build_Derived_Record_Type
4827 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4830 elsif Has_Discriminants
(Parent_Type
) then
4831 if Present
(Full_View
(Parent_Type
)) then
4832 if not Is_Completion
then
4834 -- Copy declaration for subsequent analysis, to provide a
4835 -- completion for what is a private declaration. Indicate that
4836 -- the full type is internally generated.
4838 Full_Decl
:= New_Copy_Tree
(N
);
4839 Full_Der
:= New_Copy
(Derived_Type
);
4840 Set_Comes_From_Source
(Full_Decl
, False);
4841 Set_Comes_From_Source
(Full_Der
, False);
4843 Insert_After
(N
, Full_Decl
);
4846 -- If this is a completion, the full view being built is
4847 -- itself private. We build a subtype of the parent with
4848 -- the same constraints as this full view, to convey to the
4849 -- back end the constrained components and the size of this
4850 -- subtype. If the parent is constrained, its full view can
4851 -- serve as the underlying full view of the derived type.
4853 if No
(Discriminant_Specifications
(N
)) then
4854 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
4855 N_Subtype_Indication
4857 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
4859 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
4860 Set_Underlying_Full_View
(Derived_Type
,
4861 Full_View
(Parent_Type
));
4865 -- If there are new discriminants, the parent subtype is
4866 -- constrained by them, but it is not clear how to build
4867 -- the underlying_full_view in this case ???
4874 -- Build partial view of derived type from partial view of parent
4876 Build_Derived_Record_Type
4877 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
4879 if Present
(Full_View
(Parent_Type
))
4880 and then not Is_Completion
4882 if not In_Open_Scopes
(Par_Scope
)
4883 or else not In_Same_Source_Unit
(N
, Parent_Type
)
4885 -- Swap partial and full views temporarily
4887 Install_Private_Declarations
(Par_Scope
);
4888 Install_Visible_Declarations
(Par_Scope
);
4892 -- Build full view of derived type from full view of parent which
4893 -- is now installed. Subprograms have been derived on the partial
4894 -- view, the completion does not derive them anew.
4896 if not Is_Tagged_Type
(Parent_Type
) then
4898 -- If the parent is itself derived from another private type,
4899 -- installing the private declarations has not affected its
4900 -- privacy status, so use its own full view explicitly.
4902 if Is_Private_Type
(Parent_Type
) then
4903 Build_Derived_Record_Type
4904 (Full_Decl
, Full_View
(Parent_Type
), Full_Der
, False);
4906 Build_Derived_Record_Type
4907 (Full_Decl
, Parent_Type
, Full_Der
, False);
4911 -- If full view of parent is tagged, the completion
4912 -- inherits the proper primitive operations.
4914 Set_Defining_Identifier
(Full_Decl
, Full_Der
);
4915 Build_Derived_Record_Type
4916 (Full_Decl
, Parent_Type
, Full_Der
, Derive_Subps
);
4917 Set_Analyzed
(Full_Decl
);
4921 Uninstall_Declarations
(Par_Scope
);
4923 if In_Open_Scopes
(Par_Scope
) then
4924 Install_Visible_Declarations
(Par_Scope
);
4928 Der_Base
:= Base_Type
(Derived_Type
);
4929 Set_Full_View
(Derived_Type
, Full_Der
);
4930 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
4932 -- Copy the discriminant list from full view to the partial views
4933 -- (base type and its subtype). Gigi requires that the partial
4934 -- and full views have the same discriminants.
4936 -- Note that since the partial view is pointing to discriminants
4937 -- in the full view, their scope will be that of the full view.
4938 -- This might cause some front end problems and need
4941 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
4942 Set_First_Entity
(Der_Base
, Discr
);
4945 Last_Discr
:= Discr
;
4946 Next_Discriminant
(Discr
);
4947 exit when No
(Discr
);
4950 Set_Last_Entity
(Der_Base
, Last_Discr
);
4952 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
4953 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
4954 Set_Stored_Constraint
(Full_Der
, Stored_Constraint
(Derived_Type
));
4957 -- If this is a completion, the derived type stays private
4958 -- and there is no need to create a further full view, except
4959 -- in the unusual case when the derivation is nested within a
4960 -- child unit, see below.
4965 elsif Present
(Full_View
(Parent_Type
))
4966 and then Has_Discriminants
(Full_View
(Parent_Type
))
4968 if Has_Unknown_Discriminants
(Parent_Type
)
4969 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
4970 = N_Subtype_Indication
4973 ("cannot constrain type with unknown discriminants",
4974 Subtype_Indication
(Type_Definition
(N
)));
4978 -- If full view of parent is a record type, Build full view as
4979 -- a derivation from the parent's full view. Partial view remains
4980 -- private. For code generation and linking, the full view must
4981 -- have the same public status as the partial one. This full view
4982 -- is only needed if the parent type is in an enclosing scope, so
4983 -- that the full view may actually become visible, e.g. in a child
4984 -- unit. This is both more efficient, and avoids order of freezing
4985 -- problems with the added entities.
4987 if not Is_Private_Type
(Full_View
(Parent_Type
))
4988 and then (In_Open_Scopes
(Scope
(Parent_Type
)))
4990 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
4991 Chars
(Derived_Type
));
4992 Set_Is_Itype
(Full_Der
);
4993 Set_Has_Private_Declaration
(Full_Der
);
4994 Set_Has_Private_Declaration
(Derived_Type
);
4995 Set_Associated_Node_For_Itype
(Full_Der
, N
);
4996 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
4997 Set_Full_View
(Derived_Type
, Full_Der
);
4998 Set_Is_Public
(Full_Der
, Is_Public
(Derived_Type
));
4999 Full_P
:= Full_View
(Parent_Type
);
5000 Exchange_Declarations
(Parent_Type
);
5002 Exchange_Declarations
(Full_P
);
5005 Build_Derived_Record_Type
5006 (N
, Full_View
(Parent_Type
), Derived_Type
,
5007 Derive_Subps
=> False);
5010 -- In any case, the primitive operations are inherited from
5011 -- the parent type, not from the internal full view.
5013 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
5015 if Derive_Subps
then
5016 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5020 -- Untagged type, No discriminants on either view
5022 if Nkind
(Subtype_Indication
(Type_Definition
(N
))) =
5023 N_Subtype_Indication
5026 ("illegal constraint on type without discriminants", N
);
5029 if Present
(Discriminant_Specifications
(N
))
5030 and then Present
(Full_View
(Parent_Type
))
5031 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
5034 ("cannot add discriminants to untagged type", N
);
5037 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
5038 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
5039 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
5040 Set_Has_Controlled_Component
5041 (Derived_Type
, Has_Controlled_Component
5044 -- Direct controlled types do not inherit Finalize_Storage_Only flag
5046 if not Is_Controlled
(Parent_Type
) then
5047 Set_Finalize_Storage_Only
5048 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
5051 -- Construct the implicit full view by deriving from full view of
5052 -- the parent type. In order to get proper visibility, we install
5053 -- the parent scope and its declarations.
5055 -- ??? if the parent is untagged private and its completion is
5056 -- tagged, this mechanism will not work because we cannot derive
5057 -- from the tagged full view unless we have an extension
5059 if Present
(Full_View
(Parent_Type
))
5060 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
5061 and then not Is_Completion
5064 Make_Defining_Identifier
(Sloc
(Derived_Type
),
5065 Chars
=> Chars
(Derived_Type
));
5066 Set_Is_Itype
(Full_Der
);
5067 Set_Has_Private_Declaration
(Full_Der
);
5068 Set_Has_Private_Declaration
(Derived_Type
);
5069 Set_Associated_Node_For_Itype
(Full_Der
, N
);
5070 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
5071 Set_Full_View
(Derived_Type
, Full_Der
);
5073 if not In_Open_Scopes
(Par_Scope
) then
5074 Install_Private_Declarations
(Par_Scope
);
5075 Install_Visible_Declarations
(Par_Scope
);
5077 Uninstall_Declarations
(Par_Scope
);
5079 -- If parent scope is open and in another unit, and parent has a
5080 -- completion, then the derivation is taking place in the visible
5081 -- part of a child unit. In that case retrieve the full view of
5082 -- the parent momentarily.
5084 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
5085 Full_P
:= Full_View
(Parent_Type
);
5086 Exchange_Declarations
(Parent_Type
);
5088 Exchange_Declarations
(Full_P
);
5090 -- Otherwise it is a local derivation
5096 Set_Scope
(Full_Der
, Current_Scope
);
5097 Set_Is_First_Subtype
(Full_Der
,
5098 Is_First_Subtype
(Derived_Type
));
5099 Set_Has_Size_Clause
(Full_Der
, False);
5100 Set_Has_Alignment_Clause
(Full_Der
, False);
5101 Set_Next_Entity
(Full_Der
, Empty
);
5102 Set_Has_Delayed_Freeze
(Full_Der
);
5103 Set_Is_Frozen
(Full_Der
, False);
5104 Set_Freeze_Node
(Full_Der
, Empty
);
5105 Set_Depends_On_Private
(Full_Der
,
5106 Has_Private_Component
(Full_Der
));
5107 Set_Public_Status
(Full_Der
);
5111 Set_Has_Unknown_Discriminants
(Derived_Type
,
5112 Has_Unknown_Discriminants
(Parent_Type
));
5114 if Is_Private_Type
(Derived_Type
) then
5115 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
5118 if Is_Private_Type
(Parent_Type
)
5119 and then Base_Type
(Parent_Type
) = Parent_Type
5120 and then In_Open_Scopes
(Scope
(Parent_Type
))
5122 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
5124 if Is_Child_Unit
(Scope
(Current_Scope
))
5125 and then Is_Completion
5126 and then In_Private_Part
(Current_Scope
)
5127 and then Scope
(Parent_Type
) /= Current_Scope
5129 -- This is the unusual case where a type completed by a private
5130 -- derivation occurs within a package nested in a child unit,
5131 -- and the parent is declared in an ancestor. In this case, the
5132 -- full view of the parent type will become visible in the body
5133 -- of the enclosing child, and only then will the current type
5134 -- be possibly non-private. We build a underlying full view that
5135 -- will be installed when the enclosing child body is compiled.
5138 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
5142 Make_Defining_Identifier
(Sloc
(Derived_Type
),
5143 Chars
(Derived_Type
));
5144 Set_Is_Itype
(Full_Der
);
5145 Set_Itype
(IR
, Full_Der
);
5146 Insert_After
(N
, IR
);
5148 -- The full view will be used to swap entities on entry/exit
5149 -- to the body, and must appear in the entity list for the
5152 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
5153 Set_Has_Private_Declaration
(Full_Der
);
5154 Set_Has_Private_Declaration
(Derived_Type
);
5155 Set_Associated_Node_For_Itype
(Full_Der
, N
);
5156 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
5157 Full_P
:= Full_View
(Parent_Type
);
5158 Exchange_Declarations
(Parent_Type
);
5160 Exchange_Declarations
(Full_P
);
5161 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
5165 end Build_Derived_Private_Type
;
5167 -------------------------------
5168 -- Build_Derived_Record_Type --
5169 -------------------------------
5173 -- Ideally we would like to use the same model of type derivation for
5174 -- tagged and untagged record types. Unfortunately this is not quite
5175 -- possible because the semantics of representation clauses is different
5176 -- for tagged and untagged records under inheritance. Consider the
5179 -- type R (...) is [tagged] record ... end record;
5180 -- type T (...) is new R (...) [with ...];
5182 -- The representation clauses of T can specify a completely different
5183 -- record layout from R's. Hence the same component can be placed in
5184 -- two very different positions in objects of type T and R. If R and T
5185 -- are tagged types, representation clauses for T can only specify the
5186 -- layout of non inherited components, thus components that are common
5187 -- in R and T have the same position in objects of type R and T.
5189 -- This has two implications. The first is that the entire tree for R's
5190 -- declaration needs to be copied for T in the untagged case, so that T
5191 -- can be viewed as a record type of its own with its own representation
5192 -- clauses. The second implication is the way we handle discriminants.
5193 -- Specifically, in the untagged case we need a way to communicate to Gigi
5194 -- what are the real discriminants in the record, while for the semantics
5195 -- we need to consider those introduced by the user to rename the
5196 -- discriminants in the parent type. This is handled by introducing the
5197 -- notion of stored discriminants. See below for more.
5199 -- Fortunately the way regular components are inherited can be handled in
5200 -- the same way in tagged and untagged types.
5202 -- To complicate things a bit more the private view of a private extension
5203 -- cannot be handled in the same way as the full view (for one thing the
5204 -- semantic rules are somewhat different). We will explain what differs
5207 -- 2. DISCRIMINANTS UNDER INHERITANCE
5209 -- The semantic rules governing the discriminants of derived types are
5212 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
5213 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
5215 -- If parent type has discriminants, then the discriminants that are
5216 -- declared in the derived type are [3.4 (11)]:
5218 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
5221 -- o Otherwise, each discriminant of the parent type (implicitly declared
5222 -- in the same order with the same specifications). In this case, the
5223 -- discriminants are said to be "inherited", or if unknown in the parent
5224 -- are also unknown in the derived type.
5226 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
5228 -- o The parent subtype shall be constrained;
5230 -- o If the parent type is not a tagged type, then each discriminant of
5231 -- the derived type shall be used in the constraint defining a parent
5232 -- subtype. [Implementation note: This ensures that the new discriminant
5233 -- can share storage with an existing discriminant.]
5235 -- For the derived type each discriminant of the parent type is either
5236 -- inherited, constrained to equal some new discriminant of the derived
5237 -- type, or constrained to the value of an expression.
5239 -- When inherited or constrained to equal some new discriminant, the
5240 -- parent discriminant and the discriminant of the derived type are said
5243 -- If a discriminant of the parent type is constrained to a specific value
5244 -- in the derived type definition, then the discriminant is said to be
5245 -- "specified" by that derived type definition.
5247 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
5249 -- We have spoken about stored discriminants in point 1 (introduction)
5250 -- above. There are two sort of stored discriminants: implicit and
5251 -- explicit. As long as the derived type inherits the same discriminants as
5252 -- the root record type, stored discriminants are the same as regular
5253 -- discriminants, and are said to be implicit. However, if any discriminant
5254 -- in the root type was renamed in the derived type, then the derived
5255 -- type will contain explicit stored discriminants. Explicit stored
5256 -- discriminants are discriminants in addition to the semantically visible
5257 -- discriminants defined for the derived type. Stored discriminants are
5258 -- used by Gigi to figure out what are the physical discriminants in
5259 -- objects of the derived type (see precise definition in einfo.ads).
5260 -- As an example, consider the following:
5262 -- type R (D1, D2, D3 : Int) is record ... end record;
5263 -- type T1 is new R;
5264 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
5265 -- type T3 is new T2;
5266 -- type T4 (Y : Int) is new T3 (Y, 99);
5268 -- The following table summarizes the discriminants and stored
5269 -- discriminants in R and T1 through T4.
5271 -- Type Discrim Stored Discrim Comment
5272 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
5273 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
5274 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
5275 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
5276 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
5278 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
5279 -- find the corresponding discriminant in the parent type, while
5280 -- Original_Record_Component (abbreviated ORC below), the actual physical
5281 -- component that is renamed. Finally the field Is_Completely_Hidden
5282 -- (abbreviated ICH below) is set for all explicit stored discriminants
5283 -- (see einfo.ads for more info). For the above example this gives:
5285 -- Discrim CD ORC ICH
5286 -- ^^^^^^^ ^^ ^^^ ^^^
5287 -- D1 in R empty itself no
5288 -- D2 in R empty itself no
5289 -- D3 in R empty itself no
5291 -- D1 in T1 D1 in R itself no
5292 -- D2 in T1 D2 in R itself no
5293 -- D3 in T1 D3 in R itself no
5295 -- X1 in T2 D3 in T1 D3 in T2 no
5296 -- X2 in T2 D1 in T1 D1 in T2 no
5297 -- D1 in T2 empty itself yes
5298 -- D2 in T2 empty itself yes
5299 -- D3 in T2 empty itself yes
5301 -- X1 in T3 X1 in T2 D3 in T3 no
5302 -- X2 in T3 X2 in T2 D1 in T3 no
5303 -- D1 in T3 empty itself yes
5304 -- D2 in T3 empty itself yes
5305 -- D3 in T3 empty itself yes
5307 -- Y in T4 X1 in T3 D3 in T3 no
5308 -- D1 in T3 empty itself yes
5309 -- D2 in T3 empty itself yes
5310 -- D3 in T3 empty itself yes
5312 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
5314 -- Type derivation for tagged types is fairly straightforward. If no
5315 -- discriminants are specified by the derived type, these are inherited
5316 -- from the parent. No explicit stored discriminants are ever necessary.
5317 -- The only manipulation that is done to the tree is that of adding a
5318 -- _parent field with parent type and constrained to the same constraint
5319 -- specified for the parent in the derived type definition. For instance:
5321 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
5322 -- type T1 is new R with null record;
5323 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
5325 -- are changed into:
5327 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
5328 -- _parent : R (D1, D2, D3);
5331 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
5332 -- _parent : T1 (X2, 88, X1);
5335 -- The discriminants actually present in R, T1 and T2 as well as their CD,
5336 -- ORC and ICH fields are:
5338 -- Discrim CD ORC ICH
5339 -- ^^^^^^^ ^^ ^^^ ^^^
5340 -- D1 in R empty itself no
5341 -- D2 in R empty itself no
5342 -- D3 in R empty itself no
5344 -- D1 in T1 D1 in R D1 in R no
5345 -- D2 in T1 D2 in R D2 in R no
5346 -- D3 in T1 D3 in R D3 in R no
5348 -- X1 in T2 D3 in T1 D3 in R no
5349 -- X2 in T2 D1 in T1 D1 in R no
5351 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
5353 -- Regardless of whether we dealing with a tagged or untagged type
5354 -- we will transform all derived type declarations of the form
5356 -- type T is new R (...) [with ...];
5358 -- subtype S is R (...);
5359 -- type T is new S [with ...];
5361 -- type BT is new R [with ...];
5362 -- subtype T is BT (...);
5364 -- That is, the base derived type is constrained only if it has no
5365 -- discriminants. The reason for doing this is that GNAT's semantic model
5366 -- assumes that a base type with discriminants is unconstrained.
5368 -- Note that, strictly speaking, the above transformation is not always
5369 -- correct. Consider for instance the following excerpt from ACVC b34011a:
5371 -- procedure B34011A is
5372 -- type REC (D : integer := 0) is record
5377 -- type T6 is new Rec;
5378 -- function F return T6;
5383 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
5386 -- The definition of Q6.U is illegal. However transforming Q6.U into
5388 -- type BaseU is new T6;
5389 -- subtype U is BaseU (Q6.F.I)
5391 -- turns U into a legal subtype, which is incorrect. To avoid this problem
5392 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
5393 -- the transformation described above.
5395 -- There is another instance where the above transformation is incorrect.
5399 -- type Base (D : Integer) is tagged null record;
5400 -- procedure P (X : Base);
5402 -- type Der is new Base (2) with null record;
5403 -- procedure P (X : Der);
5406 -- Then the above transformation turns this into
5408 -- type Der_Base is new Base with null record;
5409 -- -- procedure P (X : Base) is implicitly inherited here
5410 -- -- as procedure P (X : Der_Base).
5412 -- subtype Der is Der_Base (2);
5413 -- procedure P (X : Der);
5414 -- -- The overriding of P (X : Der_Base) is illegal since we
5415 -- -- have a parameter conformance problem.
5417 -- To get around this problem, after having semantically processed Der_Base
5418 -- and the rewritten subtype declaration for Der, we copy Der_Base field
5419 -- Discriminant_Constraint from Der so that when parameter conformance is
5420 -- checked when P is overridden, no semantic errors are flagged.
5422 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
5424 -- Regardless of whether we are dealing with a tagged or untagged type
5425 -- we will transform all derived type declarations of the form
5427 -- type R (D1, .., Dn : ...) is [tagged] record ...;
5428 -- type T is new R [with ...];
5430 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
5432 -- The reason for such transformation is that it allows us to implement a
5433 -- very clean form of component inheritance as explained below.
5435 -- Note that this transformation is not achieved by direct tree rewriting
5436 -- and manipulation, but rather by redoing the semantic actions that the
5437 -- above transformation will entail. This is done directly in routine
5438 -- Inherit_Components.
5440 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
5442 -- In both tagged and untagged derived types, regular non discriminant
5443 -- components are inherited in the derived type from the parent type. In
5444 -- the absence of discriminants component, inheritance is straightforward
5445 -- as components can simply be copied from the parent.
5447 -- If the parent has discriminants, inheriting components constrained with
5448 -- these discriminants requires caution. Consider the following example:
5450 -- type R (D1, D2 : Positive) is [tagged] record
5451 -- S : String (D1 .. D2);
5454 -- type T1 is new R [with null record];
5455 -- type T2 (X : positive) is new R (1, X) [with null record];
5457 -- As explained in 6. above, T1 is rewritten as
5458 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
5459 -- which makes the treatment for T1 and T2 identical.
5461 -- What we want when inheriting S, is that references to D1 and D2 in R are
5462 -- replaced with references to their correct constraints, ie D1 and D2 in
5463 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
5464 -- with either discriminant references in the derived type or expressions.
5465 -- This replacement is achieved as follows: before inheriting R's
5466 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
5467 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
5468 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
5469 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
5470 -- by String (1 .. X).
5472 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
5474 -- We explain here the rules governing private type extensions relevant to
5475 -- type derivation. These rules are explained on the following example:
5477 -- type D [(...)] is new A [(...)] with private; <-- partial view
5478 -- type D [(...)] is new P [(...)] with null record; <-- full view
5480 -- Type A is called the ancestor subtype of the private extension.
5481 -- Type P is the parent type of the full view of the private extension. It
5482 -- must be A or a type derived from A.
5484 -- The rules concerning the discriminants of private type extensions are
5487 -- o If a private extension inherits known discriminants from the ancestor
5488 -- subtype, then the full view shall also inherit its discriminants from
5489 -- the ancestor subtype and the parent subtype of the full view shall be
5490 -- constrained if and only if the ancestor subtype is constrained.
5492 -- o If a partial view has unknown discriminants, then the full view may
5493 -- define a definite or an indefinite subtype, with or without
5496 -- o If a partial view has neither known nor unknown discriminants, then
5497 -- the full view shall define a definite subtype.
5499 -- o If the ancestor subtype of a private extension has constrained
5500 -- discriminants, then the parent subtype of the full view shall impose a
5501 -- statically matching constraint on those discriminants.
5503 -- This means that only the following forms of private extensions are
5506 -- type D is new A with private; <-- partial view
5507 -- type D is new P with null record; <-- full view
5509 -- If A has no discriminants than P has no discriminants, otherwise P must
5510 -- inherit A's discriminants.
5512 -- type D is new A (...) with private; <-- partial view
5513 -- type D is new P (:::) with null record; <-- full view
5515 -- P must inherit A's discriminants and (...) and (:::) must statically
5518 -- subtype A is R (...);
5519 -- type D is new A with private; <-- partial view
5520 -- type D is new P with null record; <-- full view
5522 -- P must have inherited R's discriminants and must be derived from A or
5523 -- any of its subtypes.
5525 -- type D (..) is new A with private; <-- partial view
5526 -- type D (..) is new P [(:::)] with null record; <-- full view
5528 -- No specific constraints on P's discriminants or constraint (:::).
5529 -- Note that A can be unconstrained, but the parent subtype P must either
5530 -- be constrained or (:::) must be present.
5532 -- type D (..) is new A [(...)] with private; <-- partial view
5533 -- type D (..) is new P [(:::)] with null record; <-- full view
5535 -- P's constraints on A's discriminants must statically match those
5536 -- imposed by (...).
5538 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
5540 -- The full view of a private extension is handled exactly as described
5541 -- above. The model chose for the private view of a private extension is
5542 -- the same for what concerns discriminants (ie they receive the same
5543 -- treatment as in the tagged case). However, the private view of the
5544 -- private extension always inherits the components of the parent base,
5545 -- without replacing any discriminant reference. Strictly speaking this is
5546 -- incorrect. However, Gigi never uses this view to generate code so this
5547 -- is a purely semantic issue. In theory, a set of transformations similar
5548 -- to those given in 5. and 6. above could be applied to private views of
5549 -- private extensions to have the same model of component inheritance as
5550 -- for non private extensions. However, this is not done because it would
5551 -- further complicate private type processing. Semantically speaking, this
5552 -- leaves us in an uncomfortable situation. As an example consider:
5555 -- type R (D : integer) is tagged record
5556 -- S : String (1 .. D);
5558 -- procedure P (X : R);
5559 -- type T is new R (1) with private;
5561 -- type T is new R (1) with null record;
5564 -- This is transformed into:
5567 -- type R (D : integer) is tagged record
5568 -- S : String (1 .. D);
5570 -- procedure P (X : R);
5571 -- type T is new R (1) with private;
5573 -- type BaseT is new R with null record;
5574 -- subtype T is BaseT (1);
5577 -- (strictly speaking the above is incorrect Ada)
5579 -- From the semantic standpoint the private view of private extension T
5580 -- should be flagged as constrained since one can clearly have
5584 -- in a unit withing Pack. However, when deriving subprograms for the
5585 -- private view of private extension T, T must be seen as unconstrained
5586 -- since T has discriminants (this is a constraint of the current
5587 -- subprogram derivation model). Thus, when processing the private view of
5588 -- a private extension such as T, we first mark T as unconstrained, we
5589 -- process it, we perform program derivation and just before returning from
5590 -- Build_Derived_Record_Type we mark T as constrained.
5592 -- ??? Are there are other uncomfortable cases that we will have to
5595 -- 10. RECORD_TYPE_WITH_PRIVATE complications
5597 -- Types that are derived from a visible record type and have a private
5598 -- extension present other peculiarities. They behave mostly like private
5599 -- types, but if they have primitive operations defined, these will not
5600 -- have the proper signatures for further inheritance, because other
5601 -- primitive operations will use the implicit base that we define for
5602 -- private derivations below. This affect subprogram inheritance (see
5603 -- Derive_Subprograms for details). We also derive the implicit base from
5604 -- the base type of the full view, so that the implicit base is a record
5605 -- type and not another private type, This avoids infinite loops.
5607 procedure Build_Derived_Record_Type
5609 Parent_Type
: Entity_Id
;
5610 Derived_Type
: Entity_Id
;
5611 Derive_Subps
: Boolean := True)
5613 Loc
: constant Source_Ptr
:= Sloc
(N
);
5614 Parent_Base
: Entity_Id
;
5617 Discrim
: Entity_Id
;
5618 Last_Discrim
: Entity_Id
;
5621 Discs
: Elist_Id
:= New_Elmt_List
;
5622 -- An empty Discs list means that there were no constraints in the
5623 -- subtype indication or that there was an error processing it.
5625 Assoc_List
: Elist_Id
;
5626 New_Discrs
: Elist_Id
;
5627 New_Base
: Entity_Id
;
5629 New_Indic
: Node_Id
;
5631 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
5632 Discriminant_Specs
: constant Boolean :=
5633 Present
(Discriminant_Specifications
(N
));
5634 Private_Extension
: constant Boolean :=
5635 (Nkind
(N
) = N_Private_Extension_Declaration
);
5637 Constraint_Present
: Boolean;
5638 Inherit_Discrims
: Boolean := False;
5639 Save_Etype
: Entity_Id
;
5640 Save_Discr_Constr
: Elist_Id
;
5641 Save_Next_Entity
: Entity_Id
;
5644 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
5645 and then Present
(Full_View
(Parent_Type
))
5646 and then Has_Discriminants
(Parent_Type
)
5648 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
5650 Parent_Base
:= Base_Type
(Parent_Type
);
5653 -- Before we start the previously documented transformations, here is
5654 -- a little fix for size and alignment of tagged types. Normally when
5655 -- we derive type D from type P, we copy the size and alignment of P
5656 -- as the default for D, and in the absence of explicit representation
5657 -- clauses for D, the size and alignment are indeed the same as the
5660 -- But this is wrong for tagged types, since fields may be added,
5661 -- and the default size may need to be larger, and the default
5662 -- alignment may need to be larger.
5664 -- We therefore reset the size and alignment fields in the tagged
5665 -- case. Note that the size and alignment will in any case be at
5666 -- least as large as the parent type (since the derived type has
5667 -- a copy of the parent type in the _parent field)
5670 Init_Size_Align
(Derived_Type
);
5673 -- STEP 0a: figure out what kind of derived type declaration we have
5675 if Private_Extension
then
5677 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
5680 Type_Def
:= Type_Definition
(N
);
5682 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
5683 -- Parent_Base can be a private type or private extension. However,
5684 -- for tagged types with an extension the newly added fields are
5685 -- visible and hence the Derived_Type is always an E_Record_Type.
5686 -- (except that the parent may have its own private fields).
5687 -- For untagged types we preserve the Ekind of the Parent_Base.
5689 if Present
(Record_Extension_Part
(Type_Def
)) then
5690 Set_Ekind
(Derived_Type
, E_Record_Type
);
5692 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5696 -- Indic can either be an N_Identifier if the subtype indication
5697 -- contains no constraint or an N_Subtype_Indication if the subtype
5698 -- indication has a constraint.
5700 Indic
:= Subtype_Indication
(Type_Def
);
5701 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
5703 -- Check that the type has visible discriminants. The type may be
5704 -- a private type with unknown discriminants whose full view has
5705 -- discriminants which are invisible.
5707 if Constraint_Present
then
5708 if not Has_Discriminants
(Parent_Base
)
5710 (Has_Unknown_Discriminants
(Parent_Base
)
5711 and then Is_Private_Type
(Parent_Base
))
5714 ("invalid constraint: type has no discriminant",
5715 Constraint
(Indic
));
5717 Constraint_Present
:= False;
5718 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5720 elsif Is_Constrained
(Parent_Type
) then
5722 ("invalid constraint: parent type is already constrained",
5723 Constraint
(Indic
));
5725 Constraint_Present
:= False;
5726 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
5730 -- STEP 0b: If needed, apply transformation given in point 5. above
5732 if not Private_Extension
5733 and then Has_Discriminants
(Parent_Type
)
5734 and then not Discriminant_Specs
5735 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
5737 -- First, we must analyze the constraint (see comment in point 5.)
5739 if Constraint_Present
then
5740 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
5742 if Has_Discriminants
(Derived_Type
)
5743 and then Has_Private_Declaration
(Derived_Type
)
5744 and then Present
(Discriminant_Constraint
(Derived_Type
))
5746 -- Verify that constraints of the full view conform to those
5747 -- given in partial view.
5753 C1
:= First_Elmt
(New_Discrs
);
5754 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
5755 while Present
(C1
) and then Present
(C2
) loop
5757 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
5760 "constraint not conformant to previous declaration",
5771 -- Insert and analyze the declaration for the unconstrained base type
5773 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
5776 Make_Full_Type_Declaration
(Loc
,
5777 Defining_Identifier
=> New_Base
,
5779 Make_Derived_Type_Definition
(Loc
,
5780 Abstract_Present
=> Abstract_Present
(Type_Def
),
5781 Subtype_Indication
=>
5782 New_Occurrence_Of
(Parent_Base
, Loc
),
5783 Record_Extension_Part
=>
5784 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
5786 Set_Parent
(New_Decl
, Parent
(N
));
5787 Mark_Rewrite_Insertion
(New_Decl
);
5788 Insert_Before
(N
, New_Decl
);
5790 -- Note that this call passes False for the Derive_Subps parameter
5791 -- because subprogram derivation is deferred until after creating
5792 -- the subtype (see below).
5795 (New_Decl
, Parent_Base
, New_Base
,
5796 Is_Completion
=> True, Derive_Subps
=> False);
5798 -- ??? This needs re-examination to determine whether the
5799 -- above call can simply be replaced by a call to Analyze.
5801 Set_Analyzed
(New_Decl
);
5803 -- Insert and analyze the declaration for the constrained subtype
5805 if Constraint_Present
then
5807 Make_Subtype_Indication
(Loc
,
5808 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5809 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
5813 Constr_List
: constant List_Id
:= New_List
;
5818 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
5819 while Present
(C
) loop
5822 -- It is safe here to call New_Copy_Tree since
5823 -- Force_Evaluation was called on each constraint in
5824 -- Build_Discriminant_Constraints.
5826 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
5832 Make_Subtype_Indication
(Loc
,
5833 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
5835 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
5840 Make_Subtype_Declaration
(Loc
,
5841 Defining_Identifier
=> Derived_Type
,
5842 Subtype_Indication
=> New_Indic
));
5846 -- Derivation of subprograms must be delayed until the full subtype
5847 -- has been established to ensure proper overriding of subprograms
5848 -- inherited by full types. If the derivations occurred as part of
5849 -- the call to Build_Derived_Type above, then the check for type
5850 -- conformance would fail because earlier primitive subprograms
5851 -- could still refer to the full type prior the change to the new
5852 -- subtype and hence would not match the new base type created here.
5854 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5856 -- For tagged types the Discriminant_Constraint of the new base itype
5857 -- is inherited from the first subtype so that no subtype conformance
5858 -- problem arise when the first subtype overrides primitive
5859 -- operations inherited by the implicit base type.
5862 Set_Discriminant_Constraint
5863 (New_Base
, Discriminant_Constraint
(Derived_Type
));
5869 -- If we get here Derived_Type will have no discriminants or it will be
5870 -- a discriminated unconstrained base type.
5872 -- STEP 1a: perform preliminary actions/checks for derived tagged types
5876 -- The parent type is frozen for non-private extensions (RM 13.14(7))
5877 -- The declaration of a specific descendant of an interface type
5878 -- freezes the interface type (RM 13.14).
5880 if not Private_Extension
5881 or else Is_Interface
(Parent_Base
)
5883 Freeze_Before
(N
, Parent_Type
);
5886 -- In Ada 2005 (AI-344), the restriction that a derived tagged type
5887 -- cannot be declared at a deeper level than its parent type is
5888 -- removed. The check on derivation within a generic body is also
5889 -- relaxed, but there's a restriction that a derived tagged type
5890 -- cannot be declared in a generic body if it's derived directly
5891 -- or indirectly from a formal type of that generic.
5893 if Ada_Version
>= Ada_05
then
5894 if Present
(Enclosing_Generic_Body
(Derived_Type
)) then
5896 Ancestor_Type
: Entity_Id
;
5899 -- Check to see if any ancestor of the derived type is a
5902 Ancestor_Type
:= Parent_Type
;
5903 while not Is_Generic_Type
(Ancestor_Type
)
5904 and then Etype
(Ancestor_Type
) /= Ancestor_Type
5906 Ancestor_Type
:= Etype
(Ancestor_Type
);
5909 -- If the derived type does have a formal type as an
5910 -- ancestor, then it's an error if the derived type is
5911 -- declared within the body of the generic unit that
5912 -- declares the formal type in its generic formal part. It's
5913 -- sufficient to check whether the ancestor type is declared
5914 -- inside the same generic body as the derived type (such as
5915 -- within a nested generic spec), in which case the
5916 -- derivation is legal. If the formal type is declared
5917 -- outside of that generic body, then it's guaranteed that
5918 -- the derived type is declared within the generic body of
5919 -- the generic unit declaring the formal type.
5921 if Is_Generic_Type
(Ancestor_Type
)
5922 and then Enclosing_Generic_Body
(Ancestor_Type
) /=
5923 Enclosing_Generic_Body
(Derived_Type
)
5926 ("parent type of& must not be descendant of formal type"
5927 & " of an enclosing generic body",
5928 Indic
, Derived_Type
);
5933 elsif Type_Access_Level
(Derived_Type
) /=
5934 Type_Access_Level
(Parent_Type
)
5935 and then not Is_Generic_Type
(Derived_Type
)
5937 if Is_Controlled
(Parent_Type
) then
5939 ("controlled type must be declared at the library level",
5943 ("type extension at deeper accessibility level than parent",
5949 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
5953 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
5956 ("parent type of& must not be outside generic body"
5957 & " ('R'M 3.9.1(4))",
5958 Indic
, Derived_Type
);
5964 -- Ada 2005 (AI-251)
5966 if Ada_Version
= Ada_05
5970 -- "The declaration of a specific descendant of an interface type
5971 -- freezes the interface type" (RM 13.14).
5976 if Is_Non_Empty_List
(Interface_List
(Type_Def
)) then
5977 Iface
:= First
(Interface_List
(Type_Def
));
5978 while Present
(Iface
) loop
5979 Freeze_Before
(N
, Etype
(Iface
));
5986 -- STEP 1b : preliminary cleanup of the full view of private types
5988 -- If the type is already marked as having discriminants, then it's the
5989 -- completion of a private type or private extension and we need to
5990 -- retain the discriminants from the partial view if the current
5991 -- declaration has Discriminant_Specifications so that we can verify
5992 -- conformance. However, we must remove any existing components that
5993 -- were inherited from the parent (and attached in Copy_And_Swap)
5994 -- because the full type inherits all appropriate components anyway, and
5995 -- we do not want the partial view's components interfering.
5997 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
5998 Discrim
:= First_Discriminant
(Derived_Type
);
6000 Last_Discrim
:= Discrim
;
6001 Next_Discriminant
(Discrim
);
6002 exit when No
(Discrim
);
6005 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
6007 -- In all other cases wipe out the list of inherited components (even
6008 -- inherited discriminants), it will be properly rebuilt here.
6011 Set_First_Entity
(Derived_Type
, Empty
);
6012 Set_Last_Entity
(Derived_Type
, Empty
);
6015 -- STEP 1c: Initialize some flags for the Derived_Type
6017 -- The following flags must be initialized here so that
6018 -- Process_Discriminants can check that discriminants of tagged types do
6019 -- not have a default initial value and that access discriminants are
6020 -- only specified for limited records. For completeness, these flags are
6021 -- also initialized along with all the other flags below.
6023 -- AI-419: Limitedness is not inherited from an interface parent, so to
6024 -- be limited in that case the type must be explicitly declared as
6027 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
6028 Set_Is_Limited_Record
(Derived_Type
,
6029 Limited_Present
(Type_Def
)
6030 or else (Is_Limited_Record
(Parent_Type
)
6031 and then not Is_Interface
(Parent_Type
)));
6033 -- STEP 2a: process discriminants of derived type if any
6035 New_Scope
(Derived_Type
);
6037 if Discriminant_Specs
then
6038 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
6040 -- The following call initializes fields Has_Discriminants and
6041 -- Discriminant_Constraint, unless we are processing the completion
6042 -- of a private type declaration.
6044 Check_Or_Process_Discriminants
(N
, Derived_Type
);
6046 -- For non-tagged types the constraint on the Parent_Type must be
6047 -- present and is used to rename the discriminants.
6049 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
6050 Error_Msg_N
("untagged parent must have discriminants", Indic
);
6052 elsif not Is_Tagged
and then not Constraint_Present
then
6054 ("discriminant constraint needed for derived untagged records",
6057 -- Otherwise the parent subtype must be constrained unless we have a
6058 -- private extension.
6060 elsif not Constraint_Present
6061 and then not Private_Extension
6062 and then not Is_Constrained
(Parent_Type
)
6065 ("unconstrained type not allowed in this context", Indic
);
6067 elsif Constraint_Present
then
6068 -- The following call sets the field Corresponding_Discriminant
6069 -- for the discriminants in the Derived_Type.
6071 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
6073 -- For untagged types all new discriminants must rename
6074 -- discriminants in the parent. For private extensions new
6075 -- discriminants cannot rename old ones (implied by [7.3(13)]).
6077 Discrim
:= First_Discriminant
(Derived_Type
);
6078 while Present
(Discrim
) loop
6080 and then No
(Corresponding_Discriminant
(Discrim
))
6083 ("new discriminants must constrain old ones", Discrim
);
6085 elsif Private_Extension
6086 and then Present
(Corresponding_Discriminant
(Discrim
))
6089 ("only static constraints allowed for parent"
6090 & " discriminants in the partial view", Indic
);
6094 -- If a new discriminant is used in the constraint, then its
6095 -- subtype must be statically compatible with the parent
6096 -- discriminant's subtype (3.7(15)).
6098 if Present
(Corresponding_Discriminant
(Discrim
))
6100 not Subtypes_Statically_Compatible
6102 Etype
(Corresponding_Discriminant
(Discrim
)))
6105 ("subtype must be compatible with parent discriminant",
6109 Next_Discriminant
(Discrim
);
6112 -- Check whether the constraints of the full view statically
6113 -- match those imposed by the parent subtype [7.3(13)].
6115 if Present
(Stored_Constraint
(Derived_Type
)) then
6120 C1
:= First_Elmt
(Discs
);
6121 C2
:= First_Elmt
(Stored_Constraint
(Derived_Type
));
6122 while Present
(C1
) and then Present
(C2
) loop
6124 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
6127 ("not conformant with previous declaration",
6138 -- STEP 2b: No new discriminants, inherit discriminants if any
6141 if Private_Extension
then
6142 Set_Has_Unknown_Discriminants
6144 Has_Unknown_Discriminants
(Parent_Type
)
6145 or else Unknown_Discriminants_Present
(N
));
6147 -- The partial view of the parent may have unknown discriminants,
6148 -- but if the full view has discriminants and the parent type is
6149 -- in scope they must be inherited.
6151 elsif Has_Unknown_Discriminants
(Parent_Type
)
6153 (not Has_Discriminants
(Parent_Type
)
6154 or else not In_Open_Scopes
(Scope
(Parent_Type
)))
6156 Set_Has_Unknown_Discriminants
(Derived_Type
);
6159 if not Has_Unknown_Discriminants
(Derived_Type
)
6160 and then not Has_Unknown_Discriminants
(Parent_Base
)
6161 and then Has_Discriminants
(Parent_Type
)
6163 Inherit_Discrims
:= True;
6164 Set_Has_Discriminants
6165 (Derived_Type
, True);
6166 Set_Discriminant_Constraint
6167 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
6170 -- The following test is true for private types (remember
6171 -- transformation 5. is not applied to those) and in an error
6174 if Constraint_Present
then
6175 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
6178 -- For now mark a new derived type as constrained only if it has no
6179 -- discriminants. At the end of Build_Derived_Record_Type we properly
6180 -- set this flag in the case of private extensions. See comments in
6181 -- point 9. just before body of Build_Derived_Record_Type.
6185 not (Inherit_Discrims
6186 or else Has_Unknown_Discriminants
(Derived_Type
)));
6189 -- STEP 3: initialize fields of derived type
6191 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
6192 Set_Stored_Constraint
(Derived_Type
, No_Elist
);
6194 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
6195 -- but cannot be interfaces
6197 if not Private_Extension
6198 and then Ekind
(Derived_Type
) /= E_Private_Type
6199 and then Ekind
(Derived_Type
) /= E_Limited_Private_Type
6201 Set_Is_Interface
(Derived_Type
, Interface_Present
(Type_Def
));
6202 Set_Abstract_Interfaces
(Derived_Type
, No_Elist
);
6205 -- Fields inherited from the Parent_Type
6208 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
6209 Set_Has_Specified_Layout
6210 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
6211 Set_Is_Limited_Composite
6212 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
6213 Set_Is_Limited_Record
6215 Is_Limited_Record
(Parent_Type
)
6216 and then not Is_Interface
(Parent_Type
));
6217 Set_Is_Private_Composite
6218 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
6220 -- Fields inherited from the Parent_Base
6222 Set_Has_Controlled_Component
6223 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
6224 Set_Has_Non_Standard_Rep
6225 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6226 Set_Has_Primitive_Operations
6227 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
6229 -- Direct controlled types do not inherit Finalize_Storage_Only flag
6231 if not Is_Controlled
(Parent_Type
) then
6232 Set_Finalize_Storage_Only
6233 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
6236 -- Set fields for private derived types
6238 if Is_Private_Type
(Derived_Type
) then
6239 Set_Depends_On_Private
(Derived_Type
, True);
6240 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
6242 -- Inherit fields from non private record types. If this is the
6243 -- completion of a derivation from a private type, the parent itself
6244 -- is private, and the attributes come from its full view, which must
6248 if Is_Private_Type
(Parent_Base
)
6249 and then not Is_Record_Type
(Parent_Base
)
6251 Set_Component_Alignment
6252 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
6254 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
6256 Set_Component_Alignment
6257 (Derived_Type
, Component_Alignment
(Parent_Base
));
6260 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
6264 -- Set fields for tagged types
6267 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
6269 -- All tagged types defined in Ada.Finalization are controlled
6271 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
6272 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
6273 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
6275 Set_Is_Controlled
(Derived_Type
);
6277 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
6280 Make_Class_Wide_Type
(Derived_Type
);
6281 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
6283 if Has_Discriminants
(Derived_Type
)
6284 and then Constraint_Present
6286 Set_Stored_Constraint
6287 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Base
, Discs
));
6290 -- Ada 2005 (AI-251): Collect the list of progenitors that are not
6291 -- already in the parents.
6293 if Ada_Version
>= Ada_05
then
6295 Ifaces_List
: Elist_Id
;
6297 Collect_Abstract_Interfaces
6299 Ifaces_List
=> Ifaces_List
,
6300 Exclude_Parent_Interfaces
=> True);
6301 Set_Abstract_Interfaces
(Derived_Type
, Ifaces_List
);
6306 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
6307 Set_Has_Non_Standard_Rep
6308 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
6311 -- STEP 4: Inherit components from the parent base and constrain them.
6312 -- Apply the second transformation described in point 6. above.
6314 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
6315 or else not Has_Discriminants
(Parent_Type
)
6316 or else not Is_Constrained
(Parent_Type
)
6320 Constrs
:= Discriminant_Constraint
(Parent_Type
);
6325 (N
, Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
6327 -- STEP 5a: Copy the parent record declaration for untagged types
6329 if not Is_Tagged
then
6331 -- Discriminant_Constraint (Derived_Type) has been properly
6332 -- constructed. Save it and temporarily set it to Empty because we
6333 -- do not want the call to New_Copy_Tree below to mess this list.
6335 if Has_Discriminants
(Derived_Type
) then
6336 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
6337 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
6339 Save_Discr_Constr
:= No_Elist
;
6342 -- Save the Etype field of Derived_Type. It is correctly set now,
6343 -- but the call to New_Copy tree may remap it to point to itself,
6344 -- which is not what we want. Ditto for the Next_Entity field.
6346 Save_Etype
:= Etype
(Derived_Type
);
6347 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
6349 -- Assoc_List maps all stored discriminants in the Parent_Base to
6350 -- stored discriminants in the Derived_Type. It is fundamental that
6351 -- no types or itypes with discriminants other than the stored
6352 -- discriminants appear in the entities declared inside
6353 -- Derived_Type, since the back end cannot deal with it.
6357 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
6359 -- Restore the fields saved prior to the New_Copy_Tree call
6360 -- and compute the stored constraint.
6362 Set_Etype
(Derived_Type
, Save_Etype
);
6363 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
6365 if Has_Discriminants
(Derived_Type
) then
6366 Set_Discriminant_Constraint
6367 (Derived_Type
, Save_Discr_Constr
);
6368 Set_Stored_Constraint
6369 (Derived_Type
, Expand_To_Stored_Constraint
(Parent_Type
, Discs
));
6370 Replace_Components
(Derived_Type
, New_Decl
);
6373 -- Insert the new derived type declaration
6375 Rewrite
(N
, New_Decl
);
6377 -- STEP 5b: Complete the processing for record extensions in generics
6379 -- There is no completion for record extensions declared in the
6380 -- parameter part of a generic, so we need to complete processing for
6381 -- these generic record extensions here. The Record_Type_Definition call
6382 -- will change the Ekind of the components from E_Void to E_Component.
6384 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
6385 Record_Type_Definition
(Empty
, Derived_Type
);
6387 -- STEP 5c: Process the record extension for non private tagged types
6389 elsif not Private_Extension
then
6391 -- Add the _parent field in the derived type
6393 Expand_Record_Extension
(Derived_Type
, Type_Def
);
6395 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
6396 -- implemented interfaces if we are in expansion mode
6398 if Expander_Active
then
6399 Add_Interface_Tag_Components
(N
, Derived_Type
);
6402 -- Analyze the record extension
6404 Record_Type_Definition
6405 (Record_Extension_Part
(Type_Def
), Derived_Type
);
6410 -- Nothing else to do if there is an error in the derivation.
6411 -- An unusual case: the full view may be derived from a type in an
6412 -- instance, when the partial view was used illegally as an actual
6413 -- in that instance, leading to a circular definition.
6415 if Etype
(Derived_Type
) = Any_Type
6416 or else Etype
(Parent_Type
) = Derived_Type
6421 -- Set delayed freeze and then derive subprograms, we need to do
6422 -- this in this order so that derived subprograms inherit the
6423 -- derived freeze if necessary.
6425 Set_Has_Delayed_Freeze
(Derived_Type
);
6427 if Derive_Subps
then
6428 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6431 -- If we have a private extension which defines a constrained derived
6432 -- type mark as constrained here after we have derived subprograms. See
6433 -- comment on point 9. just above the body of Build_Derived_Record_Type.
6435 if Private_Extension
and then Inherit_Discrims
then
6436 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
6437 Set_Is_Constrained
(Derived_Type
, True);
6438 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
6440 elsif Is_Constrained
(Parent_Type
) then
6442 (Derived_Type
, True);
6443 Set_Discriminant_Constraint
6444 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
6448 -- Update the class_wide type, which shares the now-completed
6449 -- entity list with its specific type.
6453 (Class_Wide_Type
(Derived_Type
), First_Entity
(Derived_Type
));
6455 (Class_Wide_Type
(Derived_Type
), Last_Entity
(Derived_Type
));
6458 end Build_Derived_Record_Type
;
6460 ------------------------
6461 -- Build_Derived_Type --
6462 ------------------------
6464 procedure Build_Derived_Type
6466 Parent_Type
: Entity_Id
;
6467 Derived_Type
: Entity_Id
;
6468 Is_Completion
: Boolean;
6469 Derive_Subps
: Boolean := True)
6471 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
6474 -- Set common attributes
6476 Set_Scope
(Derived_Type
, Current_Scope
);
6478 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
6479 Set_Etype
(Derived_Type
, Parent_Base
);
6480 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
6482 Set_Size_Info
(Derived_Type
, Parent_Type
);
6483 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
6484 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
6485 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
6487 -- The derived type inherits the representation clauses of the parent.
6488 -- However, for a private type that is completed by a derivation, there
6489 -- may be operation attributes that have been specified already (stream
6490 -- attributes and External_Tag) and those must be provided. Finally,
6491 -- if the partial view is a private extension, the representation items
6492 -- of the parent have been inherited already, and should not be chained
6493 -- twice to the derived type.
6495 if Is_Tagged_Type
(Parent_Type
)
6496 and then Present
(First_Rep_Item
(Derived_Type
))
6498 -- The existing items are either operational items or items inherited
6499 -- from a private extension declaration.
6503 Found
: Boolean := False;
6506 Rep
:= First_Rep_Item
(Derived_Type
);
6507 while Present
(Rep
) loop
6508 if Rep
= First_Rep_Item
(Parent_Type
) then
6512 Rep
:= Next_Rep_Item
(Rep
);
6518 (First_Rep_Item
(Derived_Type
), First_Rep_Item
(Parent_Type
));
6523 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
6526 case Ekind
(Parent_Type
) is
6527 when Numeric_Kind
=>
6528 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
6531 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
6535 | Class_Wide_Kind
=>
6536 Build_Derived_Record_Type
6537 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
6540 when Enumeration_Kind
=>
6541 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
6544 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
6546 when Incomplete_Or_Private_Kind
=>
6547 Build_Derived_Private_Type
6548 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
6550 -- For discriminated types, the derivation includes deriving
6551 -- primitive operations. For others it is done below.
6553 if Is_Tagged_Type
(Parent_Type
)
6554 or else Has_Discriminants
(Parent_Type
)
6555 or else (Present
(Full_View
(Parent_Type
))
6556 and then Has_Discriminants
(Full_View
(Parent_Type
)))
6561 when Concurrent_Kind
=>
6562 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
6565 raise Program_Error
;
6568 if Etype
(Derived_Type
) = Any_Type
then
6572 -- Set delayed freeze and then derive subprograms, we need to do this
6573 -- in this order so that derived subprograms inherit the derived freeze
6576 Set_Has_Delayed_Freeze
(Derived_Type
);
6577 if Derive_Subps
then
6578 Derive_Subprograms
(Parent_Type
, Derived_Type
);
6581 Set_Has_Primitive_Operations
6582 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
6583 end Build_Derived_Type
;
6585 -----------------------
6586 -- Build_Discriminal --
6587 -----------------------
6589 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
6590 D_Minal
: Entity_Id
;
6591 CR_Disc
: Entity_Id
;
6594 -- A discriminal has the same name as the discriminant
6597 Make_Defining_Identifier
(Sloc
(Discrim
),
6598 Chars
=> Chars
(Discrim
));
6600 Set_Ekind
(D_Minal
, E_In_Parameter
);
6601 Set_Mechanism
(D_Minal
, Default_Mechanism
);
6602 Set_Etype
(D_Minal
, Etype
(Discrim
));
6604 Set_Discriminal
(Discrim
, D_Minal
);
6605 Set_Discriminal_Link
(D_Minal
, Discrim
);
6607 -- For task types, build at once the discriminants of the corresponding
6608 -- record, which are needed if discriminants are used in entry defaults
6609 -- and in family bounds.
6611 if Is_Concurrent_Type
(Current_Scope
)
6612 or else Is_Limited_Type
(Current_Scope
)
6614 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
6616 Set_Ekind
(CR_Disc
, E_In_Parameter
);
6617 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
6618 Set_Etype
(CR_Disc
, Etype
(Discrim
));
6619 Set_Discriminal_Link
(CR_Disc
, Discrim
);
6620 Set_CR_Discriminant
(Discrim
, CR_Disc
);
6622 end Build_Discriminal
;
6624 ------------------------------------
6625 -- Build_Discriminant_Constraints --
6626 ------------------------------------
6628 function Build_Discriminant_Constraints
6631 Derived_Def
: Boolean := False) return Elist_Id
6633 C
: constant Node_Id
:= Constraint
(Def
);
6634 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
6636 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
6637 -- Saves the expression corresponding to a given discriminant in T
6639 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
6640 -- Return the Position number within array Discr_Expr of a discriminant
6641 -- D within the discriminant list of the discriminated type T.
6647 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
6651 Disc
:= First_Discriminant
(T
);
6652 for J
in Discr_Expr
'Range loop
6657 Next_Discriminant
(Disc
);
6660 -- Note: Since this function is called on discriminants that are
6661 -- known to belong to the discriminated type, falling through the
6662 -- loop with no match signals an internal compiler error.
6664 raise Program_Error
;
6667 -- Declarations local to Build_Discriminant_Constraints
6671 Elist
: constant Elist_Id
:= New_Elmt_List
;
6679 Discrim_Present
: Boolean := False;
6681 -- Start of processing for Build_Discriminant_Constraints
6684 -- The following loop will process positional associations only.
6685 -- For a positional association, the (single) discriminant is
6686 -- implicitly specified by position, in textual order (RM 3.7.2).
6688 Discr
:= First_Discriminant
(T
);
6689 Constr
:= First
(Constraints
(C
));
6690 for D
in Discr_Expr
'Range loop
6691 exit when Nkind
(Constr
) = N_Discriminant_Association
;
6694 Error_Msg_N
("too few discriminants given in constraint", C
);
6695 return New_Elmt_List
;
6697 elsif Nkind
(Constr
) = N_Range
6698 or else (Nkind
(Constr
) = N_Attribute_Reference
6700 Attribute_Name
(Constr
) = Name_Range
)
6703 ("a range is not a valid discriminant constraint", Constr
);
6704 Discr_Expr
(D
) := Error
;
6707 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
6708 Discr_Expr
(D
) := Constr
;
6711 Next_Discriminant
(Discr
);
6715 if No
(Discr
) and then Present
(Constr
) then
6716 Error_Msg_N
("too many discriminants given in constraint", Constr
);
6717 return New_Elmt_List
;
6720 -- Named associations can be given in any order, but if both positional
6721 -- and named associations are used in the same discriminant constraint,
6722 -- then positional associations must occur first, at their normal
6723 -- position. Hence once a named association is used, the rest of the
6724 -- discriminant constraint must use only named associations.
6726 while Present
(Constr
) loop
6728 -- Positional association forbidden after a named association
6730 if Nkind
(Constr
) /= N_Discriminant_Association
then
6731 Error_Msg_N
("positional association follows named one", Constr
);
6732 return New_Elmt_List
;
6734 -- Otherwise it is a named association
6737 -- E records the type of the discriminants in the named
6738 -- association. All the discriminants specified in the same name
6739 -- association must have the same type.
6743 -- Search the list of discriminants in T to see if the simple name
6744 -- given in the constraint matches any of them.
6746 Id
:= First
(Selector_Names
(Constr
));
6747 while Present
(Id
) loop
6750 -- If Original_Discriminant is present, we are processing a
6751 -- generic instantiation and this is an instance node. We need
6752 -- to find the name of the corresponding discriminant in the
6753 -- actual record type T and not the name of the discriminant in
6754 -- the generic formal. Example:
6757 -- type G (D : int) is private;
6759 -- subtype W is G (D => 1);
6761 -- type Rec (X : int) is record ... end record;
6762 -- package Q is new P (G => Rec);
6764 -- At the point of the instantiation, formal type G is Rec
6765 -- and therefore when reanalyzing "subtype W is G (D => 1);"
6766 -- which really looks like "subtype W is Rec (D => 1);" at
6767 -- the point of instantiation, we want to find the discriminant
6768 -- that corresponds to D in Rec, ie X.
6770 if Present
(Original_Discriminant
(Id
)) then
6771 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
6775 Discr
:= First_Discriminant
(T
);
6776 while Present
(Discr
) loop
6777 if Chars
(Discr
) = Chars
(Id
) then
6782 Next_Discriminant
(Discr
);
6786 Error_Msg_N
("& does not match any discriminant", Id
);
6787 return New_Elmt_List
;
6789 -- The following is only useful for the benefit of generic
6790 -- instances but it does not interfere with other
6791 -- processing for the non-generic case so we do it in all
6792 -- cases (for generics this statement is executed when
6793 -- processing the generic definition, see comment at the
6794 -- beginning of this if statement).
6797 Set_Original_Discriminant
(Id
, Discr
);
6801 Position
:= Pos_Of_Discr
(T
, Discr
);
6803 if Present
(Discr_Expr
(Position
)) then
6804 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
6807 -- Each discriminant specified in the same named association
6808 -- must be associated with a separate copy of the
6809 -- corresponding expression.
6811 if Present
(Next
(Id
)) then
6812 Expr
:= New_Copy_Tree
(Expression
(Constr
));
6813 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
6815 Expr
:= Expression
(Constr
);
6818 Discr_Expr
(Position
) := Expr
;
6819 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
6822 -- A discriminant association with more than one discriminant
6823 -- name is only allowed if the named discriminants are all of
6824 -- the same type (RM 3.7.1(8)).
6827 E
:= Base_Type
(Etype
(Discr
));
6829 elsif Base_Type
(Etype
(Discr
)) /= E
then
6831 ("all discriminants in an association " &
6832 "must have the same type", Id
);
6842 -- A discriminant constraint must provide exactly one value for each
6843 -- discriminant of the type (RM 3.7.1(8)).
6845 for J
in Discr_Expr
'Range loop
6846 if No
(Discr_Expr
(J
)) then
6847 Error_Msg_N
("too few discriminants given in constraint", C
);
6848 return New_Elmt_List
;
6852 -- Determine if there are discriminant expressions in the constraint
6854 for J
in Discr_Expr
'Range loop
6855 if Denotes_Discriminant
6856 (Discr_Expr
(J
), Check_Concurrent
=> True)
6858 Discrim_Present
:= True;
6862 -- Build an element list consisting of the expressions given in the
6863 -- discriminant constraint and apply the appropriate checks. The list
6864 -- is constructed after resolving any named discriminant associations
6865 -- and therefore the expressions appear in the textual order of the
6868 Discr
:= First_Discriminant
(T
);
6869 for J
in Discr_Expr
'Range loop
6870 if Discr_Expr
(J
) /= Error
then
6871 Append_Elmt
(Discr_Expr
(J
), Elist
);
6873 -- If any of the discriminant constraints is given by a
6874 -- discriminant and we are in a derived type declaration we
6875 -- have a discriminant renaming. Establish link between new
6876 -- and old discriminant.
6878 if Denotes_Discriminant
(Discr_Expr
(J
)) then
6880 Set_Corresponding_Discriminant
6881 (Entity
(Discr_Expr
(J
)), Discr
);
6884 -- Force the evaluation of non-discriminant expressions.
6885 -- If we have found a discriminant in the constraint 3.4(26)
6886 -- and 3.8(18) demand that no range checks are performed are
6887 -- after evaluation. If the constraint is for a component
6888 -- definition that has a per-object constraint, expressions are
6889 -- evaluated but not checked either. In all other cases perform
6893 if Discrim_Present
then
6896 elsif Nkind
(Parent
(Parent
(Def
))) = N_Component_Declaration
6898 Has_Per_Object_Constraint
6899 (Defining_Identifier
(Parent
(Parent
(Def
))))
6903 elsif Is_Access_Type
(Etype
(Discr
)) then
6904 Apply_Constraint_Check
(Discr_Expr
(J
), Etype
(Discr
));
6907 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
6910 Force_Evaluation
(Discr_Expr
(J
));
6913 -- Check that the designated type of an access discriminant's
6914 -- expression is not a class-wide type unless the discriminant's
6915 -- designated type is also class-wide.
6917 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
6918 and then not Is_Class_Wide_Type
6919 (Designated_Type
(Etype
(Discr
)))
6920 and then Etype
(Discr_Expr
(J
)) /= Any_Type
6921 and then Is_Class_Wide_Type
6922 (Designated_Type
(Etype
(Discr_Expr
(J
))))
6924 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
6928 Next_Discriminant
(Discr
);
6932 end Build_Discriminant_Constraints
;
6934 ---------------------------------
6935 -- Build_Discriminated_Subtype --
6936 ---------------------------------
6938 procedure Build_Discriminated_Subtype
6942 Related_Nod
: Node_Id
;
6943 For_Access
: Boolean := False)
6945 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
6946 Constrained
: constant Boolean :=
6948 and then not Is_Empty_Elmt_List
(Elist
)
6949 and then not Is_Class_Wide_Type
(T
))
6950 or else Is_Constrained
(T
);
6953 if Ekind
(T
) = E_Record_Type
then
6955 Set_Ekind
(Def_Id
, E_Private_Subtype
);
6956 Set_Is_For_Access_Subtype
(Def_Id
, True);
6958 Set_Ekind
(Def_Id
, E_Record_Subtype
);
6961 elsif Ekind
(T
) = E_Task_Type
then
6962 Set_Ekind
(Def_Id
, E_Task_Subtype
);
6964 elsif Ekind
(T
) = E_Protected_Type
then
6965 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
6967 elsif Is_Private_Type
(T
) then
6968 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
6970 elsif Is_Class_Wide_Type
(T
) then
6971 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
6974 -- Incomplete type. Attach subtype to list of dependents, to be
6975 -- completed with full view of parent type, unless is it the
6976 -- designated subtype of a record component within an init_proc.
6977 -- This last case arises for a component of an access type whose
6978 -- designated type is incomplete (e.g. a Taft Amendment type).
6979 -- The designated subtype is within an inner scope, and needs no
6980 -- elaboration, because only the access type is needed in the
6981 -- initialization procedure.
6983 Set_Ekind
(Def_Id
, Ekind
(T
));
6985 if For_Access
and then Within_Init_Proc
then
6988 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
6992 Set_Etype
(Def_Id
, T
);
6993 Init_Size_Align
(Def_Id
);
6994 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
6995 Set_Is_Constrained
(Def_Id
, Constrained
);
6997 Set_First_Entity
(Def_Id
, First_Entity
(T
));
6998 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
6999 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7001 if Is_Tagged_Type
(T
) then
7002 Set_Is_Tagged_Type
(Def_Id
);
7003 Make_Class_Wide_Type
(Def_Id
);
7006 Set_Stored_Constraint
(Def_Id
, No_Elist
);
7009 Set_Discriminant_Constraint
(Def_Id
, Elist
);
7010 Set_Stored_Constraint_From_Discriminant_Constraint
(Def_Id
);
7013 if Is_Tagged_Type
(T
) then
7015 -- Ada 2005 (AI-251): In case of concurrent types we inherit the
7016 -- concurrent record type (which has the list of primitive
7019 if Ada_Version
>= Ada_05
7020 and then Is_Concurrent_Type
(T
)
7022 Set_Corresponding_Record_Type
(Def_Id
,
7023 Corresponding_Record_Type
(T
));
7025 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
7028 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
7031 -- Subtypes introduced by component declarations do not need to be
7032 -- marked as delayed, and do not get freeze nodes, because the semantics
7033 -- verifies that the parents of the subtypes are frozen before the
7034 -- enclosing record is frozen.
7036 if not Is_Type
(Scope
(Def_Id
)) then
7037 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
7039 if Is_Private_Type
(T
)
7040 and then Present
(Full_View
(T
))
7042 Conditional_Delay
(Def_Id
, Full_View
(T
));
7044 Conditional_Delay
(Def_Id
, T
);
7048 if Is_Record_Type
(T
) then
7049 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
7052 and then not Is_Empty_Elmt_List
(Elist
)
7053 and then not For_Access
7055 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
7056 elsif not For_Access
then
7057 Set_Cloned_Subtype
(Def_Id
, T
);
7060 end Build_Discriminated_Subtype
;
7062 ------------------------
7063 -- Build_Scalar_Bound --
7064 ------------------------
7066 function Build_Scalar_Bound
7069 Der_T
: Entity_Id
) return Node_Id
7071 New_Bound
: Entity_Id
;
7074 -- Note: not clear why this is needed, how can the original bound
7075 -- be unanalyzed at this point? and if it is, what business do we
7076 -- have messing around with it? and why is the base type of the
7077 -- parent type the right type for the resolution. It probably is
7078 -- not! It is OK for the new bound we are creating, but not for
7079 -- the old one??? Still if it never happens, no problem!
7081 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
7083 if Nkind
(Bound
) = N_Integer_Literal
7084 or else Nkind
(Bound
) = N_Real_Literal
7086 New_Bound
:= New_Copy
(Bound
);
7087 Set_Etype
(New_Bound
, Der_T
);
7088 Set_Analyzed
(New_Bound
);
7090 elsif Is_Entity_Name
(Bound
) then
7091 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
7093 -- The following is almost certainly wrong. What business do we have
7094 -- relocating a node (Bound) that is presumably still attached to
7095 -- the tree elsewhere???
7098 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
7101 Set_Etype
(New_Bound
, Der_T
);
7103 end Build_Scalar_Bound
;
7105 --------------------------------
7106 -- Build_Underlying_Full_View --
7107 --------------------------------
7109 procedure Build_Underlying_Full_View
7114 Loc
: constant Source_Ptr
:= Sloc
(N
);
7115 Subt
: constant Entity_Id
:=
7116 Make_Defining_Identifier
7117 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
7124 procedure Set_Discriminant_Name
(Id
: Node_Id
);
7125 -- If the derived type has discriminants, they may rename discriminants
7126 -- of the parent. When building the full view of the parent, we need to
7127 -- recover the names of the original discriminants if the constraint is
7128 -- given by named associations.
7130 ---------------------------
7131 -- Set_Discriminant_Name --
7132 ---------------------------
7134 procedure Set_Discriminant_Name
(Id
: Node_Id
) is
7138 Set_Original_Discriminant
(Id
, Empty
);
7140 if Has_Discriminants
(Typ
) then
7141 Disc
:= First_Discriminant
(Typ
);
7142 while Present
(Disc
) loop
7143 if Chars
(Disc
) = Chars
(Id
)
7144 and then Present
(Corresponding_Discriminant
(Disc
))
7146 Set_Chars
(Id
, Chars
(Corresponding_Discriminant
(Disc
)));
7148 Next_Discriminant
(Disc
);
7151 end Set_Discriminant_Name
;
7153 -- Start of processing for Build_Underlying_Full_View
7156 if Nkind
(N
) = N_Full_Type_Declaration
then
7157 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
7159 elsif Nkind
(N
) = N_Subtype_Declaration
then
7160 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
7162 elsif Nkind
(N
) = N_Component_Declaration
then
7165 (Constraint
(Subtype_Indication
(Component_Definition
(N
))));
7168 raise Program_Error
;
7171 C
:= First
(Constraints
(Constr
));
7172 while Present
(C
) loop
7173 if Nkind
(C
) = N_Discriminant_Association
then
7174 Id
:= First
(Selector_Names
(C
));
7175 while Present
(Id
) loop
7176 Set_Discriminant_Name
(Id
);
7185 Make_Subtype_Declaration
(Loc
,
7186 Defining_Identifier
=> Subt
,
7187 Subtype_Indication
=>
7188 Make_Subtype_Indication
(Loc
,
7189 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
7190 Constraint
=> New_Copy_Tree
(Constr
)));
7192 -- If this is a component subtype for an outer itype, it is not
7193 -- a list member, so simply set the parent link for analysis: if
7194 -- the enclosing type does not need to be in a declarative list,
7195 -- neither do the components.
7197 if Is_List_Member
(N
)
7198 and then Nkind
(N
) /= N_Component_Declaration
7200 Insert_Before
(N
, Indic
);
7202 Set_Parent
(Indic
, Parent
(N
));
7206 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
7207 end Build_Underlying_Full_View
;
7209 -------------------------------
7210 -- Check_Abstract_Overriding --
7211 -------------------------------
7213 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
7214 Alias_Subp
: Entity_Id
;
7221 Op_List
:= Primitive_Operations
(T
);
7223 -- Loop to check primitive operations
7225 Elmt
:= First_Elmt
(Op_List
);
7226 while Present
(Elmt
) loop
7227 Subp
:= Node
(Elmt
);
7228 Alias_Subp
:= Alias
(Subp
);
7230 -- Inherited subprograms are identified by the fact that they do not
7231 -- come from source, and the associated source location is the
7232 -- location of the first subtype of the derived type.
7234 -- Special exception, do not complain about failure to override the
7235 -- stream routines _Input and _Output, as well as the primitive
7236 -- operations used in dispatching selects since we always provide
7237 -- automatic overridings for these subprograms.
7239 if (Is_Abstract
(Subp
)
7240 or else (Has_Controlling_Result
(Subp
)
7241 and then Present
(Alias_Subp
)
7242 and then not Comes_From_Source
(Subp
)
7243 and then Sloc
(Subp
) = Sloc
(First_Subtype
(T
))))
7244 and then not Is_TSS
(Subp
, TSS_Stream_Input
)
7245 and then not Is_TSS
(Subp
, TSS_Stream_Output
)
7246 and then not Is_Abstract
(T
)
7247 and then Chars
(Subp
) /= Name_uDisp_Asynchronous_Select
7248 and then Chars
(Subp
) /= Name_uDisp_Conditional_Select
7249 and then Chars
(Subp
) /= Name_uDisp_Get_Prim_Op_Kind
7250 and then Chars
(Subp
) /= Name_uDisp_Timed_Select
7252 -- Ada 2005 (AI-251): Do not consider hidden entities associated
7253 -- with abstract interface types because the check will be done
7254 -- with the aliased entity (otherwise we generate a duplicated
7257 and then not Present
(Abstract_Interface_Alias
(Subp
))
7259 if Present
(Alias_Subp
) then
7261 -- Only perform the check for a derived subprogram when the
7262 -- type has an explicit record extension. This avoids
7263 -- incorrectly flagging abstract subprograms for the case of a
7264 -- type without an extension derived from a formal type with a
7265 -- tagged actual (can occur within a private part).
7267 -- Ada 2005 (AI-391): In the case of an inherited function with
7268 -- a controlling result of the type, the rule does not apply if
7269 -- the type is a null extension (unless the parent function
7270 -- itself is abstract, in which case the function must still be
7271 -- be overridden). The expander will generate an overriding
7272 -- wrapper function calling the parent subprogram (see
7273 -- Exp_Ch3.Make_Controlling_Wrapper_Functions).
7275 Type_Def
:= Type_Definition
(Parent
(T
));
7276 if Nkind
(Type_Def
) = N_Derived_Type_Definition
7277 and then Present
(Record_Extension_Part
(Type_Def
))
7279 (Ada_Version
< Ada_05
7280 or else not Is_Null_Extension
(T
)
7281 or else Ekind
(Subp
) = E_Procedure
7282 or else not Has_Controlling_Result
(Subp
)
7283 or else Is_Abstract
(Alias_Subp
)
7284 or else Is_Access_Type
(Etype
(Subp
)))
7287 ("type must be declared abstract or & overridden",
7290 -- Traverse the whole chain of aliased subprograms to
7291 -- complete the error notification. This is especially
7292 -- useful for traceability of the chain of entities when the
7293 -- subprogram corresponds with an interface subprogram
7294 -- (which might be defined in another package)
7296 if Present
(Alias_Subp
) then
7302 while Present
(Alias
(E
)) loop
7303 Error_Msg_Sloc
:= Sloc
(E
);
7304 Error_Msg_NE
("\& has been inherited #", T
, Subp
);
7308 Error_Msg_Sloc
:= Sloc
(E
);
7310 ("\& has been inherited from subprogram #", T
, Subp
);
7314 -- Ada 2005 (AI-345): Protected or task type implementing
7315 -- abstract interfaces.
7317 elsif Is_Concurrent_Record_Type
(T
)
7318 and then Present
(Abstract_Interfaces
(T
))
7320 -- The controlling formal of Subp must be of mode "out",
7321 -- "in out" or an access-to-variable to be overridden.
7323 if Ekind
(First_Formal
(Subp
)) = E_In_Parameter
then
7325 ("first formal of & must be of mode `OUT`, `IN OUT` " &
7326 "or access-to-variable", T
, Subp
);
7328 if Is_Protected_Type
7329 (Corresponding_Concurrent_Type
(T
))
7332 ("\to be overridden by protected procedure or " &
7333 "entry (`R`M 9.4(11))", T
);
7336 ("\to be overridden by task entry (`R`M 9.4(11))",
7340 -- Some other kind of overriding failure
7344 ("interface subprogram & must be overridden",
7351 ("abstract subprogram not allowed for type&",
7354 ("nonabstract type has abstract subprogram&",
7361 end Check_Abstract_Overriding
;
7363 ------------------------------------------------
7364 -- Check_Access_Discriminant_Requires_Limited --
7365 ------------------------------------------------
7367 procedure Check_Access_Discriminant_Requires_Limited
7372 -- A discriminant_specification for an access discriminant shall appear
7373 -- only in the declaration for a task or protected type, or for a type
7374 -- with the reserved word 'limited' in its definition or in one of its
7375 -- ancestors. (RM 3.7(10))
7377 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
7378 and then not Is_Concurrent_Type
(Current_Scope
)
7379 and then not Is_Concurrent_Record_Type
(Current_Scope
)
7380 and then not Is_Limited_Record
(Current_Scope
)
7381 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
7384 ("access discriminants allowed only for limited types", Loc
);
7386 end Check_Access_Discriminant_Requires_Limited
;
7388 -----------------------------------
7389 -- Check_Aliased_Component_Types --
7390 -----------------------------------
7392 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
7396 -- ??? Also need to check components of record extensions, but not
7397 -- components of protected types (which are always limited).
7399 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
7400 -- types to be unconstrained. This is safe because it is illegal to
7401 -- create access subtypes to such types with explicit discriminant
7404 if not Is_Limited_Type
(T
) then
7405 if Ekind
(T
) = E_Record_Type
then
7406 C
:= First_Component
(T
);
7407 while Present
(C
) loop
7409 and then Has_Discriminants
(Etype
(C
))
7410 and then not Is_Constrained
(Etype
(C
))
7411 and then not In_Instance_Body
7412 and then Ada_Version
< Ada_05
7415 ("aliased component must be constrained ('R'M 3.6(11))",
7422 elsif Ekind
(T
) = E_Array_Type
then
7423 if Has_Aliased_Components
(T
)
7424 and then Has_Discriminants
(Component_Type
(T
))
7425 and then not Is_Constrained
(Component_Type
(T
))
7426 and then not In_Instance_Body
7427 and then Ada_Version
< Ada_05
7430 ("aliased component type must be constrained ('R'M 3.6(11))",
7435 end Check_Aliased_Component_Types
;
7437 ----------------------
7438 -- Check_Completion --
7439 ----------------------
7441 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
7444 procedure Post_Error
;
7445 -- Post error message for lack of completion for entity E
7451 procedure Post_Error
is
7453 if not Comes_From_Source
(E
) then
7455 if Ekind
(E
) = E_Task_Type
7456 or else Ekind
(E
) = E_Protected_Type
7458 -- It may be an anonymous protected type created for a
7459 -- single variable. Post error on variable, if present.
7465 Var
:= First_Entity
(Current_Scope
);
7466 while Present
(Var
) loop
7467 exit when Etype
(Var
) = E
7468 and then Comes_From_Source
(Var
);
7473 if Present
(Var
) then
7480 -- If a generated entity has no completion, then either previous
7481 -- semantic errors have disabled the expansion phase, or else we had
7482 -- missing subunits, or else we are compiling without expan- sion,
7483 -- or else something is very wrong.
7485 if not Comes_From_Source
(E
) then
7487 (Serious_Errors_Detected
> 0
7488 or else Configurable_Run_Time_Violations
> 0
7489 or else Subunits_Missing
7490 or else not Expander_Active
);
7493 -- Here for source entity
7496 -- Here if no body to post the error message, so we post the error
7497 -- on the declaration that has no completion. This is not really
7498 -- the right place to post it, think about this later ???
7500 if No
(Body_Id
) then
7503 ("missing full declaration for }", Parent
(E
), E
);
7506 ("missing body for &", Parent
(E
), E
);
7509 -- Package body has no completion for a declaration that appears
7510 -- in the corresponding spec. Post error on the body, with a
7511 -- reference to the non-completed declaration.
7514 Error_Msg_Sloc
:= Sloc
(E
);
7518 ("missing full declaration for }!", Body_Id
, E
);
7520 elsif Is_Overloadable
(E
)
7521 and then Current_Entity_In_Scope
(E
) /= E
7523 -- It may be that the completion is mistyped and appears
7524 -- as a distinct overloading of the entity.
7527 Candidate
: constant Entity_Id
:=
7528 Current_Entity_In_Scope
(E
);
7529 Decl
: constant Node_Id
:=
7530 Unit_Declaration_Node
(Candidate
);
7533 if Is_Overloadable
(Candidate
)
7534 and then Ekind
(Candidate
) = Ekind
(E
)
7535 and then Nkind
(Decl
) = N_Subprogram_Body
7536 and then Acts_As_Spec
(Decl
)
7538 Check_Type_Conformant
(Candidate
, E
);
7541 Error_Msg_NE
("missing body for & declared#!",
7546 Error_Msg_NE
("missing body for & declared#!",
7553 -- Start processing for Check_Completion
7556 E
:= First_Entity
(Current_Scope
);
7557 while Present
(E
) loop
7558 if Is_Intrinsic_Subprogram
(E
) then
7561 -- The following situation requires special handling: a child
7562 -- unit that appears in the context clause of the body of its
7565 -- procedure Parent.Child (...);
7567 -- with Parent.Child;
7568 -- package body Parent is
7570 -- Here Parent.Child appears as a local entity, but should not
7571 -- be flagged as requiring completion, because it is a
7572 -- compilation unit.
7574 elsif Ekind
(E
) = E_Function
7575 or else Ekind
(E
) = E_Procedure
7576 or else Ekind
(E
) = E_Generic_Function
7577 or else Ekind
(E
) = E_Generic_Procedure
7579 if not Has_Completion
(E
)
7580 and then not Is_Abstract
(E
)
7581 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7583 and then Chars
(E
) /= Name_uSize
7588 elsif Is_Entry
(E
) then
7589 if not Has_Completion
(E
) and then
7590 (Ekind
(Scope
(E
)) = E_Protected_Object
7591 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
7596 elsif Is_Package_Or_Generic_Package
(E
) then
7597 if Unit_Requires_Body
(E
) then
7598 if not Has_Completion
(E
)
7599 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
7605 elsif not Is_Child_Unit
(E
) then
7606 May_Need_Implicit_Body
(E
);
7609 elsif Ekind
(E
) = E_Incomplete_Type
7610 and then No
(Underlying_Type
(E
))
7614 elsif (Ekind
(E
) = E_Task_Type
or else
7615 Ekind
(E
) = E_Protected_Type
)
7616 and then not Has_Completion
(E
)
7620 -- A single task declared in the current scope is a constant, verify
7621 -- that the body of its anonymous type is in the same scope. If the
7622 -- task is defined elsewhere, this may be a renaming declaration for
7623 -- which no completion is needed.
7625 elsif Ekind
(E
) = E_Constant
7626 and then Ekind
(Etype
(E
)) = E_Task_Type
7627 and then not Has_Completion
(Etype
(E
))
7628 and then Scope
(Etype
(E
)) = Current_Scope
7632 elsif Ekind
(E
) = E_Protected_Object
7633 and then not Has_Completion
(Etype
(E
))
7637 elsif Ekind
(E
) = E_Record_Type
then
7638 if Is_Tagged_Type
(E
) then
7639 Check_Abstract_Overriding
(E
);
7640 Check_Conventions
(E
);
7643 Check_Aliased_Component_Types
(E
);
7645 elsif Ekind
(E
) = E_Array_Type
then
7646 Check_Aliased_Component_Types
(E
);
7652 end Check_Completion
;
7654 ----------------------------
7655 -- Check_Delta_Expression --
7656 ----------------------------
7658 procedure Check_Delta_Expression
(E
: Node_Id
) is
7660 if not (Is_Real_Type
(Etype
(E
))) then
7661 Wrong_Type
(E
, Any_Real
);
7663 elsif not Is_OK_Static_Expression
(E
) then
7664 Flag_Non_Static_Expr
7665 ("non-static expression used for delta value!", E
);
7667 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
7668 Error_Msg_N
("delta expression must be positive", E
);
7674 -- If any of above errors occurred, then replace the incorrect
7675 -- expression by the real 0.1, which should prevent further errors.
7678 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
7679 Analyze_And_Resolve
(E
, Standard_Float
);
7680 end Check_Delta_Expression
;
7682 -----------------------------
7683 -- Check_Digits_Expression --
7684 -----------------------------
7686 procedure Check_Digits_Expression
(E
: Node_Id
) is
7688 if not (Is_Integer_Type
(Etype
(E
))) then
7689 Wrong_Type
(E
, Any_Integer
);
7691 elsif not Is_OK_Static_Expression
(E
) then
7692 Flag_Non_Static_Expr
7693 ("non-static expression used for digits value!", E
);
7695 elsif Expr_Value
(E
) <= 0 then
7696 Error_Msg_N
("digits value must be greater than zero", E
);
7702 -- If any of above errors occurred, then replace the incorrect
7703 -- expression by the integer 1, which should prevent further errors.
7705 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
7706 Analyze_And_Resolve
(E
, Standard_Integer
);
7708 end Check_Digits_Expression
;
7710 --------------------------
7711 -- Check_Initialization --
7712 --------------------------
7714 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
7716 if Is_Limited_Type
(T
)
7717 and then not In_Instance
7718 and then not In_Inlined_Body
7720 if not OK_For_Limited_Init
(Exp
) then
7721 -- In GNAT mode, this is just a warning, to allow it to be
7722 -- evilly turned off. Otherwise it is a real error.
7726 ("cannot initialize entities of limited type?", Exp
);
7729 ("cannot initialize entities of limited type", Exp
);
7730 Explain_Limited_Type
(T
, Exp
);
7734 end Check_Initialization
;
7736 ------------------------------------
7737 -- Check_Or_Process_Discriminants --
7738 ------------------------------------
7740 -- If an incomplete or private type declaration was already given for the
7741 -- type, the discriminants may have already been processed if they were
7742 -- present on the incomplete declaration. In this case a full conformance
7743 -- check is performed otherwise just process them.
7745 procedure Check_Or_Process_Discriminants
7748 Prev
: Entity_Id
:= Empty
)
7751 if Has_Discriminants
(T
) then
7753 -- Make the discriminants visible to component declarations
7760 D
:= First_Discriminant
(T
);
7761 while Present
(D
) loop
7762 Prev
:= Current_Entity
(D
);
7763 Set_Current_Entity
(D
);
7764 Set_Is_Immediately_Visible
(D
);
7765 Set_Homonym
(D
, Prev
);
7767 -- Ada 2005 (AI-230): Access discriminant allowed in
7768 -- non-limited record types.
7770 if Ada_Version
< Ada_05
then
7772 -- This restriction gets applied to the full type here. It
7773 -- has already been applied earlier to the partial view.
7775 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
7778 Next_Discriminant
(D
);
7782 elsif Present
(Discriminant_Specifications
(N
)) then
7783 Process_Discriminants
(N
, Prev
);
7785 end Check_Or_Process_Discriminants
;
7787 ----------------------
7788 -- Check_Real_Bound --
7789 ----------------------
7791 procedure Check_Real_Bound
(Bound
: Node_Id
) is
7793 if not Is_Real_Type
(Etype
(Bound
)) then
7795 ("bound in real type definition must be of real type", Bound
);
7797 elsif not Is_OK_Static_Expression
(Bound
) then
7798 Flag_Non_Static_Expr
7799 ("non-static expression used for real type bound!", Bound
);
7806 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
7808 Resolve
(Bound
, Standard_Float
);
7809 end Check_Real_Bound
;
7811 ------------------------------
7812 -- Complete_Private_Subtype --
7813 ------------------------------
7815 procedure Complete_Private_Subtype
7818 Full_Base
: Entity_Id
;
7819 Related_Nod
: Node_Id
)
7821 Save_Next_Entity
: Entity_Id
;
7822 Save_Homonym
: Entity_Id
;
7825 -- Set semantic attributes for (implicit) private subtype completion.
7826 -- If the full type has no discriminants, then it is a copy of the full
7827 -- view of the base. Otherwise, it is a subtype of the base with a
7828 -- possible discriminant constraint. Save and restore the original
7829 -- Next_Entity field of full to ensure that the calls to Copy_Node
7830 -- do not corrupt the entity chain.
7832 -- Note that the type of the full view is the same entity as the type of
7833 -- the partial view. In this fashion, the subtype has access to the
7834 -- correct view of the parent.
7836 Save_Next_Entity
:= Next_Entity
(Full
);
7837 Save_Homonym
:= Homonym
(Priv
);
7839 case Ekind
(Full_Base
) is
7840 when E_Record_Type |
7846 Copy_Node
(Priv
, Full
);
7848 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
7849 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
7850 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
7853 Copy_Node
(Full_Base
, Full
);
7854 Set_Chars
(Full
, Chars
(Priv
));
7855 Conditional_Delay
(Full
, Priv
);
7856 Set_Sloc
(Full
, Sloc
(Priv
));
7859 Set_Next_Entity
(Full
, Save_Next_Entity
);
7860 Set_Homonym
(Full
, Save_Homonym
);
7861 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
7863 -- Set common attributes for all subtypes
7865 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
7867 -- The Etype of the full view is inconsistent. Gigi needs to see the
7868 -- structural full view, which is what the current scheme gives:
7869 -- the Etype of the full view is the etype of the full base. However,
7870 -- if the full base is a derived type, the full view then looks like
7871 -- a subtype of the parent, not a subtype of the full base. If instead
7874 -- Set_Etype (Full, Full_Base);
7876 -- then we get inconsistencies in the front-end (confusion between
7877 -- views). Several outstanding bugs are related to this ???
7879 Set_Is_First_Subtype
(Full
, False);
7880 Set_Scope
(Full
, Scope
(Priv
));
7881 Set_Size_Info
(Full
, Full_Base
);
7882 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
7883 Set_Is_Itype
(Full
);
7885 -- A subtype of a private-type-without-discriminants, whose full-view
7886 -- has discriminants with default expressions, is not constrained!
7888 if not Has_Discriminants
(Priv
) then
7889 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
7891 if Has_Discriminants
(Full_Base
) then
7892 Set_Discriminant_Constraint
7893 (Full
, Discriminant_Constraint
(Full_Base
));
7895 -- The partial view may have been indefinite, the full view
7898 Set_Has_Unknown_Discriminants
7899 (Full
, Has_Unknown_Discriminants
(Full_Base
));
7903 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
7904 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
7906 -- Freeze the private subtype entity if its parent is delayed, and not
7907 -- already frozen. We skip this processing if the type is an anonymous
7908 -- subtype of a record component, or is the corresponding record of a
7909 -- protected type, since ???
7911 if not Is_Type
(Scope
(Full
)) then
7912 Set_Has_Delayed_Freeze
(Full
,
7913 Has_Delayed_Freeze
(Full_Base
)
7914 and then (not Is_Frozen
(Full_Base
)));
7917 Set_Freeze_Node
(Full
, Empty
);
7918 Set_Is_Frozen
(Full
, False);
7919 Set_Full_View
(Priv
, Full
);
7921 if Has_Discriminants
(Full
) then
7922 Set_Stored_Constraint_From_Discriminant_Constraint
(Full
);
7923 Set_Stored_Constraint
(Priv
, Stored_Constraint
(Full
));
7925 if Has_Unknown_Discriminants
(Full
) then
7926 Set_Discriminant_Constraint
(Full
, No_Elist
);
7930 if Ekind
(Full_Base
) = E_Record_Type
7931 and then Has_Discriminants
(Full_Base
)
7932 and then Has_Discriminants
(Priv
) -- might not, if errors
7933 and then not Has_Unknown_Discriminants
(Priv
)
7934 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
7936 Create_Constrained_Components
7937 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
7939 -- If the full base is itself derived from private, build a congruent
7940 -- subtype of its underlying type, for use by the back end. For a
7941 -- constrained record component, the declaration cannot be placed on
7942 -- the component list, but it must nevertheless be built an analyzed, to
7943 -- supply enough information for Gigi to compute the size of component.
7945 elsif Ekind
(Full_Base
) in Private_Kind
7946 and then Is_Derived_Type
(Full_Base
)
7947 and then Has_Discriminants
(Full_Base
)
7948 and then (Ekind
(Current_Scope
) /= E_Record_Subtype
)
7950 if not Is_Itype
(Priv
)
7952 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
7954 Build_Underlying_Full_View
7955 (Parent
(Priv
), Full
, Etype
(Full_Base
));
7957 elsif Nkind
(Related_Nod
) = N_Component_Declaration
then
7958 Build_Underlying_Full_View
(Related_Nod
, Full
, Etype
(Full_Base
));
7961 elsif Is_Record_Type
(Full_Base
) then
7963 -- Show Full is simply a renaming of Full_Base
7965 Set_Cloned_Subtype
(Full
, Full_Base
);
7968 -- It is unsafe to share to bounds of a scalar type, because the Itype
7969 -- is elaborated on demand, and if a bound is non-static then different
7970 -- orders of elaboration in different units will lead to different
7971 -- external symbols.
7973 if Is_Scalar_Type
(Full_Base
) then
7974 Set_Scalar_Range
(Full
,
7975 Make_Range
(Sloc
(Related_Nod
),
7977 Duplicate_Subexpr_No_Checks
(Type_Low_Bound
(Full_Base
)),
7979 Duplicate_Subexpr_No_Checks
(Type_High_Bound
(Full_Base
))));
7981 -- This completion inherits the bounds of the full parent, but if
7982 -- the parent is an unconstrained floating point type, so is the
7985 if Is_Floating_Point_Type
(Full_Base
) then
7986 Set_Includes_Infinities
7987 (Scalar_Range
(Full
), Has_Infinities
(Full_Base
));
7991 -- ??? It seems that a lot of fields are missing that should be copied
7992 -- from Full_Base to Full. Here are some that are introduced in a
7993 -- non-disruptive way but a cleanup is necessary.
7995 if Is_Tagged_Type
(Full_Base
) then
7996 Set_Is_Tagged_Type
(Full
);
7997 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
7998 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Full_Base
));
8000 -- If this is a subtype of a protected or task type, constrain its
8001 -- corresponding record, unless this is a subtype without constraints,
8002 -- i.e. a simple renaming as with an actual subtype in an instance.
8004 elsif Is_Concurrent_Type
(Full_Base
) then
8005 if Has_Discriminants
(Full
)
8006 and then Present
(Corresponding_Record_Type
(Full_Base
))
8008 not Is_Empty_Elmt_List
(Discriminant_Constraint
(Full
))
8010 Set_Corresponding_Record_Type
(Full
,
8011 Constrain_Corresponding_Record
8012 (Full
, Corresponding_Record_Type
(Full_Base
),
8013 Related_Nod
, Full_Base
));
8016 Set_Corresponding_Record_Type
(Full
,
8017 Corresponding_Record_Type
(Full_Base
));
8020 end Complete_Private_Subtype
;
8022 ----------------------------
8023 -- Constant_Redeclaration --
8024 ----------------------------
8026 procedure Constant_Redeclaration
8031 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
8032 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
8035 procedure Check_Possible_Deferred_Completion
8036 (Prev_Id
: Entity_Id
;
8037 Prev_Obj_Def
: Node_Id
;
8038 Curr_Obj_Def
: Node_Id
);
8039 -- Determine whether the two object definitions describe the partial
8040 -- and the full view of a constrained deferred constant. Generate
8041 -- a subtype for the full view and verify that it statically matches
8042 -- the subtype of the partial view.
8044 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
8045 -- If deferred constant is an access type initialized with an allocator,
8046 -- check whether there is an illegal recursion in the definition,
8047 -- through a default value of some record subcomponent. This is normally
8048 -- detected when generating init procs, but requires this additional
8049 -- mechanism when expansion is disabled.
8051 ----------------------------------------
8052 -- Check_Possible_Deferred_Completion --
8053 ----------------------------------------
8055 procedure Check_Possible_Deferred_Completion
8056 (Prev_Id
: Entity_Id
;
8057 Prev_Obj_Def
: Node_Id
;
8058 Curr_Obj_Def
: Node_Id
)
8061 if Nkind
(Prev_Obj_Def
) = N_Subtype_Indication
8062 and then Present
(Constraint
(Prev_Obj_Def
))
8063 and then Nkind
(Curr_Obj_Def
) = N_Subtype_Indication
8064 and then Present
(Constraint
(Curr_Obj_Def
))
8067 Loc
: constant Source_Ptr
:= Sloc
(N
);
8068 Def_Id
: constant Entity_Id
:=
8069 Make_Defining_Identifier
(Loc
,
8070 New_Internal_Name
('S'));
8071 Decl
: constant Node_Id
:=
8072 Make_Subtype_Declaration
(Loc
,
8073 Defining_Identifier
=>
8075 Subtype_Indication
=>
8076 Relocate_Node
(Curr_Obj_Def
));
8079 Insert_Before_And_Analyze
(N
, Decl
);
8080 Set_Etype
(Id
, Def_Id
);
8082 if not Subtypes_Statically_Match
(Etype
(Prev_Id
), Def_Id
) then
8083 Error_Msg_Sloc
:= Sloc
(Prev_Id
);
8084 Error_Msg_N
("subtype does not statically match deferred " &
8089 end Check_Possible_Deferred_Completion
;
8091 ---------------------------------
8092 -- Check_Recursive_Declaration --
8093 ---------------------------------
8095 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
8099 if Is_Record_Type
(Typ
) then
8100 Comp
:= First_Component
(Typ
);
8101 while Present
(Comp
) loop
8102 if Comes_From_Source
(Comp
) then
8103 if Present
(Expression
(Parent
(Comp
)))
8104 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
8105 and then Entity
(Expression
(Parent
(Comp
))) = Prev
8107 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
8109 ("illegal circularity with declaration for&#",
8113 elsif Is_Record_Type
(Etype
(Comp
)) then
8114 Check_Recursive_Declaration
(Etype
(Comp
));
8118 Next_Component
(Comp
);
8121 end Check_Recursive_Declaration
;
8123 -- Start of processing for Constant_Redeclaration
8126 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
8127 if Nkind
(Object_Definition
8128 (Parent
(Prev
))) = N_Subtype_Indication
8130 -- Find type of new declaration. The constraints of the two
8131 -- views must match statically, but there is no point in
8132 -- creating an itype for the full view.
8134 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
8135 Find_Type
(Subtype_Mark
(Obj_Def
));
8136 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
8139 Find_Type
(Obj_Def
);
8140 New_T
:= Entity
(Obj_Def
);
8146 -- The full view may impose a constraint, even if the partial
8147 -- view does not, so construct the subtype.
8149 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
8154 -- Current declaration is illegal, diagnosed below in Enter_Name
8160 -- If previous full declaration exists, or if a homograph is present,
8161 -- let Enter_Name handle it, either with an error, or with the removal
8162 -- of an overridden implicit subprogram.
8164 if Ekind
(Prev
) /= E_Constant
8165 or else Present
(Expression
(Parent
(Prev
)))
8166 or else Present
(Full_View
(Prev
))
8170 -- Verify that types of both declarations match, or else that both types
8171 -- are anonymous access types whose designated subtypes statically match
8172 -- (as allowed in Ada 2005 by AI-385).
8174 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
)
8176 (Ekind
(Etype
(Prev
)) /= E_Anonymous_Access_Type
8177 or else Ekind
(Etype
(New_T
)) /= E_Anonymous_Access_Type
8178 or else not Subtypes_Statically_Match
8179 (Designated_Type
(Etype
(Prev
)),
8180 Designated_Type
(Etype
(New_T
))))
8182 Error_Msg_Sloc
:= Sloc
(Prev
);
8183 Error_Msg_N
("type does not match declaration#", N
);
8184 Set_Full_View
(Prev
, Id
);
8185 Set_Etype
(Id
, Any_Type
);
8187 -- If so, process the full constant declaration
8190 -- RM 7.4 (6): If the subtype defined by the subtype_indication in
8191 -- the deferred declaration is constrained, then the subtype defined
8192 -- by the subtype_indication in the full declaration shall match it
8195 Check_Possible_Deferred_Completion
8197 Prev_Obj_Def
=> Object_Definition
(Parent
(Prev
)),
8198 Curr_Obj_Def
=> Obj_Def
);
8200 Set_Full_View
(Prev
, Id
);
8201 Set_Is_Public
(Id
, Is_Public
(Prev
));
8202 Set_Is_Internal
(Id
);
8203 Append_Entity
(Id
, Current_Scope
);
8205 -- Check ALIASED present if present before (RM 7.4(7))
8207 if Is_Aliased
(Prev
)
8208 and then not Aliased_Present
(N
)
8210 Error_Msg_Sloc
:= Sloc
(Prev
);
8211 Error_Msg_N
("ALIASED required (see declaration#)", N
);
8214 -- Check that placement is in private part and that the incomplete
8215 -- declaration appeared in the visible part.
8217 if Ekind
(Current_Scope
) = E_Package
8218 and then not In_Private_Part
(Current_Scope
)
8220 Error_Msg_Sloc
:= Sloc
(Prev
);
8221 Error_Msg_N
("full constant for declaration#"
8222 & " must be in private part", N
);
8224 elsif Ekind
(Current_Scope
) = E_Package
8225 and then List_Containing
(Parent
(Prev
))
8226 /= Visible_Declarations
8227 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
8230 ("deferred constant must be declared in visible part",
8234 if Is_Access_Type
(T
)
8235 and then Nkind
(Expression
(N
)) = N_Allocator
8237 Check_Recursive_Declaration
(Designated_Type
(T
));
8240 end Constant_Redeclaration
;
8242 ----------------------
8243 -- Constrain_Access --
8244 ----------------------
8246 procedure Constrain_Access
8247 (Def_Id
: in out Entity_Id
;
8249 Related_Nod
: Node_Id
)
8251 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
8252 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
8253 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
8254 Constraint_OK
: Boolean := True;
8256 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean;
8257 -- Simple predicate to test for defaulted discriminants
8258 -- Shouldn't this be in sem_util???
8260 ---------------------------------
8261 -- Has_Defaulted_Discriminants --
8262 ---------------------------------
8264 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean is
8266 return Has_Discriminants
(Typ
)
8267 and then Present
(First_Discriminant
(Typ
))
8269 (Discriminant_Default_Value
(First_Discriminant
(Typ
)));
8270 end Has_Defaulted_Discriminants
;
8272 -- Start of processing for Constrain_Access
8275 if Is_Array_Type
(Desig_Type
) then
8276 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
8278 elsif (Is_Record_Type
(Desig_Type
)
8279 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
8280 and then not Is_Constrained
(Desig_Type
)
8282 -- ??? The following code is a temporary kludge to ignore a
8283 -- discriminant constraint on access type if it is constraining
8284 -- the current record. Avoid creating the implicit subtype of the
8285 -- record we are currently compiling since right now, we cannot
8286 -- handle these. For now, just return the access type itself.
8288 if Desig_Type
= Current_Scope
8289 and then No
(Def_Id
)
8291 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
8292 Def_Id
:= Entity
(Subtype_Mark
(S
));
8294 -- This call added to ensure that the constraint is analyzed
8295 -- (needed for a B test). Note that we still return early from
8296 -- this procedure to avoid recursive processing. ???
8298 Constrain_Discriminated_Type
8299 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
8303 if Ekind
(T
) = E_General_Access_Type
8304 and then Has_Private_Declaration
(Desig_Type
)
8305 and then In_Open_Scopes
(Scope
(Desig_Type
))
8307 -- Enforce rule that the constraint is illegal if there is
8308 -- an unconstrained view of the designated type. This means
8309 -- that the partial view (either a private type declaration or
8310 -- a derivation from a private type) has no discriminants.
8311 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
8312 -- by ACATS B371001).
8313 -- Rule updated for Ada 2005: the private type is said to have
8314 -- a constrained partial view, given that objects of the type
8318 Pack
: constant Node_Id
:=
8319 Unit_Declaration_Node
(Scope
(Desig_Type
));
8324 if Nkind
(Pack
) = N_Package_Declaration
then
8325 Decls
:= Visible_Declarations
(Specification
(Pack
));
8326 Decl
:= First
(Decls
);
8327 while Present
(Decl
) loop
8328 if (Nkind
(Decl
) = N_Private_Type_Declaration
8330 Chars
(Defining_Identifier
(Decl
)) =
8334 (Nkind
(Decl
) = N_Full_Type_Declaration
8336 Chars
(Defining_Identifier
(Decl
)) =
8338 and then Is_Derived_Type
(Desig_Type
)
8340 Has_Private_Declaration
(Etype
(Desig_Type
)))
8342 if No
(Discriminant_Specifications
(Decl
)) then
8344 ("cannot constrain general access type if " &
8345 "designated type has constrained partial view",
8358 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
8359 For_Access
=> True);
8361 elsif (Is_Task_Type
(Desig_Type
)
8362 or else Is_Protected_Type
(Desig_Type
))
8363 and then not Is_Constrained
(Desig_Type
)
8365 Constrain_Concurrent
8366 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
8369 Error_Msg_N
("invalid constraint on access type", S
);
8370 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
8371 Constraint_OK
:= False;
8375 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
8377 Set_Ekind
(Def_Id
, E_Access_Subtype
);
8380 if Constraint_OK
then
8381 Set_Etype
(Def_Id
, Base_Type
(T
));
8383 if Is_Private_Type
(Desig_Type
) then
8384 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
8387 Set_Etype
(Def_Id
, Any_Type
);
8390 Set_Size_Info
(Def_Id
, T
);
8391 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
8392 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
8393 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8394 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
8396 Conditional_Delay
(Def_Id
, T
);
8398 -- AI-363 : Subtypes of general access types whose designated types have
8399 -- default discriminants are disallowed. In instances, the rule has to
8400 -- be checked against the actual, of which T is the subtype. In a
8401 -- generic body, the rule is checked assuming that the actual type has
8402 -- defaulted discriminants.
8404 if Ada_Version
>= Ada_05
then
8405 if Ekind
(Base_Type
(T
)) = E_General_Access_Type
8406 and then Has_Defaulted_Discriminants
(Desig_Type
)
8409 ("access subype of general access type not allowed", S
);
8410 Error_Msg_N
("\discriminants have defaults", S
);
8412 elsif Is_Access_Type
(T
)
8413 and then Is_Generic_Type
(Desig_Type
)
8414 and then Has_Discriminants
(Desig_Type
)
8415 and then In_Package_Body
(Current_Scope
)
8417 Error_Msg_N
("access subtype not allowed in generic body", S
);
8419 ("\designated type is a discriminated formal", S
);
8422 end Constrain_Access
;
8424 ---------------------
8425 -- Constrain_Array --
8426 ---------------------
8428 procedure Constrain_Array
8429 (Def_Id
: in out Entity_Id
;
8431 Related_Nod
: Node_Id
;
8432 Related_Id
: Entity_Id
;
8435 C
: constant Node_Id
:= Constraint
(SI
);
8436 Number_Of_Constraints
: Nat
:= 0;
8439 Constraint_OK
: Boolean := True;
8442 T
:= Entity
(Subtype_Mark
(SI
));
8444 if Ekind
(T
) in Access_Kind
then
8445 T
:= Designated_Type
(T
);
8448 -- If an index constraint follows a subtype mark in a subtype indication
8449 -- then the type or subtype denoted by the subtype mark must not already
8450 -- impose an index constraint. The subtype mark must denote either an
8451 -- unconstrained array type or an access type whose designated type
8452 -- is such an array type... (RM 3.6.1)
8454 if Is_Constrained
(T
) then
8456 ("array type is already constrained", Subtype_Mark
(SI
));
8457 Constraint_OK
:= False;
8460 S
:= First
(Constraints
(C
));
8461 while Present
(S
) loop
8462 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
8466 -- In either case, the index constraint must provide a discrete
8467 -- range for each index of the array type and the type of each
8468 -- discrete range must be the same as that of the corresponding
8469 -- index. (RM 3.6.1)
8471 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
8472 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
8473 Constraint_OK
:= False;
8476 S
:= First
(Constraints
(C
));
8477 Index
:= First_Index
(T
);
8480 -- Apply constraints to each index type
8482 for J
in 1 .. Number_Of_Constraints
loop
8483 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
8493 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
8494 Set_Parent
(Def_Id
, Related_Nod
);
8497 Set_Ekind
(Def_Id
, E_Array_Subtype
);
8500 Set_Size_Info
(Def_Id
, (T
));
8501 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
8502 Set_Etype
(Def_Id
, Base_Type
(T
));
8504 if Constraint_OK
then
8505 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
8507 Set_First_Index
(Def_Id
, First_Index
(T
));
8510 Set_Is_Constrained
(Def_Id
, True);
8511 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
8512 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8514 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
8515 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
8517 -- Build a freeze node if parent still needs one. Also, make sure
8518 -- that the Depends_On_Private status is set because the subtype
8519 -- will need reprocessing at the time the base type does.
8520 -- and also that a conditional delay is set.
8522 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
8523 Conditional_Delay
(Def_Id
, T
);
8525 end Constrain_Array
;
8527 ------------------------------
8528 -- Constrain_Component_Type --
8529 ------------------------------
8531 function Constrain_Component_Type
8533 Constrained_Typ
: Entity_Id
;
8534 Related_Node
: Node_Id
;
8536 Constraints
: Elist_Id
) return Entity_Id
8538 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
8539 Compon_Type
: constant Entity_Id
:= Etype
(Comp
);
8541 function Build_Constrained_Array_Type
8542 (Old_Type
: Entity_Id
) return Entity_Id
;
8543 -- If Old_Type is an array type, one of whose indices is constrained
8544 -- by a discriminant, build an Itype whose constraint replaces the
8545 -- discriminant with its value in the constraint.
8547 function Build_Constrained_Discriminated_Type
8548 (Old_Type
: Entity_Id
) return Entity_Id
;
8549 -- Ditto for record components
8551 function Build_Constrained_Access_Type
8552 (Old_Type
: Entity_Id
) return Entity_Id
;
8553 -- Ditto for access types. Makes use of previous two functions, to
8554 -- constrain designated type.
8556 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
8557 -- T is an array or discriminated type, C is a list of constraints
8558 -- that apply to T. This routine builds the constrained subtype.
8560 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
8561 -- Returns True if Expr is a discriminant
8563 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
8564 -- Find the value of discriminant Discrim in Constraint
8566 -----------------------------------
8567 -- Build_Constrained_Access_Type --
8568 -----------------------------------
8570 function Build_Constrained_Access_Type
8571 (Old_Type
: Entity_Id
) return Entity_Id
8573 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
8575 Desig_Subtype
: Entity_Id
;
8579 -- if the original access type was not embedded in the enclosing
8580 -- type definition, there is no need to produce a new access
8581 -- subtype. In fact every access type with an explicit constraint
8582 -- generates an itype whose scope is the enclosing record.
8584 if not Is_Type
(Scope
(Old_Type
)) then
8587 elsif Is_Array_Type
(Desig_Type
) then
8588 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
8590 elsif Has_Discriminants
(Desig_Type
) then
8592 -- This may be an access type to an enclosing record type for
8593 -- which we are constructing the constrained components. Return
8594 -- the enclosing record subtype. This is not always correct,
8595 -- but avoids infinite recursion. ???
8597 Desig_Subtype
:= Any_Type
;
8599 for J
in reverse 0 .. Scope_Stack
.Last
loop
8600 Scop
:= Scope_Stack
.Table
(J
).Entity
;
8603 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
8605 Desig_Subtype
:= Scop
;
8608 exit when not Is_Type
(Scop
);
8611 if Desig_Subtype
= Any_Type
then
8613 Build_Constrained_Discriminated_Type
(Desig_Type
);
8620 if Desig_Subtype
/= Desig_Type
then
8622 -- The Related_Node better be here or else we won't be able
8623 -- to attach new itypes to a node in the tree.
8625 pragma Assert
(Present
(Related_Node
));
8627 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
8629 Set_Etype
(Itype
, Base_Type
(Old_Type
));
8630 Set_Size_Info
(Itype
, (Old_Type
));
8631 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
8632 Set_Depends_On_Private
(Itype
, Has_Private_Component
8634 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
8637 -- The new itype needs freezing when it depends on a not frozen
8638 -- type and the enclosing subtype needs freezing.
8640 if Has_Delayed_Freeze
(Constrained_Typ
)
8641 and then not Is_Frozen
(Constrained_Typ
)
8643 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
8651 end Build_Constrained_Access_Type
;
8653 ----------------------------------
8654 -- Build_Constrained_Array_Type --
8655 ----------------------------------
8657 function Build_Constrained_Array_Type
8658 (Old_Type
: Entity_Id
) return Entity_Id
8662 Old_Index
: Node_Id
;
8663 Range_Node
: Node_Id
;
8664 Constr_List
: List_Id
;
8666 Need_To_Create_Itype
: Boolean := False;
8669 Old_Index
:= First_Index
(Old_Type
);
8670 while Present
(Old_Index
) loop
8671 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8673 if Is_Discriminant
(Lo_Expr
)
8674 or else Is_Discriminant
(Hi_Expr
)
8676 Need_To_Create_Itype
:= True;
8679 Next_Index
(Old_Index
);
8682 if Need_To_Create_Itype
then
8683 Constr_List
:= New_List
;
8685 Old_Index
:= First_Index
(Old_Type
);
8686 while Present
(Old_Index
) loop
8687 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
8689 if Is_Discriminant
(Lo_Expr
) then
8690 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
8693 if Is_Discriminant
(Hi_Expr
) then
8694 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
8699 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
8701 Append
(Range_Node
, To
=> Constr_List
);
8703 Next_Index
(Old_Index
);
8706 return Build_Subtype
(Old_Type
, Constr_List
);
8711 end Build_Constrained_Array_Type
;
8713 ------------------------------------------
8714 -- Build_Constrained_Discriminated_Type --
8715 ------------------------------------------
8717 function Build_Constrained_Discriminated_Type
8718 (Old_Type
: Entity_Id
) return Entity_Id
8721 Constr_List
: List_Id
;
8722 Old_Constraint
: Elmt_Id
;
8724 Need_To_Create_Itype
: Boolean := False;
8727 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8728 while Present
(Old_Constraint
) loop
8729 Expr
:= Node
(Old_Constraint
);
8731 if Is_Discriminant
(Expr
) then
8732 Need_To_Create_Itype
:= True;
8735 Next_Elmt
(Old_Constraint
);
8738 if Need_To_Create_Itype
then
8739 Constr_List
:= New_List
;
8741 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
8742 while Present
(Old_Constraint
) loop
8743 Expr
:= Node
(Old_Constraint
);
8745 if Is_Discriminant
(Expr
) then
8746 Expr
:= Get_Discr_Value
(Expr
);
8749 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
8751 Next_Elmt
(Old_Constraint
);
8754 return Build_Subtype
(Old_Type
, Constr_List
);
8759 end Build_Constrained_Discriminated_Type
;
8765 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
8767 Subtyp_Decl
: Node_Id
;
8769 Btyp
: Entity_Id
:= Base_Type
(T
);
8772 -- The Related_Node better be here or else we won't be able to
8773 -- attach new itypes to a node in the tree.
8775 pragma Assert
(Present
(Related_Node
));
8777 -- If the view of the component's type is incomplete or private
8778 -- with unknown discriminants, then the constraint must be applied
8779 -- to the full type.
8781 if Has_Unknown_Discriminants
(Btyp
)
8782 and then Present
(Underlying_Type
(Btyp
))
8784 Btyp
:= Underlying_Type
(Btyp
);
8788 Make_Subtype_Indication
(Loc
,
8789 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
8790 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
8792 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
8795 Make_Subtype_Declaration
(Loc
,
8796 Defining_Identifier
=> Def_Id
,
8797 Subtype_Indication
=> Indic
);
8799 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
8801 -- Itypes must be analyzed with checks off (see package Itypes)
8803 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
8808 ---------------------
8809 -- Get_Discr_Value --
8810 ---------------------
8812 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
8818 -- The discriminant may be declared for the type, in which case we
8819 -- find it by iterating over the list of discriminants. If the
8820 -- discriminant is inherited from a parent type, it appears as the
8821 -- corresponding discriminant of the current type. This will be the
8822 -- case when constraining an inherited component whose constraint is
8823 -- given by a discriminant of the parent.
8825 D
:= First_Discriminant
(Typ
);
8826 E
:= First_Elmt
(Constraints
);
8828 while Present
(D
) loop
8829 if D
= Entity
(Discrim
)
8830 or else D
= CR_Discriminant
(Entity
(Discrim
))
8831 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
8836 Next_Discriminant
(D
);
8840 -- The corresponding_Discriminant mechanism is incomplete, because
8841 -- the correspondence between new and old discriminants is not one
8842 -- to one: one new discriminant can constrain several old ones. In
8843 -- that case, scan sequentially the stored_constraint, the list of
8844 -- discriminants of the parents, and the constraints.
8846 if Is_Derived_Type
(Typ
)
8847 and then Present
(Stored_Constraint
(Typ
))
8848 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
8850 D
:= First_Discriminant
(Etype
(Typ
));
8851 E
:= First_Elmt
(Constraints
);
8852 G
:= First_Elmt
(Stored_Constraint
(Typ
));
8853 while Present
(D
) loop
8854 if D
= Entity
(Discrim
) then
8858 Next_Discriminant
(D
);
8864 -- Something is wrong if we did not find the value
8866 raise Program_Error
;
8867 end Get_Discr_Value
;
8869 ---------------------
8870 -- Is_Discriminant --
8871 ---------------------
8873 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
8874 Discrim_Scope
: Entity_Id
;
8877 if Denotes_Discriminant
(Expr
) then
8878 Discrim_Scope
:= Scope
(Entity
(Expr
));
8880 -- Either we have a reference to one of Typ's discriminants,
8882 pragma Assert
(Discrim_Scope
= Typ
8884 -- or to the discriminants of the parent type, in the case
8885 -- of a derivation of a tagged type with variants.
8887 or else Discrim_Scope
= Etype
(Typ
)
8888 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
8890 -- or same as above for the case where the discriminants
8891 -- were declared in Typ's private view.
8893 or else (Is_Private_Type
(Discrim_Scope
)
8894 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8896 -- or else we are deriving from the full view and the
8897 -- discriminant is declared in the private entity.
8899 or else (Is_Private_Type
(Typ
)
8900 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
8902 -- Or we are constrained the corresponding record of a
8903 -- synchronized type that completes a private declaration.
8905 or else (Is_Concurrent_Record_Type
(Typ
)
8907 Corresponding_Concurrent_Type
(Typ
) = Discrim_Scope
)
8909 -- or we have a class-wide type, in which case make sure the
8910 -- discriminant found belongs to the root type.
8912 or else (Is_Class_Wide_Type
(Typ
)
8913 and then Etype
(Typ
) = Discrim_Scope
));
8918 -- In all other cases we have something wrong
8921 end Is_Discriminant
;
8923 -- Start of processing for Constrain_Component_Type
8926 if Nkind
(Parent
(Comp
)) = N_Component_Declaration
8927 and then Comes_From_Source
(Parent
(Comp
))
8928 and then Comes_From_Source
8929 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8932 (Subtype_Indication
(Component_Definition
(Parent
(Comp
))))
8936 elsif Is_Array_Type
(Compon_Type
) then
8937 return Build_Constrained_Array_Type
(Compon_Type
);
8939 elsif Has_Discriminants
(Compon_Type
) then
8940 return Build_Constrained_Discriminated_Type
(Compon_Type
);
8942 elsif Is_Access_Type
(Compon_Type
) then
8943 return Build_Constrained_Access_Type
(Compon_Type
);
8948 end Constrain_Component_Type
;
8950 --------------------------
8951 -- Constrain_Concurrent --
8952 --------------------------
8954 -- For concurrent types, the associated record value type carries the same
8955 -- discriminants, so when we constrain a concurrent type, we must constrain
8956 -- the corresponding record type as well.
8958 procedure Constrain_Concurrent
8959 (Def_Id
: in out Entity_Id
;
8961 Related_Nod
: Node_Id
;
8962 Related_Id
: Entity_Id
;
8965 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
8969 if Ekind
(T_Ent
) in Access_Kind
then
8970 T_Ent
:= Designated_Type
(T_Ent
);
8973 T_Val
:= Corresponding_Record_Type
(T_Ent
);
8975 if Present
(T_Val
) then
8978 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8981 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8983 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
8984 Set_Corresponding_Record_Type
(Def_Id
,
8985 Constrain_Corresponding_Record
8986 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
8989 -- If there is no associated record, expansion is disabled and this
8990 -- is a generic context. Create a subtype in any case, so that
8991 -- semantic analysis can proceed.
8994 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
8997 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
8999 end Constrain_Concurrent
;
9001 ------------------------------------
9002 -- Constrain_Corresponding_Record --
9003 ------------------------------------
9005 function Constrain_Corresponding_Record
9006 (Prot_Subt
: Entity_Id
;
9007 Corr_Rec
: Entity_Id
;
9008 Related_Nod
: Node_Id
;
9009 Related_Id
: Entity_Id
) return Entity_Id
9011 T_Sub
: constant Entity_Id
:=
9012 Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
9015 Set_Etype
(T_Sub
, Corr_Rec
);
9016 Init_Size_Align
(T_Sub
);
9017 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
9018 Set_Is_Constrained
(T_Sub
, True);
9019 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
9020 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
9022 -- As elsewhere, we do not want to create a freeze node for this itype
9023 -- if it is created for a constrained component of an enclosing record
9024 -- because references to outer discriminants will appear out of scope.
9026 if Ekind
(Scope
(Prot_Subt
)) /= E_Record_Type
then
9027 Conditional_Delay
(T_Sub
, Corr_Rec
);
9029 Set_Is_Frozen
(T_Sub
);
9032 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
9033 Set_Discriminant_Constraint
9034 (T_Sub
, Discriminant_Constraint
(Prot_Subt
));
9035 Set_Stored_Constraint_From_Discriminant_Constraint
(T_Sub
);
9036 Create_Constrained_Components
9037 (T_Sub
, Related_Nod
, Corr_Rec
, Discriminant_Constraint
(T_Sub
));
9040 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
9043 end Constrain_Corresponding_Record
;
9045 -----------------------
9046 -- Constrain_Decimal --
9047 -----------------------
9049 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
9050 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9051 C
: constant Node_Id
:= Constraint
(S
);
9052 Loc
: constant Source_Ptr
:= Sloc
(C
);
9053 Range_Expr
: Node_Id
;
9054 Digits_Expr
: Node_Id
;
9059 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
9061 if Nkind
(C
) = N_Range_Constraint
then
9062 Range_Expr
:= Range_Expression
(C
);
9063 Digits_Val
:= Digits_Value
(T
);
9066 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
9067 Digits_Expr
:= Digits_Expression
(C
);
9068 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
9070 Check_Digits_Expression
(Digits_Expr
);
9071 Digits_Val
:= Expr_Value
(Digits_Expr
);
9073 if Digits_Val
> Digits_Value
(T
) then
9075 ("digits expression is incompatible with subtype", C
);
9076 Digits_Val
:= Digits_Value
(T
);
9079 if Present
(Range_Constraint
(C
)) then
9080 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
9082 Range_Expr
:= Empty
;
9086 Set_Etype
(Def_Id
, Base_Type
(T
));
9087 Set_Size_Info
(Def_Id
, (T
));
9088 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9089 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9090 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
9091 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9092 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
9093 Set_Digits_Value
(Def_Id
, Digits_Val
);
9095 -- Manufacture range from given digits value if no range present
9097 if No
(Range_Expr
) then
9098 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
9102 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
9104 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
9107 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
9108 Set_Discrete_RM_Size
(Def_Id
);
9110 -- Unconditionally delay the freeze, since we cannot set size
9111 -- information in all cases correctly until the freeze point.
9113 Set_Has_Delayed_Freeze
(Def_Id
);
9114 end Constrain_Decimal
;
9116 ----------------------------------
9117 -- Constrain_Discriminated_Type --
9118 ----------------------------------
9120 procedure Constrain_Discriminated_Type
9121 (Def_Id
: Entity_Id
;
9123 Related_Nod
: Node_Id
;
9124 For_Access
: Boolean := False)
9126 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9129 Elist
: Elist_Id
:= New_Elmt_List
;
9131 procedure Fixup_Bad_Constraint
;
9132 -- This is called after finding a bad constraint, and after having
9133 -- posted an appropriate error message. The mission is to leave the
9134 -- entity T in as reasonable state as possible!
9136 --------------------------
9137 -- Fixup_Bad_Constraint --
9138 --------------------------
9140 procedure Fixup_Bad_Constraint
is
9142 -- Set a reasonable Ekind for the entity. For an incomplete type,
9143 -- we can't do much, but for other types, we can set the proper
9144 -- corresponding subtype kind.
9146 if Ekind
(T
) = E_Incomplete_Type
then
9147 Set_Ekind
(Def_Id
, Ekind
(T
));
9149 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
9152 Set_Etype
(Def_Id
, Any_Type
);
9153 Set_Error_Posted
(Def_Id
);
9154 end Fixup_Bad_Constraint
;
9156 -- Start of processing for Constrain_Discriminated_Type
9159 C
:= Constraint
(S
);
9161 -- A discriminant constraint is only allowed in a subtype indication,
9162 -- after a subtype mark. This subtype mark must denote either a type
9163 -- with discriminants, or an access type whose designated type is a
9164 -- type with discriminants. A discriminant constraint specifies the
9165 -- values of these discriminants (RM 3.7.2(5)).
9167 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
9169 if Ekind
(T
) in Access_Kind
then
9170 T
:= Designated_Type
(T
);
9173 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
9174 -- Avoid generating an error for access-to-incomplete subtypes.
9176 if Ada_Version
>= Ada_05
9177 and then Ekind
(T
) = E_Incomplete_Type
9178 and then Nkind
(Parent
(S
)) = N_Subtype_Declaration
9179 and then not Is_Itype
(Def_Id
)
9181 -- A little sanity check, emit an error message if the type
9182 -- has discriminants to begin with. Type T may be a regular
9183 -- incomplete type or imported via a limited with clause.
9185 if Has_Discriminants
(T
)
9188 and then Present
(Non_Limited_View
(T
))
9189 and then Nkind
(Parent
(Non_Limited_View
(T
))) =
9190 N_Full_Type_Declaration
9191 and then Present
(Discriminant_Specifications
9192 (Parent
(Non_Limited_View
(T
)))))
9195 ("(Ada 2005) incomplete subtype may not be constrained", C
);
9198 ("invalid constraint: type has no discriminant", C
);
9201 Fixup_Bad_Constraint
;
9204 -- Check that the type has visible discriminants. The type may be
9205 -- a private type with unknown discriminants whose full view has
9206 -- discriminants which are invisible.
9208 elsif not Has_Discriminants
(T
)
9210 (Has_Unknown_Discriminants
(T
)
9211 and then Is_Private_Type
(T
))
9213 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
9214 Fixup_Bad_Constraint
;
9217 elsif Is_Constrained
(E
)
9218 or else (Ekind
(E
) = E_Class_Wide_Subtype
9219 and then Present
(Discriminant_Constraint
(E
)))
9221 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
9222 Fixup_Bad_Constraint
;
9226 -- T may be an unconstrained subtype (e.g. a generic actual).
9227 -- Constraint applies to the base type.
9231 Elist
:= Build_Discriminant_Constraints
(T
, S
);
9233 -- If the list returned was empty we had an error in building the
9234 -- discriminant constraint. We have also already signalled an error
9235 -- in the incomplete type case
9237 if Is_Empty_Elmt_List
(Elist
) then
9238 Fixup_Bad_Constraint
;
9242 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
9243 end Constrain_Discriminated_Type
;
9245 ---------------------------
9246 -- Constrain_Enumeration --
9247 ---------------------------
9249 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
9250 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9251 C
: constant Node_Id
:= Constraint
(S
);
9254 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9256 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
9258 Set_Etype
(Def_Id
, Base_Type
(T
));
9259 Set_Size_Info
(Def_Id
, (T
));
9260 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9261 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9263 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9265 Set_Discrete_RM_Size
(Def_Id
);
9266 end Constrain_Enumeration
;
9268 ----------------------
9269 -- Constrain_Float --
9270 ----------------------
9272 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
9273 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9279 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
9281 Set_Etype
(Def_Id
, Base_Type
(T
));
9282 Set_Size_Info
(Def_Id
, (T
));
9283 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9285 -- Process the constraint
9287 C
:= Constraint
(S
);
9289 -- Digits constraint present
9291 if Nkind
(C
) = N_Digits_Constraint
then
9292 Check_Restriction
(No_Obsolescent_Features
, C
);
9294 if Warn_On_Obsolescent_Feature
then
9296 ("subtype digits constraint is an " &
9297 "obsolescent feature ('R'M 'J.3(8))?", C
);
9300 D
:= Digits_Expression
(C
);
9301 Analyze_And_Resolve
(D
, Any_Integer
);
9302 Check_Digits_Expression
(D
);
9303 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
9305 -- Check that digits value is in range. Obviously we can do this
9306 -- at compile time, but it is strictly a runtime check, and of
9307 -- course there is an ACVC test that checks this!
9309 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
9310 Error_Msg_Uint_1
:= Digits_Value
(T
);
9311 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
9313 Make_Raise_Constraint_Error
(Sloc
(D
),
9314 Reason
=> CE_Range_Check_Failed
);
9315 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9318 C
:= Range_Constraint
(C
);
9320 -- No digits constraint present
9323 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
9326 -- Range constraint present
9328 if Nkind
(C
) = N_Range_Constraint
then
9329 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9331 -- No range constraint present
9334 pragma Assert
(No
(C
));
9335 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9338 Set_Is_Constrained
(Def_Id
);
9339 end Constrain_Float
;
9341 ---------------------
9342 -- Constrain_Index --
9343 ---------------------
9345 procedure Constrain_Index
9348 Related_Nod
: Node_Id
;
9349 Related_Id
: Entity_Id
;
9354 R
: Node_Id
:= Empty
;
9355 T
: constant Entity_Id
:= Etype
(Index
);
9358 if Nkind
(S
) = N_Range
9360 (Nkind
(S
) = N_Attribute_Reference
9361 and then Attribute_Name
(S
) = Name_Range
)
9363 -- A Range attribute will transformed into N_Range by Resolve
9369 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
);
9371 if not Error_Posted
(S
)
9373 (Nkind
(S
) /= N_Range
9374 or else not Covers
(T
, (Etype
(Low_Bound
(S
))))
9375 or else not Covers
(T
, (Etype
(High_Bound
(S
)))))
9377 if Base_Type
(T
) /= Any_Type
9378 and then Etype
(Low_Bound
(S
)) /= Any_Type
9379 and then Etype
(High_Bound
(S
)) /= Any_Type
9381 Error_Msg_N
("range expected", S
);
9385 elsif Nkind
(S
) = N_Subtype_Indication
then
9387 -- The parser has verified that this is a discrete indication
9389 Resolve_Discrete_Subtype_Indication
(S
, T
);
9390 R
:= Range_Expression
(Constraint
(S
));
9392 elsif Nkind
(S
) = N_Discriminant_Association
then
9394 -- Syntactically valid in subtype indication
9396 Error_Msg_N
("invalid index constraint", S
);
9397 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9400 -- Subtype_Mark case, no anonymous subtypes to construct
9405 if Is_Entity_Name
(S
) then
9406 if not Is_Type
(Entity
(S
)) then
9407 Error_Msg_N
("expect subtype mark for index constraint", S
);
9409 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
9410 Wrong_Type
(S
, Base_Type
(T
));
9416 Error_Msg_N
("invalid index constraint", S
);
9417 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
9423 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
9425 Set_Etype
(Def_Id
, Base_Type
(T
));
9427 if Is_Modular_Integer_Type
(T
) then
9428 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9430 elsif Is_Integer_Type
(T
) then
9431 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9434 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
9435 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
9438 Set_Size_Info
(Def_Id
, (T
));
9439 Set_RM_Size
(Def_Id
, RM_Size
(T
));
9440 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9442 Set_Scalar_Range
(Def_Id
, R
);
9444 Set_Etype
(S
, Def_Id
);
9445 Set_Discrete_RM_Size
(Def_Id
);
9446 end Constrain_Index
;
9448 -----------------------
9449 -- Constrain_Integer --
9450 -----------------------
9452 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
9453 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9454 C
: constant Node_Id
:= Constraint
(S
);
9457 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9459 if Is_Modular_Integer_Type
(T
) then
9460 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
9462 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
9465 Set_Etype
(Def_Id
, Base_Type
(T
));
9466 Set_Size_Info
(Def_Id
, (T
));
9467 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9468 Set_Discrete_RM_Size
(Def_Id
);
9469 end Constrain_Integer
;
9471 ------------------------------
9472 -- Constrain_Ordinary_Fixed --
9473 ------------------------------
9475 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
9476 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
9482 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
9483 Set_Etype
(Def_Id
, Base_Type
(T
));
9484 Set_Size_Info
(Def_Id
, (T
));
9485 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
9486 Set_Small_Value
(Def_Id
, Small_Value
(T
));
9488 -- Process the constraint
9490 C
:= Constraint
(S
);
9492 -- Delta constraint present
9494 if Nkind
(C
) = N_Delta_Constraint
then
9495 Check_Restriction
(No_Obsolescent_Features
, C
);
9497 if Warn_On_Obsolescent_Feature
then
9499 ("subtype delta constraint is an " &
9500 "obsolescent feature ('R'M 'J.3(7))?");
9503 D
:= Delta_Expression
(C
);
9504 Analyze_And_Resolve
(D
, Any_Real
);
9505 Check_Delta_Expression
(D
);
9506 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
9508 -- Check that delta value is in range. Obviously we can do this
9509 -- at compile time, but it is strictly a runtime check, and of
9510 -- course there is an ACVC test that checks this!
9512 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
9513 Error_Msg_N
("?delta value is too small", D
);
9515 Make_Raise_Constraint_Error
(Sloc
(D
),
9516 Reason
=> CE_Range_Check_Failed
);
9517 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
9520 C
:= Range_Constraint
(C
);
9522 -- No delta constraint present
9525 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
9528 -- Range constraint present
9530 if Nkind
(C
) = N_Range_Constraint
then
9531 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
9533 -- No range constraint present
9536 pragma Assert
(No
(C
));
9537 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
9541 Set_Discrete_RM_Size
(Def_Id
);
9543 -- Unconditionally delay the freeze, since we cannot set size
9544 -- information in all cases correctly until the freeze point.
9546 Set_Has_Delayed_Freeze
(Def_Id
);
9547 end Constrain_Ordinary_Fixed
;
9549 ---------------------------
9550 -- Convert_Scalar_Bounds --
9551 ---------------------------
9553 procedure Convert_Scalar_Bounds
9555 Parent_Type
: Entity_Id
;
9556 Derived_Type
: Entity_Id
;
9559 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
9566 Lo
:= Build_Scalar_Bound
9567 (Type_Low_Bound
(Derived_Type
),
9568 Parent_Type
, Implicit_Base
);
9570 Hi
:= Build_Scalar_Bound
9571 (Type_High_Bound
(Derived_Type
),
9572 Parent_Type
, Implicit_Base
);
9579 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
9581 Set_Parent
(Rng
, N
);
9582 Set_Scalar_Range
(Derived_Type
, Rng
);
9584 -- Analyze the bounds
9586 Analyze_And_Resolve
(Lo
, Implicit_Base
);
9587 Analyze_And_Resolve
(Hi
, Implicit_Base
);
9589 -- Analyze the range itself, except that we do not analyze it if
9590 -- the bounds are real literals, and we have a fixed-point type.
9591 -- The reason for this is that we delay setting the bounds in this
9592 -- case till we know the final Small and Size values (see circuit
9593 -- in Freeze.Freeze_Fixed_Point_Type for further details).
9595 if Is_Fixed_Point_Type
(Parent_Type
)
9596 and then Nkind
(Lo
) = N_Real_Literal
9597 and then Nkind
(Hi
) = N_Real_Literal
9601 -- Here we do the analysis of the range
9603 -- Note: we do this manually, since if we do a normal Analyze and
9604 -- Resolve call, there are problems with the conversions used for
9605 -- the derived type range.
9608 Set_Etype
(Rng
, Implicit_Base
);
9609 Set_Analyzed
(Rng
, True);
9611 end Convert_Scalar_Bounds
;
9617 procedure Copy_And_Swap
(Priv
, Full
: Entity_Id
) is
9619 -- Initialize new full declaration entity by copying the pertinent
9620 -- fields of the corresponding private declaration entity.
9622 -- We temporarily set Ekind to a value appropriate for a type to
9623 -- avoid assert failures in Einfo from checking for setting type
9624 -- attributes on something that is not a type. Ekind (Priv) is an
9625 -- appropriate choice, since it allowed the attributes to be set
9626 -- in the first place. This Ekind value will be modified later.
9628 Set_Ekind
(Full
, Ekind
(Priv
));
9630 -- Also set Etype temporarily to Any_Type, again, in the absence
9631 -- of errors, it will be properly reset, and if there are errors,
9632 -- then we want a value of Any_Type to remain.
9634 Set_Etype
(Full
, Any_Type
);
9636 -- Now start copying attributes
9638 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
9640 if Has_Discriminants
(Full
) then
9641 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
9642 Set_Stored_Constraint
(Full
, Stored_Constraint
(Priv
));
9645 Set_First_Rep_Item
(Full
, First_Rep_Item
(Priv
));
9646 Set_Homonym
(Full
, Homonym
(Priv
));
9647 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
9648 Set_Is_Public
(Full
, Is_Public
(Priv
));
9649 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
9650 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
9652 Conditional_Delay
(Full
, Priv
);
9654 if Is_Tagged_Type
(Full
) then
9655 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
9657 if Priv
= Base_Type
(Priv
) then
9658 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
9662 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
9663 Set_Treat_As_Volatile
(Full
, Treat_As_Volatile
(Priv
));
9664 Set_Scope
(Full
, Scope
(Priv
));
9665 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
9666 Set_First_Entity
(Full
, First_Entity
(Priv
));
9667 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
9669 -- If access types have been recorded for later handling, keep them in
9670 -- the full view so that they get handled when the full view freeze
9671 -- node is expanded.
9673 if Present
(Freeze_Node
(Priv
))
9674 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
9676 Ensure_Freeze_Node
(Full
);
9677 Set_Access_Types_To_Process
9678 (Freeze_Node
(Full
),
9679 Access_Types_To_Process
(Freeze_Node
(Priv
)));
9682 -- Swap the two entities. Now Privat is the full type entity and
9683 -- Full is the private one. They will be swapped back at the end
9684 -- of the private part. This swapping ensures that the entity that
9685 -- is visible in the private part is the full declaration.
9687 Exchange_Entities
(Priv
, Full
);
9688 Append_Entity
(Full
, Scope
(Full
));
9691 -------------------------------------
9692 -- Copy_Array_Base_Type_Attributes --
9693 -------------------------------------
9695 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
9697 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
9698 Set_Component_Type
(T1
, Component_Type
(T2
));
9699 Set_Component_Size
(T1
, Component_Size
(T2
));
9700 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
9701 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
9702 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
9703 Set_Has_Task
(T1
, Has_Task
(T2
));
9704 Set_Is_Packed
(T1
, Is_Packed
(T2
));
9705 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
9706 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
9707 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
9708 end Copy_Array_Base_Type_Attributes
;
9710 -----------------------------------
9711 -- Copy_Array_Subtype_Attributes --
9712 -----------------------------------
9714 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
9716 Set_Size_Info
(T1
, T2
);
9718 Set_First_Index
(T1
, First_Index
(T2
));
9719 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
9720 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
9721 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
9722 Set_Treat_As_Volatile
(T1
, Treat_As_Volatile
(T2
));
9723 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
9724 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
9725 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
9726 Set_Convention
(T1
, Convention
(T2
));
9727 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
9728 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
9729 end Copy_Array_Subtype_Attributes
;
9731 -----------------------------------
9732 -- Create_Constrained_Components --
9733 -----------------------------------
9735 procedure Create_Constrained_Components
9737 Decl_Node
: Node_Id
;
9739 Constraints
: Elist_Id
)
9741 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
9742 Comp_List
: constant Elist_Id
:= New_Elmt_List
;
9743 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
9744 Assoc_List
: constant List_Id
:= New_List
;
9745 Discr_Val
: Elmt_Id
;
9749 Is_Static
: Boolean := True;
9751 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
9752 -- Collect parent type components that do not appear in a variant part
9754 procedure Create_All_Components
;
9755 -- Iterate over Comp_List to create the components of the subtype
9757 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
9758 -- Creates a new component from Old_Compon, copying all the fields from
9759 -- it, including its Etype, inserts the new component in the Subt entity
9760 -- chain and returns the new component.
9762 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
9763 -- If true, and discriminants are static, collect only components from
9764 -- variants selected by discriminant values.
9766 ------------------------------
9767 -- Collect_Fixed_Components --
9768 ------------------------------
9770 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
9772 -- Build association list for discriminants, and find components of the
9773 -- variant part selected by the values of the discriminants.
9775 Old_C
:= First_Discriminant
(Typ
);
9776 Discr_Val
:= First_Elmt
(Constraints
);
9777 while Present
(Old_C
) loop
9778 Append_To
(Assoc_List
,
9779 Make_Component_Association
(Loc
,
9780 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
9781 Expression
=> New_Copy
(Node
(Discr_Val
))));
9783 Next_Elmt
(Discr_Val
);
9784 Next_Discriminant
(Old_C
);
9787 -- The tag, and the possible parent and controller components
9788 -- are unconditionally in the subtype.
9790 if Is_Tagged_Type
(Typ
)
9791 or else Has_Controlled_Component
(Typ
)
9793 Old_C
:= First_Component
(Typ
);
9794 while Present
(Old_C
) loop
9795 if Chars
((Old_C
)) = Name_uTag
9796 or else Chars
((Old_C
)) = Name_uParent
9797 or else Chars
((Old_C
)) = Name_uController
9799 Append_Elmt
(Old_C
, Comp_List
);
9802 Next_Component
(Old_C
);
9805 end Collect_Fixed_Components
;
9807 ---------------------------
9808 -- Create_All_Components --
9809 ---------------------------
9811 procedure Create_All_Components
is
9815 Comp
:= First_Elmt
(Comp_List
);
9816 while Present
(Comp
) loop
9817 Old_C
:= Node
(Comp
);
9818 New_C
:= Create_Component
(Old_C
);
9822 Constrain_Component_Type
9823 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
9824 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9828 end Create_All_Components
;
9830 ----------------------
9831 -- Create_Component --
9832 ----------------------
9834 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
9835 New_Compon
: constant Entity_Id
:= New_Copy
(Old_Compon
);
9838 if Ekind
(Old_Compon
) = E_Discriminant
9839 and then Is_Completely_Hidden
(Old_Compon
)
9842 -- This is a shadow discriminant created for a discriminant of
9843 -- the parent type that is one of several renamed by the same
9844 -- new discriminant. Give the shadow discriminant an internal
9845 -- name that cannot conflict with that of visible components.
9847 Set_Chars
(New_Compon
, New_Internal_Name
('C'));
9850 -- Set the parent so we have a proper link for freezing etc. This is
9851 -- not a real parent pointer, since of course our parent does not own
9852 -- up to us and reference us, we are an illegitimate child of the
9855 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
9857 -- If the old component's Esize was already determined and is a
9858 -- static value, then the new component simply inherits it. Otherwise
9859 -- the old component's size may require run-time determination, but
9860 -- the new component's size still might be statically determinable
9861 -- (if, for example it has a static constraint). In that case we want
9862 -- Layout_Type to recompute the component's size, so we reset its
9863 -- size and positional fields.
9865 if Frontend_Layout_On_Target
9866 and then not Known_Static_Esize
(Old_Compon
)
9868 Set_Esize
(New_Compon
, Uint_0
);
9869 Init_Normalized_First_Bit
(New_Compon
);
9870 Init_Normalized_Position
(New_Compon
);
9871 Init_Normalized_Position_Max
(New_Compon
);
9874 -- We do not want this node marked as Comes_From_Source, since
9875 -- otherwise it would get first class status and a separate cross-
9876 -- reference line would be generated. Illegitimate children do not
9877 -- rate such recognition.
9879 Set_Comes_From_Source
(New_Compon
, False);
9881 -- But it is a real entity, and a birth certificate must be properly
9882 -- registered by entering it into the entity list.
9884 Enter_Name
(New_Compon
);
9887 end Create_Component
;
9889 -----------------------
9890 -- Is_Variant_Record --
9891 -----------------------
9893 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
9895 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
9896 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
9897 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
9899 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
9900 end Is_Variant_Record
;
9902 -- Start of processing for Create_Constrained_Components
9905 pragma Assert
(Subt
/= Base_Type
(Subt
));
9906 pragma Assert
(Typ
= Base_Type
(Typ
));
9908 Set_First_Entity
(Subt
, Empty
);
9909 Set_Last_Entity
(Subt
, Empty
);
9911 -- Check whether constraint is fully static, in which case we can
9912 -- optimize the list of components.
9914 Discr_Val
:= First_Elmt
(Constraints
);
9915 while Present
(Discr_Val
) loop
9916 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
9921 Next_Elmt
(Discr_Val
);
9924 Set_Has_Static_Discriminants
(Subt
, Is_Static
);
9928 -- Inherit the discriminants of the parent type
9930 Add_Discriminants
: declare
9936 Old_C
:= First_Discriminant
(Typ
);
9938 while Present
(Old_C
) loop
9939 Num_Disc
:= Num_Disc
+ 1;
9940 New_C
:= Create_Component
(Old_C
);
9941 Set_Is_Public
(New_C
, Is_Public
(Subt
));
9942 Next_Discriminant
(Old_C
);
9945 -- For an untagged derived subtype, the number of discriminants may
9946 -- be smaller than the number of inherited discriminants, because
9947 -- several of them may be renamed by a single new discriminant.
9948 -- In this case, add the hidden discriminants back into the subtype,
9949 -- because otherwise the size of the subtype is computed incorrectly
9954 if Is_Derived_Type
(Typ
)
9955 and then not Is_Tagged_Type
(Typ
)
9957 Old_C
:= First_Stored_Discriminant
(Typ
);
9959 while Present
(Old_C
) loop
9960 Num_Gird
:= Num_Gird
+ 1;
9961 Next_Stored_Discriminant
(Old_C
);
9965 if Num_Gird
> Num_Disc
then
9967 -- Find out multiple uses of new discriminants, and add hidden
9968 -- components for the extra renamed discriminants. We recognize
9969 -- multiple uses through the Corresponding_Discriminant of a
9970 -- new discriminant: if it constrains several old discriminants,
9971 -- this field points to the last one in the parent type. The
9972 -- stored discriminants of the derived type have the same name
9973 -- as those of the parent.
9977 New_Discr
: Entity_Id
;
9978 Old_Discr
: Entity_Id
;
9981 Constr
:= First_Elmt
(Stored_Constraint
(Typ
));
9982 Old_Discr
:= First_Stored_Discriminant
(Typ
);
9984 while Present
(Constr
) loop
9985 if Is_Entity_Name
(Node
(Constr
))
9986 and then Ekind
(Entity
(Node
(Constr
))) = E_Discriminant
9988 New_Discr
:= Entity
(Node
(Constr
));
9990 if Chars
(Corresponding_Discriminant
(New_Discr
))
9991 /= Chars
(Old_Discr
)
9994 -- The new discriminant has been used to rename
9995 -- a subsequent old discriminant. Introduce a shadow
9996 -- component for the current old discriminant.
9998 New_C
:= Create_Component
(Old_Discr
);
9999 Set_Original_Record_Component
(New_C
, Old_Discr
);
10003 Next_Elmt
(Constr
);
10004 Next_Stored_Discriminant
(Old_Discr
);
10008 end Add_Discriminants
;
10011 and then Is_Variant_Record
(Typ
)
10013 Collect_Fixed_Components
(Typ
);
10015 Gather_Components
(
10017 Component_List
(Type_Definition
(Parent
(Typ
))),
10018 Governed_By
=> Assoc_List
,
10020 Report_Errors
=> Errors
);
10021 pragma Assert
(not Errors
);
10023 Create_All_Components
;
10025 -- If the subtype declaration is created for a tagged type derivation
10026 -- with constraints, we retrieve the record definition of the parent
10027 -- type to select the components of the proper variant.
10030 and then Is_Tagged_Type
(Typ
)
10031 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
10033 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
10034 and then Is_Variant_Record
(Parent_Type
)
10036 Collect_Fixed_Components
(Typ
);
10038 Gather_Components
(
10040 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
10041 Governed_By
=> Assoc_List
,
10043 Report_Errors
=> Errors
);
10044 pragma Assert
(not Errors
);
10046 -- If the tagged derivation has a type extension, collect all the
10047 -- new components therein.
10050 (Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
10052 Old_C
:= First_Component
(Typ
);
10053 while Present
(Old_C
) loop
10054 if Original_Record_Component
(Old_C
) = Old_C
10055 and then Chars
(Old_C
) /= Name_uTag
10056 and then Chars
(Old_C
) /= Name_uParent
10057 and then Chars
(Old_C
) /= Name_uController
10059 Append_Elmt
(Old_C
, Comp_List
);
10062 Next_Component
(Old_C
);
10066 Create_All_Components
;
10069 -- If discriminants are not static, or if this is a multi-level type
10070 -- extension, we have to include all components of the parent type.
10072 Old_C
:= First_Component
(Typ
);
10073 while Present
(Old_C
) loop
10074 New_C
:= Create_Component
(Old_C
);
10078 Constrain_Component_Type
10079 (Old_C
, Subt
, Decl_Node
, Typ
, Constraints
));
10080 Set_Is_Public
(New_C
, Is_Public
(Subt
));
10082 Next_Component
(Old_C
);
10087 end Create_Constrained_Components
;
10089 ------------------------------------------
10090 -- Decimal_Fixed_Point_Type_Declaration --
10091 ------------------------------------------
10093 procedure Decimal_Fixed_Point_Type_Declaration
10097 Loc
: constant Source_Ptr
:= Sloc
(Def
);
10098 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
10099 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
10100 Implicit_Base
: Entity_Id
;
10106 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
10109 Check_Restriction
(No_Fixed_Point
, Def
);
10111 -- Create implicit base type
10114 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
10115 Set_Etype
(Implicit_Base
, Implicit_Base
);
10117 -- Analyze and process delta expression
10119 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
10121 Check_Delta_Expression
(Delta_Expr
);
10122 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
10124 -- Check delta is power of 10, and determine scale value from it
10130 Scale_Val
:= Uint_0
;
10133 if Val
< Ureal_1
then
10134 while Val
< Ureal_1
loop
10135 Val
:= Val
* Ureal_10
;
10136 Scale_Val
:= Scale_Val
+ 1;
10139 if Scale_Val
> 18 then
10140 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
10141 Scale_Val
:= UI_From_Int
(+18);
10145 while Val
> Ureal_1
loop
10146 Val
:= Val
/ Ureal_10
;
10147 Scale_Val
:= Scale_Val
- 1;
10150 if Scale_Val
< -18 then
10151 Error_Msg_N
("scale is less than minimum value of -18", Def
);
10152 Scale_Val
:= UI_From_Int
(-18);
10156 if Val
/= Ureal_1
then
10157 Error_Msg_N
("delta expression must be a power of 10", Def
);
10158 Delta_Val
:= Ureal_10
** (-Scale_Val
);
10162 -- Set delta, scale and small (small = delta for decimal type)
10164 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
10165 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
10166 Set_Small_Value
(Implicit_Base
, Delta_Val
);
10168 -- Analyze and process digits expression
10170 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
10171 Check_Digits_Expression
(Digs_Expr
);
10172 Digs_Val
:= Expr_Value
(Digs_Expr
);
10174 if Digs_Val
> 18 then
10175 Digs_Val
:= UI_From_Int
(+18);
10176 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
10179 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
10180 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
10182 -- Set range of base type from digits value for now. This will be
10183 -- expanded to represent the true underlying base range by Freeze.
10185 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
10187 -- Set size to zero for now, size will be set at freeze time. We have
10188 -- to do this for ordinary fixed-point, because the size depends on
10189 -- the specified small, and we might as well do the same for decimal
10192 Init_Size_Align
(Implicit_Base
);
10194 -- If there are bounds given in the declaration use them as the
10195 -- bounds of the first named subtype.
10197 if Present
(Real_Range_Specification
(Def
)) then
10199 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
10200 Low
: constant Node_Id
:= Low_Bound
(RRS
);
10201 High
: constant Node_Id
:= High_Bound
(RRS
);
10206 Analyze_And_Resolve
(Low
, Any_Real
);
10207 Analyze_And_Resolve
(High
, Any_Real
);
10208 Check_Real_Bound
(Low
);
10209 Check_Real_Bound
(High
);
10210 Low_Val
:= Expr_Value_R
(Low
);
10211 High_Val
:= Expr_Value_R
(High
);
10213 if Low_Val
< (-Bound_Val
) then
10215 ("range low bound too small for digits value", Low
);
10216 Low_Val
:= -Bound_Val
;
10219 if High_Val
> Bound_Val
then
10221 ("range high bound too large for digits value", High
);
10222 High_Val
:= Bound_Val
;
10225 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
10228 -- If no explicit range, use range that corresponds to given
10229 -- digits value. This will end up as the final range for the
10233 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
10236 -- Complete entity for first subtype
10238 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
10239 Set_Etype
(T
, Implicit_Base
);
10240 Set_Size_Info
(T
, Implicit_Base
);
10241 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
10242 Set_Digits_Value
(T
, Digs_Val
);
10243 Set_Delta_Value
(T
, Delta_Val
);
10244 Set_Small_Value
(T
, Delta_Val
);
10245 Set_Scale_Value
(T
, Scale_Val
);
10246 Set_Is_Constrained
(T
);
10247 end Decimal_Fixed_Point_Type_Declaration
;
10249 ----------------------------------
10250 -- Derive_Interface_Subprograms --
10251 ----------------------------------
10253 procedure Derive_Interface_Subprograms
10254 (Parent_Type
: Entity_Id
;
10255 Tagged_Type
: Entity_Id
;
10256 Ifaces_List
: Elist_Id
)
10258 function Collect_Interface_Primitives
10259 (Tagged_Type
: Entity_Id
) return Elist_Id
;
10260 -- Ada 2005 (AI-251): Collect the primitives of all the implemented
10263 function In_List
(L
: Elist_Id
; Subp
: Entity_Id
) return Boolean;
10264 -- Determine if Subp already in the list L
10266 procedure Remove_Homonym
(E
: Entity_Id
);
10267 -- Removes E from the homonym chain
10269 ----------------------------------
10270 -- Collect_Interface_Primitives --
10271 ----------------------------------
10273 function Collect_Interface_Primitives
10274 (Tagged_Type
: Entity_Id
) return Elist_Id
10276 Op_List
: constant Elist_Id
:= New_Elmt_List
;
10278 Ifaces_List
: Elist_Id
;
10279 Iface_Elmt
: Elmt_Id
;
10283 pragma Assert
(Is_Tagged_Type
(Tagged_Type
)
10284 and then Has_Abstract_Interfaces
(Tagged_Type
));
10286 Collect_Abstract_Interfaces
(Tagged_Type
, Ifaces_List
);
10288 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
10289 while Present
(Iface_Elmt
) loop
10290 Elmt
:= First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
10292 while Present
(Elmt
) loop
10293 Prim
:= Node
(Elmt
);
10295 if not Is_Predefined_Dispatching_Operation
(Prim
) then
10296 Append_Elmt
(Prim
, Op_List
);
10302 Next_Elmt
(Iface_Elmt
);
10306 end Collect_Interface_Primitives
;
10312 function In_List
(L
: Elist_Id
; Subp
: Entity_Id
) return Boolean is
10315 Elmt
:= First_Elmt
(L
);
10316 while Present
(Elmt
) loop
10317 if Node
(Elmt
) = Subp
then
10327 --------------------
10328 -- Remove_Homonym --
10329 --------------------
10331 procedure Remove_Homonym
(E
: Entity_Id
) is
10332 Prev
: Entity_Id
:= Empty
;
10336 if E
= Current_Entity
(E
) then
10337 Set_Current_Entity
(Homonym
(E
));
10339 H
:= Current_Entity
(E
);
10340 while Present
(H
) and then H
/= E
loop
10345 Set_Homonym
(Prev
, Homonym
(E
));
10347 end Remove_Homonym
;
10354 Iface_Subp
: Entity_Id
;
10355 New_Subp
: Entity_Id
:= Empty
;
10356 Op_List
: Elist_Id
;
10357 Parent_Base
: Entity_Id
;
10360 -- Start of processing for Derive_Interface_Subprograms
10363 if Ada_Version
< Ada_05
10364 or else not Is_Record_Type
(Tagged_Type
)
10365 or else not Is_Tagged_Type
(Tagged_Type
)
10366 or else not Has_Abstract_Interfaces
(Tagged_Type
)
10371 -- Add to the list of interface subprograms all the primitives inherited
10372 -- from abstract interfaces that are not immediate ancestors and also
10373 -- add their derivation to the list of interface primitives.
10375 Op_List
:= Collect_Interface_Primitives
(Tagged_Type
);
10377 Elmt
:= First_Elmt
(Op_List
);
10378 while Present
(Elmt
) loop
10379 Subp
:= Node
(Elmt
);
10380 Iface
:= Find_Dispatching_Type
(Subp
);
10382 if not Is_Ancestor
(Iface
, Tagged_Type
) then
10383 Derive_Subprogram
(New_Subp
, Subp
, Tagged_Type
, Iface
);
10384 Append_Elmt
(New_Subp
, Ifaces_List
);
10390 -- Complete the derivation of the interface subprograms. Assignate to
10391 -- each entity associated with abstract interfaces their aliased entity
10392 -- and complete their decoration as hidden interface entities that will
10393 -- be used later to build the secondary dispatch tables.
10395 if not Is_Empty_Elmt_List
(Ifaces_List
) then
10396 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
10397 and then Has_Discriminants
(Parent_Type
)
10398 and then Present
(Full_View
(Parent_Type
))
10400 Parent_Base
:= Full_View
(Parent_Type
);
10402 Parent_Base
:= Parent_Type
;
10405 Elmt
:= First_Elmt
(Ifaces_List
);
10406 while Present
(Elmt
) loop
10407 Iface_Subp
:= Node
(Elmt
);
10409 -- Look for the first overriding entity in the homonym chain.
10410 -- In this way if we are in the private part of a package spec
10411 -- we get the last overriding subprogram.
10413 E
:= Current_Entity_In_Scope
(Iface_Subp
);
10414 while Present
(E
) loop
10415 if Is_Dispatching_Operation
(E
)
10416 and then Scope
(E
) = Scope
(Iface_Subp
)
10417 and then Type_Conformant
(E
, Iface_Subp
)
10418 and then not In_List
(Ifaces_List
, E
)
10426 -- Create an overriding entity if not found in the homonym chain
10428 if not Present
(E
) then
10430 (E
, Alias
(Iface_Subp
), Tagged_Type
, Parent_Base
);
10432 elsif not In_List
(Primitive_Operations
(Tagged_Type
), E
) then
10434 -- Inherit the operation from the private view
10436 Append_Elmt
(E
, Primitive_Operations
(Tagged_Type
));
10439 -- Complete the decoration of the hidden interface entity
10441 Set_Is_Hidden
(Iface_Subp
);
10442 Set_Abstract_Interface_Alias
(Iface_Subp
, Alias
(Iface_Subp
));
10443 Set_Alias
(Iface_Subp
, E
);
10444 Set_Is_Abstract
(Iface_Subp
, Is_Abstract
(E
));
10445 Remove_Homonym
(Iface_Subp
);
10450 end Derive_Interface_Subprograms
;
10452 -----------------------
10453 -- Derive_Subprogram --
10454 -----------------------
10456 procedure Derive_Subprogram
10457 (New_Subp
: in out Entity_Id
;
10458 Parent_Subp
: Entity_Id
;
10459 Derived_Type
: Entity_Id
;
10460 Parent_Type
: Entity_Id
;
10461 Actual_Subp
: Entity_Id
:= Empty
)
10463 Formal
: Entity_Id
;
10464 New_Formal
: Entity_Id
;
10465 Visible_Subp
: Entity_Id
:= Parent_Subp
;
10467 function Is_Private_Overriding
return Boolean;
10468 -- If Subp is a private overriding of a visible operation, the in-
10469 -- herited operation derives from the overridden op (even though
10470 -- its body is the overriding one) and the inherited operation is
10471 -- visible now. See sem_disp to see the details of the handling of
10472 -- the overridden subprogram, which is removed from the list of
10473 -- primitive operations of the type. The overridden subprogram is
10474 -- saved locally in Visible_Subp, and used to diagnose abstract
10475 -- operations that need overriding in the derived type.
10477 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
10478 -- When the type is an anonymous access type, create a new access type
10479 -- designating the derived type.
10481 procedure Set_Derived_Name
;
10482 -- This procedure sets the appropriate Chars name for New_Subp. This
10483 -- is normally just a copy of the parent name. An exception arises for
10484 -- type support subprograms, where the name is changed to reflect the
10485 -- name of the derived type, e.g. if type foo is derived from type bar,
10486 -- then a procedure barDA is derived with a name fooDA.
10488 ---------------------------
10489 -- Is_Private_Overriding --
10490 ---------------------------
10492 function Is_Private_Overriding
return Boolean is
10496 -- If the parent is not a dispatching operation there is no
10497 -- need to investigate overridings
10499 if not Is_Dispatching_Operation
(Parent_Subp
) then
10503 -- The visible operation that is overridden is a homonym of the
10504 -- parent subprogram. We scan the homonym chain to find the one
10505 -- whose alias is the subprogram we are deriving.
10507 Prev
:= Current_Entity
(Parent_Subp
);
10508 while Present
(Prev
) loop
10509 if Ekind
(Prev
) = Ekind
(Parent_Subp
)
10510 and then Alias
(Prev
) = Parent_Subp
10511 and then Scope
(Parent_Subp
) = Scope
(Prev
)
10512 and then not Is_Hidden
(Prev
)
10514 Visible_Subp
:= Prev
;
10518 Prev
:= Homonym
(Prev
);
10522 end Is_Private_Overriding
;
10528 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
10529 Acc_Type
: Entity_Id
;
10531 Par
: constant Node_Id
:= Parent
(Derived_Type
);
10534 -- When the type is an anonymous access type, create a new access
10535 -- type designating the derived type. This itype must be elaborated
10536 -- at the point of the derivation, not on subsequent calls that may
10537 -- be out of the proper scope for Gigi, so we insert a reference to
10538 -- it after the derivation.
10540 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
10542 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
10545 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
10546 and then Present
(Full_View
(Desig_Typ
))
10547 and then not Is_Private_Type
(Parent_Type
)
10549 Desig_Typ
:= Full_View
(Desig_Typ
);
10552 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
)
10554 -- Ada 2005 (AI-251): Handle also derivations of abstract
10555 -- interface primitives.
10557 or else (Is_Interface
(Desig_Typ
)
10558 and then not Is_Class_Wide_Type
(Desig_Typ
))
10560 Acc_Type
:= New_Copy
(Etype
(Id
));
10561 Set_Etype
(Acc_Type
, Acc_Type
);
10562 Set_Scope
(Acc_Type
, New_Subp
);
10564 -- Compute size of anonymous access type
10566 if Is_Array_Type
(Desig_Typ
)
10567 and then not Is_Constrained
(Desig_Typ
)
10569 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
10571 Init_Size
(Acc_Type
, System_Address_Size
);
10574 Init_Alignment
(Acc_Type
);
10575 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
10577 Set_Etype
(New_Id
, Acc_Type
);
10578 Set_Scope
(New_Id
, New_Subp
);
10580 -- Create a reference to it
10582 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
10583 Set_Itype
(IR
, Acc_Type
);
10584 Insert_After
(Parent
(Derived_Type
), IR
);
10587 Set_Etype
(New_Id
, Etype
(Id
));
10591 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
10593 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
10594 and then Present
(Full_View
(Etype
(Id
)))
10596 Base_Type
(Full_View
(Etype
(Id
))) = Base_Type
(Parent_Type
))
10598 -- Constraint checks on formals are generated during expansion,
10599 -- based on the signature of the original subprogram. The bounds
10600 -- of the derived type are not relevant, and thus we can use
10601 -- the base type for the formals. However, the return type may be
10602 -- used in a context that requires that the proper static bounds
10603 -- be used (a case statement, for example) and for those cases
10604 -- we must use the derived type (first subtype), not its base.
10606 -- If the derived_type_definition has no constraints, we know that
10607 -- the derived type has the same constraints as the first subtype
10608 -- of the parent, and we can also use it rather than its base,
10609 -- which can lead to more efficient code.
10611 if Etype
(Id
) = Parent_Type
then
10612 if Is_Scalar_Type
(Parent_Type
)
10614 Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
)
10616 Set_Etype
(New_Id
, Derived_Type
);
10618 elsif Nkind
(Par
) = N_Full_Type_Declaration
10620 Nkind
(Type_Definition
(Par
)) = N_Derived_Type_Definition
10623 (Subtype_Indication
(Type_Definition
(Par
)))
10625 Set_Etype
(New_Id
, Derived_Type
);
10628 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10632 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
10635 -- Ada 2005 (AI-251): Handle derivations of abstract interface
10638 elsif Is_Interface
(Etype
(Id
))
10639 and then not Is_Class_Wide_Type
(Etype
(Id
))
10641 Set_Etype
(New_Id
, Derived_Type
);
10644 Set_Etype
(New_Id
, Etype
(Id
));
10648 ----------------------
10649 -- Set_Derived_Name --
10650 ----------------------
10652 procedure Set_Derived_Name
is
10653 Nm
: constant TSS_Name_Type
:= Get_TSS_Name
(Parent_Subp
);
10655 if Nm
= TSS_Null
then
10656 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
10658 Set_Chars
(New_Subp
, Make_TSS_Name
(Base_Type
(Derived_Type
), Nm
));
10660 end Set_Derived_Name
;
10662 -- Start of processing for Derive_Subprogram
10666 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
10667 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
10669 -- Check whether the inherited subprogram is a private operation that
10670 -- should be inherited but not yet made visible. Such subprograms can
10671 -- become visible at a later point (e.g., the private part of a public
10672 -- child unit) via Declare_Inherited_Private_Subprograms. If the
10673 -- following predicate is true, then this is not such a private
10674 -- operation and the subprogram simply inherits the name of the parent
10675 -- subprogram. Note the special check for the names of controlled
10676 -- operations, which are currently exempted from being inherited with
10677 -- a hidden name because they must be findable for generation of
10678 -- implicit run-time calls.
10680 if not Is_Hidden
(Parent_Subp
)
10681 or else Is_Internal
(Parent_Subp
)
10682 or else Is_Private_Overriding
10683 or else Is_Internal_Name
(Chars
(Parent_Subp
))
10684 or else Chars
(Parent_Subp
) = Name_Initialize
10685 or else Chars
(Parent_Subp
) = Name_Adjust
10686 or else Chars
(Parent_Subp
) = Name_Finalize
10690 -- If parent is hidden, this can be a regular derivation if the
10691 -- parent is immediately visible in a non-instantiating context,
10692 -- or if we are in the private part of an instance. This test
10693 -- should still be refined ???
10695 -- The test for In_Instance_Not_Visible avoids inheriting the derived
10696 -- operation as a non-visible operation in cases where the parent
10697 -- subprogram might not be visible now, but was visible within the
10698 -- original generic, so it would be wrong to make the inherited
10699 -- subprogram non-visible now. (Not clear if this test is fully
10700 -- correct; are there any cases where we should declare the inherited
10701 -- operation as not visible to avoid it being overridden, e.g., when
10702 -- the parent type is a generic actual with private primitives ???)
10704 -- (they should be treated the same as other private inherited
10705 -- subprograms, but it's not clear how to do this cleanly). ???
10707 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
10708 and then Is_Immediately_Visible
(Parent_Subp
)
10709 and then not In_Instance
)
10710 or else In_Instance_Not_Visible
10714 -- Ada 2005 (AI-251): Hidden entity associated with abstract interface
10717 elsif Present
(Abstract_Interface_Alias
(Parent_Subp
)) then
10720 -- The type is inheriting a private operation, so enter
10721 -- it with a special name so it can't be overridden.
10724 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
10727 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
10728 Replace_Type
(Parent_Subp
, New_Subp
);
10729 Conditional_Delay
(New_Subp
, Parent_Subp
);
10731 Formal
:= First_Formal
(Parent_Subp
);
10732 while Present
(Formal
) loop
10733 New_Formal
:= New_Copy
(Formal
);
10735 -- Normally we do not go copying parents, but in the case of
10736 -- formals, we need to link up to the declaration (which is the
10737 -- parameter specification), and it is fine to link up to the
10738 -- original formal's parameter specification in this case.
10740 Set_Parent
(New_Formal
, Parent
(Formal
));
10742 Append_Entity
(New_Formal
, New_Subp
);
10744 Replace_Type
(Formal
, New_Formal
);
10745 Next_Formal
(Formal
);
10748 -- If this derivation corresponds to a tagged generic actual, then
10749 -- primitive operations rename those of the actual. Otherwise the
10750 -- primitive operations rename those of the parent type, If the
10751 -- parent renames an intrinsic operator, so does the new subprogram.
10752 -- We except concatenation, which is always properly typed, and does
10753 -- not get expanded as other intrinsic operations.
10755 if No
(Actual_Subp
) then
10756 if Is_Intrinsic_Subprogram
(Parent_Subp
) then
10757 Set_Is_Intrinsic_Subprogram
(New_Subp
);
10759 if Present
(Alias
(Parent_Subp
))
10760 and then Chars
(Parent_Subp
) /= Name_Op_Concat
10762 Set_Alias
(New_Subp
, Alias
(Parent_Subp
));
10764 Set_Alias
(New_Subp
, Parent_Subp
);
10768 Set_Alias
(New_Subp
, Parent_Subp
);
10772 Set_Alias
(New_Subp
, Actual_Subp
);
10775 -- Derived subprograms of a tagged type must inherit the convention
10776 -- of the parent subprogram (a requirement of AI-117). Derived
10777 -- subprograms of untagged types simply get convention Ada by default.
10779 if Is_Tagged_Type
(Derived_Type
) then
10780 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
10783 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
10784 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
10786 if Ekind
(Parent_Subp
) = E_Procedure
then
10787 Set_Is_Valued_Procedure
10788 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
10791 -- No_Return must be inherited properly. If this is overridden in the
10792 -- case of a dispatching operation, then a check is made in Sem_Disp
10793 -- that the overriding operation is also No_Return (no such check is
10794 -- required for the case of non-dispatching operation.
10796 Set_No_Return
(New_Subp
, No_Return
(Parent_Subp
));
10798 -- A derived function with a controlling result is abstract. If the
10799 -- Derived_Type is a nonabstract formal generic derived type, then
10800 -- inherited operations are not abstract: the required check is done at
10801 -- instantiation time. If the derivation is for a generic actual, the
10802 -- function is not abstract unless the actual is.
10804 if Is_Generic_Type
(Derived_Type
)
10805 and then not Is_Abstract
(Derived_Type
)
10809 elsif Is_Abstract
(Alias
(New_Subp
))
10810 or else (Is_Tagged_Type
(Derived_Type
)
10811 and then Etype
(New_Subp
) = Derived_Type
10812 and then No
(Actual_Subp
))
10814 Set_Is_Abstract
(New_Subp
);
10816 -- Finally, if the parent type is abstract we must verify that all
10817 -- inherited operations are either non-abstract or overridden, or
10818 -- that the derived type itself is abstract (this check is performed
10819 -- at the end of a package declaration, in Check_Abstract_Overriding).
10820 -- A private overriding in the parent type will not be visible in the
10821 -- derivation if we are not in an inner package or in a child unit of
10822 -- the parent type, in which case the abstractness of the inherited
10823 -- operation is carried to the new subprogram.
10825 elsif Is_Abstract
(Parent_Type
)
10826 and then not In_Open_Scopes
(Scope
(Parent_Type
))
10827 and then Is_Private_Overriding
10828 and then Is_Abstract
(Visible_Subp
)
10830 Set_Alias
(New_Subp
, Visible_Subp
);
10831 Set_Is_Abstract
(New_Subp
);
10834 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
10836 -- Check for case of a derived subprogram for the instantiation of a
10837 -- formal derived tagged type, if so mark the subprogram as dispatching
10838 -- and inherit the dispatching attributes of the parent subprogram. The
10839 -- derived subprogram is effectively renaming of the actual subprogram,
10840 -- so it needs to have the same attributes as the actual.
10842 if Present
(Actual_Subp
)
10843 and then Is_Dispatching_Operation
(Parent_Subp
)
10845 Set_Is_Dispatching_Operation
(New_Subp
);
10847 if Present
(DTC_Entity
(Parent_Subp
)) then
10848 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
10849 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
10853 -- Indicate that a derived subprogram does not require a body and that
10854 -- it does not require processing of default expressions.
10856 Set_Has_Completion
(New_Subp
);
10857 Set_Default_Expressions_Processed
(New_Subp
);
10859 if Ekind
(New_Subp
) = E_Function
then
10860 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
10862 end Derive_Subprogram
;
10864 ------------------------
10865 -- Derive_Subprograms --
10866 ------------------------
10868 procedure Derive_Subprograms
10869 (Parent_Type
: Entity_Id
;
10870 Derived_Type
: Entity_Id
;
10871 Generic_Actual
: Entity_Id
:= Empty
)
10873 Op_List
: constant Elist_Id
:=
10874 Collect_Primitive_Operations
(Parent_Type
);
10875 Ifaces_List
: constant Elist_Id
:= New_Elmt_List
;
10876 Act_List
: Elist_Id
;
10877 Act_Elmt
: Elmt_Id
;
10879 New_Subp
: Entity_Id
:= Empty
;
10880 Parent_Base
: Entity_Id
;
10884 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
10885 and then Has_Discriminants
(Parent_Type
)
10886 and then Present
(Full_View
(Parent_Type
))
10888 Parent_Base
:= Full_View
(Parent_Type
);
10890 Parent_Base
:= Parent_Type
;
10893 -- Derive primitives inherited from the parent
10895 if Present
(Generic_Actual
) then
10896 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
10897 Act_Elmt
:= First_Elmt
(Act_List
);
10899 Act_Elmt
:= No_Elmt
;
10902 -- Literals are derived earlier in the process of building the derived
10903 -- type, and are skipped here.
10905 Elmt
:= First_Elmt
(Op_List
);
10906 while Present
(Elmt
) loop
10907 Subp
:= Node
(Elmt
);
10909 if Ekind
(Subp
) /= E_Enumeration_Literal
then
10911 if Ada_Version
>= Ada_05
10912 and then Present
(Abstract_Interface_Alias
(Subp
))
10916 elsif No
(Generic_Actual
) then
10917 Derive_Subprogram
(New_Subp
, Subp
, Derived_Type
, Parent_Base
);
10919 -- Ada 2005 (AI-251): Add the derivation of an abstract
10920 -- interface primitive to the list of entities to which
10921 -- we have to associate aliased entity.
10923 if Ada_Version
>= Ada_05
10924 and then Is_Dispatching_Operation
(Subp
)
10925 and then Present
(Find_Dispatching_Type
(Subp
))
10926 and then Is_Interface
(Find_Dispatching_Type
(Subp
))
10927 and then not Is_Predefined_Dispatching_Operation
(Subp
)
10929 Append_Elmt
(New_Subp
, Ifaces_List
);
10934 (New_Subp
, Subp
, Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
10935 Next_Elmt
(Act_Elmt
);
10942 Derive_Interface_Subprograms
(Parent_Type
, Derived_Type
, Ifaces_List
);
10943 end Derive_Subprograms
;
10945 --------------------------------
10946 -- Derived_Standard_Character --
10947 --------------------------------
10949 procedure Derived_Standard_Character
10951 Parent_Type
: Entity_Id
;
10952 Derived_Type
: Entity_Id
)
10954 Loc
: constant Source_Ptr
:= Sloc
(N
);
10955 Def
: constant Node_Id
:= Type_Definition
(N
);
10956 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
10957 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
10958 Implicit_Base
: constant Entity_Id
:=
10960 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
10966 Discard_Node
(Process_Subtype
(Indic
, N
));
10968 Set_Etype
(Implicit_Base
, Parent_Base
);
10969 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
10970 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
10972 Set_Is_Character_Type
(Implicit_Base
, True);
10973 Set_Has_Delayed_Freeze
(Implicit_Base
);
10975 -- The bounds of the implicit base are the bounds of the parent base.
10976 -- Note that their type is the parent base.
10978 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
10979 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
10981 Set_Scalar_Range
(Implicit_Base
,
10984 High_Bound
=> Hi
));
10986 Conditional_Delay
(Derived_Type
, Parent_Type
);
10988 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
10989 Set_Etype
(Derived_Type
, Implicit_Base
);
10990 Set_Size_Info
(Derived_Type
, Parent_Type
);
10992 if Unknown_RM_Size
(Derived_Type
) then
10993 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
10996 Set_Is_Character_Type
(Derived_Type
, True);
10998 if Nkind
(Indic
) /= N_Subtype_Indication
then
11000 -- If no explicit constraint, the bounds are those
11001 -- of the parent type.
11003 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
11004 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
11005 Set_Scalar_Range
(Derived_Type
, Make_Range
(Loc
, Lo
, Hi
));
11008 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
11010 -- Because the implicit base is used in the conversion of the bounds,
11011 -- we have to freeze it now. This is similar to what is done for
11012 -- numeric types, and it equally suspicious, but otherwise a non-
11013 -- static bound will have a reference to an unfrozen type, which is
11014 -- rejected by Gigi (???). This requires specific care for definition
11015 -- of stream attributes. For details, see comments at the end of
11016 -- Build_Derived_Numeric_Type.
11018 Freeze_Before
(N
, Implicit_Base
);
11019 end Derived_Standard_Character
;
11021 ------------------------------
11022 -- Derived_Type_Declaration --
11023 ------------------------------
11025 procedure Derived_Type_Declaration
11028 Is_Completion
: Boolean)
11030 Def
: constant Node_Id
:= Type_Definition
(N
);
11031 Iface_Def
: Node_Id
;
11032 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
11033 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
11034 Parent_Type
: Entity_Id
;
11035 Parent_Scope
: Entity_Id
;
11038 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean;
11039 -- Check whether the parent type is a generic formal, or derives
11040 -- directly or indirectly from one.
11042 ------------------------
11043 -- Comes_From_Generic --
11044 ------------------------
11046 function Comes_From_Generic
(Typ
: Entity_Id
) return Boolean is
11048 if Is_Generic_Type
(Typ
) then
11051 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
11054 elsif Is_Private_Type
(Typ
)
11055 and then Present
(Full_View
(Typ
))
11056 and then Is_Generic_Type
(Root_Type
(Full_View
(Typ
)))
11060 elsif Is_Generic_Actual_Type
(Typ
) then
11066 end Comes_From_Generic
;
11068 -- Start of processing for Derived_Type_Declaration
11071 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
11073 -- Ada 2005 (AI-251): In case of interface derivation check that the
11074 -- parent is also an interface.
11076 if Interface_Present
(Def
) then
11077 if not Is_Interface
(Parent_Type
) then
11078 Error_Msg_NE
("(Ada 2005) & must be an interface",
11079 Indic
, Parent_Type
);
11082 Iface_Def
:= Type_Definition
(Parent
(Parent_Type
));
11084 -- Ada 2005 (AI-251): Limited interfaces can only inherit from
11085 -- other limited interfaces.
11087 if Limited_Present
(Def
) then
11088 if Limited_Present
(Iface_Def
) then
11091 elsif Protected_Present
(Iface_Def
) then
11092 Error_Msg_N
("(Ada 2005) limited interface cannot" &
11093 " inherit from protected interface", Indic
);
11095 elsif Synchronized_Present
(Iface_Def
) then
11096 Error_Msg_N
("(Ada 2005) limited interface cannot" &
11097 " inherit from synchronized interface", Indic
);
11099 elsif Task_Present
(Iface_Def
) then
11100 Error_Msg_N
("(Ada 2005) limited interface cannot" &
11101 " inherit from task interface", Indic
);
11104 Error_Msg_N
("(Ada 2005) limited interface cannot" &
11105 " inherit from non-limited interface", Indic
);
11108 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
11109 -- from non-limited or limited interfaces.
11111 elsif not Protected_Present
(Def
)
11112 and then not Synchronized_Present
(Def
)
11113 and then not Task_Present
(Def
)
11115 if Limited_Present
(Iface_Def
) then
11118 elsif Protected_Present
(Iface_Def
) then
11119 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
11120 " inherit from protected interface", Indic
);
11122 elsif Synchronized_Present
(Iface_Def
) then
11123 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
11124 " inherit from synchronized interface", Indic
);
11126 elsif Task_Present
(Iface_Def
) then
11127 Error_Msg_N
("(Ada 2005) non-limited interface cannot" &
11128 " inherit from task interface", Indic
);
11137 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
11140 if Is_Tagged_Type
(Parent_Type
)
11141 and then Is_Non_Empty_List
(Interface_List
(Def
))
11148 Intf
:= First
(Interface_List
(Def
));
11149 while Present
(Intf
) loop
11150 T
:= Find_Type_Of_Subtype_Indic
(Intf
);
11152 if not Is_Interface
(T
) then
11153 Error_Msg_NE
("(Ada 2005) & must be an interface", Intf
, T
);
11155 elsif Limited_Present
(Def
)
11156 and then not Is_Limited_Interface
(T
)
11159 ("progenitor interface& of limited type must be limited",
11168 if Parent_Type
= Any_Type
11169 or else Etype
(Parent_Type
) = Any_Type
11170 or else (Is_Class_Wide_Type
(Parent_Type
)
11171 and then Etype
(Parent_Type
) = T
)
11173 -- If Parent_Type is undefined or illegal, make new type into a
11174 -- subtype of Any_Type, and set a few attributes to prevent cascaded
11175 -- errors. If this is a self-definition, emit error now.
11178 or else T
= Etype
(Parent_Type
)
11180 Error_Msg_N
("type cannot be used in its own definition", Indic
);
11183 Set_Ekind
(T
, Ekind
(Parent_Type
));
11184 Set_Etype
(T
, Any_Type
);
11185 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
11187 if Is_Tagged_Type
(T
) then
11188 Set_Primitive_Operations
(T
, New_Elmt_List
);
11194 -- Ada 2005 (AI-251): The case in which the parent of the full-view is
11195 -- an interface is special because the list of interfaces in the full
11196 -- view can be given in any order. For example:
11198 -- type A is interface;
11199 -- type B is interface and A;
11200 -- type D is new B with private;
11202 -- type D is new A and B with null record; -- 1 --
11204 -- In this case we perform the following transformation of -1-:
11206 -- type D is new B and A with null record;
11208 -- If the parent of the full-view covers the parent of the partial-view
11209 -- we have two possible cases:
11211 -- 1) They have the same parent
11212 -- 2) The parent of the full-view implements some further interfaces
11214 -- In both cases we do not need to perform the transformation. In the
11215 -- first case the source program is correct and the transformation is
11216 -- not needed; in the second case the source program does not fulfill
11217 -- the no-hidden interfaces rule (AI-396) and the error will be reported
11220 -- This transformation not only simplifies the rest of the analysis of
11221 -- this type declaration but also simplifies the correct generation of
11222 -- the object layout to the expander.
11224 if In_Private_Part
(Current_Scope
)
11225 and then Is_Interface
(Parent_Type
)
11229 Partial_View
: Entity_Id
;
11230 Partial_View_Parent
: Entity_Id
;
11231 New_Iface
: Node_Id
;
11234 -- Look for the associated private type declaration
11236 Partial_View
:= First_Entity
(Current_Scope
);
11238 exit when No
(Partial_View
)
11239 or else (Has_Private_Declaration
(Partial_View
)
11240 and then Full_View
(Partial_View
) = T
);
11242 Next_Entity
(Partial_View
);
11245 -- If the partial view was not found then the source code has
11246 -- errors and the transformation is not needed.
11248 if Present
(Partial_View
) then
11249 Partial_View_Parent
:= Etype
(Partial_View
);
11251 -- If the parent of the full-view covers the parent of the
11252 -- partial-view we have nothing else to do.
11254 if Interface_Present_In_Ancestor
11255 (Parent_Type
, Partial_View_Parent
)
11259 -- Traverse the list of interfaces of the full-view to look
11260 -- for the parent of the partial-view and perform the tree
11264 Iface
:= First
(Interface_List
(Def
));
11265 while Present
(Iface
) loop
11266 if Etype
(Iface
) = Etype
(Partial_View
) then
11267 Rewrite
(Subtype_Indication
(Def
),
11268 New_Copy
(Subtype_Indication
11269 (Parent
(Partial_View
))));
11271 New_Iface
:= Make_Identifier
(Sloc
(N
),
11272 Chars
(Parent_Type
));
11273 Append
(New_Iface
, Interface_List
(Def
));
11275 -- Analyze the transformed code
11277 Derived_Type_Declaration
(T
, N
, Is_Completion
);
11288 -- Only composite types other than array types are allowed to have
11291 if Present
(Discriminant_Specifications
(N
))
11292 and then (Is_Elementary_Type
(Parent_Type
)
11293 or else Is_Array_Type
(Parent_Type
))
11294 and then not Error_Posted
(N
)
11297 ("elementary or array type cannot have discriminants",
11298 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
11299 Set_Has_Discriminants
(T
, False);
11302 -- In Ada 83, a derived type defined in a package specification cannot
11303 -- be used for further derivation until the end of its visible part.
11304 -- Note that derivation in the private part of the package is allowed.
11306 if Ada_Version
= Ada_83
11307 and then Is_Derived_Type
(Parent_Type
)
11308 and then In_Visible_Part
(Scope
(Parent_Type
))
11310 if Ada_Version
= Ada_83
and then Comes_From_Source
(Indic
) then
11312 ("(Ada 83): premature use of type for derivation", Indic
);
11316 -- Check for early use of incomplete or private type
11318 if Ekind
(Parent_Type
) = E_Void
11319 or else Ekind
(Parent_Type
) = E_Incomplete_Type
11321 Error_Msg_N
("premature derivation of incomplete type", Indic
);
11324 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
11325 and then not Comes_From_Generic
(Parent_Type
))
11326 or else Has_Private_Component
(Parent_Type
)
11328 -- The ancestor type of a formal type can be incomplete, in which
11329 -- case only the operations of the partial view are available in
11330 -- the generic. Subsequent checks may be required when the full
11331 -- view is analyzed, to verify that derivation from a tagged type
11332 -- has an extension.
11334 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
11337 elsif No
(Underlying_Type
(Parent_Type
))
11338 or else Has_Private_Component
(Parent_Type
)
11341 ("premature derivation of derived or private type", Indic
);
11343 -- Flag the type itself as being in error, this prevents some
11344 -- nasty problems with subsequent uses of the malformed type.
11346 Set_Error_Posted
(T
);
11348 -- Check that within the immediate scope of an untagged partial
11349 -- view it's illegal to derive from the partial view if the
11350 -- full view is tagged. (7.3(7))
11352 -- We verify that the Parent_Type is a partial view by checking
11353 -- that it is not a Full_Type_Declaration (i.e. a private type or
11354 -- private extension declaration), to distinguish a partial view
11355 -- from a derivation from a private type which also appears as
11358 elsif Present
(Full_View
(Parent_Type
))
11359 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
11360 and then not Is_Tagged_Type
(Parent_Type
)
11361 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
11363 Parent_Scope
:= Scope
(T
);
11364 while Present
(Parent_Scope
)
11365 and then Parent_Scope
/= Standard_Standard
11367 if Parent_Scope
= Scope
(Parent_Type
) then
11369 ("premature derivation from type with tagged full view",
11373 Parent_Scope
:= Scope
(Parent_Scope
);
11378 -- Check that form of derivation is appropriate
11380 Taggd
:= Is_Tagged_Type
(Parent_Type
);
11382 -- Perhaps the parent type should be changed to the class-wide type's
11383 -- specific type in this case to prevent cascading errors ???
11385 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
11386 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
11390 if Present
(Extension
) and then not Taggd
then
11392 ("type derived from untagged type cannot have extension", Indic
);
11394 elsif No
(Extension
) and then Taggd
then
11396 -- If this declaration is within a private part (or body) of a
11397 -- generic instantiation then the derivation is allowed (the parent
11398 -- type can only appear tagged in this case if it's a generic actual
11399 -- type, since it would otherwise have been rejected in the analysis
11400 -- of the generic template).
11402 if not Is_Generic_Actual_Type
(Parent_Type
)
11403 or else In_Visible_Part
(Scope
(Parent_Type
))
11406 ("type derived from tagged type must have extension", Indic
);
11410 -- AI-443: Synchronized formal derived types require a private
11411 -- extension. There is no point in checking the ancestor type or
11412 -- the progenitors since the construct is wrong to begin with.
11414 if Ada_Version
>= Ada_05
11415 and then Is_Generic_Type
(T
)
11416 and then Present
(Original_Node
(N
))
11419 Decl
: constant Node_Id
:= Original_Node
(N
);
11422 if Nkind
(Decl
) = N_Formal_Type_Declaration
11423 and then Nkind
(Formal_Type_Definition
(Decl
)) =
11424 N_Formal_Derived_Type_Definition
11425 and then Synchronized_Present
(Formal_Type_Definition
(Decl
))
11426 and then No
(Extension
)
11428 -- Avoid emitting a duplicate error message
11430 and then not Error_Posted
(Indic
)
11433 ("synchronized derived type must have extension", N
);
11438 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
11440 -- AI-419: The parent type of an explicitly limited derived type must
11441 -- be a limited type or a limited interface.
11443 if Limited_Present
(Def
) then
11444 Set_Is_Limited_Record
(T
);
11446 if Is_Interface
(T
) then
11447 Set_Is_Limited_Interface
(T
);
11450 if not Is_Limited_Type
(Parent_Type
)
11452 (not Is_Interface
(Parent_Type
)
11453 or else not Is_Limited_Interface
(Parent_Type
))
11455 Error_Msg_NE
("parent type& of limited type must be limited",
11459 end Derived_Type_Declaration
;
11461 ----------------------------------
11462 -- Enumeration_Type_Declaration --
11463 ----------------------------------
11465 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11472 -- Create identifier node representing lower bound
11474 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11475 L
:= First
(Literals
(Def
));
11476 Set_Chars
(B_Node
, Chars
(L
));
11477 Set_Entity
(B_Node
, L
);
11478 Set_Etype
(B_Node
, T
);
11479 Set_Is_Static_Expression
(B_Node
, True);
11481 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
11482 Set_Low_Bound
(R_Node
, B_Node
);
11484 Set_Ekind
(T
, E_Enumeration_Type
);
11485 Set_First_Literal
(T
, L
);
11487 Set_Is_Constrained
(T
);
11491 -- Loop through literals of enumeration type setting pos and rep values
11492 -- except that if the Ekind is already set, then it means that the
11493 -- literal was already constructed (case of a derived type declaration
11494 -- and we should not disturb the Pos and Rep values.
11496 while Present
(L
) loop
11497 if Ekind
(L
) /= E_Enumeration_Literal
then
11498 Set_Ekind
(L
, E_Enumeration_Literal
);
11499 Set_Enumeration_Pos
(L
, Ev
);
11500 Set_Enumeration_Rep
(L
, Ev
);
11501 Set_Is_Known_Valid
(L
, True);
11505 New_Overloaded_Entity
(L
);
11506 Generate_Definition
(L
);
11507 Set_Convention
(L
, Convention_Intrinsic
);
11509 if Nkind
(L
) = N_Defining_Character_Literal
then
11510 Set_Is_Character_Type
(T
, True);
11517 -- Now create a node representing upper bound
11519 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
11520 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
11521 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
11522 Set_Etype
(B_Node
, T
);
11523 Set_Is_Static_Expression
(B_Node
, True);
11525 Set_High_Bound
(R_Node
, B_Node
);
11526 Set_Scalar_Range
(T
, R_Node
);
11527 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
11528 Set_Enum_Esize
(T
);
11530 -- Set Discard_Names if configuration pragma set, or if there is
11531 -- a parameterless pragma in the current declarative region
11533 if Global_Discard_Names
11534 or else Discard_Names
(Scope
(T
))
11536 Set_Discard_Names
(T
);
11539 -- Process end label if there is one
11541 if Present
(Def
) then
11542 Process_End_Label
(Def
, 'e', T
);
11544 end Enumeration_Type_Declaration
;
11546 ---------------------------------
11547 -- Expand_To_Stored_Constraint --
11548 ---------------------------------
11550 function Expand_To_Stored_Constraint
11552 Constraint
: Elist_Id
) return Elist_Id
11554 Explicitly_Discriminated_Type
: Entity_Id
;
11555 Expansion
: Elist_Id
;
11556 Discriminant
: Entity_Id
;
11558 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
11559 -- Find the nearest type that actually specifies discriminants
11561 ---------------------------------
11562 -- Type_With_Explicit_Discrims --
11563 ---------------------------------
11565 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
11566 Typ
: constant E
:= Base_Type
(Id
);
11569 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
11570 if Present
(Full_View
(Typ
)) then
11571 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
11575 if Has_Discriminants
(Typ
) then
11580 if Etype
(Typ
) = Typ
then
11582 elsif Has_Discriminants
(Typ
) then
11585 return Type_With_Explicit_Discrims
(Etype
(Typ
));
11588 end Type_With_Explicit_Discrims
;
11590 -- Start of processing for Expand_To_Stored_Constraint
11594 or else Is_Empty_Elmt_List
(Constraint
)
11599 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
11601 if No
(Explicitly_Discriminated_Type
) then
11605 Expansion
:= New_Elmt_List
;
11608 First_Stored_Discriminant
(Explicitly_Discriminated_Type
);
11609 while Present
(Discriminant
) loop
11611 Get_Discriminant_Value
(
11612 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
11614 Next_Stored_Discriminant
(Discriminant
);
11618 end Expand_To_Stored_Constraint
;
11620 --------------------
11621 -- Find_Type_Name --
11622 --------------------
11624 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
11625 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
11627 New_Id
: Entity_Id
;
11628 Prev_Par
: Node_Id
;
11631 -- Find incomplete declaration, if one was given
11633 Prev
:= Current_Entity_In_Scope
(Id
);
11635 if Present
(Prev
) then
11637 -- Previous declaration exists. Error if not incomplete/private case
11638 -- except if previous declaration is implicit, etc. Enter_Name will
11639 -- emit error if appropriate.
11641 Prev_Par
:= Parent
(Prev
);
11643 if not Is_Incomplete_Or_Private_Type
(Prev
) then
11647 elsif Nkind
(N
) /= N_Full_Type_Declaration
11648 and then Nkind
(N
) /= N_Task_Type_Declaration
11649 and then Nkind
(N
) /= N_Protected_Type_Declaration
11651 -- Completion must be a full type declarations (RM 7.3(4))
11653 Error_Msg_Sloc
:= Sloc
(Prev
);
11654 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
11656 -- Set scope of Id to avoid cascaded errors. Entity is never
11657 -- examined again, except when saving globals in generics.
11659 Set_Scope
(Id
, Current_Scope
);
11662 -- Case of full declaration of incomplete type
11664 elsif Ekind
(Prev
) = E_Incomplete_Type
then
11666 -- Indicate that the incomplete declaration has a matching full
11667 -- declaration. The defining occurrence of the incomplete
11668 -- declaration remains the visible one, and the procedure
11669 -- Get_Full_View dereferences it whenever the type is used.
11671 if Present
(Full_View
(Prev
)) then
11672 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11675 Set_Full_View
(Prev
, Id
);
11676 Append_Entity
(Id
, Current_Scope
);
11677 Set_Is_Public
(Id
, Is_Public
(Prev
));
11678 Set_Is_Internal
(Id
);
11681 -- Case of full declaration of private type
11684 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
11685 if Etype
(Prev
) /= Prev
then
11687 -- Prev is a private subtype or a derived type, and needs
11690 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
11693 elsif Ekind
(Prev
) = E_Private_Type
11695 (Nkind
(N
) = N_Task_Type_Declaration
11696 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11699 ("completion of nonlimited type cannot be limited", N
);
11701 elsif Ekind
(Prev
) = E_Record_Type_With_Private
11703 (Nkind
(N
) = N_Task_Type_Declaration
11704 or else Nkind
(N
) = N_Protected_Type_Declaration
)
11706 if not Is_Limited_Record
(Prev
) then
11708 ("completion of nonlimited type cannot be limited", N
);
11710 elsif No
(Interface_List
(N
)) then
11712 ("completion of tagged private type must be tagged",
11717 -- Ada 2005 (AI-251): Private extension declaration of a
11718 -- task type. This case arises with tasks implementing interfaces
11720 elsif Nkind
(N
) = N_Task_Type_Declaration
11721 or else Nkind
(N
) = N_Protected_Type_Declaration
11725 elsif Nkind
(N
) /= N_Full_Type_Declaration
11726 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
11729 ("full view of private extension must be an extension", N
);
11731 elsif not (Abstract_Present
(Parent
(Prev
)))
11732 and then Abstract_Present
(Type_Definition
(N
))
11735 ("full view of non-abstract extension cannot be abstract", N
);
11738 if not In_Private_Part
(Current_Scope
) then
11740 ("declaration of full view must appear in private part", N
);
11743 Copy_And_Swap
(Prev
, Id
);
11744 Set_Has_Private_Declaration
(Prev
);
11745 Set_Has_Private_Declaration
(Id
);
11747 -- If no error, propagate freeze_node from private to full view.
11748 -- It may have been generated for an early operational item.
11750 if Present
(Freeze_Node
(Id
))
11751 and then Serious_Errors_Detected
= 0
11752 and then No
(Full_View
(Id
))
11754 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
11755 Set_Freeze_Node
(Id
, Empty
);
11756 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
11759 Set_Full_View
(Id
, Prev
);
11763 -- Verify that full declaration conforms to incomplete one
11765 if Is_Incomplete_Or_Private_Type
(Prev
)
11766 and then Present
(Discriminant_Specifications
(Prev_Par
))
11768 if Present
(Discriminant_Specifications
(N
)) then
11769 if Ekind
(Prev
) = E_Incomplete_Type
then
11770 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
11772 Check_Discriminant_Conformance
(N
, Prev
, Id
);
11777 ("missing discriminants in full type declaration", N
);
11779 -- To avoid cascaded errors on subsequent use, share the
11780 -- discriminants of the partial view.
11782 Set_Discriminant_Specifications
(N
,
11783 Discriminant_Specifications
(Prev_Par
));
11787 -- A prior untagged private type can have an associated class-wide
11788 -- type due to use of the class attribute, and in this case also the
11789 -- full type is required to be tagged.
11792 and then (Is_Tagged_Type
(Prev
)
11793 or else Present
(Class_Wide_Type
(Prev
)))
11794 and then (Nkind
(N
) /= N_Task_Type_Declaration
11795 and then Nkind
(N
) /= N_Protected_Type_Declaration
)
11797 -- The full declaration is either a tagged record or an
11798 -- extension otherwise this is an error
11800 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
11801 if not Tagged_Present
(Type_Definition
(N
)) then
11803 ("full declaration of } must be tagged", Prev
, Id
);
11804 Set_Is_Tagged_Type
(Id
);
11805 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11808 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
11809 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
11811 "full declaration of } must be a record extension",
11813 Set_Is_Tagged_Type
(Id
);
11814 Set_Primitive_Operations
(Id
, New_Elmt_List
);
11819 ("full declaration of } must be a tagged type", Prev
, Id
);
11827 -- New type declaration
11832 end Find_Type_Name
;
11834 -------------------------
11835 -- Find_Type_Of_Object --
11836 -------------------------
11838 function Find_Type_Of_Object
11839 (Obj_Def
: Node_Id
;
11840 Related_Nod
: Node_Id
) return Entity_Id
11842 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
11843 P
: Node_Id
:= Parent
(Obj_Def
);
11848 -- If the parent is a component_definition node we climb to the
11849 -- component_declaration node
11851 if Nkind
(P
) = N_Component_Definition
then
11855 -- Case of an anonymous array subtype
11857 if Def_Kind
= N_Constrained_Array_Definition
11858 or else Def_Kind
= N_Unconstrained_Array_Definition
11861 Array_Type_Declaration
(T
, Obj_Def
);
11863 -- Create an explicit subtype whenever possible
11865 elsif Nkind
(P
) /= N_Component_Declaration
11866 and then Def_Kind
= N_Subtype_Indication
11868 -- Base name of subtype on object name, which will be unique in
11869 -- the current scope.
11871 -- If this is a duplicate declaration, return base type, to avoid
11872 -- generating duplicate anonymous types.
11874 if Error_Posted
(P
) then
11875 Analyze
(Subtype_Mark
(Obj_Def
));
11876 return Entity
(Subtype_Mark
(Obj_Def
));
11881 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
11883 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
11885 Insert_Action
(Obj_Def
,
11886 Make_Subtype_Declaration
(Sloc
(P
),
11887 Defining_Identifier
=> T
,
11888 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
11890 -- This subtype may need freezing, and this will not be done
11891 -- automatically if the object declaration is not in declarative
11892 -- part. Since this is an object declaration, the type cannot always
11893 -- be frozen here. Deferred constants do not freeze their type
11894 -- (which often enough will be private).
11896 if Nkind
(P
) = N_Object_Declaration
11897 and then Constant_Present
(P
)
11898 and then No
(Expression
(P
))
11902 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
11905 -- Ada 2005 AI-406: the object definition in an object declaration
11906 -- can be an access definition.
11908 elsif Def_Kind
= N_Access_Definition
then
11909 T
:= Access_Definition
(Related_Nod
, Obj_Def
);
11911 if Nkind
(Parent
(Related_Nod
)) /= N_Extended_Return_Statement
then
11912 Set_Is_Local_Anonymous_Access
(T
);
11915 -- Otherwise, the object definition is just a subtype_mark
11918 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
11922 end Find_Type_Of_Object
;
11924 --------------------------------
11925 -- Find_Type_Of_Subtype_Indic --
11926 --------------------------------
11928 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
11932 -- Case of subtype mark with a constraint
11934 if Nkind
(S
) = N_Subtype_Indication
then
11935 Find_Type
(Subtype_Mark
(S
));
11936 Typ
:= Entity
(Subtype_Mark
(S
));
11939 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
11942 ("incorrect constraint for this kind of type", Constraint
(S
));
11943 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11946 -- Otherwise we have a subtype mark without a constraint
11948 elsif Error_Posted
(S
) then
11949 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
11957 if Typ
= Standard_Wide_Character
11958 or else Typ
= Standard_Wide_Wide_Character
11959 or else Typ
= Standard_Wide_String
11960 or else Typ
= Standard_Wide_Wide_String
11962 Check_Restriction
(No_Wide_Characters
, S
);
11966 end Find_Type_Of_Subtype_Indic
;
11968 -------------------------------------
11969 -- Floating_Point_Type_Declaration --
11970 -------------------------------------
11972 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
11973 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
11975 Base_Typ
: Entity_Id
;
11976 Implicit_Base
: Entity_Id
;
11979 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
11980 -- Find if given digits value allows derivation from specified type
11982 ---------------------
11983 -- Can_Derive_From --
11984 ---------------------
11986 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
11987 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
11990 if Digs_Val
> Digits_Value
(E
) then
11994 if Present
(Spec
) then
11995 if Expr_Value_R
(Type_Low_Bound
(E
)) >
11996 Expr_Value_R
(Low_Bound
(Spec
))
12001 if Expr_Value_R
(Type_High_Bound
(E
)) <
12002 Expr_Value_R
(High_Bound
(Spec
))
12009 end Can_Derive_From
;
12011 -- Start of processing for Floating_Point_Type_Declaration
12014 Check_Restriction
(No_Floating_Point
, Def
);
12016 -- Create an implicit base type
12019 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
12021 -- Analyze and verify digits value
12023 Analyze_And_Resolve
(Digs
, Any_Integer
);
12024 Check_Digits_Expression
(Digs
);
12025 Digs_Val
:= Expr_Value
(Digs
);
12027 -- Process possible range spec and find correct type to derive from
12029 Process_Real_Range_Specification
(Def
);
12031 if Can_Derive_From
(Standard_Short_Float
) then
12032 Base_Typ
:= Standard_Short_Float
;
12033 elsif Can_Derive_From
(Standard_Float
) then
12034 Base_Typ
:= Standard_Float
;
12035 elsif Can_Derive_From
(Standard_Long_Float
) then
12036 Base_Typ
:= Standard_Long_Float
;
12037 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
12038 Base_Typ
:= Standard_Long_Long_Float
;
12040 -- If we can't derive from any existing type, use long_long_float
12041 -- and give appropriate message explaining the problem.
12044 Base_Typ
:= Standard_Long_Long_Float
;
12046 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
12047 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
12048 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
12052 ("range too large for any predefined type",
12053 Real_Range_Specification
(Def
));
12057 -- If there are bounds given in the declaration use them as the bounds
12058 -- of the type, otherwise use the bounds of the predefined base type
12059 -- that was chosen based on the Digits value.
12061 if Present
(Real_Range_Specification
(Def
)) then
12062 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
12063 Set_Is_Constrained
(T
);
12065 -- The bounds of this range must be converted to machine numbers
12066 -- in accordance with RM 4.9(38).
12068 Bound
:= Type_Low_Bound
(T
);
12070 if Nkind
(Bound
) = N_Real_Literal
then
12072 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
12073 Set_Is_Machine_Number
(Bound
);
12076 Bound
:= Type_High_Bound
(T
);
12078 if Nkind
(Bound
) = N_Real_Literal
then
12080 (Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
, Bound
));
12081 Set_Is_Machine_Number
(Bound
);
12085 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
12088 -- Complete definition of implicit base and declared first subtype
12090 Set_Etype
(Implicit_Base
, Base_Typ
);
12092 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
12093 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
12094 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
12095 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
12096 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
12097 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
12099 Set_Ekind
(T
, E_Floating_Point_Subtype
);
12100 Set_Etype
(T
, Implicit_Base
);
12102 Set_Size_Info
(T
, (Implicit_Base
));
12103 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
12104 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
12105 Set_Digits_Value
(T
, Digs_Val
);
12106 end Floating_Point_Type_Declaration
;
12108 ----------------------------
12109 -- Get_Discriminant_Value --
12110 ----------------------------
12112 -- This is the situation:
12114 -- There is a non-derived type
12116 -- type T0 (Dx, Dy, Dz...)
12118 -- There are zero or more levels of derivation, with each derivation
12119 -- either purely inheriting the discriminants, or defining its own.
12121 -- type Ti is new Ti-1
12123 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
12125 -- subtype Ti is ...
12127 -- The subtype issue is avoided by the use of Original_Record_Component,
12128 -- and the fact that derived subtypes also derive the constraints.
12130 -- This chain leads back from
12132 -- Typ_For_Constraint
12134 -- Typ_For_Constraint has discriminants, and the value for each
12135 -- discriminant is given by its corresponding Elmt of Constraints.
12137 -- Discriminant is some discriminant in this hierarchy
12139 -- We need to return its value
12141 -- We do this by recursively searching each level, and looking for
12142 -- Discriminant. Once we get to the bottom, we start backing up
12143 -- returning the value for it which may in turn be a discriminant
12144 -- further up, so on the backup we continue the substitution.
12146 function Get_Discriminant_Value
12147 (Discriminant
: Entity_Id
;
12148 Typ_For_Constraint
: Entity_Id
;
12149 Constraint
: Elist_Id
) return Node_Id
12151 function Search_Derivation_Levels
12153 Discrim_Values
: Elist_Id
;
12154 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
;
12155 -- This is the routine that performs the recursive search of levels
12156 -- as described above.
12158 ------------------------------
12159 -- Search_Derivation_Levels --
12160 ------------------------------
12162 function Search_Derivation_Levels
12164 Discrim_Values
: Elist_Id
;
12165 Stored_Discrim_Values
: Boolean) return Node_Or_Entity_Id
12169 Result
: Node_Or_Entity_Id
;
12170 Result_Entity
: Node_Id
;
12173 -- If inappropriate type, return Error, this happens only in
12174 -- cascaded error situations, and we want to avoid a blow up.
12176 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
12180 -- Look deeper if possible. Use Stored_Constraints only for
12181 -- untagged types. For tagged types use the given constraint.
12182 -- This asymmetry needs explanation???
12184 if not Stored_Discrim_Values
12185 and then Present
(Stored_Constraint
(Ti
))
12186 and then not Is_Tagged_Type
(Ti
)
12189 Search_Derivation_Levels
(Ti
, Stored_Constraint
(Ti
), True);
12192 Td
: constant Entity_Id
:= Etype
(Ti
);
12196 Result
:= Discriminant
;
12199 if Present
(Stored_Constraint
(Ti
)) then
12201 Search_Derivation_Levels
12202 (Td
, Stored_Constraint
(Ti
), True);
12205 Search_Derivation_Levels
12206 (Td
, Discrim_Values
, Stored_Discrim_Values
);
12212 -- Extra underlying places to search, if not found above. For
12213 -- concurrent types, the relevant discriminant appears in the
12214 -- corresponding record. For a type derived from a private type
12215 -- without discriminant, the full view inherits the discriminants
12216 -- of the full view of the parent.
12218 if Result
= Discriminant
then
12219 if Is_Concurrent_Type
(Ti
)
12220 and then Present
(Corresponding_Record_Type
(Ti
))
12223 Search_Derivation_Levels
(
12224 Corresponding_Record_Type
(Ti
),
12226 Stored_Discrim_Values
);
12228 elsif Is_Private_Type
(Ti
)
12229 and then not Has_Discriminants
(Ti
)
12230 and then Present
(Full_View
(Ti
))
12231 and then Etype
(Full_View
(Ti
)) /= Ti
12234 Search_Derivation_Levels
(
12237 Stored_Discrim_Values
);
12241 -- If Result is not a (reference to a) discriminant, return it,
12242 -- otherwise set Result_Entity to the discriminant.
12244 if Nkind
(Result
) = N_Defining_Identifier
then
12245 pragma Assert
(Result
= Discriminant
);
12246 Result_Entity
:= Result
;
12249 if not Denotes_Discriminant
(Result
) then
12253 Result_Entity
:= Entity
(Result
);
12256 -- See if this level of derivation actually has discriminants
12257 -- because tagged derivations can add them, hence the lower
12258 -- levels need not have any.
12260 if not Has_Discriminants
(Ti
) then
12264 -- Scan Ti's discriminants for Result_Entity,
12265 -- and return its corresponding value, if any.
12267 Result_Entity
:= Original_Record_Component
(Result_Entity
);
12269 Assoc
:= First_Elmt
(Discrim_Values
);
12271 if Stored_Discrim_Values
then
12272 Disc
:= First_Stored_Discriminant
(Ti
);
12274 Disc
:= First_Discriminant
(Ti
);
12277 while Present
(Disc
) loop
12278 pragma Assert
(Present
(Assoc
));
12280 if Original_Record_Component
(Disc
) = Result_Entity
then
12281 return Node
(Assoc
);
12286 if Stored_Discrim_Values
then
12287 Next_Stored_Discriminant
(Disc
);
12289 Next_Discriminant
(Disc
);
12293 -- Could not find it
12296 end Search_Derivation_Levels
;
12298 Result
: Node_Or_Entity_Id
;
12300 -- Start of processing for Get_Discriminant_Value
12303 -- ??? This routine is a gigantic mess and will be deleted. For the
12304 -- time being just test for the trivial case before calling recurse.
12306 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
12312 D
:= First_Discriminant
(Typ_For_Constraint
);
12313 E
:= First_Elmt
(Constraint
);
12314 while Present
(D
) loop
12315 if Chars
(D
) = Chars
(Discriminant
) then
12319 Next_Discriminant
(D
);
12325 Result
:= Search_Derivation_Levels
12326 (Typ_For_Constraint
, Constraint
, False);
12328 -- ??? hack to disappear when this routine is gone
12330 if Nkind
(Result
) = N_Defining_Identifier
then
12336 D
:= First_Discriminant
(Typ_For_Constraint
);
12337 E
:= First_Elmt
(Constraint
);
12338 while Present
(D
) loop
12339 if Corresponding_Discriminant
(D
) = Discriminant
then
12343 Next_Discriminant
(D
);
12349 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
12351 end Get_Discriminant_Value
;
12353 --------------------------
12354 -- Has_Range_Constraint --
12355 --------------------------
12357 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
12358 C
: constant Node_Id
:= Constraint
(N
);
12361 if Nkind
(C
) = N_Range_Constraint
then
12364 elsif Nkind
(C
) = N_Digits_Constraint
then
12366 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
12368 Present
(Range_Constraint
(C
));
12370 elsif Nkind
(C
) = N_Delta_Constraint
then
12371 return Present
(Range_Constraint
(C
));
12376 end Has_Range_Constraint
;
12378 ------------------------
12379 -- Inherit_Components --
12380 ------------------------
12382 function Inherit_Components
12384 Parent_Base
: Entity_Id
;
12385 Derived_Base
: Entity_Id
;
12386 Is_Tagged
: Boolean;
12387 Inherit_Discr
: Boolean;
12388 Discs
: Elist_Id
) return Elist_Id
12390 Assoc_List
: constant Elist_Id
:= New_Elmt_List
;
12392 procedure Inherit_Component
12393 (Old_C
: Entity_Id
;
12394 Plain_Discrim
: Boolean := False;
12395 Stored_Discrim
: Boolean := False);
12396 -- Inherits component Old_C from Parent_Base to the Derived_Base. If
12397 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
12398 -- True, Old_C is a stored discriminant. If they are both false then
12399 -- Old_C is a regular component.
12401 -----------------------
12402 -- Inherit_Component --
12403 -----------------------
12405 procedure Inherit_Component
12406 (Old_C
: Entity_Id
;
12407 Plain_Discrim
: Boolean := False;
12408 Stored_Discrim
: Boolean := False)
12410 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
12412 Discrim
: Entity_Id
;
12413 Corr_Discrim
: Entity_Id
;
12416 pragma Assert
(not Is_Tagged
or else not Stored_Discrim
);
12418 Set_Parent
(New_C
, Parent
(Old_C
));
12420 -- Regular discriminants and components must be inserted in the scope
12421 -- of the Derived_Base. Do it here.
12423 if not Stored_Discrim
then
12424 Enter_Name
(New_C
);
12427 -- For tagged types the Original_Record_Component must point to
12428 -- whatever this field was pointing to in the parent type. This has
12429 -- already been achieved by the call to New_Copy above.
12431 if not Is_Tagged
then
12432 Set_Original_Record_Component
(New_C
, New_C
);
12435 -- If we have inherited a component then see if its Etype contains
12436 -- references to Parent_Base discriminants. In this case, replace
12437 -- these references with the constraints given in Discs. We do not
12438 -- do this for the partial view of private types because this is
12439 -- not needed (only the components of the full view will be used
12440 -- for code generation) and cause problem. We also avoid this
12441 -- transformation in some error situations.
12443 if Ekind
(New_C
) = E_Component
then
12444 if (Is_Private_Type
(Derived_Base
)
12445 and then not Is_Generic_Type
(Derived_Base
))
12446 or else (Is_Empty_Elmt_List
(Discs
)
12447 and then not Expander_Active
)
12449 Set_Etype
(New_C
, Etype
(Old_C
));
12452 -- The current component introduces a circularity of the
12455 -- limited with Pack_2;
12456 -- package Pack_1 is
12457 -- type T_1 is tagged record
12458 -- Comp : access Pack_2.T_2;
12464 -- package Pack_2 is
12465 -- type T_2 is new Pack_1.T_1 with ...;
12468 -- When Comp is being duplicated for type T_2, its designated
12469 -- type must be set to point to the non-limited view of T_2.
12471 if Ada_Version
>= Ada_05
12473 Ekind
(Etype
(New_C
)) = E_Anonymous_Access_Type
12475 Ekind
(Directly_Designated_Type
12476 (Etype
(New_C
))) = E_Incomplete_Type
12478 From_With_Type
(Directly_Designated_Type
(Etype
(New_C
)))
12480 Present
(Non_Limited_View
12481 (Directly_Designated_Type
(Etype
(New_C
))))
12483 Non_Limited_View
(Directly_Designated_Type
12484 (Etype
(New_C
))) = Derived_Base
12486 Set_Directly_Designated_Type
12489 (Directly_Designated_Type
(Etype
(New_C
))));
12494 Constrain_Component_Type
12495 (Old_C
, Derived_Base
, N
, Parent_Base
, Discs
));
12500 -- In derived tagged types it is illegal to reference a non
12501 -- discriminant component in the parent type. To catch this, mark
12502 -- these components with an Ekind of E_Void. This will be reset in
12503 -- Record_Type_Definition after processing the record extension of
12504 -- the derived type.
12506 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
12507 Set_Ekind
(New_C
, E_Void
);
12510 if Plain_Discrim
then
12511 Set_Corresponding_Discriminant
(New_C
, Old_C
);
12512 Build_Discriminal
(New_C
);
12514 -- If we are explicitly inheriting a stored discriminant it will be
12515 -- completely hidden.
12517 elsif Stored_Discrim
then
12518 Set_Corresponding_Discriminant
(New_C
, Empty
);
12519 Set_Discriminal
(New_C
, Empty
);
12520 Set_Is_Completely_Hidden
(New_C
);
12522 -- Set the Original_Record_Component of each discriminant in the
12523 -- derived base to point to the corresponding stored that we just
12526 Discrim
:= First_Discriminant
(Derived_Base
);
12527 while Present
(Discrim
) loop
12528 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
12530 -- Corr_Discrim could be missing in an error situation
12532 if Present
(Corr_Discrim
)
12533 and then Original_Record_Component
(Corr_Discrim
) = Old_C
12535 Set_Original_Record_Component
(Discrim
, New_C
);
12538 Next_Discriminant
(Discrim
);
12541 Append_Entity
(New_C
, Derived_Base
);
12544 if not Is_Tagged
then
12545 Append_Elmt
(Old_C
, Assoc_List
);
12546 Append_Elmt
(New_C
, Assoc_List
);
12548 end Inherit_Component
;
12550 -- Variables local to Inherit_Component
12552 Loc
: constant Source_Ptr
:= Sloc
(N
);
12554 Parent_Discrim
: Entity_Id
;
12555 Stored_Discrim
: Entity_Id
;
12557 Component
: Entity_Id
;
12559 -- Start of processing for Inherit_Components
12562 if not Is_Tagged
then
12563 Append_Elmt
(Parent_Base
, Assoc_List
);
12564 Append_Elmt
(Derived_Base
, Assoc_List
);
12567 -- Inherit parent discriminants if needed
12569 if Inherit_Discr
then
12570 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
12571 while Present
(Parent_Discrim
) loop
12572 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
12573 Next_Discriminant
(Parent_Discrim
);
12577 -- Create explicit stored discrims for untagged types when necessary
12579 if not Has_Unknown_Discriminants
(Derived_Base
)
12580 and then Has_Discriminants
(Parent_Base
)
12581 and then not Is_Tagged
12584 or else First_Discriminant
(Parent_Base
) /=
12585 First_Stored_Discriminant
(Parent_Base
))
12587 Stored_Discrim
:= First_Stored_Discriminant
(Parent_Base
);
12588 while Present
(Stored_Discrim
) loop
12589 Inherit_Component
(Stored_Discrim
, Stored_Discrim
=> True);
12590 Next_Stored_Discriminant
(Stored_Discrim
);
12594 -- See if we can apply the second transformation for derived types, as
12595 -- explained in point 6. in the comments above Build_Derived_Record_Type
12596 -- This is achieved by appending Derived_Base discriminants into Discs,
12597 -- which has the side effect of returning a non empty Discs list to the
12598 -- caller of Inherit_Components, which is what we want. This must be
12599 -- done for private derived types if there are explicit stored
12600 -- discriminants, to ensure that we can retrieve the values of the
12601 -- constraints provided in the ancestors.
12604 and then Is_Empty_Elmt_List
(Discs
)
12605 and then Present
(First_Discriminant
(Derived_Base
))
12607 (not Is_Private_Type
(Derived_Base
)
12608 or else Is_Completely_Hidden
12609 (First_Stored_Discriminant
(Derived_Base
))
12610 or else Is_Generic_Type
(Derived_Base
))
12612 D
:= First_Discriminant
(Derived_Base
);
12613 while Present
(D
) loop
12614 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
12615 Next_Discriminant
(D
);
12619 -- Finally, inherit non-discriminant components unless they are not
12620 -- visible because defined or inherited from the full view of the
12621 -- parent. Don't inherit the _parent field of the parent type.
12623 Component
:= First_Entity
(Parent_Base
);
12624 while Present
(Component
) loop
12626 -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
12627 -- interfaces of the parent
12629 if Ekind
(Component
) = E_Component
12630 and then Is_Tag
(Component
)
12631 and then RTE_Available
(RE_Interface_Tag
)
12632 and then Etype
(Component
) = RTE
(RE_Interface_Tag
)
12636 elsif Ekind
(Component
) /= E_Component
12637 or else Chars
(Component
) = Name_uParent
12641 -- If the derived type is within the parent type's declarative
12642 -- region, then the components can still be inherited even though
12643 -- they aren't visible at this point. This can occur for cases
12644 -- such as within public child units where the components must
12645 -- become visible upon entering the child unit's private part.
12647 elsif not Is_Visible_Component
(Component
)
12648 and then not In_Open_Scopes
(Scope
(Parent_Base
))
12652 elsif Ekind
(Derived_Base
) = E_Private_Type
12653 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
12658 Inherit_Component
(Component
);
12661 Next_Entity
(Component
);
12664 -- For tagged derived types, inherited discriminants cannot be used in
12665 -- component declarations of the record extension part. To achieve this
12666 -- we mark the inherited discriminants as not visible.
12668 if Is_Tagged
and then Inherit_Discr
then
12669 D
:= First_Discriminant
(Derived_Base
);
12670 while Present
(D
) loop
12671 Set_Is_Immediately_Visible
(D
, False);
12672 Next_Discriminant
(D
);
12677 end Inherit_Components
;
12679 -----------------------
12680 -- Is_Null_Extension --
12681 -----------------------
12683 function Is_Null_Extension
(T
: Entity_Id
) return Boolean is
12684 Full_Type_Decl
: constant Node_Id
:= Parent
(T
);
12685 Full_Type_Defn
: constant Node_Id
:= Type_Definition
(Full_Type_Decl
);
12686 Comp_List
: Node_Id
;
12687 First_Comp
: Node_Id
;
12690 if not Is_Tagged_Type
(T
)
12691 or else Nkind
(Full_Type_Defn
) /= N_Derived_Type_Definition
12696 Comp_List
:= Component_List
(Record_Extension_Part
(Full_Type_Defn
));
12698 if Present
(Discriminant_Specifications
(Full_Type_Decl
)) then
12701 elsif Present
(Comp_List
)
12702 and then Is_Non_Empty_List
(Component_Items
(Comp_List
))
12704 First_Comp
:= First
(Component_Items
(Comp_List
));
12706 return Chars
(Defining_Identifier
(First_Comp
)) = Name_uParent
12707 and then No
(Next
(First_Comp
));
12712 end Is_Null_Extension
;
12714 ------------------------------
12715 -- Is_Valid_Constraint_Kind --
12716 ------------------------------
12718 function Is_Valid_Constraint_Kind
12719 (T_Kind
: Type_Kind
;
12720 Constraint_Kind
: Node_Kind
) return Boolean
12724 when Enumeration_Kind |
12726 return Constraint_Kind
= N_Range_Constraint
;
12728 when Decimal_Fixed_Point_Kind
=>
12730 Constraint_Kind
= N_Digits_Constraint
12732 Constraint_Kind
= N_Range_Constraint
;
12734 when Ordinary_Fixed_Point_Kind
=>
12736 Constraint_Kind
= N_Delta_Constraint
12738 Constraint_Kind
= N_Range_Constraint
;
12742 Constraint_Kind
= N_Digits_Constraint
12744 Constraint_Kind
= N_Range_Constraint
;
12751 E_Incomplete_Type |
12754 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
12757 return True; -- Error will be detected later
12759 end Is_Valid_Constraint_Kind
;
12761 --------------------------
12762 -- Is_Visible_Component --
12763 --------------------------
12765 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
12766 Original_Comp
: Entity_Id
:= Empty
;
12767 Original_Scope
: Entity_Id
;
12768 Type_Scope
: Entity_Id
;
12770 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean;
12771 -- Check whether parent type of inherited component is declared locally,
12772 -- possibly within a nested package or instance. The current scope is
12773 -- the derived record itself.
12775 -------------------
12776 -- Is_Local_Type --
12777 -------------------
12779 function Is_Local_Type
(Typ
: Entity_Id
) return Boolean is
12783 Scop
:= Scope
(Typ
);
12784 while Present
(Scop
)
12785 and then Scop
/= Standard_Standard
12787 if Scop
= Scope
(Current_Scope
) then
12791 Scop
:= Scope
(Scop
);
12797 -- Start of processing for Is_Visible_Component
12800 if Ekind
(C
) = E_Component
12801 or else Ekind
(C
) = E_Discriminant
12803 Original_Comp
:= Original_Record_Component
(C
);
12806 if No
(Original_Comp
) then
12808 -- Premature usage, or previous error
12813 Original_Scope
:= Scope
(Original_Comp
);
12814 Type_Scope
:= Scope
(Base_Type
(Scope
(C
)));
12817 -- This test only concerns tagged types
12819 if not Is_Tagged_Type
(Original_Scope
) then
12822 -- If it is _Parent or _Tag, there is no visibility issue
12824 elsif not Comes_From_Source
(Original_Comp
) then
12827 -- If we are in the body of an instantiation, the component is visible
12828 -- even when the parent type (possibly defined in an enclosing unit or
12829 -- in a parent unit) might not.
12831 elsif In_Instance_Body
then
12834 -- Discriminants are always visible
12836 elsif Ekind
(Original_Comp
) = E_Discriminant
12837 and then not Has_Unknown_Discriminants
(Original_Scope
)
12841 -- If the component has been declared in an ancestor which is currently
12842 -- a private type, then it is not visible. The same applies if the
12843 -- component's containing type is not in an open scope and the original
12844 -- component's enclosing type is a visible full type of a private type
12845 -- (which can occur in cases where an attempt is being made to reference
12846 -- a component in a sibling package that is inherited from a visible
12847 -- component of a type in an ancestor package; the component in the
12848 -- sibling package should not be visible even though the component it
12849 -- inherited from is visible). This does not apply however in the case
12850 -- where the scope of the type is a private child unit, or when the
12851 -- parent comes from a local package in which the ancestor is currently
12852 -- visible. The latter suppression of visibility is needed for cases
12853 -- that are tested in B730006.
12855 elsif Is_Private_Type
(Original_Scope
)
12857 (not Is_Private_Descendant
(Type_Scope
)
12858 and then not In_Open_Scopes
(Type_Scope
)
12859 and then Has_Private_Declaration
(Original_Scope
))
12861 -- If the type derives from an entity in a formal package, there
12862 -- are no additional visible components.
12864 if Nkind
(Original_Node
(Unit_Declaration_Node
(Type_Scope
))) =
12865 N_Formal_Package_Declaration
12869 -- if we are not in the private part of the current package, there
12870 -- are no additional visible components.
12872 elsif Ekind
(Scope
(Current_Scope
)) = E_Package
12873 and then not In_Private_Part
(Scope
(Current_Scope
))
12878 Is_Child_Unit
(Cunit_Entity
(Current_Sem_Unit
))
12879 and then Is_Local_Type
(Type_Scope
);
12882 -- There is another weird way in which a component may be invisible
12883 -- when the private and the full view are not derived from the same
12884 -- ancestor. Here is an example :
12886 -- type A1 is tagged record F1 : integer; end record;
12887 -- type A2 is new A1 with record F2 : integer; end record;
12888 -- type T is new A1 with private;
12890 -- type T is new A2 with null record;
12892 -- In this case, the full view of T inherits F1 and F2 but the private
12893 -- view inherits only F1
12897 Ancestor
: Entity_Id
:= Scope
(C
);
12901 if Ancestor
= Original_Scope
then
12903 elsif Ancestor
= Etype
(Ancestor
) then
12907 Ancestor
:= Etype
(Ancestor
);
12913 end Is_Visible_Component
;
12915 --------------------------
12916 -- Make_Class_Wide_Type --
12917 --------------------------
12919 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
12920 CW_Type
: Entity_Id
;
12922 Next_E
: Entity_Id
;
12925 -- The class wide type can have been defined by the partial view, in
12926 -- which case everything is already done.
12928 if Present
(Class_Wide_Type
(T
)) then
12933 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
12935 -- Inherit root type characteristics
12937 CW_Name
:= Chars
(CW_Type
);
12938 Next_E
:= Next_Entity
(CW_Type
);
12939 Copy_Node
(T
, CW_Type
);
12940 Set_Comes_From_Source
(CW_Type
, False);
12941 Set_Chars
(CW_Type
, CW_Name
);
12942 Set_Parent
(CW_Type
, Parent
(T
));
12943 Set_Next_Entity
(CW_Type
, Next_E
);
12945 -- Ensure we have a new freeze node for the class-wide type. The partial
12946 -- view may have freeze action of its own, requiring a proper freeze
12947 -- node, and the same freeze node cannot be shared between the two
12950 Set_Has_Delayed_Freeze
(CW_Type
);
12951 Set_Freeze_Node
(CW_Type
, Empty
);
12953 -- Customize the class-wide type: It has no prim. op., it cannot be
12954 -- abstract and its Etype points back to the specific root type.
12956 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
12957 Set_Is_Tagged_Type
(CW_Type
, True);
12958 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
12959 Set_Is_Abstract
(CW_Type
, False);
12960 Set_Is_Constrained
(CW_Type
, False);
12961 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
12962 Init_Size_Align
(CW_Type
);
12964 if Ekind
(T
) = E_Class_Wide_Subtype
then
12965 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
12967 Set_Etype
(CW_Type
, T
);
12970 -- If this is the class_wide type of a constrained subtype, it does
12971 -- not have discriminants.
12973 Set_Has_Discriminants
(CW_Type
,
12974 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
12976 Set_Has_Unknown_Discriminants
(CW_Type
, True);
12977 Set_Class_Wide_Type
(T
, CW_Type
);
12978 Set_Equivalent_Type
(CW_Type
, Empty
);
12980 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
12982 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
12983 end Make_Class_Wide_Type
;
12989 procedure Make_Index
12991 Related_Nod
: Node_Id
;
12992 Related_Id
: Entity_Id
:= Empty
;
12993 Suffix_Index
: Nat
:= 1)
12997 Def_Id
: Entity_Id
:= Empty
;
12998 Found
: Boolean := False;
13001 -- For a discrete range used in a constrained array definition and
13002 -- defined by a range, an implicit conversion to the predefined type
13003 -- INTEGER is assumed if each bound is either a numeric literal, a named
13004 -- number, or an attribute, and the type of both bounds (prior to the
13005 -- implicit conversion) is the type universal_integer. Otherwise, both
13006 -- bounds must be of the same discrete type, other than universal
13007 -- integer; this type must be determinable independently of the
13008 -- context, but using the fact that the type must be discrete and that
13009 -- both bounds must have the same type.
13011 -- Character literals also have a universal type in the absence of
13012 -- of additional context, and are resolved to Standard_Character.
13014 if Nkind
(I
) = N_Range
then
13016 -- The index is given by a range constraint. The bounds are known
13017 -- to be of a consistent type.
13019 if not Is_Overloaded
(I
) then
13022 -- If the bounds are universal, choose the specific predefined
13025 if T
= Universal_Integer
then
13026 T
:= Standard_Integer
;
13028 elsif T
= Any_Character
then
13030 if Ada_Version
>= Ada_95
then
13032 ("ambiguous character literals (could be Wide_Character)",
13036 T
:= Standard_Character
;
13043 Ind
: Interp_Index
;
13047 Get_First_Interp
(I
, Ind
, It
);
13048 while Present
(It
.Typ
) loop
13049 if Is_Discrete_Type
(It
.Typ
) then
13052 and then not Covers
(It
.Typ
, T
)
13053 and then not Covers
(T
, It
.Typ
)
13055 Error_Msg_N
("ambiguous bounds in discrete range", I
);
13063 Get_Next_Interp
(Ind
, It
);
13066 if T
= Any_Type
then
13067 Error_Msg_N
("discrete type required for range", I
);
13068 Set_Etype
(I
, Any_Type
);
13071 elsif T
= Universal_Integer
then
13072 T
:= Standard_Integer
;
13077 if not Is_Discrete_Type
(T
) then
13078 Error_Msg_N
("discrete type required for range", I
);
13079 Set_Etype
(I
, Any_Type
);
13083 if Nkind
(Low_Bound
(I
)) = N_Attribute_Reference
13084 and then Attribute_Name
(Low_Bound
(I
)) = Name_First
13085 and then Is_Entity_Name
(Prefix
(Low_Bound
(I
)))
13086 and then Is_Type
(Entity
(Prefix
(Low_Bound
(I
))))
13087 and then Is_Discrete_Type
(Entity
(Prefix
(Low_Bound
(I
))))
13089 -- The type of the index will be the type of the prefix, as long
13090 -- as the upper bound is 'Last of the same type.
13092 Def_Id
:= Entity
(Prefix
(Low_Bound
(I
)));
13094 if Nkind
(High_Bound
(I
)) /= N_Attribute_Reference
13095 or else Attribute_Name
(High_Bound
(I
)) /= Name_Last
13096 or else not Is_Entity_Name
(Prefix
(High_Bound
(I
)))
13097 or else Entity
(Prefix
(High_Bound
(I
))) /= Def_Id
13104 Process_Range_Expr_In_Decl
(R
, T
);
13106 elsif Nkind
(I
) = N_Subtype_Indication
then
13108 -- The index is given by a subtype with a range constraint
13110 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
13112 if not Is_Discrete_Type
(T
) then
13113 Error_Msg_N
("discrete type required for range", I
);
13114 Set_Etype
(I
, Any_Type
);
13118 R
:= Range_Expression
(Constraint
(I
));
13121 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
13123 elsif Nkind
(I
) = N_Attribute_Reference
then
13125 -- The parser guarantees that the attribute is a RANGE attribute
13127 -- If the node denotes the range of a type mark, that is also the
13128 -- resulting type, and we do no need to create an Itype for it.
13130 if Is_Entity_Name
(Prefix
(I
))
13131 and then Comes_From_Source
(I
)
13132 and then Is_Type
(Entity
(Prefix
(I
)))
13133 and then Is_Discrete_Type
(Entity
(Prefix
(I
)))
13135 Def_Id
:= Entity
(Prefix
(I
));
13138 Analyze_And_Resolve
(I
);
13142 -- If none of the above, must be a subtype. We convert this to a
13143 -- range attribute reference because in the case of declared first
13144 -- named subtypes, the types in the range reference can be different
13145 -- from the type of the entity. A range attribute normalizes the
13146 -- reference and obtains the correct types for the bounds.
13148 -- This transformation is in the nature of an expansion, is only
13149 -- done if expansion is active. In particular, it is not done on
13150 -- formal generic types, because we need to retain the name of the
13151 -- original index for instantiation purposes.
13154 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
13155 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
13156 Set_Etype
(I
, Any_Integer
);
13160 -- The type mark may be that of an incomplete type. It is only
13161 -- now that we can get the full view, previous analysis does
13162 -- not look specifically for a type mark.
13164 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
13165 Set_Etype
(I
, Entity
(I
));
13166 Def_Id
:= Entity
(I
);
13168 if not Is_Discrete_Type
(Def_Id
) then
13169 Error_Msg_N
("discrete type required for index", I
);
13170 Set_Etype
(I
, Any_Type
);
13175 if Expander_Active
then
13177 Make_Attribute_Reference
(Sloc
(I
),
13178 Attribute_Name
=> Name_Range
,
13179 Prefix
=> Relocate_Node
(I
)));
13181 -- The original was a subtype mark that does not freeze. This
13182 -- means that the rewritten version must not freeze either.
13184 Set_Must_Not_Freeze
(I
);
13185 Set_Must_Not_Freeze
(Prefix
(I
));
13187 -- Is order critical??? if so, document why, if not
13188 -- use Analyze_And_Resolve
13190 Analyze_And_Resolve
(I
);
13194 -- If expander is inactive, type is legal, nothing else to construct
13201 if not Is_Discrete_Type
(T
) then
13202 Error_Msg_N
("discrete type required for range", I
);
13203 Set_Etype
(I
, Any_Type
);
13206 elsif T
= Any_Type
then
13207 Set_Etype
(I
, Any_Type
);
13211 -- We will now create the appropriate Itype to describe the range, but
13212 -- first a check. If we originally had a subtype, then we just label
13213 -- the range with this subtype. Not only is there no need to construct
13214 -- a new subtype, but it is wrong to do so for two reasons:
13216 -- 1. A legality concern, if we have a subtype, it must not freeze,
13217 -- and the Itype would cause freezing incorrectly
13219 -- 2. An efficiency concern, if we created an Itype, it would not be
13220 -- recognized as the same type for the purposes of eliminating
13221 -- checks in some circumstances.
13223 -- We signal this case by setting the subtype entity in Def_Id
13225 if No
(Def_Id
) then
13227 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
13228 Set_Etype
(Def_Id
, Base_Type
(T
));
13230 if Is_Signed_Integer_Type
(T
) then
13231 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
13233 elsif Is_Modular_Integer_Type
(T
) then
13234 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
13237 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
13238 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
13239 Set_First_Literal
(Def_Id
, First_Literal
(T
));
13242 Set_Size_Info
(Def_Id
, (T
));
13243 Set_RM_Size
(Def_Id
, RM_Size
(T
));
13244 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
13246 Set_Scalar_Range
(Def_Id
, R
);
13247 Conditional_Delay
(Def_Id
, T
);
13249 -- In the subtype indication case, if the immediate parent of the
13250 -- new subtype is non-static, then the subtype we create is non-
13251 -- static, even if its bounds are static.
13253 if Nkind
(I
) = N_Subtype_Indication
13254 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
13256 Set_Is_Non_Static_Subtype
(Def_Id
);
13260 -- Final step is to label the index with this constructed type
13262 Set_Etype
(I
, Def_Id
);
13265 ------------------------------
13266 -- Modular_Type_Declaration --
13267 ------------------------------
13269 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
13270 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
13273 procedure Set_Modular_Size
(Bits
: Int
);
13274 -- Sets RM_Size to Bits, and Esize to normal word size above this
13276 ----------------------
13277 -- Set_Modular_Size --
13278 ----------------------
13280 procedure Set_Modular_Size
(Bits
: Int
) is
13282 Set_RM_Size
(T
, UI_From_Int
(Bits
));
13287 elsif Bits
<= 16 then
13288 Init_Esize
(T
, 16);
13290 elsif Bits
<= 32 then
13291 Init_Esize
(T
, 32);
13294 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
13296 end Set_Modular_Size
;
13298 -- Start of processing for Modular_Type_Declaration
13301 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
13303 Set_Ekind
(T
, E_Modular_Integer_Type
);
13304 Init_Alignment
(T
);
13305 Set_Is_Constrained
(T
);
13307 if not Is_OK_Static_Expression
(Mod_Expr
) then
13308 Flag_Non_Static_Expr
13309 ("non-static expression used for modular type bound!", Mod_Expr
);
13310 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
13312 M_Val
:= Expr_Value
(Mod_Expr
);
13316 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
13317 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
13320 Set_Modulus
(T
, M_Val
);
13322 -- Create bounds for the modular type based on the modulus given in
13323 -- the type declaration and then analyze and resolve those bounds.
13325 Set_Scalar_Range
(T
,
13326 Make_Range
(Sloc
(Mod_Expr
),
13328 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
13330 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
13332 -- Properly analyze the literals for the range. We do this manually
13333 -- because we can't go calling Resolve, since we are resolving these
13334 -- bounds with the type, and this type is certainly not complete yet!
13336 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
13337 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
13338 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
13339 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
13341 -- Loop through powers of two to find number of bits required
13343 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
13347 if M_Val
= 2 ** Bits
then
13348 Set_Modular_Size
(Bits
);
13353 elsif M_Val
< 2 ** Bits
then
13354 Set_Non_Binary_Modulus
(T
);
13356 if Bits
> System_Max_Nonbinary_Modulus_Power
then
13357 Error_Msg_Uint_1
:=
13358 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
13360 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
13361 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
13365 -- In the non-binary case, set size as per RM 13.3(55)
13367 Set_Modular_Size
(Bits
);
13374 -- If we fall through, then the size exceed System.Max_Binary_Modulus
13375 -- so we just signal an error and set the maximum size.
13377 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
13378 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
13380 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
13381 Init_Alignment
(T
);
13383 end Modular_Type_Declaration
;
13385 --------------------------
13386 -- New_Concatenation_Op --
13387 --------------------------
13389 procedure New_Concatenation_Op
(Typ
: Entity_Id
) is
13390 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
13393 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
13394 -- Create abbreviated declaration for the formal of a predefined
13395 -- Operator 'Op' of type 'Typ'
13397 --------------------
13398 -- Make_Op_Formal --
13399 --------------------
13401 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
13402 Formal
: Entity_Id
;
13404 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
13405 Set_Etype
(Formal
, Typ
);
13406 Set_Mechanism
(Formal
, Default_Mechanism
);
13408 end Make_Op_Formal
;
13410 -- Start of processing for New_Concatenation_Op
13413 Op
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Concat
);
13415 Set_Ekind
(Op
, E_Operator
);
13416 Set_Scope
(Op
, Current_Scope
);
13417 Set_Etype
(Op
, Typ
);
13418 Set_Homonym
(Op
, Get_Name_Entity_Id
(Name_Op_Concat
));
13419 Set_Is_Immediately_Visible
(Op
);
13420 Set_Is_Intrinsic_Subprogram
(Op
);
13421 Set_Has_Completion
(Op
);
13422 Append_Entity
(Op
, Current_Scope
);
13424 Set_Name_Entity_Id
(Name_Op_Concat
, Op
);
13426 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
13427 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
13428 end New_Concatenation_Op
;
13430 -------------------------
13431 -- OK_For_Limited_Init --
13432 -------------------------
13434 -- ???Check all calls of this, and compare the conditions under which it's
13437 function OK_For_Limited_Init
(Exp
: Node_Id
) return Boolean is
13439 return Ada_Version
>= Ada_05
13440 and then not Debug_Flag_Dot_L
13441 and then OK_For_Limited_Init_In_05
(Exp
);
13442 end OK_For_Limited_Init
;
13444 -------------------------------
13445 -- OK_For_Limited_Init_In_05 --
13446 -------------------------------
13448 function OK_For_Limited_Init_In_05
(Exp
: Node_Id
) return Boolean is
13450 -- ???Expand_N_Extended_Return_Statement generates code that would
13451 -- violate the rules in some cases. Once we have build-in-place
13452 -- function returns working, we can probably remove the following
13455 if not Comes_From_Source
(Exp
) then
13459 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front-end in
13460 -- case of limited aggregates (including extension aggregates),
13461 -- and function calls.
13463 case Nkind
(Original_Node
(Exp
)) is
13464 when N_Aggregate | N_Extension_Aggregate | N_Function_Call
=>
13467 when N_Qualified_Expression
=>
13468 return OK_For_Limited_Init_In_05
13469 (Expression
(Original_Node
(Exp
)));
13474 end OK_For_Limited_Init_In_05
;
13476 -------------------------------------------
13477 -- Ordinary_Fixed_Point_Type_Declaration --
13478 -------------------------------------------
13480 procedure Ordinary_Fixed_Point_Type_Declaration
13484 Loc
: constant Source_Ptr
:= Sloc
(Def
);
13485 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
13486 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
13487 Implicit_Base
: Entity_Id
;
13494 Check_Restriction
(No_Fixed_Point
, Def
);
13496 -- Create implicit base type
13499 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
13500 Set_Etype
(Implicit_Base
, Implicit_Base
);
13502 -- Analyze and process delta expression
13504 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
13506 Check_Delta_Expression
(Delta_Expr
);
13507 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
13509 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
13511 -- Compute default small from given delta, which is the largest power
13512 -- of two that does not exceed the given delta value.
13522 if Delta_Val
< Ureal_1
then
13523 while Delta_Val
< Tmp
loop
13524 Tmp
:= Tmp
/ Ureal_2
;
13525 Scale
:= Scale
+ 1;
13530 Tmp
:= Tmp
* Ureal_2
;
13531 exit when Tmp
> Delta_Val
;
13532 Scale
:= Scale
- 1;
13536 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
13539 Set_Small_Value
(Implicit_Base
, Small_Val
);
13541 -- If no range was given, set a dummy range
13543 if RRS
<= Empty_Or_Error
then
13544 Low_Val
:= -Small_Val
;
13545 High_Val
:= Small_Val
;
13547 -- Otherwise analyze and process given range
13551 Low
: constant Node_Id
:= Low_Bound
(RRS
);
13552 High
: constant Node_Id
:= High_Bound
(RRS
);
13555 Analyze_And_Resolve
(Low
, Any_Real
);
13556 Analyze_And_Resolve
(High
, Any_Real
);
13557 Check_Real_Bound
(Low
);
13558 Check_Real_Bound
(High
);
13560 -- Obtain and set the range
13562 Low_Val
:= Expr_Value_R
(Low
);
13563 High_Val
:= Expr_Value_R
(High
);
13565 if Low_Val
> High_Val
then
13566 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
13571 -- The range for both the implicit base and the declared first subtype
13572 -- cannot be set yet, so we use the special routine Set_Fixed_Range to
13573 -- set a temporary range in place. Note that the bounds of the base
13574 -- type will be widened to be symmetrical and to fill the available
13575 -- bits when the type is frozen.
13577 -- We could do this with all discrete types, and probably should, but
13578 -- we absolutely have to do it for fixed-point, since the end-points
13579 -- of the range and the size are determined by the small value, which
13580 -- could be reset before the freeze point.
13582 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
13583 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
13585 Init_Size_Align
(Implicit_Base
);
13587 -- Complete definition of first subtype
13589 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
13590 Set_Etype
(T
, Implicit_Base
);
13591 Init_Size_Align
(T
);
13592 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
13593 Set_Small_Value
(T
, Small_Val
);
13594 Set_Delta_Value
(T
, Delta_Val
);
13595 Set_Is_Constrained
(T
);
13597 end Ordinary_Fixed_Point_Type_Declaration
;
13599 ----------------------------------------
13600 -- Prepare_Private_Subtype_Completion --
13601 ----------------------------------------
13603 procedure Prepare_Private_Subtype_Completion
13605 Related_Nod
: Node_Id
)
13607 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
13608 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
13612 if Present
(Full_B
) then
13614 -- The Base_Type is already completed, we can complete the subtype
13615 -- now. We have to create a new entity with the same name, Thus we
13616 -- can't use Create_Itype.
13618 -- This is messy, should be fixed ???
13620 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
13621 Set_Is_Itype
(Full
);
13622 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
13623 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
13626 -- The parent subtype may be private, but the base might not, in some
13627 -- nested instances. In that case, the subtype does not need to be
13628 -- exchanged. It would still be nice to make private subtypes and their
13629 -- bases consistent at all times ???
13631 if Is_Private_Type
(Id_B
) then
13632 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
13635 end Prepare_Private_Subtype_Completion
;
13637 ---------------------------
13638 -- Process_Discriminants --
13639 ---------------------------
13641 procedure Process_Discriminants
13643 Prev
: Entity_Id
:= Empty
)
13645 Elist
: constant Elist_Id
:= New_Elmt_List
;
13648 Discr_Number
: Uint
;
13649 Discr_Type
: Entity_Id
;
13650 Default_Present
: Boolean := False;
13651 Default_Not_Present
: Boolean := False;
13654 -- A composite type other than an array type can have discriminants.
13655 -- Discriminants of non-limited types must have a discrete type.
13656 -- On entry, the current scope is the composite type.
13658 -- The discriminants are initially entered into the scope of the type
13659 -- via Enter_Name with the default Ekind of E_Void to prevent premature
13660 -- use, as explained at the end of this procedure.
13662 Discr
:= First
(Discriminant_Specifications
(N
));
13663 while Present
(Discr
) loop
13664 Enter_Name
(Defining_Identifier
(Discr
));
13666 -- For navigation purposes we add a reference to the discriminant
13667 -- in the entity for the type. If the current declaration is a
13668 -- completion, place references on the partial view. Otherwise the
13669 -- type is the current scope.
13671 if Present
(Prev
) then
13673 -- The references go on the partial view, if present. If the
13674 -- partial view has discriminants, the references have been
13675 -- generated already.
13677 if not Has_Discriminants
(Prev
) then
13678 Generate_Reference
(Prev
, Defining_Identifier
(Discr
), 'd');
13682 (Current_Scope
, Defining_Identifier
(Discr
), 'd');
13685 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
13686 Discr_Type
:= Access_Definition
(Discr
, Discriminant_Type
(Discr
));
13688 -- Ada 2005 (AI-230): Access discriminants are now allowed for
13689 -- nonlimited types, and are treated like other components of
13690 -- anonymous access types in terms of accessibility.
13692 if not Is_Concurrent_Type
(Current_Scope
)
13693 and then not Is_Concurrent_Record_Type
(Current_Scope
)
13694 and then not Is_Limited_Record
(Current_Scope
)
13695 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
13697 Set_Is_Local_Anonymous_Access
(Discr_Type
);
13700 -- Ada 2005 (AI-254)
13702 if Present
(Access_To_Subprogram_Definition
13703 (Discriminant_Type
(Discr
)))
13704 and then Protected_Present
(Access_To_Subprogram_Definition
13705 (Discriminant_Type
(Discr
)))
13708 Replace_Anonymous_Access_To_Protected_Subprogram
13709 (Discr
, Discr_Type
);
13713 Find_Type
(Discriminant_Type
(Discr
));
13714 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
13716 if Error_Posted
(Discriminant_Type
(Discr
)) then
13717 Discr_Type
:= Any_Type
;
13721 if Is_Access_Type
(Discr_Type
) then
13723 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
13726 if Ada_Version
< Ada_05
then
13727 Check_Access_Discriminant_Requires_Limited
13728 (Discr
, Discriminant_Type
(Discr
));
13731 if Ada_Version
= Ada_83
and then Comes_From_Source
(Discr
) then
13733 ("(Ada 83) access discriminant not allowed", Discr
);
13736 elsif not Is_Discrete_Type
(Discr_Type
) then
13737 Error_Msg_N
("discriminants must have a discrete or access type",
13738 Discriminant_Type
(Discr
));
13741 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
13743 -- If a discriminant specification includes the assignment compound
13744 -- delimiter followed by an expression, the expression is the default
13745 -- expression of the discriminant; the default expression must be of
13746 -- the type of the discriminant. (RM 3.7.1) Since this expression is
13747 -- a default expression, we do the special preanalysis, since this
13748 -- expression does not freeze (see "Handling of Default and Per-
13749 -- Object Expressions" in spec of package Sem).
13751 if Present
(Expression
(Discr
)) then
13752 Analyze_Per_Use_Expression
(Expression
(Discr
), Discr_Type
);
13754 if Nkind
(N
) = N_Formal_Type_Declaration
then
13756 ("discriminant defaults not allowed for formal type",
13757 Expression
(Discr
));
13759 -- Tagged types cannot have defaulted discriminants, but a
13760 -- non-tagged private type with defaulted discriminants
13761 -- can have a tagged completion.
13763 elsif Is_Tagged_Type
(Current_Scope
)
13764 and then Comes_From_Source
(N
)
13767 ("discriminants of tagged type cannot have defaults",
13768 Expression
(Discr
));
13771 Default_Present
:= True;
13772 Append_Elmt
(Expression
(Discr
), Elist
);
13774 -- Tag the defining identifiers for the discriminants with
13775 -- their corresponding default expressions from the tree.
13777 Set_Discriminant_Default_Value
13778 (Defining_Identifier
(Discr
), Expression
(Discr
));
13782 Default_Not_Present
:= True;
13785 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
13786 -- Discr_Type but with the null-exclusion attribute
13788 if Ada_Version
>= Ada_05
then
13790 -- Ada 2005 (AI-231): Static checks
13792 if Can_Never_Be_Null
(Discr_Type
) then
13793 Null_Exclusion_Static_Checks
(Discr
);
13795 elsif Is_Access_Type
(Discr_Type
)
13796 and then Null_Exclusion_Present
(Discr
)
13798 -- No need to check itypes because in their case this check
13799 -- was done at their point of creation
13801 and then not Is_Itype
(Discr_Type
)
13803 if Can_Never_Be_Null
(Discr_Type
) then
13805 ("null-exclusion cannot be applied to " &
13806 "a null excluding type", Discr
);
13809 Set_Etype
(Defining_Identifier
(Discr
),
13810 Create_Null_Excluding_Itype
13812 Related_Nod
=> Discr
));
13815 -- Ada 2005 (AI-402): access discriminants of nonlimited types
13816 -- can't have defaults
13818 if Is_Access_Type
(Discr_Type
) then
13819 if Ekind
(Discr_Type
) /= E_Anonymous_Access_Type
13820 or else not Default_Present
13821 or else Is_Limited_Record
(Current_Scope
)
13822 or else Is_Concurrent_Type
(Current_Scope
)
13823 or else Is_Concurrent_Record_Type
(Current_Scope
)
13824 or else Ekind
(Current_Scope
) = E_Limited_Private_Type
13829 ("(Ada 2005) access discriminants of nonlimited types",
13830 Expression
(Discr
));
13831 Error_Msg_N
("\cannot have defaults", Expression
(Discr
));
13839 -- An element list consisting of the default expressions of the
13840 -- discriminants is constructed in the above loop and used to set
13841 -- the Discriminant_Constraint attribute for the type. If an object
13842 -- is declared of this (record or task) type without any explicit
13843 -- discriminant constraint given, this element list will form the
13844 -- actual parameters for the corresponding initialization procedure
13847 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
13848 Set_Stored_Constraint
(Current_Scope
, No_Elist
);
13850 -- Default expressions must be provided either for all or for none
13851 -- of the discriminants of a discriminant part. (RM 3.7.1)
13853 if Default_Present
and then Default_Not_Present
then
13855 ("incomplete specification of defaults for discriminants", N
);
13858 -- The use of the name of a discriminant is not allowed in default
13859 -- expressions of a discriminant part if the specification of the
13860 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
13862 -- To detect this, the discriminant names are entered initially with an
13863 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
13864 -- attempt to use a void entity (for example in an expression that is
13865 -- type-checked) produces the error message: premature usage. Now after
13866 -- completing the semantic analysis of the discriminant part, we can set
13867 -- the Ekind of all the discriminants appropriately.
13869 Discr
:= First
(Discriminant_Specifications
(N
));
13870 Discr_Number
:= Uint_1
;
13871 while Present
(Discr
) loop
13872 Id
:= Defining_Identifier
(Discr
);
13873 Set_Ekind
(Id
, E_Discriminant
);
13874 Init_Component_Location
(Id
);
13876 Set_Discriminant_Number
(Id
, Discr_Number
);
13878 -- Make sure this is always set, even in illegal programs
13880 Set_Corresponding_Discriminant
(Id
, Empty
);
13882 -- Initialize the Original_Record_Component to the entity itself.
13883 -- Inherit_Components will propagate the right value to
13884 -- discriminants in derived record types.
13886 Set_Original_Record_Component
(Id
, Id
);
13888 -- Create the discriminal for the discriminant
13890 Build_Discriminal
(Id
);
13893 Discr_Number
:= Discr_Number
+ 1;
13896 Set_Has_Discriminants
(Current_Scope
);
13897 end Process_Discriminants
;
13899 -----------------------
13900 -- Process_Full_View --
13901 -----------------------
13903 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
13904 Priv_Parent
: Entity_Id
;
13905 Full_Parent
: Entity_Id
;
13906 Full_Indic
: Node_Id
;
13908 procedure Collect_Implemented_Interfaces
13910 Ifaces
: Elist_Id
);
13911 -- Ada 2005: Gather all the interfaces that Typ directly or
13912 -- inherently implements. Duplicate entries are not added to
13913 -- the list Ifaces.
13915 function Contain_Interface
13916 (Iface
: Entity_Id
;
13917 Ifaces
: Elist_Id
) return Boolean;
13918 -- Ada 2005: Determine whether Iface is present in the list Ifaces
13920 function Find_Hidden_Interface
13922 Dest
: Elist_Id
) return Entity_Id
;
13923 -- Ada 2005: Determine whether the interfaces in list Src are all
13924 -- present in the list Dest. Return the first differing interface,
13925 -- or Empty otherwise.
13927 ------------------------------------
13928 -- Collect_Implemented_Interfaces --
13929 ------------------------------------
13931 procedure Collect_Implemented_Interfaces
13936 Iface_Elmt
: Elmt_Id
;
13939 -- Abstract interfaces are only associated with tagged record types
13941 if not Is_Tagged_Type
(Typ
)
13942 or else not Is_Record_Type
(Typ
)
13947 -- Recursively climb to the ancestors
13949 if Etype
(Typ
) /= Typ
13951 -- Protect the frontend against wrong cyclic declarations like:
13953 -- type B is new A with private;
13954 -- type C is new A with private;
13956 -- type B is new C with null record;
13957 -- type C is new B with null record;
13959 and then Etype
(Typ
) /= Priv_T
13960 and then Etype
(Typ
) /= Full_T
13962 -- Keep separate the management of private type declarations
13964 if Ekind
(Typ
) = E_Record_Type_With_Private
then
13966 -- Handle the following erronous case:
13967 -- type Private_Type is tagged private;
13969 -- type Private_Type is new Type_Implementing_Iface;
13971 if Present
(Full_View
(Typ
))
13972 and then Etype
(Typ
) /= Full_View
(Typ
)
13974 if Is_Interface
(Etype
(Typ
))
13975 and then not Contain_Interface
(Etype
(Typ
), Ifaces
)
13977 Append_Elmt
(Etype
(Typ
), Ifaces
);
13980 Collect_Implemented_Interfaces
(Etype
(Typ
), Ifaces
);
13983 -- Non-private types
13986 if Is_Interface
(Etype
(Typ
))
13987 and then not Contain_Interface
(Etype
(Typ
), Ifaces
)
13989 Append_Elmt
(Etype
(Typ
), Ifaces
);
13992 Collect_Implemented_Interfaces
(Etype
(Typ
), Ifaces
);
13996 -- Handle entities in the list of abstract interfaces
13998 if Present
(Abstract_Interfaces
(Typ
)) then
13999 Iface_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
14000 while Present
(Iface_Elmt
) loop
14001 Iface
:= Node
(Iface_Elmt
);
14003 pragma Assert
(Is_Interface
(Iface
));
14005 if not Contain_Interface
(Iface
, Ifaces
) then
14006 Append_Elmt
(Iface
, Ifaces
);
14007 Collect_Implemented_Interfaces
(Iface
, Ifaces
);
14010 Next_Elmt
(Iface_Elmt
);
14013 end Collect_Implemented_Interfaces
;
14015 -----------------------
14016 -- Contain_Interface --
14017 -----------------------
14019 function Contain_Interface
14020 (Iface
: Entity_Id
;
14021 Ifaces
: Elist_Id
) return Boolean
14023 Iface_Elmt
: Elmt_Id
;
14026 if Present
(Ifaces
) then
14027 Iface_Elmt
:= First_Elmt
(Ifaces
);
14028 while Present
(Iface_Elmt
) loop
14029 if Node
(Iface_Elmt
) = Iface
then
14033 Next_Elmt
(Iface_Elmt
);
14038 end Contain_Interface
;
14040 ---------------------------
14041 -- Find_Hidden_Interface --
14042 ---------------------------
14044 function Find_Hidden_Interface
14046 Dest
: Elist_Id
) return Entity_Id
14049 Iface_Elmt
: Elmt_Id
;
14052 if Present
(Src
) and then Present
(Dest
) then
14053 Iface_Elmt
:= First_Elmt
(Src
);
14054 while Present
(Iface_Elmt
) loop
14055 Iface
:= Node
(Iface_Elmt
);
14057 if not Contain_Interface
(Iface
, Dest
) then
14061 Next_Elmt
(Iface_Elmt
);
14066 end Find_Hidden_Interface
;
14068 -- Start of processing for Process_Full_View
14071 -- First some sanity checks that must be done after semantic
14072 -- decoration of the full view and thus cannot be placed with other
14073 -- similar checks in Find_Type_Name
14075 if not Is_Limited_Type
(Priv_T
)
14076 and then (Is_Limited_Type
(Full_T
)
14077 or else Is_Limited_Composite
(Full_T
))
14080 ("completion of nonlimited type cannot be limited", Full_T
);
14081 Explain_Limited_Type
(Full_T
, Full_T
);
14083 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
14085 ("completion of nonabstract type cannot be abstract", Full_T
);
14087 elsif Is_Tagged_Type
(Priv_T
)
14088 and then Is_Limited_Type
(Priv_T
)
14089 and then not Is_Limited_Type
(Full_T
)
14091 -- GNAT allow its own definition of Limited_Controlled to disobey
14092 -- this rule in order in ease the implementation. The next test is
14093 -- safe because Root_Controlled is defined in a private system child
14095 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
14096 Set_Is_Limited_Composite
(Full_T
);
14099 ("completion of limited tagged type must be limited", Full_T
);
14102 elsif Is_Generic_Type
(Priv_T
) then
14103 Error_Msg_N
("generic type cannot have a completion", Full_T
);
14106 -- Check that ancestor interfaces of private and full views are
14107 -- consistent. We omit this check for synchronized types because
14108 -- they are performed on thecorresponding record type when frozen.
14110 if Ada_Version
>= Ada_05
14111 and then Is_Tagged_Type
(Priv_T
)
14112 and then Is_Tagged_Type
(Full_T
)
14113 and then Ekind
(Full_T
) /= E_Task_Type
14114 and then Ekind
(Full_T
) /= E_Protected_Type
14118 Priv_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
14119 Full_T_Ifaces
: constant Elist_Id
:= New_Elmt_List
;
14122 Collect_Implemented_Interfaces
(Priv_T
, Priv_T_Ifaces
);
14123 Collect_Implemented_Interfaces
(Full_T
, Full_T_Ifaces
);
14125 -- Ada 2005 (AI-251): The partial view shall be a descendant of
14126 -- an interface type if and only if the full type is descendant
14127 -- of the interface type (AARM 7.3 (7.3/2).
14129 Iface
:= Find_Hidden_Interface
(Priv_T_Ifaces
, Full_T_Ifaces
);
14131 if Present
(Iface
) then
14132 Error_Msg_NE
("interface & not implemented by full type " &
14133 "('R'M'-2005 7.3 (7.3/2))", Priv_T
, Iface
);
14136 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
14138 if Present
(Iface
) then
14139 Error_Msg_NE
("interface & not implemented by partial view " &
14140 "('R'M'-2005 7.3 (7.3/2))", Full_T
, Iface
);
14145 if Is_Tagged_Type
(Priv_T
)
14146 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
14147 and then Is_Derived_Type
(Full_T
)
14149 Priv_Parent
:= Etype
(Priv_T
);
14151 -- The full view of a private extension may have been transformed
14152 -- into an unconstrained derived type declaration and a subtype
14153 -- declaration (see build_derived_record_type for details).
14155 if Nkind
(N
) = N_Subtype_Declaration
then
14156 Full_Indic
:= Subtype_Indication
(N
);
14157 Full_Parent
:= Etype
(Base_Type
(Full_T
));
14159 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
14160 Full_Parent
:= Etype
(Full_T
);
14163 -- Check that the parent type of the full type is a descendant of
14164 -- the ancestor subtype given in the private extension. If either
14165 -- entity has an Etype equal to Any_Type then we had some previous
14166 -- error situation [7.3(8)].
14168 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
14171 -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in
14172 -- any order. Therefore we don't have to check that its parent must
14173 -- be a descendant of the parent of the private type declaration.
14175 elsif Is_Interface
(Priv_Parent
)
14176 and then Is_Interface
(Full_Parent
)
14180 -- Ada 2005 (AI-251): If the parent of the private type declaration
14181 -- is an interface there is no need to check that it is an ancestor
14182 -- of the associated full type declaration. The required tests for
14183 -- this case case are performed by Build_Derived_Record_Type.
14185 elsif not Is_Interface
(Base_Type
(Priv_Parent
))
14186 and then not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
)
14189 ("parent of full type must descend from parent"
14190 & " of private extension", Full_Indic
);
14192 -- Check the rules of 7.3(10): if the private extension inherits
14193 -- known discriminants, then the full type must also inherit those
14194 -- discriminants from the same (ancestor) type, and the parent
14195 -- subtype of the full type must be constrained if and only if
14196 -- the ancestor subtype of the private extension is constrained.
14198 elsif No
(Discriminant_Specifications
(Parent
(Priv_T
)))
14199 and then not Has_Unknown_Discriminants
(Priv_T
)
14200 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
14203 Priv_Indic
: constant Node_Id
:=
14204 Subtype_Indication
(Parent
(Priv_T
));
14206 Priv_Constr
: constant Boolean :=
14207 Is_Constrained
(Priv_Parent
)
14209 Nkind
(Priv_Indic
) = N_Subtype_Indication
14210 or else Is_Constrained
(Entity
(Priv_Indic
));
14212 Full_Constr
: constant Boolean :=
14213 Is_Constrained
(Full_Parent
)
14215 Nkind
(Full_Indic
) = N_Subtype_Indication
14216 or else Is_Constrained
(Entity
(Full_Indic
));
14218 Priv_Discr
: Entity_Id
;
14219 Full_Discr
: Entity_Id
;
14222 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
14223 Full_Discr
:= First_Discriminant
(Full_Parent
);
14224 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
14225 if Original_Record_Component
(Priv_Discr
) =
14226 Original_Record_Component
(Full_Discr
)
14228 Corresponding_Discriminant
(Priv_Discr
) =
14229 Corresponding_Discriminant
(Full_Discr
)
14236 Next_Discriminant
(Priv_Discr
);
14237 Next_Discriminant
(Full_Discr
);
14240 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
14242 ("full view must inherit discriminants of the parent type"
14243 & " used in the private extension", Full_Indic
);
14245 elsif Priv_Constr
and then not Full_Constr
then
14247 ("parent subtype of full type must be constrained",
14250 elsif Full_Constr
and then not Priv_Constr
then
14252 ("parent subtype of full type must be unconstrained",
14257 -- Check the rules of 7.3(12): if a partial view has neither known
14258 -- or unknown discriminants, then the full type declaration shall
14259 -- define a definite subtype.
14261 elsif not Has_Unknown_Discriminants
(Priv_T
)
14262 and then not Has_Discriminants
(Priv_T
)
14263 and then not Is_Constrained
(Full_T
)
14266 ("full view must define a constrained type if partial view"
14267 & " has no discriminants", Full_T
);
14270 -- ??????? Do we implement the following properly ?????
14271 -- If the ancestor subtype of a private extension has constrained
14272 -- discriminants, then the parent subtype of the full view shall
14273 -- impose a statically matching constraint on those discriminants
14277 -- For untagged types, verify that a type without discriminants
14278 -- is not completed with an unconstrained type.
14280 if not Is_Indefinite_Subtype
(Priv_T
)
14281 and then Is_Indefinite_Subtype
(Full_T
)
14283 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
14287 -- AI-419: verify that the use of "limited" is consistent
14290 Orig_Decl
: constant Node_Id
:= Original_Node
(N
);
14293 if Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
14294 and then not Limited_Present
(Parent
(Priv_T
))
14295 and then not Synchronized_Present
(Parent
(Priv_T
))
14296 and then Nkind
(Orig_Decl
) = N_Full_Type_Declaration
14298 (Type_Definition
(Orig_Decl
)) = N_Derived_Type_Definition
14299 and then Limited_Present
(Type_Definition
(Orig_Decl
))
14302 ("full view of non-limited extension cannot be limited", N
);
14306 -- Ada 2005 (AI-443): A synchronized private extension must be
14307 -- completed by a task or protected type.
14309 if Ada_Version
>= Ada_05
14310 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
14311 and then Synchronized_Present
(Parent
(Priv_T
))
14312 and then Ekind
(Full_T
) /= E_Task_Type
14313 and then Ekind
(Full_T
) /= E_Protected_Type
14315 Error_Msg_N
("full view of synchronized extension must " &
14316 "be synchronized type", N
);
14319 -- Ada 2005 AI-363: if the full view has discriminants with
14320 -- defaults, it is illegal to declare constrained access subtypes
14321 -- whose designated type is the current type. This allows objects
14322 -- of the type that are declared in the heap to be unconstrained.
14324 if not Has_Unknown_Discriminants
(Priv_T
)
14325 and then not Has_Discriminants
(Priv_T
)
14326 and then Has_Discriminants
(Full_T
)
14328 Present
(Discriminant_Default_Value
(First_Discriminant
(Full_T
)))
14330 Set_Has_Constrained_Partial_View
(Full_T
);
14331 Set_Has_Constrained_Partial_View
(Priv_T
);
14334 -- Create a full declaration for all its subtypes recorded in
14335 -- Private_Dependents and swap them similarly to the base type. These
14336 -- are subtypes that have been define before the full declaration of
14337 -- the private type. We also swap the entry in Private_Dependents list
14338 -- so we can properly restore the private view on exit from the scope.
14341 Priv_Elmt
: Elmt_Id
;
14346 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
14347 while Present
(Priv_Elmt
) loop
14348 Priv
:= Node
(Priv_Elmt
);
14350 if Ekind
(Priv
) = E_Private_Subtype
14351 or else Ekind
(Priv
) = E_Limited_Private_Subtype
14352 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
14354 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
14355 Set_Is_Itype
(Full
);
14356 Set_Parent
(Full
, Parent
(Priv
));
14357 Set_Associated_Node_For_Itype
(Full
, N
);
14359 -- Now we need to complete the private subtype, but since the
14360 -- base type has already been swapped, we must also swap the
14361 -- subtypes (and thus, reverse the arguments in the call to
14362 -- Complete_Private_Subtype).
14364 Copy_And_Swap
(Priv
, Full
);
14365 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
14366 Replace_Elmt
(Priv_Elmt
, Full
);
14369 Next_Elmt
(Priv_Elmt
);
14373 -- If the private view was tagged, copy the new Primitive
14374 -- operations from the private view to the full view.
14376 if Is_Tagged_Type
(Full_T
)
14377 and then Ekind
(Full_T
) /= E_Task_Type
14378 and then Ekind
(Full_T
) /= E_Protected_Type
14381 Priv_List
: Elist_Id
;
14382 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
14385 D_Type
: Entity_Id
;
14388 if Is_Tagged_Type
(Priv_T
) then
14389 Priv_List
:= Primitive_Operations
(Priv_T
);
14391 P1
:= First_Elmt
(Priv_List
);
14392 while Present
(P1
) loop
14395 -- Transfer explicit primitives, not those inherited from
14396 -- parent of partial view, which will be re-inherited on
14399 if Comes_From_Source
(Prim
) then
14400 P2
:= First_Elmt
(Full_List
);
14401 while Present
(P2
) and then Node
(P2
) /= Prim
loop
14405 -- If not found, that is a new one
14408 Append_Elmt
(Prim
, Full_List
);
14416 -- In this case the partial view is untagged, so here we locate
14417 -- all of the earlier primitives that need to be treated as
14418 -- dispatching (those that appear between the two views). Note
14419 -- that these additional operations must all be new operations
14420 -- (any earlier operations that override inherited operations
14421 -- of the full view will already have been inserted in the
14422 -- primitives list, marked by Check_Operation_From_Private_View
14423 -- as dispatching. Note that implicit "/=" operators are
14424 -- excluded from being added to the primitives list since they
14425 -- shouldn't be treated as dispatching (tagged "/=" is handled
14428 Prim
:= Next_Entity
(Full_T
);
14429 while Present
(Prim
) and then Prim
/= Priv_T
loop
14430 if Ekind
(Prim
) = E_Procedure
14432 Ekind
(Prim
) = E_Function
14435 D_Type
:= Find_Dispatching_Type
(Prim
);
14438 and then (Chars
(Prim
) /= Name_Op_Ne
14439 or else Comes_From_Source
(Prim
))
14441 Check_Controlling_Formals
(Full_T
, Prim
);
14443 if not Is_Dispatching_Operation
(Prim
) then
14444 Append_Elmt
(Prim
, Full_List
);
14445 Set_Is_Dispatching_Operation
(Prim
, True);
14446 Set_DT_Position
(Prim
, No_Uint
);
14449 elsif Is_Dispatching_Operation
(Prim
)
14450 and then D_Type
/= Full_T
14453 -- Verify that it is not otherwise controlled by a
14454 -- formal or a return value of type T.
14456 Check_Controlling_Formals
(D_Type
, Prim
);
14460 Next_Entity
(Prim
);
14464 -- For the tagged case, the two views can share the same
14465 -- Primitive Operation list and the same class wide type.
14466 -- Update attributes of the class-wide type which depend on
14467 -- the full declaration.
14469 if Is_Tagged_Type
(Priv_T
) then
14470 Set_Primitive_Operations
(Priv_T
, Full_List
);
14471 Set_Class_Wide_Type
14472 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
14474 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
14479 -- Ada 2005 AI 161: Check preelaboratable initialization consistency
14481 if Known_To_Have_Preelab_Init
(Priv_T
) then
14483 -- Case where there is a pragma Preelaborable_Initialization. We
14484 -- always allow this in predefined units, which is a bit of a kludge,
14485 -- but it means we don't have to struggle to meet the requirements in
14486 -- the RM for having Preelaborable Initialization. Otherwise we
14487 -- require that the type meets the RM rules. But we can't check that
14488 -- yet, because of the rule about overriding Ininitialize, so we
14489 -- simply set a flag that will be checked at freeze time.
14491 if not In_Predefined_Unit
(Full_T
) then
14492 Set_Must_Have_Preelab_Init
(Full_T
);
14495 end Process_Full_View
;
14497 -----------------------------------
14498 -- Process_Incomplete_Dependents --
14499 -----------------------------------
14501 procedure Process_Incomplete_Dependents
14503 Full_T
: Entity_Id
;
14506 Inc_Elmt
: Elmt_Id
;
14507 Priv_Dep
: Entity_Id
;
14508 New_Subt
: Entity_Id
;
14510 Disc_Constraint
: Elist_Id
;
14513 if No
(Private_Dependents
(Inc_T
)) then
14517 -- Itypes that may be generated by the completion of an incomplete
14518 -- subtype are not used by the back-end and not attached to the tree.
14519 -- They are created only for constraint-checking purposes.
14521 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
14522 while Present
(Inc_Elmt
) loop
14523 Priv_Dep
:= Node
(Inc_Elmt
);
14525 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
14527 -- An Access_To_Subprogram type may have a return type or a
14528 -- parameter type that is incomplete. Replace with the full view.
14530 if Etype
(Priv_Dep
) = Inc_T
then
14531 Set_Etype
(Priv_Dep
, Full_T
);
14535 Formal
: Entity_Id
;
14538 Formal
:= First_Formal
(Priv_Dep
);
14539 while Present
(Formal
) loop
14540 if Etype
(Formal
) = Inc_T
then
14541 Set_Etype
(Formal
, Full_T
);
14544 Next_Formal
(Formal
);
14548 elsif Is_Overloadable
(Priv_Dep
) then
14550 -- A protected operation is never dispatching: only its
14551 -- wrapper operation (which has convention Ada) is.
14553 if Is_Tagged_Type
(Full_T
)
14554 and then Convention
(Priv_Dep
) /= Convention_Protected
14557 -- Subprogram has an access parameter whose designated type
14558 -- was incomplete. Reexamine declaration now, because it may
14559 -- be a primitive operation of the full type.
14561 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
14562 Set_Is_Dispatching_Operation
(Priv_Dep
);
14563 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
14566 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
14568 -- Can happen during processing of a body before the completion
14569 -- of a TA type. Ignore, because spec is also on dependent list.
14573 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
14574 -- corresponding subtype of the full view.
14576 elsif Ekind
(Priv_Dep
) = E_Incomplete_Subtype
then
14577 Set_Subtype_Indication
14578 (Parent
(Priv_Dep
), New_Reference_To
(Full_T
, Sloc
(Priv_Dep
)));
14579 Set_Etype
(Priv_Dep
, Full_T
);
14580 Set_Ekind
(Priv_Dep
, Subtype_Kind
(Ekind
(Full_T
)));
14581 Set_Analyzed
(Parent
(Priv_Dep
), False);
14583 -- Reanalyze the declaration, suppressing the call to
14584 -- Enter_Name to avoid duplicate names.
14586 Analyze_Subtype_Declaration
14587 (N
=> Parent
(Priv_Dep
),
14590 -- Dependent is a subtype
14593 -- We build a new subtype indication using the full view of the
14594 -- incomplete parent. The discriminant constraints have been
14595 -- elaborated already at the point of the subtype declaration.
14597 New_Subt
:= Create_Itype
(E_Void
, N
);
14599 if Has_Discriminants
(Full_T
) then
14600 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
14602 Disc_Constraint
:= No_Elist
;
14605 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
14606 Set_Full_View
(Priv_Dep
, New_Subt
);
14609 Next_Elmt
(Inc_Elmt
);
14611 end Process_Incomplete_Dependents
;
14613 --------------------------------
14614 -- Process_Range_Expr_In_Decl --
14615 --------------------------------
14617 procedure Process_Range_Expr_In_Decl
14620 Check_List
: List_Id
:= Empty_List
;
14621 R_Check_Off
: Boolean := False)
14624 R_Checks
: Check_Result
;
14625 Type_Decl
: Node_Id
;
14626 Def_Id
: Entity_Id
;
14629 Analyze_And_Resolve
(R
, Base_Type
(T
));
14631 if Nkind
(R
) = N_Range
then
14632 Lo
:= Low_Bound
(R
);
14633 Hi
:= High_Bound
(R
);
14635 -- We need to ensure validity of the bounds here, because if we
14636 -- go ahead and do the expansion, then the expanded code will get
14637 -- analyzed with range checks suppressed and we miss the check.
14639 Validity_Check_Range
(R
);
14641 -- If there were errors in the declaration, try and patch up some
14642 -- common mistakes in the bounds. The cases handled are literals
14643 -- which are Integer where the expected type is Real and vice versa.
14644 -- These corrections allow the compilation process to proceed further
14645 -- along since some basic assumptions of the format of the bounds
14648 if Etype
(R
) = Any_Type
then
14650 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
14652 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
14654 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
14656 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
14658 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
14660 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
14662 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
14664 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
14671 -- If the bounds of the range have been mistakenly given as string
14672 -- literals (perhaps in place of character literals), then an error
14673 -- has already been reported, but we rewrite the string literal as a
14674 -- bound of the range's type to avoid blowups in later processing
14675 -- that looks at static values.
14677 if Nkind
(Lo
) = N_String_Literal
then
14679 Make_Attribute_Reference
(Sloc
(Lo
),
14680 Attribute_Name
=> Name_First
,
14681 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
14682 Analyze_And_Resolve
(Lo
);
14685 if Nkind
(Hi
) = N_String_Literal
then
14687 Make_Attribute_Reference
(Sloc
(Hi
),
14688 Attribute_Name
=> Name_First
,
14689 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
14690 Analyze_And_Resolve
(Hi
);
14693 -- If bounds aren't scalar at this point then exit, avoiding
14694 -- problems with further processing of the range in this procedure.
14696 if not Is_Scalar_Type
(Etype
(Lo
)) then
14700 -- Resolve (actually Sem_Eval) has checked that the bounds are in
14701 -- then range of the base type. Here we check whether the bounds
14702 -- are in the range of the subtype itself. Note that if the bounds
14703 -- represent the null range the Constraint_Error exception should
14706 -- ??? The following code should be cleaned up as follows
14708 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
14709 -- is done in the call to Range_Check (R, T); below
14711 -- 2. The use of R_Check_Off should be investigated and possibly
14712 -- removed, this would clean up things a bit.
14714 if Is_Null_Range
(Lo
, Hi
) then
14718 -- Capture values of bounds and generate temporaries for them
14719 -- if needed, before applying checks, since checks may cause
14720 -- duplication of the expression without forcing evaluation.
14722 if Expander_Active
then
14723 Force_Evaluation
(Lo
);
14724 Force_Evaluation
(Hi
);
14727 -- We use a flag here instead of suppressing checks on the
14728 -- type because the type we check against isn't necessarily
14729 -- the place where we put the check.
14731 if not R_Check_Off
then
14732 R_Checks
:= Range_Check
(R
, T
);
14734 -- Look up tree to find an appropriate insertion point.
14735 -- This seems really junk code, and very brittle, couldn't
14736 -- we just use an insert actions call of some kind ???
14738 Type_Decl
:= Parent
(R
);
14739 while Present
(Type_Decl
) and then not
14740 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
14742 Nkind
(Type_Decl
) = N_Subtype_Declaration
14744 Nkind
(Type_Decl
) = N_Loop_Statement
14746 Nkind
(Type_Decl
) = N_Task_Type_Declaration
14748 Nkind
(Type_Decl
) = N_Single_Task_Declaration
14750 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
14752 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
14754 Type_Decl
:= Parent
(Type_Decl
);
14757 -- Why would Type_Decl not be present??? Without this test,
14758 -- short regression tests fail.
14760 if Present
(Type_Decl
) then
14762 -- Case of loop statement (more comments ???)
14764 if Nkind
(Type_Decl
) = N_Loop_Statement
then
14769 Indic
:= Parent
(R
);
14770 while Present
(Indic
) and then not
14771 (Nkind
(Indic
) = N_Subtype_Indication
)
14773 Indic
:= Parent
(Indic
);
14776 if Present
(Indic
) then
14777 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
14779 Insert_Range_Checks
14785 Do_Before
=> True);
14789 -- All other cases (more comments ???)
14792 Def_Id
:= Defining_Identifier
(Type_Decl
);
14794 if (Ekind
(Def_Id
) = E_Record_Type
14795 and then Depends_On_Discriminant
(R
))
14797 (Ekind
(Def_Id
) = E_Protected_Type
14798 and then Has_Discriminants
(Def_Id
))
14800 Append_Range_Checks
14801 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
14804 Insert_Range_Checks
14805 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
14813 elsif Expander_Active
then
14814 Get_Index_Bounds
(R
, Lo
, Hi
);
14815 Force_Evaluation
(Lo
);
14816 Force_Evaluation
(Hi
);
14818 end Process_Range_Expr_In_Decl
;
14820 --------------------------------------
14821 -- Process_Real_Range_Specification --
14822 --------------------------------------
14824 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
14825 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
14828 Err
: Boolean := False;
14830 procedure Analyze_Bound
(N
: Node_Id
);
14831 -- Analyze and check one bound
14833 -------------------
14834 -- Analyze_Bound --
14835 -------------------
14837 procedure Analyze_Bound
(N
: Node_Id
) is
14839 Analyze_And_Resolve
(N
, Any_Real
);
14841 if not Is_OK_Static_Expression
(N
) then
14842 Flag_Non_Static_Expr
14843 ("bound in real type definition is not static!", N
);
14848 -- Start of processing for Process_Real_Range_Specification
14851 if Present
(Spec
) then
14852 Lo
:= Low_Bound
(Spec
);
14853 Hi
:= High_Bound
(Spec
);
14854 Analyze_Bound
(Lo
);
14855 Analyze_Bound
(Hi
);
14857 -- If error, clear away junk range specification
14860 Set_Real_Range_Specification
(Def
, Empty
);
14863 end Process_Real_Range_Specification
;
14865 ---------------------
14866 -- Process_Subtype --
14867 ---------------------
14869 function Process_Subtype
14871 Related_Nod
: Node_Id
;
14872 Related_Id
: Entity_Id
:= Empty
;
14873 Suffix
: Character := ' ') return Entity_Id
14876 Def_Id
: Entity_Id
;
14877 Error_Node
: Node_Id
;
14878 Full_View_Id
: Entity_Id
;
14879 Subtype_Mark_Id
: Entity_Id
;
14881 May_Have_Null_Exclusion
: Boolean;
14883 procedure Check_Incomplete
(T
: Entity_Id
);
14884 -- Called to verify that an incomplete type is not used prematurely
14886 ----------------------
14887 -- Check_Incomplete --
14888 ----------------------
14890 procedure Check_Incomplete
(T
: Entity_Id
) is
14892 -- Ada 2005 (AI-412): Incomplete subtypes are legal
14894 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
14896 not (Ada_Version
>= Ada_05
14898 (Nkind
(Parent
(T
)) = N_Subtype_Declaration
14900 (Nkind
(Parent
(T
)) = N_Subtype_Indication
14901 and then Nkind
(Parent
(Parent
(T
))) =
14902 N_Subtype_Declaration
)))
14904 Error_Msg_N
("invalid use of type before its full declaration", T
);
14906 end Check_Incomplete
;
14908 -- Start of processing for Process_Subtype
14911 -- Case of no constraints present
14913 if Nkind
(S
) /= N_Subtype_Indication
then
14916 Check_Incomplete
(S
);
14919 -- Ada 2005 (AI-231): Static check
14921 if Ada_Version
>= Ada_05
14922 and then Present
(P
)
14923 and then Null_Exclusion_Present
(P
)
14924 and then Nkind
(P
) /= N_Access_To_Object_Definition
14925 and then not Is_Access_Type
(Entity
(S
))
14928 ("null-exclusion must be applied to an access type", S
);
14931 May_Have_Null_Exclusion
:=
14932 Nkind
(P
) = N_Access_Definition
14933 or else Nkind
(P
) = N_Access_Function_Definition
14934 or else Nkind
(P
) = N_Access_Procedure_Definition
14935 or else Nkind
(P
) = N_Access_To_Object_Definition
14936 or else Nkind
(P
) = N_Allocator
14937 or else Nkind
(P
) = N_Component_Definition
14938 or else Nkind
(P
) = N_Derived_Type_Definition
14939 or else Nkind
(P
) = N_Discriminant_Specification
14940 or else Nkind
(P
) = N_Object_Declaration
14941 or else Nkind
(P
) = N_Parameter_Specification
14942 or else Nkind
(P
) = N_Subtype_Declaration
;
14944 -- Create an Itype that is a duplicate of Entity (S) but with the
14945 -- null-exclusion attribute
14947 if May_Have_Null_Exclusion
14948 and then Is_Access_Type
(Entity
(S
))
14949 and then Null_Exclusion_Present
(P
)
14951 -- No need to check the case of an access to object definition.
14952 -- It is correct to define double not-null pointers.
14955 -- type Not_Null_Int_Ptr is not null access Integer;
14956 -- type Acc is not null access Not_Null_Int_Ptr;
14958 and then Nkind
(P
) /= N_Access_To_Object_Definition
14960 if Can_Never_Be_Null
(Entity
(S
)) then
14961 case Nkind
(Related_Nod
) is
14962 when N_Full_Type_Declaration
=>
14963 if Nkind
(Type_Definition
(Related_Nod
))
14964 in N_Array_Type_Definition
14968 (Component_Definition
14969 (Type_Definition
(Related_Nod
)));
14972 Subtype_Indication
(Type_Definition
(Related_Nod
));
14975 when N_Subtype_Declaration
=>
14976 Error_Node
:= Subtype_Indication
(Related_Nod
);
14978 when N_Object_Declaration
=>
14979 Error_Node
:= Object_Definition
(Related_Nod
);
14981 when N_Component_Declaration
=>
14983 Subtype_Indication
(Component_Definition
(Related_Nod
));
14986 pragma Assert
(False);
14987 Error_Node
:= Related_Nod
;
14991 ("null-exclusion cannot be applied to " &
14992 "a null excluding type", Error_Node
);
14996 Create_Null_Excluding_Itype
14998 Related_Nod
=> P
));
14999 Set_Entity
(S
, Etype
(S
));
15004 -- Case of constraint present, so that we have an N_Subtype_Indication
15005 -- node (this node is created only if constraints are present).
15008 Find_Type
(Subtype_Mark
(S
));
15010 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
15012 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
15013 and then Is_Itype
(Defining_Identifier
(Parent
(S
))))
15015 Check_Incomplete
(Subtype_Mark
(S
));
15019 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
15021 -- Explicit subtype declaration case
15023 if Nkind
(P
) = N_Subtype_Declaration
then
15024 Def_Id
:= Defining_Identifier
(P
);
15026 -- Explicit derived type definition case
15028 elsif Nkind
(P
) = N_Derived_Type_Definition
then
15029 Def_Id
:= Defining_Identifier
(Parent
(P
));
15031 -- Implicit case, the Def_Id must be created as an implicit type.
15032 -- The one exception arises in the case of concurrent types, array
15033 -- and access types, where other subsidiary implicit types may be
15034 -- created and must appear before the main implicit type. In these
15035 -- cases we leave Def_Id set to Empty as a signal that Create_Itype
15036 -- has not yet been called to create Def_Id.
15039 if Is_Array_Type
(Subtype_Mark_Id
)
15040 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
15041 or else Is_Access_Type
(Subtype_Mark_Id
)
15045 -- For the other cases, we create a new unattached Itype,
15046 -- and set the indication to ensure it gets attached later.
15050 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
15054 -- If the kind of constraint is invalid for this kind of type,
15055 -- then give an error, and then pretend no constraint was given.
15057 if not Is_Valid_Constraint_Kind
15058 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
15061 ("incorrect constraint for this kind of type", Constraint
(S
));
15063 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
15065 -- Set Ekind of orphan itype, to prevent cascaded errors
15067 if Present
(Def_Id
) then
15068 Set_Ekind
(Def_Id
, Ekind
(Any_Type
));
15071 -- Make recursive call, having got rid of the bogus constraint
15073 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
15076 -- Remaining processing depends on type
15078 case Ekind
(Subtype_Mark_Id
) is
15079 when Access_Kind
=>
15080 Constrain_Access
(Def_Id
, S
, Related_Nod
);
15083 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
15085 when Decimal_Fixed_Point_Kind
=>
15086 Constrain_Decimal
(Def_Id
, S
);
15088 when Enumeration_Kind
=>
15089 Constrain_Enumeration
(Def_Id
, S
);
15091 when Ordinary_Fixed_Point_Kind
=>
15092 Constrain_Ordinary_Fixed
(Def_Id
, S
);
15095 Constrain_Float
(Def_Id
, S
);
15097 when Integer_Kind
=>
15098 Constrain_Integer
(Def_Id
, S
);
15100 when E_Record_Type |
15103 E_Incomplete_Type
=>
15104 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
15106 when Private_Kind
=>
15107 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
15108 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
15110 -- In case of an invalid constraint prevent further processing
15111 -- since the type constructed is missing expected fields.
15113 if Etype
(Def_Id
) = Any_Type
then
15117 -- If the full view is that of a task with discriminants,
15118 -- we must constrain both the concurrent type and its
15119 -- corresponding record type. Otherwise we will just propagate
15120 -- the constraint to the full view, if available.
15122 if Present
(Full_View
(Subtype_Mark_Id
))
15123 and then Has_Discriminants
(Subtype_Mark_Id
)
15124 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
15127 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
15129 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
15130 Constrain_Concurrent
(Full_View_Id
, S
,
15131 Related_Nod
, Related_Id
, Suffix
);
15132 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
15133 Set_Full_View
(Def_Id
, Full_View_Id
);
15135 -- Introduce an explicit reference to the private subtype,
15136 -- to prevent scope anomalies in gigi if first use appears
15137 -- in a nested context, e.g. a later function body.
15138 -- Should this be generated in other contexts than a full
15139 -- type declaration?
15141 if Is_Itype
(Def_Id
)
15143 Nkind
(Parent
(P
)) = N_Full_Type_Declaration
15146 Ref_Node
: Node_Id
;
15148 Ref_Node
:= Make_Itype_Reference
(Sloc
(Related_Nod
));
15149 Set_Itype
(Ref_Node
, Def_Id
);
15150 Insert_After
(Parent
(P
), Ref_Node
);
15155 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
15158 when Concurrent_Kind
=>
15159 Constrain_Concurrent
(Def_Id
, S
,
15160 Related_Nod
, Related_Id
, Suffix
);
15163 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
15166 -- Size and Convention are always inherited from the base type
15168 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
15169 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
15173 end Process_Subtype
;
15175 -----------------------------
15176 -- Record_Type_Declaration --
15177 -----------------------------
15179 procedure Record_Type_Declaration
15184 Loc
: constant Source_Ptr
:= Sloc
(N
);
15185 Def
: constant Node_Id
:= Type_Definition
(N
);
15186 Inc_T
: Entity_Id
:= Empty
;
15188 Is_Tagged
: Boolean;
15189 Tag_Comp
: Entity_Id
;
15191 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
);
15192 -- Ada 2005 AI-382: an access component in a record declaration can
15193 -- refer to the enclosing record, in which case it denotes the type
15194 -- itself, and not the current instance of the type. We create an
15195 -- anonymous access type for the component, and flag it as an access
15196 -- to a component, so that accessibility checks are properly performed
15197 -- on it. The declaration of the access type is placed ahead of that
15198 -- of the record, to prevent circular order-of-elaboration issues in
15199 -- Gigi. We create an incomplete type for the record declaration, which
15200 -- is the designated type of the anonymous access.
15202 procedure Make_Incomplete_Type_Declaration
;
15203 -- If the record type contains components that include an access to the
15204 -- current record, create an incomplete type declaration for the record,
15205 -- to be used as the designated type of the anonymous access. This is
15206 -- done only once, and only if there is no previous partial view of the
15209 ----------------------------------
15210 -- Check_Anonymous_Access_Types --
15211 ----------------------------------
15213 procedure Check_Anonymous_Access_Types
(Comp_List
: Node_Id
) is
15214 Anon_Access
: Entity_Id
;
15217 Comp_Def
: Node_Id
;
15219 Type_Def
: Node_Id
;
15221 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean;
15222 -- Check whether an access definition includes a reference to
15223 -- the enclosing record type. The reference can be a subtype
15224 -- mark in the access definition itself, or a 'Class attribute
15225 -- reference, or recursively a reference appearing in a parameter
15226 -- type in an access_to_subprogram definition.
15232 function Mentions_T
(Acc_Def
: Node_Id
) return Boolean is
15236 if No
(Access_To_Subprogram_Definition
(Acc_Def
)) then
15237 Subt
:= Subtype_Mark
(Acc_Def
);
15239 if Nkind
(Subt
) = N_Identifier
then
15240 return Chars
(Subt
) = Chars
(T
);
15242 -- A reference to the current type may appear as the prefix
15243 -- of a 'Class attribute.
15245 elsif Nkind
(Subt
) = N_Attribute_Reference
15246 and then Attribute_Name
(Subt
) = Name_Class
15247 and then Is_Entity_Name
(Prefix
(Subt
))
15249 return (Chars
(Prefix
(Subt
))) = Chars
(T
);
15255 -- Component is an access_to_subprogram: examine its formals
15258 Param_Spec
: Node_Id
;
15263 (Parameter_Specifications
15264 (Access_To_Subprogram_Definition
(Acc_Def
)));
15265 while Present
(Param_Spec
) loop
15266 if Nkind
(Parameter_Type
(Param_Spec
))
15267 = N_Access_Definition
15268 and then Mentions_T
(Parameter_Type
(Param_Spec
))
15281 -- Start of processing for Check_Anonymous_Access_Types
15284 if No
(Comp_List
) then
15288 Comp
:= First
(Component_Items
(Comp_List
));
15289 while Present
(Comp
) loop
15290 if Nkind
(Comp
) = N_Component_Declaration
15292 (Access_Definition
(Component_Definition
(Comp
)))
15294 Mentions_T
(Access_Definition
(Component_Definition
(Comp
)))
15296 Comp_Def
:= Component_Definition
(Comp
);
15298 Access_To_Subprogram_Definition
15299 (Access_Definition
(Comp_Def
));
15301 Make_Incomplete_Type_Declaration
;
15303 Make_Defining_Identifier
(Loc
,
15304 Chars
=> New_Internal_Name
('S'));
15306 -- Create a declaration for the anonymous access type: either
15307 -- an access_to_object or an access_to_subprogram.
15309 if Present
(Acc_Def
) then
15310 if Nkind
(Acc_Def
) = N_Access_Function_Definition
then
15312 Make_Access_Function_Definition
(Loc
,
15313 Parameter_Specifications
=>
15314 Parameter_Specifications
(Acc_Def
),
15315 Result_Definition
=> Result_Definition
(Acc_Def
));
15318 Make_Access_Procedure_Definition
(Loc
,
15319 Parameter_Specifications
=>
15320 Parameter_Specifications
(Acc_Def
));
15325 Make_Access_To_Object_Definition
(Loc
,
15326 Subtype_Indication
=>
15329 (Access_Definition
(Comp_Def
))));
15332 Decl
:= Make_Full_Type_Declaration
(Loc
,
15333 Defining_Identifier
=> Anon_Access
,
15334 Type_Definition
=> Type_Def
);
15336 Insert_Before
(N
, Decl
);
15339 -- If an access to object, Preserve entity of designated type,
15340 -- for ASIS use, before rewriting the component definition.
15342 if No
(Acc_Def
) then
15347 Desig
:= Entity
(Subtype_Indication
(Type_Def
));
15349 -- If the access definition is to the current record,
15350 -- the visible entity at this point is an incomplete
15351 -- type. Retrieve the full view to simplify ASIS queries
15353 if Ekind
(Desig
) = E_Incomplete_Type
then
15354 Desig
:= Full_View
(Desig
);
15358 (Subtype_Mark
(Access_Definition
(Comp_Def
)), Desig
);
15363 Make_Component_Definition
(Loc
,
15364 Subtype_Indication
=>
15365 New_Occurrence_Of
(Anon_Access
, Loc
)));
15366 Set_Ekind
(Anon_Access
, E_Anonymous_Access_Type
);
15367 Set_Is_Local_Anonymous_Access
(Anon_Access
);
15373 if Present
(Variant_Part
(Comp_List
)) then
15377 V
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
15378 while Present
(V
) loop
15379 Check_Anonymous_Access_Types
(Component_List
(V
));
15380 Next_Non_Pragma
(V
);
15384 end Check_Anonymous_Access_Types
;
15386 --------------------------------------
15387 -- Make_Incomplete_Type_Declaration --
15388 --------------------------------------
15390 procedure Make_Incomplete_Type_Declaration
is
15395 -- If there is a previous partial view, no need to create a new one
15396 -- If the partial view is incomplete, it is given by Prev. If it is
15397 -- a private declaration, full declaration is flagged accordingly.
15400 or else Has_Private_Declaration
(T
)
15404 elsif No
(Inc_T
) then
15405 Inc_T
:= Make_Defining_Identifier
(Loc
, Chars
(T
));
15406 Decl
:= Make_Incomplete_Type_Declaration
(Loc
, Inc_T
);
15408 -- Type has already been inserted into the current scope.
15409 -- Remove it, and add incomplete declaration for type, so
15410 -- that subsequent anonymous access types can use it.
15411 -- The entity is unchained from the homonym list and from
15412 -- immediate visibility. After analysis, the entity in the
15413 -- incomplete declaration becomes immediately visible in the
15414 -- record declaration that follows.
15416 H
:= Current_Entity
(T
);
15419 Set_Name_Entity_Id
(Chars
(T
), Homonym
(T
));
15422 and then Homonym
(H
) /= T
15427 Set_Homonym
(H
, Homonym
(T
));
15430 Insert_Before
(N
, Decl
);
15432 Set_Full_View
(Inc_T
, T
);
15434 if Tagged_Present
(Def
) then
15435 Make_Class_Wide_Type
(Inc_T
);
15436 Set_Class_Wide_Type
(T
, Class_Wide_Type
(Inc_T
));
15437 Set_Etype
(Class_Wide_Type
(T
), T
);
15440 end Make_Incomplete_Type_Declaration
;
15442 -- Start of processing for Record_Type_Declaration
15445 -- These flags must be initialized before calling Process_Discriminants
15446 -- because this routine makes use of them.
15448 Set_Ekind
(T
, E_Record_Type
);
15450 Init_Size_Align
(T
);
15451 Set_Abstract_Interfaces
(T
, No_Elist
);
15452 Set_Stored_Constraint
(T
, No_Elist
);
15456 if Ada_Version
< Ada_05
15457 or else not Interface_Present
(Def
)
15459 -- The flag Is_Tagged_Type might have already been set by
15460 -- Find_Type_Name if it detected an error for declaration T. This
15461 -- arises in the case of private tagged types where the full view
15462 -- omits the word tagged.
15465 Tagged_Present
(Def
)
15466 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
15468 Set_Is_Tagged_Type
(T
, Is_Tagged
);
15469 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
15471 -- Type is abstract if full declaration carries keyword, or if
15472 -- previous partial view did.
15474 Set_Is_Abstract
(T
, Is_Abstract
(T
)
15475 or else Abstract_Present
(Def
));
15479 Analyze_Interface_Declaration
(T
, Def
);
15481 if Present
(Discriminant_Specifications
(N
)) then
15483 ("interface types cannot have discriminants",
15484 Defining_Identifier
15485 (First
(Discriminant_Specifications
(N
))));
15489 -- First pass: if there are self-referential access components,
15490 -- create the required anonymous access type declarations, and if
15491 -- need be an incomplete type declaration for T itself.
15493 Check_Anonymous_Access_Types
(Component_List
(Def
));
15495 if Ada_Version
>= Ada_05
15496 and then Present
(Interface_List
(Def
))
15500 Iface_Def
: Node_Id
;
15501 Iface_Typ
: Entity_Id
;
15502 Ifaces_List
: Elist_Id
;
15505 Iface
:= First
(Interface_List
(Def
));
15506 while Present
(Iface
) loop
15507 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
15508 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
15510 if not Is_Interface
(Iface_Typ
) then
15511 Error_Msg_NE
("(Ada 2005) & must be an interface",
15515 -- "The declaration of a specific descendant of an
15516 -- interface type freezes the interface type" RM 13.14
15518 Freeze_Before
(N
, Iface_Typ
);
15520 -- Ada 2005 (AI-345): Protected interfaces can only
15521 -- inherit from limited, synchronized or protected
15524 if Protected_Present
(Def
) then
15525 if Limited_Present
(Iface_Def
)
15526 or else Synchronized_Present
(Iface_Def
)
15527 or else Protected_Present
(Iface_Def
)
15531 elsif Task_Present
(Iface_Def
) then
15532 Error_Msg_N
("(Ada 2005) protected interface cannot"
15533 & " inherit from task interface", Iface
);
15536 Error_Msg_N
("(Ada 2005) protected interface cannot"
15537 & " inherit from non-limited interface", Iface
);
15540 -- Ada 2005 (AI-345): Synchronized interfaces can only
15541 -- inherit from limited and synchronized.
15543 elsif Synchronized_Present
(Def
) then
15544 if Limited_Present
(Iface_Def
)
15545 or else Synchronized_Present
(Iface_Def
)
15549 elsif Protected_Present
(Iface_Def
) then
15550 Error_Msg_N
("(Ada 2005) synchronized interface " &
15551 "cannot inherit from protected interface", Iface
);
15553 elsif Task_Present
(Iface_Def
) then
15554 Error_Msg_N
("(Ada 2005) synchronized interface " &
15555 "cannot inherit from task interface", Iface
);
15558 Error_Msg_N
("(Ada 2005) synchronized interface " &
15559 "cannot inherit from non-limited interface",
15563 -- Ada 2005 (AI-345): Task interfaces can only inherit
15564 -- from limited, synchronized or task interfaces.
15566 elsif Task_Present
(Def
) then
15567 if Limited_Present
(Iface_Def
)
15568 or else Synchronized_Present
(Iface_Def
)
15569 or else Task_Present
(Iface_Def
)
15573 elsif Protected_Present
(Iface_Def
) then
15574 Error_Msg_N
("(Ada 2005) task interface cannot" &
15575 " inherit from protected interface", Iface
);
15578 Error_Msg_N
("(Ada 2005) task interface cannot" &
15579 " inherit from non-limited interface", Iface
);
15587 -- Ada 2005 (AI-251): Collect the list of progenitors that are not
15588 -- already in the parents.
15590 Collect_Abstract_Interfaces
15592 Ifaces_List
=> Ifaces_List
,
15593 Exclude_Parent_Interfaces
=> True);
15595 Set_Abstract_Interfaces
(T
, Ifaces_List
);
15599 -- Records constitute a scope for the component declarations within.
15600 -- The scope is created prior to the processing of these declarations.
15601 -- Discriminants are processed first, so that they are visible when
15602 -- processing the other components. The Ekind of the record type itself
15603 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
15605 -- Enter record scope
15609 -- If an incomplete or private type declaration was already given for
15610 -- the type, then this scope already exists, and the discriminants have
15611 -- been declared within. We must verify that the full declaration
15612 -- matches the incomplete one.
15614 Check_Or_Process_Discriminants
(N
, T
, Prev
);
15616 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
15617 Set_Has_Delayed_Freeze
(T
, True);
15619 -- For tagged types add a manually analyzed component corresponding
15620 -- to the component _tag, the corresponding piece of tree will be
15621 -- expanded as part of the freezing actions if it is not a CPP_Class.
15625 -- Do not add the tag unless we are in expansion mode
15627 if Expander_Active
then
15628 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
15629 Enter_Name
(Tag_Comp
);
15631 Set_Is_Tag
(Tag_Comp
);
15632 Set_Is_Aliased
(Tag_Comp
);
15633 Set_Ekind
(Tag_Comp
, E_Component
);
15634 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
15635 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
15636 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
15637 Init_Component_Location
(Tag_Comp
);
15639 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
15640 -- implemented interfaces
15642 Add_Interface_Tag_Components
(N
, T
);
15645 Make_Class_Wide_Type
(T
);
15646 Set_Primitive_Operations
(T
, New_Elmt_List
);
15649 -- We must suppress range checks when processing the components
15650 -- of a record in the presence of discriminants, since we don't
15651 -- want spurious checks to be generated during their analysis, but
15652 -- must reset the Suppress_Range_Checks flags after having processed
15653 -- the record definition.
15655 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd,
15656 -- couldn't we just use the normal range check suppression method here.
15657 -- That would seem cleaner ???
15659 if Has_Discriminants
(T
) and then not Range_Checks_Suppressed
(T
) then
15660 Set_Kill_Range_Checks
(T
, True);
15661 Record_Type_Definition
(Def
, Prev
);
15662 Set_Kill_Range_Checks
(T
, False);
15664 Record_Type_Definition
(Def
, Prev
);
15667 -- Exit from record scope
15671 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all
15672 -- the implemented interfaces and associate them an aliased entity.
15675 and then not Is_Empty_List
(Interface_List
(Def
))
15678 Ifaces_List
: constant Elist_Id
:= New_Elmt_List
;
15680 Derive_Interface_Subprograms
(T
, T
, Ifaces_List
);
15683 end Record_Type_Declaration
;
15685 ----------------------------
15686 -- Record_Type_Definition --
15687 ----------------------------
15689 procedure Record_Type_Definition
(Def
: Node_Id
; Prev_T
: Entity_Id
) is
15690 Component
: Entity_Id
;
15691 Ctrl_Components
: Boolean := False;
15692 Final_Storage_Only
: Boolean;
15696 if Ekind
(Prev_T
) = E_Incomplete_Type
then
15697 T
:= Full_View
(Prev_T
);
15702 Final_Storage_Only
:= not Is_Controlled
(T
);
15704 -- Ada 2005: check whether an explicit Limited is present in a derived
15705 -- type declaration.
15707 if Nkind
(Parent
(Def
)) = N_Derived_Type_Definition
15708 and then Limited_Present
(Parent
(Def
))
15710 Set_Is_Limited_Record
(T
);
15713 -- If the component list of a record type is defined by the reserved
15714 -- word null and there is no discriminant part, then the record type has
15715 -- no components and all records of the type are null records (RM 3.7)
15716 -- This procedure is also called to process the extension part of a
15717 -- record extension, in which case the current scope may have inherited
15721 or else No
(Component_List
(Def
))
15722 or else Null_Present
(Component_List
(Def
))
15727 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
15729 if Present
(Variant_Part
(Component_List
(Def
))) then
15730 Analyze
(Variant_Part
(Component_List
(Def
)));
15734 -- After completing the semantic analysis of the record definition,
15735 -- record components, both new and inherited, are accessible. Set
15736 -- their kind accordingly.
15738 Component
:= First_Entity
(Current_Scope
);
15739 while Present
(Component
) loop
15740 if Ekind
(Component
) = E_Void
then
15741 Set_Ekind
(Component
, E_Component
);
15742 Init_Component_Location
(Component
);
15745 if Has_Task
(Etype
(Component
)) then
15749 if Ekind
(Component
) /= E_Component
then
15752 elsif Has_Controlled_Component
(Etype
(Component
))
15753 or else (Chars
(Component
) /= Name_uParent
15754 and then Is_Controlled
(Etype
(Component
)))
15756 Set_Has_Controlled_Component
(T
, True);
15757 Final_Storage_Only
:= Final_Storage_Only
15758 and then Finalize_Storage_Only
(Etype
(Component
));
15759 Ctrl_Components
:= True;
15762 Next_Entity
(Component
);
15765 -- A type is Finalize_Storage_Only only if all its controlled
15766 -- components are so.
15768 if Ctrl_Components
then
15769 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
15772 -- Place reference to end record on the proper entity, which may
15773 -- be a partial view.
15775 if Present
(Def
) then
15776 Process_End_Label
(Def
, 'e', Prev_T
);
15778 end Record_Type_Definition
;
15780 ------------------------
15781 -- Replace_Components --
15782 ------------------------
15784 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
15785 function Process
(N
: Node_Id
) return Traverse_Result
;
15791 function Process
(N
: Node_Id
) return Traverse_Result
is
15795 if Nkind
(N
) = N_Discriminant_Specification
then
15796 Comp
:= First_Discriminant
(Typ
);
15797 while Present
(Comp
) loop
15798 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15799 Set_Defining_Identifier
(N
, Comp
);
15803 Next_Discriminant
(Comp
);
15806 elsif Nkind
(N
) = N_Component_Declaration
then
15807 Comp
:= First_Component
(Typ
);
15808 while Present
(Comp
) loop
15809 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
15810 Set_Defining_Identifier
(N
, Comp
);
15814 Next_Component
(Comp
);
15821 procedure Replace
is new Traverse_Proc
(Process
);
15823 -- Start of processing for Replace_Components
15827 end Replace_Components
;
15829 -------------------------------
15830 -- Set_Completion_Referenced --
15831 -------------------------------
15833 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
15835 -- If in main unit, mark entity that is a completion as referenced,
15836 -- warnings go on the partial view when needed.
15838 if In_Extended_Main_Source_Unit
(E
) then
15839 Set_Referenced
(E
);
15841 end Set_Completion_Referenced
;
15843 ---------------------
15844 -- Set_Fixed_Range --
15845 ---------------------
15847 -- The range for fixed-point types is complicated by the fact that we
15848 -- do not know the exact end points at the time of the declaration. This
15849 -- is true for three reasons:
15851 -- A size clause may affect the fudging of the end-points
15852 -- A small clause may affect the values of the end-points
15853 -- We try to include the end-points if it does not affect the size
15855 -- This means that the actual end-points must be established at the point
15856 -- when the type is frozen. Meanwhile, we first narrow the range as
15857 -- permitted (so that it will fit if necessary in a small specified size),
15858 -- and then build a range subtree with these narrowed bounds.
15860 -- Set_Fixed_Range constructs the range from real literal values, and sets
15861 -- the range as the Scalar_Range of the given fixed-point type entity.
15863 -- The parent of this range is set to point to the entity so that it is
15864 -- properly hooked into the tree (unlike normal Scalar_Range entries for
15865 -- other scalar types, which are just pointers to the range in the
15866 -- original tree, this would otherwise be an orphan).
15868 -- The tree is left unanalyzed. When the type is frozen, the processing
15869 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
15870 -- analyzed, and uses this as an indication that it should complete
15871 -- work on the range (it will know the final small and size values).
15873 procedure Set_Fixed_Range
15879 S
: constant Node_Id
:=
15881 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
15882 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
15885 Set_Scalar_Range
(E
, S
);
15887 end Set_Fixed_Range
;
15889 ----------------------------------
15890 -- Set_Scalar_Range_For_Subtype --
15891 ----------------------------------
15893 procedure Set_Scalar_Range_For_Subtype
15894 (Def_Id
: Entity_Id
;
15898 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
15901 Set_Scalar_Range
(Def_Id
, R
);
15903 -- We need to link the range into the tree before resolving it so
15904 -- that types that are referenced, including importantly the subtype
15905 -- itself, are properly frozen (Freeze_Expression requires that the
15906 -- expression be properly linked into the tree). Of course if it is
15907 -- already linked in, then we do not disturb the current link.
15909 if No
(Parent
(R
)) then
15910 Set_Parent
(R
, Def_Id
);
15913 -- Reset the kind of the subtype during analysis of the range, to
15914 -- catch possible premature use in the bounds themselves.
15916 Set_Ekind
(Def_Id
, E_Void
);
15917 Process_Range_Expr_In_Decl
(R
, Subt
);
15918 Set_Ekind
(Def_Id
, Kind
);
15920 end Set_Scalar_Range_For_Subtype
;
15922 --------------------------------------------------------
15923 -- Set_Stored_Constraint_From_Discriminant_Constraint --
15924 --------------------------------------------------------
15926 procedure Set_Stored_Constraint_From_Discriminant_Constraint
15930 -- Make sure set if encountered during Expand_To_Stored_Constraint
15932 Set_Stored_Constraint
(E
, No_Elist
);
15934 -- Give it the right value
15936 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
15937 Set_Stored_Constraint
(E
,
15938 Expand_To_Stored_Constraint
(E
, Discriminant_Constraint
(E
)));
15940 end Set_Stored_Constraint_From_Discriminant_Constraint
;
15942 -------------------------------------
15943 -- Signed_Integer_Type_Declaration --
15944 -------------------------------------
15946 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
15947 Implicit_Base
: Entity_Id
;
15948 Base_Typ
: Entity_Id
;
15951 Errs
: Boolean := False;
15955 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
15956 -- Determine whether given bounds allow derivation from specified type
15958 procedure Check_Bound
(Expr
: Node_Id
);
15959 -- Check bound to make sure it is integral and static. If not, post
15960 -- appropriate error message and set Errs flag
15962 ---------------------
15963 -- Can_Derive_From --
15964 ---------------------
15966 -- Note we check both bounds against both end values, to deal with
15967 -- strange types like ones with a range of 0 .. -12341234.
15969 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
15970 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
15971 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
15973 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
15975 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
15976 end Can_Derive_From
;
15982 procedure Check_Bound
(Expr
: Node_Id
) is
15984 -- If a range constraint is used as an integer type definition, each
15985 -- bound of the range must be defined by a static expression of some
15986 -- integer type, but the two bounds need not have the same integer
15987 -- type (Negative bounds are allowed.) (RM 3.5.4)
15989 if not Is_Integer_Type
(Etype
(Expr
)) then
15991 ("integer type definition bounds must be of integer type", Expr
);
15994 elsif not Is_OK_Static_Expression
(Expr
) then
15995 Flag_Non_Static_Expr
15996 ("non-static expression used for integer type bound!", Expr
);
15999 -- The bounds are folded into literals, and we set their type to be
16000 -- universal, to avoid typing difficulties: we cannot set the type
16001 -- of the literal to the new type, because this would be a forward
16002 -- reference for the back end, and if the original type is user-
16003 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
16006 if Is_Entity_Name
(Expr
) then
16007 Fold_Uint
(Expr
, Expr_Value
(Expr
), True);
16010 Set_Etype
(Expr
, Universal_Integer
);
16014 -- Start of processing for Signed_Integer_Type_Declaration
16017 -- Create an anonymous base type
16020 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
16022 -- Analyze and check the bounds, they can be of any integer type
16024 Lo
:= Low_Bound
(Def
);
16025 Hi
:= High_Bound
(Def
);
16027 -- Arbitrarily use Integer as the type if either bound had an error
16029 if Hi
= Error
or else Lo
= Error
then
16030 Base_Typ
:= Any_Integer
;
16031 Set_Error_Posted
(T
, True);
16033 -- Here both bounds are OK expressions
16036 Analyze_And_Resolve
(Lo
, Any_Integer
);
16037 Analyze_And_Resolve
(Hi
, Any_Integer
);
16043 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
16044 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
16047 -- Find type to derive from
16049 Lo_Val
:= Expr_Value
(Lo
);
16050 Hi_Val
:= Expr_Value
(Hi
);
16052 if Can_Derive_From
(Standard_Short_Short_Integer
) then
16053 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
16055 elsif Can_Derive_From
(Standard_Short_Integer
) then
16056 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
16058 elsif Can_Derive_From
(Standard_Integer
) then
16059 Base_Typ
:= Base_Type
(Standard_Integer
);
16061 elsif Can_Derive_From
(Standard_Long_Integer
) then
16062 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
16064 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
16065 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
16068 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
16069 Error_Msg_N
("integer type definition bounds out of range", Def
);
16070 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
16071 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
16075 -- Complete both implicit base and declared first subtype entities
16077 Set_Etype
(Implicit_Base
, Base_Typ
);
16078 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
16079 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
16080 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
16081 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
16083 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
16084 Set_Etype
(T
, Implicit_Base
);
16086 Set_Size_Info
(T
, (Implicit_Base
));
16087 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
16088 Set_Scalar_Range
(T
, Def
);
16089 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
16090 Set_Is_Constrained
(T
);
16091 end Signed_Integer_Type_Declaration
;