1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Elists
; use Elists
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Eval_Fat
; use Eval_Fat
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Dist
; use Exp_Dist
;
35 with Exp_Util
; use Exp_Util
;
36 with Freeze
; use Freeze
;
37 with Itypes
; use Itypes
;
38 with Layout
; use Layout
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Nmake
; use Nmake
;
44 with Restrict
; use Restrict
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Case
; use Sem_Case
;
48 with Sem_Cat
; use Sem_Cat
;
49 with Sem_Ch6
; use Sem_Ch6
;
50 with Sem_Ch7
; use Sem_Ch7
;
51 with Sem_Ch8
; use Sem_Ch8
;
52 with Sem_Ch13
; use Sem_Ch13
;
53 with Sem_Disp
; use Sem_Disp
;
54 with Sem_Dist
; use Sem_Dist
;
55 with Sem_Elim
; use Sem_Elim
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Mech
; use Sem_Mech
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Smem
; use Sem_Smem
;
60 with Sem_Type
; use Sem_Type
;
61 with Sem_Util
; use Sem_Util
;
62 with Stand
; use Stand
;
63 with Sinfo
; use Sinfo
;
64 with Snames
; use Snames
;
65 with Tbuild
; use Tbuild
;
66 with Ttypes
; use Ttypes
;
67 with Uintp
; use Uintp
;
68 with Urealp
; use Urealp
;
70 package body Sem_Ch3
is
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 procedure Build_Derived_Type
78 Parent_Type
: Entity_Id
;
79 Derived_Type
: Entity_Id
;
80 Is_Completion
: Boolean;
81 Derive_Subps
: Boolean := True);
82 -- Create and decorate a Derived_Type given the Parent_Type entity.
83 -- N is the N_Full_Type_Declaration node containing the derived type
84 -- definition. Parent_Type is the entity for the parent type in the derived
85 -- type definition and Derived_Type the actual derived type. Is_Completion
86 -- must be set to False if Derived_Type is the N_Defining_Identifier node
87 -- in N (ie Derived_Type = Defining_Identifier (N)). In this case N is not
88 -- the completion of a private type declaration. If Is_Completion is
89 -- set to True, N is the completion of a private type declaration and
90 -- Derived_Type is different from the defining identifier inside N (i.e.
91 -- Derived_Type /= Defining_Identifier (N)). Derive_Subps indicates whether
92 -- the parent subprograms should be derived. The only case where this
93 -- parameter is False is when Build_Derived_Type is recursively called to
94 -- process an implicit derived full type for a type derived from a private
95 -- type (in that case the subprograms must only be derived for the private
97 -- ??? These flags need a bit of re-examination and re-documentation:
98 -- ??? are they both necessary (both seem related to the recursion)?
100 procedure Build_Derived_Access_Type
102 Parent_Type
: Entity_Id
;
103 Derived_Type
: Entity_Id
);
104 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
105 -- create an implicit base if the parent type is constrained or if the
106 -- subtype indication has a constraint.
108 procedure Build_Derived_Array_Type
110 Parent_Type
: Entity_Id
;
111 Derived_Type
: Entity_Id
);
112 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
113 -- create an implicit base if the parent type is constrained or if the
114 -- subtype indication has a constraint.
116 procedure Build_Derived_Concurrent_Type
118 Parent_Type
: Entity_Id
;
119 Derived_Type
: Entity_Id
);
120 -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
121 -- tected type, inherit entries and protected subprograms, check legality
122 -- of discriminant constraints if any.
124 procedure Build_Derived_Enumeration_Type
126 Parent_Type
: Entity_Id
;
127 Derived_Type
: Entity_Id
);
128 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
129 -- type, we must create a new list of literals. Types derived from
130 -- Character and Wide_Character are special-cased.
132 procedure Build_Derived_Numeric_Type
134 Parent_Type
: Entity_Id
;
135 Derived_Type
: Entity_Id
);
136 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
137 -- an anonymous base type, and propagate constraint to subtype if needed.
139 procedure Build_Derived_Private_Type
141 Parent_Type
: Entity_Id
;
142 Derived_Type
: Entity_Id
;
143 Is_Completion
: Boolean;
144 Derive_Subps
: Boolean := True);
145 -- Substidiary procedure to Build_Derived_Type. This procedure is complex
146 -- because the parent may or may not have a completion, and the derivation
147 -- may itself be a completion.
149 procedure Build_Derived_Record_Type
151 Parent_Type
: Entity_Id
;
152 Derived_Type
: Entity_Id
;
153 Derive_Subps
: Boolean := True);
154 -- Subsidiary procedure to Build_Derived_Type and
155 -- Analyze_Private_Extension_Declaration used for tagged and untagged
156 -- record types. All parameters are as in Build_Derived_Type except that
157 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
158 -- N_Private_Extension_Declaration node. See the definition of this routine
159 -- for much more info. Derive_Subps indicates whether subprograms should
160 -- be derived from the parent type. The only case where Derive_Subps is
161 -- False is for an implicit derived full type for a type derived from a
162 -- private type (see Build_Derived_Type).
164 function Inherit_Components
166 Parent_Base
: Entity_Id
;
167 Derived_Base
: Entity_Id
;
169 Inherit_Discr
: Boolean;
172 -- Called from Build_Derived_Record_Type to inherit the components of
173 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
174 -- For more information on derived types and component inheritance please
175 -- consult the comment above the body of Build_Derived_Record_Type.
177 -- N is the original derived type declaration.
178 -- Is_Tagged is set if we are dealing with tagged types.
179 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
180 -- Parent_Base, otherwise no discriminants are inherited.
181 -- Discs gives the list of constraints that apply to Parent_Base in the
182 -- derived type declaration. If Discs is set to No_Elist, then we have the
183 -- following situation:
185 -- type Parent (D1..Dn : ..) is [tagged] record ...;
186 -- type Derived is new Parent [with ...];
188 -- which gets treated as
190 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
192 -- For untagged types the returned value is an association list:
193 -- (Old_Component => New_Component), where Old_Component is the Entity_Id
194 -- of a component in Parent_Base and New_Component is the Entity_Id of the
195 -- corresponding component in Derived_Base. For untagged records, this
196 -- association list is needed when copying the record declaration for the
197 -- derived base. In the tagged case the value returned is irrelevant.
199 procedure Build_Discriminal
(Discrim
: Entity_Id
);
200 -- Create the discriminal corresponding to discriminant Discrim, that is
201 -- the parameter corresponding to Discrim to be used in initialization
202 -- procedures for the type where Discrim is a discriminant. Discriminals
203 -- are not used during semantic analysis, and are not fully defined
204 -- entities until expansion. Thus they are not given a scope until
205 -- initialization procedures are built.
207 function Build_Discriminant_Constraints
210 Derived_Def
: Boolean := False)
212 -- Validate discriminant constraints, and return the list of the
213 -- constraints in order of discriminant declarations. T is the
214 -- discriminated unconstrained type. Def is the N_Subtype_Indication
215 -- node where the discriminants constraints for T are specified.
216 -- Derived_Def is True if we are building the discriminant constraints
217 -- in a derived type definition of the form "type D (...) is new T (xxx)".
218 -- In this case T is the parent type and Def is the constraint "(xxx)" on
219 -- T and this routine sets the Corresponding_Discriminant field of the
220 -- discriminants in the derived type D to point to the corresponding
221 -- discriminants in the parent type T.
223 procedure Build_Discriminated_Subtype
227 Related_Nod
: Node_Id
;
228 For_Access
: Boolean := False);
229 -- Subsidiary procedure to Constrain_Discriminated_Type and to
230 -- Process_Incomplete_Dependents. Given
232 -- T (a possibly discriminated base type)
233 -- Def_Id (a very partially built subtype for T),
235 -- the call completes Def_Id to be the appropriate E_*_Subtype.
237 -- The Elist is the list of discriminant constraints if any (it is set to
238 -- No_Elist if T is not a discriminated type, and to an empty list if
239 -- T has discriminants but there are no discriminant constraints). The
240 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
241 -- The For_Access says whether or not this subtype is really constraining
242 -- an access type. That is its sole purpose is the designated type of an
243 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
244 -- is built to avoid freezing T when the access subtype is frozen.
246 function Build_Scalar_Bound
251 -- The bounds of a derived scalar type are conversions of the bounds of
252 -- the parent type. Optimize the representation if the bounds are literals.
253 -- Needs a more complete spec--what are the parameters exactly, and what
254 -- exactly is the returned value, and how is Bound affected???
256 procedure Build_Underlying_Full_View
260 -- If the completion of a private type is itself derived from a private
261 -- type, or if the full view of a private subtype is itself private, the
262 -- back-end has no way to compute the actual size of this type. We build
263 -- an internal subtype declaration of the proper parent type to convey
264 -- this information. This extra mechanism is needed because a full
265 -- view cannot itself have a full view (it would get clobbered during
268 procedure Check_Access_Discriminant_Requires_Limited
271 -- Check the restriction that the type to which an access discriminant
272 -- belongs must be a concurrent type or a descendant of a type with
273 -- the reserved word 'limited' in its declaration.
275 procedure Check_Delta_Expression
(E
: Node_Id
);
276 -- Check that the expression represented by E is suitable for use as
277 -- a delta expression, i.e. it is of real type and is static.
279 procedure Check_Digits_Expression
(E
: Node_Id
);
280 -- Check that the expression represented by E is suitable for use as
281 -- a digits expression, i.e. it is of integer type, positive and static.
283 procedure Check_Incomplete
(T
: Entity_Id
);
284 -- Called to verify that an incomplete type is not used prematurely
286 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
);
287 -- Validate the initialization of an object declaration. T is the
288 -- required type, and Exp is the initialization expression.
290 procedure Check_Or_Process_Discriminants
(N
: Node_Id
; T
: Entity_Id
);
291 -- If T is the full declaration of an incomplete or private type, check
292 -- the conformance of the discriminants, otherwise process them.
294 procedure Check_Real_Bound
(Bound
: Node_Id
);
295 -- Check given bound for being of real type and static. If not, post an
296 -- appropriate message, and rewrite the bound with the real literal zero.
298 procedure Constant_Redeclaration
302 -- Various checks on legality of full declaration of deferred constant.
303 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
304 -- node. The caller has not yet set any attributes of this entity.
306 procedure Convert_Scalar_Bounds
308 Parent_Type
: Entity_Id
;
309 Derived_Type
: Entity_Id
;
311 -- For derived scalar types, convert the bounds in the type definition
312 -- to the derived type, and complete their analysis.
314 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
);
315 -- Copies attributes from array base type T2 to array base type T1.
316 -- Copies only attributes that apply to base types, but not subtypes.
318 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
);
319 -- Copies attributes from array subtype T2 to array subtype T1. Copies
320 -- attributes that apply to both subtypes and base types.
322 procedure Create_Constrained_Components
326 Constraints
: Elist_Id
);
327 -- Build the list of entities for a constrained discriminated record
328 -- subtype. If a component depends on a discriminant, replace its subtype
329 -- using the discriminant values in the discriminant constraint.
330 -- Subt is the defining identifier for the subtype whose list of
331 -- constrained entities we will create. Decl_Node is the type declaration
332 -- node where we will attach all the itypes created. Typ is the base
333 -- discriminated type for the subtype Subt. Constraints is the list of
334 -- discriminant constraints for Typ.
336 function Constrain_Component_Type
337 (Compon_Type
: Entity_Id
;
338 Constrained_Typ
: Entity_Id
;
339 Related_Node
: Node_Id
;
341 Constraints
: Elist_Id
)
343 -- Given a discriminated base type Typ, a list of discriminant constraint
344 -- Constraints for Typ and the type of a component of Typ, Compon_Type,
345 -- create and return the type corresponding to Compon_type where all
346 -- discriminant references are replaced with the corresponding
347 -- constraint. If no discriminant references occurr in Compon_Typ then
348 -- return it as is. Constrained_Typ is the final constrained subtype to
349 -- which the constrained Compon_Type belongs. Related_Node is the node
350 -- where we will attach all the itypes created.
352 procedure Constrain_Access
353 (Def_Id
: in out Entity_Id
;
355 Related_Nod
: Node_Id
);
356 -- Apply a list of constraints to an access type. If Def_Id is empty,
357 -- it is an anonymous type created for a subtype indication. In that
358 -- case it is created in the procedure and attached to Related_Nod.
360 procedure Constrain_Array
361 (Def_Id
: in out Entity_Id
;
363 Related_Nod
: Node_Id
;
364 Related_Id
: Entity_Id
;
366 -- Apply a list of index constraints to an unconstrained array type. The
367 -- first parameter is the entity for the resulting subtype. A value of
368 -- Empty for Def_Id indicates that an implicit type must be created, but
369 -- creation is delayed (and must be done by this procedure) because other
370 -- subsidiary implicit types must be created first (which is why Def_Id
371 -- is an in/out parameter). The second parameter is a subtype indication
372 -- node for the constrained array to be created (e.g. something of the
373 -- form string (1 .. 10)). Related_Nod gives the place where this type
374 -- has to be inserted in the tree. The Related_Id and Suffix parameters
375 -- are used to build the associated Implicit type name.
377 procedure Constrain_Concurrent
378 (Def_Id
: in out Entity_Id
;
380 Related_Nod
: Node_Id
;
381 Related_Id
: Entity_Id
;
383 -- Apply list of discriminant constraints to an unconstrained concurrent
386 -- SI is the N_Subtype_Indication node containing the constraint and
387 -- the unconstrained type to constrain.
389 -- Def_Id is the entity for the resulting constrained subtype. A
390 -- value of Empty for Def_Id indicates that an implicit type must be
391 -- created, but creation is delayed (and must be done by this procedure)
392 -- because other subsidiary implicit types must be created first (which
393 -- is why Def_Id is an in/out parameter).
395 -- Related_Nod gives the place where this type has to be inserted
398 -- The last two arguments are used to create its external name if needed.
400 function Constrain_Corresponding_Record
401 (Prot_Subt
: Entity_Id
;
402 Corr_Rec
: Entity_Id
;
403 Related_Nod
: Node_Id
;
404 Related_Id
: Entity_Id
)
406 -- When constraining a protected type or task type with discriminants,
407 -- constrain the corresponding record with the same discriminant values.
409 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
);
410 -- Constrain a decimal fixed point type with a digits constraint and/or a
411 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
413 procedure Constrain_Discriminated_Type
416 Related_Nod
: Node_Id
;
417 For_Access
: Boolean := False);
418 -- Process discriminant constraints of composite type. Verify that values
419 -- have been provided for all discriminants, that the original type is
420 -- unconstrained, and that the types of the supplied expressions match
421 -- the discriminant types. The first three parameters are like in routine
422 -- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
425 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
);
426 -- Constrain an enumeration type with a range constraint. This is
427 -- identical to Constrain_Integer, but for the Ekind of the
428 -- resulting subtype.
430 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
);
431 -- Constrain a floating point type with either a digits constraint
432 -- and/or a range constraint, building a E_Floating_Point_Subtype.
434 procedure Constrain_Index
437 Related_Nod
: Node_Id
;
438 Related_Id
: Entity_Id
;
441 -- Process an index constraint in a constrained array declaration.
442 -- The constraint can be a subtype name, or a range with or without
443 -- an explicit subtype mark. The index is the corresponding index of the
444 -- unconstrained array. The Related_Id and Suffix parameters are used to
445 -- build the associated Implicit type name.
447 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
);
448 -- Build subtype of a signed or modular integer type.
450 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
);
451 -- Constrain an ordinary fixed point type with a range constraint, and
452 -- build an E_Ordinary_Fixed_Point_Subtype entity.
454 procedure Copy_And_Swap
(Privat
, Full
: Entity_Id
);
455 -- Copy the Privat entity into the entity of its full declaration
456 -- then swap the two entities in such a manner that the former private
457 -- type is now seen as a full type.
459 procedure Copy_Private_To_Full
(Priv
, Full
: Entity_Id
);
460 -- Initialize the full view declaration with the relevant fields
461 -- from the private view.
463 procedure Decimal_Fixed_Point_Type_Declaration
466 -- Create a new decimal fixed point type, and apply the constraint to
467 -- obtain a subtype of this new type.
469 procedure Complete_Private_Subtype
472 Full_Base
: Entity_Id
;
473 Related_Nod
: Node_Id
);
474 -- Complete the implicit full view of a private subtype by setting
475 -- the appropriate semantic fields. If the full view of the parent is
476 -- a record type, build constrained components of subtype.
478 procedure Derived_Standard_Character
480 Parent_Type
: Entity_Id
;
481 Derived_Type
: Entity_Id
);
482 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
483 -- derivations from types Standard.Character and Standard.Wide_Character.
485 procedure Derived_Type_Declaration
488 Is_Completion
: Boolean);
489 -- Process a derived type declaration. This routine will invoke
490 -- Build_Derived_Type to process the actual derived type definition.
491 -- Parameters N and Is_Completion have the same meaning as in
492 -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
493 -- defined in the N_Full_Type_Declaration node N, that is T is the
496 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
;
497 -- Given a subtype indication S (which is really an N_Subtype_Indication
498 -- node or a plain N_Identifier), find the type of the subtype mark.
500 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
501 -- Insert each literal in symbol table, as an overloadable identifier
502 -- Each enumeration type is mapped into a sequence of integers, and
503 -- each literal is defined as a constant with integer value. If any
504 -- of the literals are character literals, the type is a character
505 -- type, which means that strings are legal aggregates for arrays of
506 -- components of the type.
508 procedure Expand_Others_Choice
509 (Case_Table
: Choice_Table_Type
;
510 Others_Choice
: Node_Id
;
511 Choice_Type
: Entity_Id
);
512 -- In the case of a variant part of a record type that has an OTHERS
513 -- choice, this procedure expands the OTHERS into the actual choices
514 -- that it represents. This new list of choice nodes is attached to
515 -- the OTHERS node via the Others_Discrete_Choices field. The Case_Table
516 -- contains all choices that have been given explicitly in the variant.
518 function Find_Type_Of_Object
520 Related_Nod
: Node_Id
)
522 -- Get type entity for object referenced by Obj_Def, attaching the
523 -- implicit types generated to Related_Nod
525 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
526 -- Create a new float, and apply the constraint to obtain subtype of it
528 function Has_Range_Constraint
(N
: Node_Id
) return Boolean;
529 -- Given an N_Subtype_Indication node N, return True if a range constraint
530 -- is present, either directly, or as part of a digits or delta constraint.
531 -- In addition, a digits constraint in the decimal case returns True, since
532 -- it establishes a default range if no explicit range is present.
534 function Is_Valid_Constraint_Kind
536 Constraint_Kind
: Node_Kind
)
538 -- Returns True if it is legal to apply the given kind of constraint
539 -- to the given kind of type (index constraint to an array type,
542 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
543 -- Create new modular type. Verify that modulus is in bounds and is
544 -- a power of two (implementation restriction).
546 procedure New_Binary_Operator
(Op_Name
: Name_Id
; Typ
: Entity_Id
);
547 -- Create an abbreviated declaration for an operator in order to
548 -- materialize minimally operators on derived types.
550 procedure Ordinary_Fixed_Point_Type_Declaration
553 -- Create a new ordinary fixed point type, and apply the constraint
554 -- to obtain subtype of it.
556 procedure Prepare_Private_Subtype_Completion
558 Related_Nod
: Node_Id
);
559 -- Id is a subtype of some private type. Creates the full declaration
560 -- associated with Id whenever possible, i.e. when the full declaration
561 -- of the base type is already known. Records each subtype into
562 -- Private_Dependents of the base type.
564 procedure Process_Incomplete_Dependents
568 -- Process all entities that depend on an incomplete type. There include
569 -- subtypes, subprogram types that mention the incomplete type in their
570 -- profiles, and subprogram with access parameters that designate the
573 -- Inc_T is the defining identifier of an incomplete type declaration, its
574 -- Ekind is E_Incomplete_Type.
576 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
578 -- Full_T is N's defining identifier.
580 -- Subtypes of incomplete types with discriminants are completed when the
581 -- parent type is. This is simpler than private subtypes, because they can
582 -- only appear in the same scope, and there is no need to exchange views.
583 -- Similarly, access_to_subprogram types may have a parameter or a return
584 -- type that is an incomplete type, and that must be replaced with the
587 -- If the full type is tagged, subprogram with access parameters that
588 -- designated the incomplete may be primitive operations of the full type,
589 -- and have to be processed accordingly.
591 procedure Process_Real_Range_Specification
(Def
: Node_Id
);
592 -- Given the type definition for a real type, this procedure processes
593 -- and checks the real range specification of this type definition if
594 -- one is present. If errors are found, error messages are posted, and
595 -- the Real_Range_Specification of Def is reset to Empty.
597 procedure Record_Type_Declaration
(T
: Entity_Id
; N
: Node_Id
);
598 -- Process a record type declaration (for both untagged and tagged
599 -- records). Parameters T and N are exactly like in procedure
600 -- Derived_Type_Declaration, except that no flag Is_Completion is
601 -- needed for this routine.
603 procedure Record_Type_Definition
(Def
: Node_Id
; T
: Entity_Id
);
604 -- This routine is used to process the actual record type definition
605 -- (both for untagged and tagged records). Def is a record type
606 -- definition node. This procedure analyzes the components in this
607 -- record type definition. T is the entity for the enclosing record
608 -- type. It is provided so that its Has_Task flag can be set if any of
609 -- the component have Has_Task set.
611 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
);
612 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
613 -- build a copy of the declaration tree of the parent, and we create
614 -- independently the list of components for the derived type. Semantic
615 -- information uses the component entities, but record representation
616 -- clauses are validated on the declaration tree. This procedure replaces
617 -- discriminants and components in the declaration with those that have
618 -- been created by Inherit_Components.
620 procedure Set_Fixed_Range
625 -- Build a range node with the given bounds and set it as the Scalar_Range
626 -- of the given fixed-point type entity. Loc is the source location used
627 -- for the constructed range. See body for further details.
629 procedure Set_Scalar_Range_For_Subtype
633 -- This routine is used to set the scalar range field for a subtype
634 -- given Def_Id, the entity for the subtype, and R, the range expression
635 -- for the scalar range. Subt provides the parent subtype to be used
636 -- to analyze, resolve, and check the given range.
638 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
639 -- Create a new signed integer entity, and apply the constraint to obtain
640 -- the required first named subtype of this type.
642 -----------------------
643 -- Access_Definition --
644 -----------------------
646 function Access_Definition
647 (Related_Nod
: Node_Id
;
651 Anon_Type
: constant Entity_Id
:=
652 Create_Itype
(E_Anonymous_Access_Type
, Related_Nod
,
653 Scope_Id
=> Scope
(Current_Scope
));
654 Desig_Type
: Entity_Id
;
657 if Is_Entry
(Current_Scope
)
658 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
660 Error_Msg_N
("task entries cannot have access parameters", N
);
663 Find_Type
(Subtype_Mark
(N
));
664 Desig_Type
:= Entity
(Subtype_Mark
(N
));
666 Set_Directly_Designated_Type
667 (Anon_Type
, Desig_Type
);
668 Set_Etype
(Anon_Type
, Anon_Type
);
669 Init_Size_Align
(Anon_Type
);
670 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
672 -- The anonymous access type is as public as the discriminated type or
673 -- subprogram that defines it. It is imported (for back-end purposes)
674 -- if the designated type is.
676 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
677 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
679 -- The context is either a subprogram declaration or an access
680 -- discriminant, in a private or a full type declaration. In
681 -- the case of a subprogram, If the designated type is incomplete,
682 -- the operation will be a primitive operation of the full type, to
683 -- be updated subsequently.
685 if Ekind
(Desig_Type
) = E_Incomplete_Type
686 and then Is_Overloadable
(Current_Scope
)
688 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
689 Set_Has_Delayed_Freeze
(Current_Scope
);
693 end Access_Definition
;
695 -----------------------------------
696 -- Access_Subprogram_Declaration --
697 -----------------------------------
699 procedure Access_Subprogram_Declaration
703 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
705 Desig_Type
: constant Entity_Id
:=
706 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
709 if Nkind
(T_Def
) = N_Access_Function_Definition
then
710 Analyze
(Subtype_Mark
(T_Def
));
711 Set_Etype
(Desig_Type
, Entity
(Subtype_Mark
(T_Def
)));
713 Set_Etype
(Desig_Type
, Standard_Void_Type
);
716 if Present
(Formals
) then
717 New_Scope
(Desig_Type
);
718 Process_Formals
(Formals
, Parent
(T_Def
));
720 -- A bit of a kludge here, End_Scope requires that the parent
721 -- pointer be set to something reasonable, but Itypes don't
722 -- have parent pointers. So we set it and then unset it ???
723 -- If and when Itypes have proper parent pointers to their
724 -- declarations, this kludge can be removed.
726 Set_Parent
(Desig_Type
, T_Name
);
728 Set_Parent
(Desig_Type
, Empty
);
731 -- The return type and/or any parameter type may be incomplete. Mark
732 -- the subprogram_type as depending on the incomplete type, so that
733 -- it can be updated when the full type declaration is seen.
735 if Present
(Formals
) then
736 Formal
:= First_Formal
(Desig_Type
);
738 while Present
(Formal
) loop
740 if Ekind
(Formal
) /= E_In_Parameter
741 and then Nkind
(T_Def
) = N_Access_Function_Definition
743 Error_Msg_N
("functions can only have IN parameters", Formal
);
746 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
747 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
748 Set_Has_Delayed_Freeze
(Desig_Type
);
751 Next_Formal
(Formal
);
755 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
756 and then not Has_Delayed_Freeze
(Desig_Type
)
758 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
759 Set_Has_Delayed_Freeze
(Desig_Type
);
762 Check_Delayed_Subprogram
(Desig_Type
);
764 if Protected_Present
(T_Def
) then
765 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
766 Set_Convention
(Desig_Type
, Convention_Protected
);
768 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
771 Set_Etype
(T_Name
, T_Name
);
772 Init_Size_Align
(T_Name
);
773 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
775 Check_Restriction
(No_Access_Subprograms
, T_Def
);
776 end Access_Subprogram_Declaration
;
778 ----------------------------
779 -- Access_Type_Declaration --
780 ----------------------------
782 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
783 S
: constant Node_Id
:= Subtype_Indication
(Def
);
784 P
: constant Node_Id
:= Parent
(Def
);
787 -- Check for permissible use of incomplete type
789 if Nkind
(S
) /= N_Subtype_Indication
then
792 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
793 Set_Directly_Designated_Type
(T
, Entity
(S
));
795 Set_Directly_Designated_Type
(T
,
796 Process_Subtype
(S
, P
, T
, 'P'));
800 Set_Directly_Designated_Type
(T
,
801 Process_Subtype
(S
, P
, T
, 'P'));
804 if All_Present
(Def
) or Constant_Present
(Def
) then
805 Set_Ekind
(T
, E_General_Access_Type
);
807 Set_Ekind
(T
, E_Access_Type
);
810 if Base_Type
(Designated_Type
(T
)) = T
then
811 Error_Msg_N
("access type cannot designate itself", S
);
816 -- If the type has appeared already in a with_type clause, it is
817 -- frozen and the pointer size is already set. Else, initialize.
819 if not From_With_Type
(T
) then
823 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
825 -- If designated type is an imported tagged type, indicate that the
826 -- access type is also imported, and therefore restricted in its use.
827 -- The access type may already be imported, so keep setting otherwise.
829 if From_With_Type
(Designated_Type
(T
)) then
830 Set_From_With_Type
(T
);
833 -- Note that Has_Task is always false, since the access type itself
834 -- is not a task type. See Einfo for more description on this point.
835 -- Exactly the same consideration applies to Has_Controlled_Component.
837 Set_Has_Task
(T
, False);
838 Set_Has_Controlled_Component
(T
, False);
839 end Access_Type_Declaration
;
841 -----------------------------------
842 -- Analyze_Component_Declaration --
843 -----------------------------------
845 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
846 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
851 Generate_Definition
(Id
);
853 T
:= Find_Type_Of_Object
(Subtype_Indication
(N
), N
);
855 -- If the component declaration includes a default expression, then we
856 -- check that the component is not of a limited type (RM 3.7(5)),
857 -- and do the special preanalysis of the expression (see section on
858 -- "Handling of Default Expressions" in the spec of package Sem).
860 if Present
(Expression
(N
)) then
861 Analyze_Default_Expression
(Expression
(N
), T
);
862 Check_Initialization
(T
, Expression
(N
));
865 -- The parent type may be a private view with unknown discriminants,
866 -- and thus unconstrained. Regular components must be constrained.
868 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
870 ("unconstrained subtype in component declaration",
871 Subtype_Indication
(N
));
873 -- Components cannot be abstract, except for the special case of
874 -- the _Parent field (case of extending an abstract tagged type)
876 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
877 Error_Msg_N
("type of a component cannot be abstract", N
);
881 Set_Is_Aliased
(Id
, Aliased_Present
(N
));
883 -- If the this component is private (or depends on a private type),
884 -- flag the record type to indicate that some operations are not
887 P
:= Private_Component
(T
);
890 -- Check for circular definitions.
893 Set_Etype
(Id
, Any_Type
);
895 -- There is a gap in the visibility of operations only if the
896 -- component type is not defined in the scope of the record type.
898 elsif Scope
(P
) = Scope
(Current_Scope
) then
901 elsif Is_Limited_Type
(P
) then
902 Set_Is_Limited_Composite
(Current_Scope
);
905 Set_Is_Private_Composite
(Current_Scope
);
910 and then Is_Limited_Type
(T
)
911 and then Chars
(Id
) /= Name_uParent
912 and then Is_Tagged_Type
(Current_Scope
)
914 if Is_Derived_Type
(Current_Scope
)
915 and then not Is_Limited_Record
(Root_Type
(Current_Scope
))
918 ("extension of nonlimited type cannot have limited components",
920 Set_Etype
(Id
, Any_Type
);
921 Set_Is_Limited_Composite
(Current_Scope
, False);
923 elsif not Is_Derived_Type
(Current_Scope
)
924 and then not Is_Limited_Record
(Current_Scope
)
926 Error_Msg_N
("nonlimited type cannot have limited components", N
);
927 Set_Etype
(Id
, Any_Type
);
928 Set_Is_Limited_Composite
(Current_Scope
, False);
932 Set_Original_Record_Component
(Id
, Id
);
933 end Analyze_Component_Declaration
;
935 --------------------------
936 -- Analyze_Declarations --
937 --------------------------
939 procedure Analyze_Declarations
(L
: List_Id
) is
942 Freeze_From
: Entity_Id
:= Empty
;
945 -- Adjust D not to include implicit label declarations, since these
946 -- have strange Sloc values that result in elaboration check problems.
948 procedure Adjust_D
is
950 while Present
(Prev
(D
))
951 and then Nkind
(D
) = N_Implicit_Label_Declaration
957 -- Start of processing for Analyze_Declarations
961 while Present
(D
) loop
963 -- Complete analysis of declaration
966 Next_Node
:= Next
(D
);
968 if No
(Freeze_From
) then
969 Freeze_From
:= First_Entity
(Current_Scope
);
972 -- At the end of a declarative part, freeze remaining entities
973 -- declared in it. The end of the visible declarations of a
974 -- package specification is not the end of a declarative part
975 -- if private declarations are present. The end of a package
976 -- declaration is a freezing point only if it a library package.
977 -- A task definition or protected type definition is not a freeze
978 -- point either. Finally, we do not freeze entities in generic
979 -- scopes, because there is no code generated for them and freeze
980 -- nodes will be generated for the instance.
982 -- The end of a package instantiation is not a freeze point, but
983 -- for now we make it one, because the generic body is inserted
984 -- (currently) immediately after. Generic instantiations will not
985 -- be a freeze point once delayed freezing of bodies is implemented.
986 -- (This is needed in any case for early instantiations ???).
988 if No
(Next_Node
) then
989 if Nkind
(Parent
(L
)) = N_Component_List
990 or else Nkind
(Parent
(L
)) = N_Task_Definition
991 or else Nkind
(Parent
(L
)) = N_Protected_Definition
995 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
997 if Nkind
(Parent
(L
)) = N_Package_Body
then
998 Freeze_From
:= First_Entity
(Current_Scope
);
1002 Freeze_All
(Freeze_From
, D
);
1003 Freeze_From
:= Last_Entity
(Current_Scope
);
1005 elsif Scope
(Current_Scope
) /= Standard_Standard
1006 and then not Is_Child_Unit
(Current_Scope
)
1007 and then No
(Generic_Parent
(Parent
(L
)))
1011 elsif L
/= Visible_Declarations
(Parent
(L
))
1012 or else No
(Private_Declarations
(Parent
(L
)))
1013 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1016 Freeze_All
(Freeze_From
, D
);
1017 Freeze_From
:= Last_Entity
(Current_Scope
);
1020 -- If next node is a body then freeze all types before the body.
1021 -- An exception occurs for expander generated bodies, which can
1022 -- be recognized by their already being analyzed. The expander
1023 -- ensures that all types needed by these bodies have been frozen
1024 -- but it is not necessary to freeze all types (and would be wrong
1025 -- since it would not correspond to an RM defined freeze point).
1027 elsif not Analyzed
(Next_Node
)
1028 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1029 or else Nkind
(Next_Node
) = N_Entry_Body
1030 or else Nkind
(Next_Node
) = N_Package_Body
1031 or else Nkind
(Next_Node
) = N_Protected_Body
1032 or else Nkind
(Next_Node
) = N_Task_Body
1033 or else Nkind
(Next_Node
) in N_Body_Stub
)
1036 Freeze_All
(Freeze_From
, D
);
1037 Freeze_From
:= Last_Entity
(Current_Scope
);
1043 end Analyze_Declarations
;
1045 --------------------------------
1046 -- Analyze_Default_Expression --
1047 --------------------------------
1049 procedure Analyze_Default_Expression
(N
: Node_Id
; T
: Entity_Id
) is
1050 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
1053 In_Default_Expression
:= True;
1054 Pre_Analyze_And_Resolve
(N
, T
);
1055 In_Default_Expression
:= Save_In_Default_Expression
;
1056 end Analyze_Default_Expression
;
1058 ----------------------------------
1059 -- Analyze_Incomplete_Type_Decl --
1060 ----------------------------------
1062 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1063 F
: constant Boolean := Is_Pure
(Current_Scope
);
1067 Generate_Definition
(Defining_Identifier
(N
));
1069 -- Process an incomplete declaration. The identifier must not have been
1070 -- declared already in the scope. However, an incomplete declaration may
1071 -- appear in the private part of a package, for a private type that has
1072 -- already been declared.
1074 -- In this case, the discriminants (if any) must match.
1076 T
:= Find_Type_Name
(N
);
1078 Set_Ekind
(T
, E_Incomplete_Type
);
1079 Init_Size_Align
(T
);
1080 Set_Is_First_Subtype
(T
, True);
1084 Set_Girder_Constraint
(T
, No_Elist
);
1086 if Present
(Discriminant_Specifications
(N
)) then
1087 Process_Discriminants
(N
);
1092 -- If the type has discriminants, non-trivial subtypes may be
1093 -- be declared before the full view of the type. The full views
1094 -- of those subtypes will be built after the full view of the type.
1096 Set_Private_Dependents
(T
, New_Elmt_List
);
1098 end Analyze_Incomplete_Type_Decl
;
1100 -----------------------------
1101 -- Analyze_Itype_Reference --
1102 -----------------------------
1104 -- Nothing to do. This node is placed in the tree only for the benefit
1105 -- of Gigi processing, and has no effect on the semantic processing.
1107 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1109 pragma Assert
(Is_Itype
(Itype
(N
)));
1111 end Analyze_Itype_Reference
;
1113 --------------------------------
1114 -- Analyze_Number_Declaration --
1115 --------------------------------
1117 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1118 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1119 E
: constant Node_Id
:= Expression
(N
);
1121 Index
: Interp_Index
;
1125 Generate_Definition
(Id
);
1128 -- This is an optimization of a common case of an integer literal
1130 if Nkind
(E
) = N_Integer_Literal
then
1131 Set_Is_Static_Expression
(E
, True);
1132 Set_Etype
(E
, Universal_Integer
);
1134 Set_Etype
(Id
, Universal_Integer
);
1135 Set_Ekind
(Id
, E_Named_Integer
);
1136 Set_Is_Frozen
(Id
, True);
1140 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1142 -- Process expression, replacing error by integer zero, to avoid
1143 -- cascaded errors or aborts further along in the processing
1145 -- Replace Error by integer zero, which seems least likely to
1146 -- cause cascaded errors.
1149 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1150 Set_Error_Posted
(E
);
1155 -- Verify that the expression is static and numeric. If
1156 -- the expression is overloaded, we apply the preference
1157 -- rule that favors root numeric types.
1159 if not Is_Overloaded
(E
) then
1164 Get_First_Interp
(E
, Index
, It
);
1166 while Present
(It
.Typ
) loop
1167 if (Is_Integer_Type
(It
.Typ
)
1168 or else Is_Real_Type
(It
.Typ
))
1169 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1171 if T
= Any_Type
then
1174 elsif It
.Typ
= Universal_Real
1175 or else It
.Typ
= Universal_Integer
1177 -- Choose universal interpretation over any other.
1184 Get_Next_Interp
(Index
, It
);
1188 if Is_Integer_Type
(T
) then
1190 Set_Etype
(Id
, Universal_Integer
);
1191 Set_Ekind
(Id
, E_Named_Integer
);
1193 elsif Is_Real_Type
(T
) then
1195 -- Because the real value is converted to universal_real, this
1196 -- is a legal context for a universal fixed expression.
1198 if T
= Universal_Fixed
then
1200 Loc
: constant Source_Ptr
:= Sloc
(N
);
1201 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1203 New_Occurrence_Of
(Universal_Real
, Loc
),
1204 Expression
=> Relocate_Node
(E
));
1211 elsif T
= Any_Fixed
then
1212 Error_Msg_N
("illegal context for mixed mode operation", E
);
1214 -- Expression is of the form : universal_fixed * integer.
1215 -- Try to resolve as universal_real.
1217 T
:= Universal_Real
;
1222 Set_Etype
(Id
, Universal_Real
);
1223 Set_Ekind
(Id
, E_Named_Real
);
1226 Wrong_Type
(E
, Any_Numeric
);
1229 Set_Ekind
(Id
, E_Constant
);
1230 Set_Not_Source_Assigned
(Id
, True);
1231 Set_Is_True_Constant
(Id
, True);
1235 if Nkind
(E
) = N_Integer_Literal
1236 or else Nkind
(E
) = N_Real_Literal
1238 Set_Etype
(E
, Etype
(Id
));
1241 if not Is_OK_Static_Expression
(E
) then
1242 Error_Msg_N
("non-static expression used in number declaration", E
);
1243 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1244 Set_Etype
(E
, Any_Type
);
1247 end Analyze_Number_Declaration
;
1249 --------------------------------
1250 -- Analyze_Object_Declaration --
1251 --------------------------------
1253 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1254 Loc
: constant Source_Ptr
:= Sloc
(N
);
1255 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1259 E
: Node_Id
:= Expression
(N
);
1260 -- E is set to Expression (N) throughout this routine. When
1261 -- Expression (N) is modified, E is changed accordingly.
1263 Prev_Entity
: Entity_Id
:= Empty
;
1265 function Build_Default_Subtype
return Entity_Id
;
1266 -- If the object is limited or aliased, and if the type is unconstrained
1267 -- and there is no expression, the discriminants cannot be modified and
1268 -- the subtype of the object is constrained by the defaults, so it is
1269 -- worthile building the corresponding subtype.
1271 ---------------------------
1272 -- Build_Default_Subtype --
1273 ---------------------------
1275 function Build_Default_Subtype
return Entity_Id
is
1277 Constraints
: List_Id
:= New_List
;
1282 Disc
:= First_Discriminant
(T
);
1284 if No
(Discriminant_Default_Value
(Disc
)) then
1285 return T
; -- previous error.
1288 Act
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1289 while Present
(Disc
) loop
1292 Discriminant_Default_Value
(Disc
)), Constraints
);
1293 Next_Discriminant
(Disc
);
1297 Make_Subtype_Declaration
(Loc
,
1298 Defining_Identifier
=> Act
,
1299 Subtype_Indication
=>
1300 Make_Subtype_Indication
(Loc
,
1301 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1303 Make_Index_Or_Discriminant_Constraint
1304 (Loc
, Constraints
)));
1306 Insert_Before
(N
, Decl
);
1309 end Build_Default_Subtype
;
1311 -- Start of processing for Analyze_Object_Declaration
1314 -- There are three kinds of implicit types generated by an
1315 -- object declaration:
1317 -- 1. Those for generated by the original Object Definition
1319 -- 2. Those generated by the Expression
1321 -- 3. Those used to constrained the Object Definition with the
1322 -- expression constraints when it is unconstrained
1324 -- They must be generated in this order to avoid order of elaboration
1325 -- issues. Thus the first step (after entering the name) is to analyze
1326 -- the object definition.
1328 if Constant_Present
(N
) then
1329 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
1331 -- If homograph is an implicit subprogram, it is overridden by the
1332 -- current declaration.
1334 if Present
(Prev_Entity
)
1335 and then Is_Overloadable
(Prev_Entity
)
1336 and then Is_Inherited_Operation
(Prev_Entity
)
1338 Prev_Entity
:= Empty
;
1342 if Present
(Prev_Entity
) then
1343 Constant_Redeclaration
(Id
, N
, T
);
1345 Generate_Reference
(Prev_Entity
, Id
, 'c');
1346 Set_Completion_Referenced
(Id
);
1348 if Error_Posted
(N
) then
1349 -- Type mismatch or illegal redeclaration, Do not analyze
1350 -- expression to avoid cascaded errors.
1352 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1354 Set_Ekind
(Id
, E_Variable
);
1358 -- In the normal case, enter identifier at the start to catch
1359 -- premature usage in the initialization expression.
1362 Generate_Definition
(Id
);
1365 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1367 if Error_Posted
(Id
) then
1369 Set_Ekind
(Id
, E_Variable
);
1374 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1376 -- If deferred constant, make sure context is appropriate. We detect
1377 -- a deferred constant as a constant declaration with no expression.
1378 -- A deferred constant can appear in a package body if its completion
1379 -- is by means of an interface pragma.
1381 if Constant_Present
(N
)
1384 if not Is_Package
(Current_Scope
) then
1386 ("invalid context for deferred constant declaration", N
);
1387 Set_Constant_Present
(N
, False);
1389 -- In Ada 83, deferred constant must be of private type
1391 elsif not Is_Private_Type
(T
) then
1392 if Ada_83
and then Comes_From_Source
(N
) then
1394 ("(Ada 83) deferred constant must be private type", N
);
1398 -- If not a deferred constant, then object declaration freezes its type
1401 Check_Fully_Declared
(T
, N
);
1402 Freeze_Before
(N
, T
);
1405 -- If the object was created by a constrained array definition, then
1406 -- set the link in both the anonymous base type and anonymous subtype
1407 -- that are built to represent the array type to point to the object.
1409 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
1410 N_Constrained_Array_Definition
1412 Set_Related_Array_Object
(T
, Id
);
1413 Set_Related_Array_Object
(Base_Type
(T
), Id
);
1416 -- Special checks for protected objects not at library level
1418 if Is_Protected_Type
(T
)
1419 and then not Is_Library_Level_Entity
(Id
)
1421 Check_Restriction
(No_Local_Protected_Objects
, Id
);
1423 -- Protected objects with interrupt handlers must be at library level
1425 if Has_Interrupt_Handler
(T
) then
1427 ("interrupt object can only be declared at library level", Id
);
1431 -- The actual subtype of the object is the nominal subtype, unless
1432 -- the nominal one is unconstrained and obtained from the expression.
1436 -- Process initialization expression if present and not in error
1438 if Present
(E
) and then E
/= Error
then
1441 if not Assignment_OK
(N
) then
1442 Check_Initialization
(T
, E
);
1447 -- Check for library level object that will require implicit
1450 if Is_Array_Type
(T
)
1451 and then not Size_Known_At_Compile_Time
(T
)
1452 and then Is_Library_Level_Entity
(Id
)
1454 -- String literals are always allowed
1456 if T
= Standard_String
1457 and then Nkind
(E
) = N_String_Literal
1461 -- Otherwise we do not allow this since it may cause an
1462 -- implicit heap allocation.
1466 (No_Implicit_Heap_Allocations
, Object_Definition
(N
));
1470 -- Check incorrect use of dynamically tagged expressions. Note
1471 -- the use of Is_Tagged_Type (T) which seems redundant but is in
1472 -- fact important to avoid spurious errors due to expanded code
1473 -- for dispatching functions over an anonymous access type
1475 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
1476 and then Is_Tagged_Type
(T
)
1477 and then not Is_Class_Wide_Type
(T
)
1479 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
1482 Apply_Scalar_Range_Check
(E
, T
);
1483 Apply_Static_Length_Check
(E
, T
);
1486 -- Abstract type is never permitted for a variable or constant.
1487 -- Note: we inhibit this check for objects that do not come from
1488 -- source because there is at least one case (the expansion of
1489 -- x'class'input where x is abstract) where we legitimately
1490 -- generate an abstract object.
1492 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
1493 Error_Msg_N
("type of object cannot be abstract",
1494 Object_Definition
(N
));
1495 if Is_CPP_Class
(T
) then
1496 Error_Msg_NE
("\} may need a cpp_constructor",
1497 Object_Definition
(N
), T
);
1500 -- Case of unconstrained type
1502 elsif Is_Indefinite_Subtype
(T
) then
1504 -- Nothing to do in deferred constant case
1506 if Constant_Present
(N
) and then No
(E
) then
1509 -- Case of no initialization present
1512 if No_Initialization
(N
) then
1515 elsif Is_Class_Wide_Type
(T
) then
1517 ("initialization required in class-wide declaration ", N
);
1521 ("unconstrained subtype not allowed (need initialization)",
1522 Object_Definition
(N
));
1525 -- Case of initialization present but in error. Set initial
1526 -- expression as absent (but do not make above complaints)
1528 elsif E
= Error
then
1529 Set_Expression
(N
, Empty
);
1532 -- Case of initialization present
1535 -- Not allowed in Ada 83
1537 if not Constant_Present
(N
) then
1539 and then Comes_From_Source
(Object_Definition
(N
))
1542 ("(Ada 83) unconstrained variable not allowed",
1543 Object_Definition
(N
));
1547 -- Now we constrain the variable from the initializing expression
1549 -- If the expression is an aggregate, it has been expanded into
1550 -- individual assignments. Retrieve the actual type from the
1551 -- expanded construct.
1553 if Is_Array_Type
(T
)
1554 and then No_Initialization
(N
)
1555 and then Nkind
(Original_Node
(E
)) = N_Aggregate
1560 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
1561 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1564 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
1566 if Aliased_Present
(N
) then
1567 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
1570 Freeze_Before
(N
, Act_T
);
1571 Freeze_Before
(N
, T
);
1574 elsif Is_Array_Type
(T
)
1575 and then No_Initialization
(N
)
1576 and then Nkind
(Original_Node
(E
)) = N_Aggregate
1578 if not Is_Entity_Name
(Object_Definition
(N
)) then
1581 if Aliased_Present
(N
) then
1582 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
1586 -- When the given object definition and the aggregate are specified
1587 -- independently, and their lengths might differ do a length check.
1588 -- This cannot happen if the aggregate is of the form (others =>...)
1590 if not Is_Constrained
(T
) then
1593 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
1595 -- Aggregate is statically illegal. Place back in declaration
1597 Set_Expression
(N
, E
);
1598 Set_No_Initialization
(N
, False);
1600 elsif T
= Etype
(E
) then
1603 elsif Nkind
(E
) = N_Aggregate
1604 and then Present
(Component_Associations
(E
))
1605 and then Present
(Choices
(First
(Component_Associations
(E
))))
1606 and then Nkind
(First
1607 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
1612 Apply_Length_Check
(E
, T
);
1615 elsif (Is_Limited_Record
(T
)
1616 or else Is_Concurrent_Type
(T
))
1617 and then not Is_Constrained
(T
)
1618 and then Has_Discriminants
(T
)
1620 Act_T
:= Build_Default_Subtype
;
1621 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
1623 elsif not Is_Constrained
(T
)
1624 and then Has_Discriminants
(T
)
1625 and then Constant_Present
(N
)
1626 and then Nkind
(E
) = N_Function_Call
1628 -- The back-end has problems with constants of a discriminated type
1629 -- with defaults, if the initial value is a function call. We
1630 -- generate an intermediate temporary for the result of the call.
1631 -- It is unclear why this should make it acceptable to gcc. ???
1633 Remove_Side_Effects
(E
);
1636 if T
= Standard_Wide_Character
1637 or else Root_Type
(T
) = Standard_Wide_String
1639 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
1642 -- Now establish the proper kind and type of the object
1644 if Constant_Present
(N
) then
1645 Set_Ekind
(Id
, E_Constant
);
1646 Set_Not_Source_Assigned
(Id
, True);
1647 Set_Is_True_Constant
(Id
, True);
1650 Set_Ekind
(Id
, E_Variable
);
1652 -- A variable is set as shared passive if it appears in a shared
1653 -- passive package, and is at the outer level. This is not done
1654 -- for entities generated during expansion, because those are
1655 -- always manipulated locally.
1657 if Is_Shared_Passive
(Current_Scope
)
1658 and then Is_Library_Level_Entity
(Id
)
1659 and then Comes_From_Source
(Id
)
1661 Set_Is_Shared_Passive
(Id
);
1662 Check_Shared_Var
(Id
, T
, N
);
1665 -- If an initializing expression is present, then the variable
1666 -- is potentially a true constant if no further assignments are
1667 -- present. The code generator can use this for optimization.
1668 -- The flag will be reset if there are any assignments. We only
1669 -- set this flag for non library level entities, since for any
1670 -- library level entities, assignments could exist in other units.
1673 if not Is_Library_Level_Entity
(Id
) then
1675 -- For now we omit this, because it seems to cause some
1676 -- problems. In particular, if you uncomment this out, then
1677 -- test case 4427-002 will fail for unclear reasons ???
1680 Set_Is_True_Constant
(Id
);
1684 -- Case of no initializing expression present. If the type is not
1685 -- fully initialized, then we set Not_Source_Assigned, since this
1686 -- is a case of a potentially uninitialized object. Note that we
1687 -- do not consider access variables to be fully initialized for
1688 -- this purpose, since it still seems dubious if someone declares
1689 -- an access variable and never assigns to it.
1692 if Is_Access_Type
(T
)
1693 or else not Is_Fully_Initialized_Type
(T
)
1695 Set_Not_Source_Assigned
(Id
);
1700 Init_Alignment
(Id
);
1703 if Aliased_Present
(N
) then
1704 Set_Is_Aliased
(Id
);
1707 and then Is_Record_Type
(T
)
1708 and then not Is_Constrained
(T
)
1709 and then Has_Discriminants
(T
)
1711 Set_Actual_Subtype
(Id
, Build_Default_Subtype
);
1715 Set_Etype
(Id
, Act_T
);
1717 if Has_Controlled_Component
(Etype
(Id
))
1718 or else Is_Controlled
(Etype
(Id
))
1720 if not Is_Library_Level_Entity
(Id
) then
1721 Check_Restriction
(No_Nested_Finalization
, N
);
1724 Validate_Controlled_Object
(Id
);
1727 -- Generate a warning when an initialization causes an obvious
1728 -- ABE violation. If the init expression is a simple aggregate
1729 -- there shouldn't be any initialize/adjust call generated. This
1730 -- will be true as soon as aggregates are built in place when
1731 -- possible. ??? at the moment we do not generate warnings for
1732 -- temporaries created for those aggregates although a
1733 -- Program_Error might be generated if compiled with -gnato
1735 if Is_Controlled
(Etype
(Id
))
1736 and then Comes_From_Source
(Id
)
1739 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
1740 Implicit_Call
: Entity_Id
;
1742 function Is_Aggr
(N
: Node_Id
) return Boolean;
1743 -- Check that N is an aggregate
1745 function Is_Aggr
(N
: Node_Id
) return Boolean is
1747 case Nkind
(Original_Node
(N
)) is
1748 when N_Aggregate | N_Extension_Aggregate
=>
1751 when N_Qualified_Expression |
1753 N_Unchecked_Type_Conversion
=>
1754 return Is_Aggr
(Expression
(Original_Node
(N
)));
1762 -- If no underlying type, we already are in an error situation
1763 -- don't try to add a warning since we do not have access
1766 if No
(Underlying_Type
(BT
)) then
1767 Implicit_Call
:= Empty
;
1769 -- A generic type does not have usable primitive operators.
1770 -- Initialization calls are built for instances.
1772 elsif Is_Generic_Type
(BT
) then
1773 Implicit_Call
:= Empty
;
1775 -- if the init expression is not an aggregate, an adjust
1776 -- call will be generated
1778 elsif Present
(E
) and then not Is_Aggr
(E
) then
1779 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
1781 -- if no init expression and we are not in the deferred
1782 -- constant case, an Initialize call will be generated
1784 elsif No
(E
) and then not Constant_Present
(N
) then
1785 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
1788 Implicit_Call
:= Empty
;
1794 if Has_Task
(Etype
(Id
)) then
1795 if not Is_Library_Level_Entity
(Id
) then
1796 Check_Restriction
(No_Task_Hierarchy
, N
);
1797 Check_Potentially_Blocking_Operation
(N
);
1800 -- A rather specialized test. If we see two tasks being declared
1801 -- of the same type in the same object declaration, and the task
1802 -- has an entry with an address clause, we know that program error
1803 -- will be raised at run-time since we can't have two tasks with
1804 -- entries at the same address.
1806 if Is_Task_Type
(Etype
(Id
))
1807 and then More_Ids
(N
)
1813 E
:= First_Entity
(Etype
(Id
));
1814 while Present
(E
) loop
1815 if Ekind
(E
) = E_Entry
1816 and then Present
(Get_Attribute_Definition_Clause
1817 (E
, Attribute_Address
))
1820 ("?more than one task with same entry address", N
);
1822 ("\?Program_Error will be raised at run time", N
);
1824 Make_Raise_Program_Error
(Loc
,
1825 Reason
=> PE_Duplicated_Entry_Address
));
1835 -- Some simple constant-propagation: if the expression is a constant
1836 -- string initialized with a literal, share the literal. This avoids
1840 and then Is_Entity_Name
(E
)
1841 and then Ekind
(Entity
(E
)) = E_Constant
1842 and then Base_Type
(Etype
(E
)) = Standard_String
1845 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
1849 and then Nkind
(Val
) = N_String_Literal
1851 Rewrite
(E
, New_Copy
(Val
));
1856 -- Another optimization: if the nominal subtype is unconstrained and
1857 -- the expression is a function call that returns and unconstrained
1858 -- type, rewrite the declararation as a renaming of the result of the
1859 -- call. The exceptions below are cases where the copy is expected,
1860 -- either by the back end (Aliased case) or by the semantics, as for
1861 -- initializing controlled types or copying tags for classwide types.
1864 and then Nkind
(E
) = N_Explicit_Dereference
1865 and then Nkind
(Original_Node
(E
)) = N_Function_Call
1866 and then not Is_Library_Level_Entity
(Id
)
1867 and then not Is_Constrained
(T
)
1868 and then not Is_Aliased
(Id
)
1869 and then not Is_Class_Wide_Type
(T
)
1870 and then not Is_Controlled
(T
)
1871 and then not Has_Controlled_Component
(Base_Type
(T
))
1872 and then Expander_Active
1875 Make_Object_Renaming_Declaration
(Loc
,
1876 Defining_Identifier
=> Id
,
1877 Subtype_Mark
=> New_Occurrence_Of
1878 (Base_Type
(Etype
(Id
)), Loc
),
1881 Set_Renamed_Object
(Id
, E
);
1884 if Present
(Prev_Entity
)
1885 and then Is_Frozen
(Prev_Entity
)
1886 and then not Error_Posted
(Id
)
1888 Error_Msg_N
("full constant declaration appears too late", N
);
1891 Check_Eliminated
(Id
);
1892 end Analyze_Object_Declaration
;
1894 ---------------------------
1895 -- Analyze_Others_Choice --
1896 ---------------------------
1898 -- Nothing to do for the others choice node itself, the semantic analysis
1899 -- of the others choice will occur as part of the processing of the parent
1901 procedure Analyze_Others_Choice
(N
: Node_Id
) is
1902 pragma Warnings
(Off
, N
);
1906 end Analyze_Others_Choice
;
1908 -------------------------------------------
1909 -- Analyze_Private_Extension_Declaration --
1910 -------------------------------------------
1912 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
1913 T
: Entity_Id
:= Defining_Identifier
(N
);
1914 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
1915 Parent_Type
: Entity_Id
;
1916 Parent_Base
: Entity_Id
;
1919 Generate_Definition
(T
);
1922 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
1923 Parent_Base
:= Base_Type
(Parent_Type
);
1925 if Parent_Type
= Any_Type
1926 or else Etype
(Parent_Type
) = Any_Type
1928 Set_Ekind
(T
, Ekind
(Parent_Type
));
1929 Set_Etype
(T
, Any_Type
);
1932 elsif not Is_Tagged_Type
(Parent_Type
) then
1934 ("parent of type extension must be a tagged type ", Indic
);
1937 elsif Ekind
(Parent_Type
) = E_Void
1938 or else Ekind
(Parent_Type
) = E_Incomplete_Type
1940 Error_Msg_N
("premature derivation of incomplete type", Indic
);
1944 -- Perhaps the parent type should be changed to the class-wide type's
1945 -- specific type in this case to prevent cascading errors ???
1947 if Is_Class_Wide_Type
(Parent_Type
) then
1949 ("parent of type extension must not be a class-wide type", Indic
);
1953 if (not Is_Package
(Current_Scope
)
1954 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
1955 or else In_Private_Part
(Current_Scope
)
1958 Error_Msg_N
("invalid context for private extension", N
);
1961 -- Set common attributes
1963 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
1964 Set_Scope
(T
, Current_Scope
);
1965 Set_Ekind
(T
, E_Record_Type_With_Private
);
1966 Init_Size_Align
(T
);
1968 Set_Etype
(T
, Parent_Base
);
1969 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
1971 Set_Convention
(T
, Convention
(Parent_Type
));
1972 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
1973 Set_Is_First_Subtype
(T
);
1974 Make_Class_Wide_Type
(T
);
1976 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
1977 end Analyze_Private_Extension_Declaration
;
1979 ---------------------------------
1980 -- Analyze_Subtype_Declaration --
1981 ---------------------------------
1983 procedure Analyze_Subtype_Declaration
(N
: Node_Id
) is
1984 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1986 R_Checks
: Check_Result
;
1989 Generate_Definition
(Id
);
1990 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1991 Init_Size_Align
(Id
);
1993 -- The following guard condition on Enter_Name is to handle cases
1994 -- where the defining identifier has already been entered into the
1995 -- scope but the declaration as a whole needs to be analyzed.
1997 -- This case in particular happens for derived enumeration types.
1998 -- The derived enumeration type is processed as an inserted enumeration
1999 -- type declaration followed by a rewritten subtype declaration. The
2000 -- defining identifier, however, is entered into the name scope very
2001 -- early in the processing of the original type declaration and
2002 -- therefore needs to be avoided here, when the created subtype
2003 -- declaration is analyzed. (See Build_Derived_Types)
2005 -- This also happens when the full view of a private type is a
2006 -- derived type with constraints. In this case the entity has been
2007 -- introduced in the private declaration.
2009 if Present
(Etype
(Id
))
2010 and then (Is_Private_Type
(Etype
(Id
))
2011 or else Is_Task_Type
(Etype
(Id
))
2012 or else Is_Rewrite_Substitution
(N
))
2020 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2022 -- Inherit common attributes
2024 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2025 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2026 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2028 -- In the case where there is no constraint given in the subtype
2029 -- indication, Process_Subtype just returns the Subtype_Mark,
2030 -- so its semantic attributes must be established here.
2032 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2033 Set_Etype
(Id
, Base_Type
(T
));
2037 Set_Ekind
(Id
, E_Array_Subtype
);
2039 -- Shouldn't we call Copy_Array_Subtype_Attributes here???
2041 Set_First_Index
(Id
, First_Index
(T
));
2042 Set_Is_Aliased
(Id
, Is_Aliased
(T
));
2043 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2045 when Decimal_Fixed_Point_Kind
=>
2046 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2047 Set_Digits_Value
(Id
, Digits_Value
(T
));
2048 Set_Delta_Value
(Id
, Delta_Value
(T
));
2049 Set_Scale_Value
(Id
, Scale_Value
(T
));
2050 Set_Small_Value
(Id
, Small_Value
(T
));
2051 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2052 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2053 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2054 Set_RM_Size
(Id
, RM_Size
(T
));
2056 when Enumeration_Kind
=>
2057 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2058 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2059 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2060 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2061 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2062 Set_RM_Size
(Id
, RM_Size
(T
));
2064 when Ordinary_Fixed_Point_Kind
=>
2065 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2066 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2067 Set_Small_Value
(Id
, Small_Value
(T
));
2068 Set_Delta_Value
(Id
, Delta_Value
(T
));
2069 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2070 Set_RM_Size
(Id
, RM_Size
(T
));
2073 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2074 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2075 Set_Digits_Value
(Id
, Digits_Value
(T
));
2076 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2078 when Signed_Integer_Kind
=>
2079 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2080 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2081 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2082 Set_RM_Size
(Id
, RM_Size
(T
));
2084 when Modular_Integer_Kind
=>
2085 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2086 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2087 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2088 Set_RM_Size
(Id
, RM_Size
(T
));
2090 when Class_Wide_Kind
=>
2091 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2092 Set_First_Entity
(Id
, First_Entity
(T
));
2093 Set_Last_Entity
(Id
, Last_Entity
(T
));
2094 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2095 Set_Cloned_Subtype
(Id
, T
);
2096 Set_Is_Tagged_Type
(Id
, True);
2097 Set_Has_Unknown_Discriminants
2100 if Ekind
(T
) = E_Class_Wide_Subtype
then
2101 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
2104 when E_Record_Type | E_Record_Subtype
=>
2105 Set_Ekind
(Id
, E_Record_Subtype
);
2107 if Ekind
(T
) = E_Record_Subtype
2108 and then Present
(Cloned_Subtype
(T
))
2110 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
2112 Set_Cloned_Subtype
(Id
, T
);
2115 Set_First_Entity
(Id
, First_Entity
(T
));
2116 Set_Last_Entity
(Id
, Last_Entity
(T
));
2117 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2118 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2119 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2120 Set_Has_Unknown_Discriminants
2121 (Id
, Has_Unknown_Discriminants
(T
));
2123 if Has_Discriminants
(T
) then
2124 Set_Discriminant_Constraint
2125 (Id
, Discriminant_Constraint
(T
));
2126 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2128 elsif Has_Unknown_Discriminants
(Id
) then
2129 Set_Discriminant_Constraint
(Id
, No_Elist
);
2132 if Is_Tagged_Type
(T
) then
2133 Set_Is_Tagged_Type
(Id
);
2134 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2135 Set_Primitive_Operations
2136 (Id
, Primitive_Operations
(T
));
2137 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2140 when Private_Kind
=>
2141 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2142 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2143 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2144 Set_First_Entity
(Id
, First_Entity
(T
));
2145 Set_Last_Entity
(Id
, Last_Entity
(T
));
2146 Set_Private_Dependents
(Id
, New_Elmt_List
);
2147 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2148 Set_Has_Unknown_Discriminants
2149 (Id
, Has_Unknown_Discriminants
(T
));
2151 if Is_Tagged_Type
(T
) then
2152 Set_Is_Tagged_Type
(Id
);
2153 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2154 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2157 -- In general the attributes of the subtype of a private
2158 -- type are the attributes of the partial view of parent.
2159 -- However, the full view may be a discriminated type,
2160 -- and the subtype must share the discriminant constraint
2161 -- to generate correct calls to initialization procedures.
2163 if Has_Discriminants
(T
) then
2164 Set_Discriminant_Constraint
2165 (Id
, Discriminant_Constraint
(T
));
2166 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2168 elsif Present
(Full_View
(T
))
2169 and then Has_Discriminants
(Full_View
(T
))
2171 Set_Discriminant_Constraint
2172 (Id
, Discriminant_Constraint
(Full_View
(T
)));
2173 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2175 -- This would seem semantically correct, but apparently
2176 -- confuses the back-end (4412-009). To be explained ???
2178 -- Set_Has_Discriminants (Id);
2181 Prepare_Private_Subtype_Completion
(Id
, N
);
2184 Set_Ekind
(Id
, E_Access_Subtype
);
2185 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2186 Set_Is_Access_Constant
2187 (Id
, Is_Access_Constant
(T
));
2188 Set_Directly_Designated_Type
2189 (Id
, Designated_Type
(T
));
2191 -- A Pure library_item must not contain the declaration of a
2192 -- named access type, except within a subprogram, generic
2193 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
2195 if Comes_From_Source
(Id
)
2196 and then In_Pure_Unit
2197 and then not In_Subprogram_Task_Protected_Unit
2200 ("named access types not allowed in pure unit", N
);
2203 when Concurrent_Kind
=>
2204 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2205 Set_Corresponding_Record_Type
(Id
,
2206 Corresponding_Record_Type
(T
));
2207 Set_First_Entity
(Id
, First_Entity
(T
));
2208 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
2209 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2210 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2211 Set_Last_Entity
(Id
, Last_Entity
(T
));
2213 if Has_Discriminants
(T
) then
2214 Set_Discriminant_Constraint
(Id
,
2215 Discriminant_Constraint
(T
));
2216 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2219 -- If the subtype name denotes an incomplete type
2220 -- an error was already reported by Process_Subtype.
2222 when E_Incomplete_Type
=>
2223 Set_Etype
(Id
, Any_Type
);
2226 raise Program_Error
;
2230 if Etype
(Id
) = Any_Type
then
2234 -- Some common processing on all types
2236 Set_Size_Info
(Id
, T
);
2237 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
2241 Set_Is_Immediately_Visible
(Id
, True);
2242 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
2244 if Present
(Generic_Parent_Type
(N
))
2247 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
2249 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
2250 /= N_Formal_Private_Type_Definition
)
2252 if Is_Tagged_Type
(Id
) then
2253 if Is_Class_Wide_Type
(Id
) then
2254 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
2256 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
2259 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
2260 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
2264 if Is_Private_Type
(T
)
2265 and then Present
(Full_View
(T
))
2267 Conditional_Delay
(Id
, Full_View
(T
));
2269 -- The subtypes of components or subcomponents of protected types
2270 -- do not need freeze nodes, which would otherwise appear in the
2271 -- wrong scope (before the freeze node for the protected type). The
2272 -- proper subtypes are those of the subcomponents of the corresponding
2275 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
2276 and then Present
(Scope
(Scope
(Id
))) -- error defense!
2277 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
2279 Conditional_Delay
(Id
, T
);
2282 -- Check that constraint_error is raised for a scalar subtype
2283 -- indication when the lower or upper bound of a non-null range
2284 -- lies outside the range of the type mark.
2286 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
2287 if Is_Scalar_Type
(Etype
(Id
))
2288 and then Scalar_Range
(Id
) /=
2289 Scalar_Range
(Etype
(Subtype_Mark
2290 (Subtype_Indication
(N
))))
2294 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
2296 elsif Is_Array_Type
(Etype
(Id
))
2297 and then Present
(First_Index
(Id
))
2299 -- This really should be a subprogram that finds the indications
2302 if ((Nkind
(First_Index
(Id
)) = N_Identifier
2303 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
2304 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
2306 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
2309 Target_Typ
: Entity_Id
:=
2312 (Etype
(Subtype_Mark
(Subtype_Indication
(N
)))));
2316 (Scalar_Range
(Etype
(First_Index
(Id
))),
2318 Etype
(First_Index
(Id
)),
2319 Defining_Identifier
(N
));
2325 Sloc
(Defining_Identifier
(N
)));
2331 Check_Eliminated
(Id
);
2332 end Analyze_Subtype_Declaration
;
2334 --------------------------------
2335 -- Analyze_Subtype_Indication --
2336 --------------------------------
2338 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
2339 T
: constant Entity_Id
:= Subtype_Mark
(N
);
2340 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
2347 Set_Etype
(N
, Etype
(R
));
2349 Set_Error_Posted
(R
);
2350 Set_Error_Posted
(T
);
2352 end Analyze_Subtype_Indication
;
2354 ------------------------------
2355 -- Analyze_Type_Declaration --
2356 ------------------------------
2358 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
2359 Def
: constant Node_Id
:= Type_Definition
(N
);
2360 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2365 Prev
:= Find_Type_Name
(N
);
2367 if Ekind
(Prev
) = E_Incomplete_Type
then
2368 T
:= Full_View
(Prev
);
2373 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2375 -- We set the flag Is_First_Subtype here. It is needed to set the
2376 -- corresponding flag for the Implicit class-wide-type created
2377 -- during tagged types processing.
2379 Set_Is_First_Subtype
(T
, True);
2381 -- Only composite types other than array types are allowed to have
2386 -- For derived types, the rule will be checked once we've figured
2387 -- out the parent type.
2389 when N_Derived_Type_Definition
=>
2392 -- For record types, discriminants are allowed.
2394 when N_Record_Definition
=>
2398 if Present
(Discriminant_Specifications
(N
)) then
2400 ("elementary or array type cannot have discriminants",
2402 (First
(Discriminant_Specifications
(N
))));
2406 -- Elaborate the type definition according to kind, and generate
2407 -- susbsidiary (implicit) subtypes where needed. We skip this if
2408 -- it was already done (this happens during the reanalysis that
2409 -- follows a call to the high level optimizer).
2411 if not Analyzed
(T
) then
2416 when N_Access_To_Subprogram_Definition
=>
2417 Access_Subprogram_Declaration
(T
, Def
);
2419 -- If this is a remote access to subprogram, we must create
2420 -- the equivalent fat pointer type, and related subprograms.
2422 if Is_Remote_Types
(Current_Scope
)
2423 or else Is_Remote_Call_Interface
(Current_Scope
)
2425 Validate_Remote_Access_To_Subprogram_Type
(N
);
2426 Process_Remote_AST_Declaration
(N
);
2429 -- Validate categorization rule against access type declaration
2430 -- usually a violation in Pure unit, Shared_Passive unit.
2432 Validate_Access_Type_Declaration
(T
, N
);
2434 when N_Access_To_Object_Definition
=>
2435 Access_Type_Declaration
(T
, Def
);
2437 -- Validate categorization rule against access type declaration
2438 -- usually a violation in Pure unit, Shared_Passive unit.
2440 Validate_Access_Type_Declaration
(T
, N
);
2442 -- If we are in a Remote_Call_Interface package and define
2443 -- a RACW, Read and Write attribute must be added.
2445 if (Is_Remote_Call_Interface
(Current_Scope
)
2446 or else Is_Remote_Types
(Current_Scope
))
2447 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
2449 Add_RACW_Features
(Def_Id
);
2452 when N_Array_Type_Definition
=>
2453 Array_Type_Declaration
(T
, Def
);
2455 when N_Derived_Type_Definition
=>
2456 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
2458 when N_Enumeration_Type_Definition
=>
2459 Enumeration_Type_Declaration
(T
, Def
);
2461 when N_Floating_Point_Definition
=>
2462 Floating_Point_Type_Declaration
(T
, Def
);
2464 when N_Decimal_Fixed_Point_Definition
=>
2465 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
2467 when N_Ordinary_Fixed_Point_Definition
=>
2468 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
2470 when N_Signed_Integer_Type_Definition
=>
2471 Signed_Integer_Type_Declaration
(T
, Def
);
2473 when N_Modular_Type_Definition
=>
2474 Modular_Type_Declaration
(T
, Def
);
2476 when N_Record_Definition
=>
2477 Record_Type_Declaration
(T
, N
);
2480 raise Program_Error
;
2485 if Etype
(T
) = Any_Type
then
2489 -- Some common processing for all types
2491 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
2493 -- Both the declared entity, and its anonymous base type if one
2494 -- was created, need freeze nodes allocated.
2497 B
: constant Entity_Id
:= Base_Type
(T
);
2500 -- In the case where the base type is different from the first
2501 -- subtype, we pre-allocate a freeze node, and set the proper
2502 -- link to the first subtype. Freeze_Entity will use this
2503 -- preallocated freeze node when it freezes the entity.
2506 Ensure_Freeze_Node
(B
);
2507 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
2510 if not From_With_Type
(T
) then
2511 Set_Has_Delayed_Freeze
(T
);
2515 -- Case of T is the full declaration of some private type which has
2516 -- been swapped in Defining_Identifier (N).
2518 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
2519 Process_Full_View
(N
, T
, Def_Id
);
2521 -- Record the reference. The form of this is a little strange,
2522 -- since the full declaration has been swapped in. So the first
2523 -- parameter here represents the entity to which a reference is
2524 -- made which is the "real" entity, i.e. the one swapped in,
2525 -- and the second parameter provides the reference location.
2527 Generate_Reference
(T
, T
, 'c');
2528 Set_Completion_Referenced
(Def_Id
);
2530 -- For completion of incomplete type, process incomplete dependents
2531 -- and always mark the full type as referenced (it is the incomplete
2532 -- type that we get for any real reference).
2534 elsif Ekind
(Prev
) = E_Incomplete_Type
then
2535 Process_Incomplete_Dependents
(N
, T
, Prev
);
2536 Generate_Reference
(Prev
, Def_Id
, 'c');
2537 Set_Completion_Referenced
(Def_Id
);
2539 -- If not private type or incomplete type completion, this is a real
2540 -- definition of a new entity, so record it.
2543 Generate_Definition
(Def_Id
);
2546 Check_Eliminated
(Def_Id
);
2547 end Analyze_Type_Declaration
;
2549 --------------------------
2550 -- Analyze_Variant_Part --
2551 --------------------------
2553 procedure Analyze_Variant_Part
(N
: Node_Id
) is
2555 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
2556 -- Error routine invoked by the generic instantiation below when
2557 -- the variant part has a non static choice.
2559 procedure Process_Declarations
(Variant
: Node_Id
);
2560 -- Analyzes all the declarations associated with a Variant.
2561 -- Needed by the generic instantiation below.
2563 package Variant_Choices_Processing
is new
2564 Generic_Choices_Processing
2565 (Get_Alternatives
=> Variants
,
2566 Get_Choices
=> Discrete_Choices
,
2567 Process_Empty_Choice
=> No_OP
,
2568 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
2569 Process_Associated_Node
=> Process_Declarations
);
2570 use Variant_Choices_Processing
;
2571 -- Instantiation of the generic choice processing package.
2573 -----------------------------
2574 -- Non_Static_Choice_Error --
2575 -----------------------------
2577 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
2579 Error_Msg_N
("choice given in variant part is not static", Choice
);
2580 end Non_Static_Choice_Error
;
2582 --------------------------
2583 -- Process_Declarations --
2584 --------------------------
2586 procedure Process_Declarations
(Variant
: Node_Id
) is
2588 if not Null_Present
(Component_List
(Variant
)) then
2589 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
2591 if Present
(Variant_Part
(Component_List
(Variant
))) then
2592 Analyze
(Variant_Part
(Component_List
(Variant
)));
2595 end Process_Declarations
;
2597 -- Variables local to Analyze_Case_Statement.
2599 Others_Choice
: Node_Id
;
2601 Discr_Name
: Node_Id
;
2602 Discr_Type
: Entity_Id
;
2604 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
2606 Dont_Care
: Boolean;
2607 Others_Present
: Boolean := False;
2609 -- Start of processing for Analyze_Variant_Part
2612 Discr_Name
:= Name
(N
);
2613 Analyze
(Discr_Name
);
2615 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
2616 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
2619 Discr_Type
:= Etype
(Entity
(Discr_Name
));
2621 if not Is_Discrete_Type
(Discr_Type
) then
2623 ("discriminant in a variant part must be of a discrete type",
2628 -- Call the instantiated Analyze_Choices which does the rest of the work
2631 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
2633 if Others_Present
then
2634 -- Fill in Others_Discrete_Choices field of the OTHERS choice
2636 Others_Choice
:= First
(Discrete_Choices
(Last
(Variants
(N
))));
2637 Expand_Others_Choice
2638 (Case_Table
(1 .. Last_Choice
), Others_Choice
, Discr_Type
);
2641 end Analyze_Variant_Part
;
2643 ----------------------------
2644 -- Array_Type_Declaration --
2645 ----------------------------
2647 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
2648 Component_Def
: constant Node_Id
:= Subtype_Indication
(Def
);
2649 Element_Type
: Entity_Id
;
2650 Implicit_Base
: Entity_Id
;
2652 Related_Id
: Entity_Id
:= Empty
;
2654 P
: constant Node_Id
:= Parent
(Def
);
2658 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2660 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
2662 -- Find proper names for the implicit types which may be public.
2663 -- in case of anonymous arrays we use the name of the first object
2664 -- of that type as prefix.
2667 Related_Id
:= Defining_Identifier
(P
);
2673 Index
:= First
(Subtype_Marks
(Def
));
2678 while Present
(Index
) loop
2680 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
2682 Nb_Index
:= Nb_Index
+ 1;
2685 Element_Type
:= Process_Subtype
(Component_Def
, P
, Related_Id
, 'C');
2687 -- Constrained array case
2690 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
2693 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2695 -- Establish Implicit_Base as unconstrained base type
2697 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
2699 Init_Size_Align
(Implicit_Base
);
2700 Set_Etype
(Implicit_Base
, Implicit_Base
);
2701 Set_Scope
(Implicit_Base
, Current_Scope
);
2702 Set_Has_Delayed_Freeze
(Implicit_Base
);
2704 -- The constrained array type is a subtype of the unconstrained one
2706 Set_Ekind
(T
, E_Array_Subtype
);
2707 Init_Size_Align
(T
);
2708 Set_Etype
(T
, Implicit_Base
);
2709 Set_Scope
(T
, Current_Scope
);
2710 Set_Is_Constrained
(T
, True);
2711 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
2712 Set_Has_Delayed_Freeze
(T
);
2714 -- Complete setup of implicit base type
2716 Set_First_Index
(Implicit_Base
, First_Index
(T
));
2717 Set_Component_Type
(Implicit_Base
, Element_Type
);
2718 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
2719 Set_Component_Size
(Implicit_Base
, Uint_0
);
2720 Set_Has_Controlled_Component
2721 (Implicit_Base
, Has_Controlled_Component
2724 Is_Controlled
(Element_Type
));
2725 Set_Finalize_Storage_Only
2726 (Implicit_Base
, Finalize_Storage_Only
2729 -- Unconstrained array case
2732 Set_Ekind
(T
, E_Array_Type
);
2733 Init_Size_Align
(T
);
2735 Set_Scope
(T
, Current_Scope
);
2736 Set_Component_Size
(T
, Uint_0
);
2737 Set_Is_Constrained
(T
, False);
2738 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
2739 Set_Has_Delayed_Freeze
(T
, True);
2740 Set_Has_Task
(T
, Has_Task
(Element_Type
));
2741 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
2744 Is_Controlled
(Element_Type
));
2745 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
2749 Set_Component_Type
(Base_Type
(T
), Element_Type
);
2751 if Aliased_Present
(Def
) then
2752 Set_Has_Aliased_Components
(Etype
(T
));
2755 Priv
:= Private_Component
(Element_Type
);
2757 if Present
(Priv
) then
2759 -- Check for circular definitions
2761 if Priv
= Any_Type
then
2762 Set_Component_Type
(Etype
(T
), Any_Type
);
2764 -- There is a gap in the visiblity of operations on the composite
2765 -- type only if the component type is defined in a different scope.
2767 elsif Scope
(Priv
) = Current_Scope
then
2770 elsif Is_Limited_Type
(Priv
) then
2771 Set_Is_Limited_Composite
(Etype
(T
));
2772 Set_Is_Limited_Composite
(T
);
2774 Set_Is_Private_Composite
(Etype
(T
));
2775 Set_Is_Private_Composite
(T
);
2779 -- Create a concatenation operator for the new type. Internal
2780 -- array types created for packed entities do not need such, they
2781 -- are compatible with the user-defined type.
2783 if Number_Dimensions
(T
) = 1
2784 and then not Is_Packed_Array_Type
(T
)
2786 New_Binary_Operator
(Name_Op_Concat
, T
);
2789 -- In the case of an unconstrained array the parser has already
2790 -- verified that all the indices are unconstrained but we still
2791 -- need to make sure that the element type is constrained.
2793 if Is_Indefinite_Subtype
(Element_Type
) then
2795 ("unconstrained element type in array declaration ",
2798 elsif Is_Abstract
(Element_Type
) then
2799 Error_Msg_N
("The type of a component cannot be abstract ",
2803 end Array_Type_Declaration
;
2805 -------------------------------
2806 -- Build_Derived_Access_Type --
2807 -------------------------------
2809 procedure Build_Derived_Access_Type
2811 Parent_Type
: Entity_Id
;
2812 Derived_Type
: Entity_Id
)
2814 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
2816 Desig_Type
: Entity_Id
;
2818 Discr_Con_Elist
: Elist_Id
;
2819 Discr_Con_El
: Elmt_Id
;
2824 -- Set the designated type so it is available in case this is
2825 -- an access to a self-referential type, e.g. a standard list
2826 -- type with a next pointer. Will be reset after subtype is built.
2828 Set_Directly_Designated_Type
(Derived_Type
,
2829 Designated_Type
(Parent_Type
));
2831 Subt
:= Process_Subtype
(S
, N
);
2833 if Nkind
(S
) /= N_Subtype_Indication
2834 and then Subt
/= Base_Type
(Subt
)
2836 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
2839 if Ekind
(Derived_Type
) = E_Access_Subtype
then
2841 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
2842 Ibase
: constant Entity_Id
:=
2843 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
2844 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
2845 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
2848 Copy_Node
(Pbase
, Ibase
);
2850 Set_Chars
(Ibase
, Svg_Chars
);
2851 Set_Next_Entity
(Ibase
, Svg_Next_E
);
2852 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
2853 Set_Scope
(Ibase
, Scope
(Derived_Type
));
2854 Set_Freeze_Node
(Ibase
, Empty
);
2855 Set_Is_Frozen
(Ibase
, False);
2856 Set_Comes_From_Source
(Ibase
, False);
2857 Set_Is_First_Subtype
(Ibase
, False);
2859 Set_Etype
(Ibase
, Pbase
);
2860 Set_Etype
(Derived_Type
, Ibase
);
2864 Set_Directly_Designated_Type
2865 (Derived_Type
, Designated_Type
(Subt
));
2867 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
2868 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
2869 Set_Size_Info
(Derived_Type
, Parent_Type
);
2870 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
2871 Set_Depends_On_Private
(Derived_Type
,
2872 Has_Private_Component
(Derived_Type
));
2873 Conditional_Delay
(Derived_Type
, Subt
);
2875 -- Note: we do not copy the Storage_Size_Variable, since
2876 -- we always go to the root type for this information.
2878 -- Apply range checks to discriminants for derived record case
2879 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
2881 Desig_Type
:= Designated_Type
(Derived_Type
);
2882 if Is_Composite_Type
(Desig_Type
)
2883 and then (not Is_Array_Type
(Desig_Type
))
2884 and then Has_Discriminants
(Desig_Type
)
2885 and then Base_Type
(Desig_Type
) /= Desig_Type
2887 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
2888 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
2890 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
2891 while Present
(Discr_Con_El
) loop
2892 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
2893 Next_Elmt
(Discr_Con_El
);
2894 Next_Discriminant
(Discr
);
2897 end Build_Derived_Access_Type
;
2899 ------------------------------
2900 -- Build_Derived_Array_Type --
2901 ------------------------------
2903 procedure Build_Derived_Array_Type
2905 Parent_Type
: Entity_Id
;
2906 Derived_Type
: Entity_Id
)
2908 Loc
: constant Source_Ptr
:= Sloc
(N
);
2909 Tdef
: constant Node_Id
:= Type_Definition
(N
);
2910 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
2911 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
2912 Implicit_Base
: Entity_Id
;
2913 New_Indic
: Node_Id
;
2915 procedure Make_Implicit_Base
;
2916 -- If the parent subtype is constrained, the derived type is a
2917 -- subtype of an implicit base type derived from the parent base.
2919 ------------------------
2920 -- Make_Implicit_Base --
2921 ------------------------
2923 procedure Make_Implicit_Base
is
2926 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
2928 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
2929 Set_Etype
(Implicit_Base
, Parent_Base
);
2931 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
2932 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
2934 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
2935 end Make_Implicit_Base
;
2937 -- Start of processing for Build_Derived_Array_Type
2940 if not Is_Constrained
(Parent_Type
) then
2941 if Nkind
(Indic
) /= N_Subtype_Indication
then
2942 Set_Ekind
(Derived_Type
, E_Array_Type
);
2944 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
2945 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
2947 Set_Has_Delayed_Freeze
(Derived_Type
, True);
2951 Set_Etype
(Derived_Type
, Implicit_Base
);
2954 Make_Subtype_Declaration
(Loc
,
2955 Defining_Identifier
=> Derived_Type
,
2956 Subtype_Indication
=>
2957 Make_Subtype_Indication
(Loc
,
2958 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
2959 Constraint
=> Constraint
(Indic
)));
2961 Rewrite
(N
, New_Indic
);
2966 if Nkind
(Indic
) /= N_Subtype_Indication
then
2969 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
2970 Set_Etype
(Derived_Type
, Implicit_Base
);
2971 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
2974 Error_Msg_N
("illegal constraint on constrained type", Indic
);
2978 -- If the parent type is not a derived type itself, and is
2979 -- declared in a closed scope (e.g., a subprogram), then we
2980 -- need to explicitly introduce the new type's concatenation
2981 -- operator since Derive_Subprograms will not inherit the
2982 -- parent's operator.
2984 if Number_Dimensions
(Parent_Type
) = 1
2985 and then not Is_Limited_Type
(Parent_Type
)
2986 and then not Is_Derived_Type
(Parent_Type
)
2987 and then not Is_Package
(Scope
(Base_Type
(Parent_Type
)))
2989 New_Binary_Operator
(Name_Op_Concat
, Derived_Type
);
2991 end Build_Derived_Array_Type
;
2993 -----------------------------------
2994 -- Build_Derived_Concurrent_Type --
2995 -----------------------------------
2997 procedure Build_Derived_Concurrent_Type
2999 Parent_Type
: Entity_Id
;
3000 Derived_Type
: Entity_Id
)
3002 D_Constraint
: Node_Id
;
3003 Disc_Spec
: Node_Id
;
3004 Old_Disc
: Entity_Id
;
3005 New_Disc
: Entity_Id
;
3007 Constraint_Present
: constant Boolean :=
3008 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3009 = N_Subtype_Indication
;
3012 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
3014 if Is_Task_Type
(Parent_Type
) then
3015 Set_Storage_Size_Variable
(Derived_Type
,
3016 Storage_Size_Variable
(Parent_Type
));
3019 if Present
(Discriminant_Specifications
(N
)) then
3020 New_Scope
(Derived_Type
);
3021 Check_Or_Process_Discriminants
(N
, Derived_Type
);
3024 elsif Constraint_Present
then
3026 -- Build constrained subtype and derive from it
3029 Loc
: constant Source_Ptr
:= Sloc
(N
);
3031 Make_Defining_Identifier
(Loc
,
3032 New_External_Name
(Chars
(Derived_Type
), 'T'));
3037 Make_Subtype_Declaration
(Loc
,
3038 Defining_Identifier
=> Anon
,
3039 Subtype_Indication
=>
3040 New_Copy_Tree
(Subtype_Indication
(Type_Definition
(N
))));
3041 Insert_Before
(N
, Decl
);
3042 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
3043 New_Occurrence_Of
(Anon
, Loc
));
3045 Set_Analyzed
(Derived_Type
, False);
3051 -- All attributes are inherited from parent. In particular,
3052 -- entries and the corresponding record type are the same.
3053 -- Discriminants may be renamed, and must be treated separately.
3055 Set_Has_Discriminants
3056 (Derived_Type
, Has_Discriminants
(Parent_Type
));
3057 Set_Corresponding_Record_Type
3058 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
3060 if Constraint_Present
then
3062 if not Has_Discriminants
(Parent_Type
) then
3063 Error_Msg_N
("untagged parent must have discriminants", N
);
3065 elsif Present
(Discriminant_Specifications
(N
)) then
3067 -- Verify that new discriminants are used to constrain
3070 Old_Disc
:= First_Discriminant
(Parent_Type
);
3071 New_Disc
:= First_Discriminant
(Derived_Type
);
3072 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
3076 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
3078 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
3080 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
3083 Analyze
(Discriminant_Type
(Disc_Spec
));
3085 if not Subtypes_Statically_Compatible
(
3086 Etype
(Discriminant_Type
(Disc_Spec
)),
3090 ("not statically compatible with parent discriminant",
3091 Discriminant_Type
(Disc_Spec
));
3095 if Nkind
(D_Constraint
) = N_Identifier
3096 and then Chars
(D_Constraint
) /=
3097 Chars
(Defining_Identifier
(Disc_Spec
))
3099 Error_Msg_N
("new discriminants must constrain old ones",
3102 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
3105 Next_Discriminant
(Old_Disc
);
3106 Next_Discriminant
(New_Disc
);
3110 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
3111 Error_Msg_N
("discriminant mismatch in derivation", N
);
3116 elsif Present
(Discriminant_Specifications
(N
)) then
3118 ("missing discriminant constraint in untagged derivation",
3122 if Present
(Discriminant_Specifications
(N
)) then
3124 Old_Disc
:= First_Discriminant
(Parent_Type
);
3126 while Present
(Old_Disc
) loop
3128 if No
(Next_Entity
(Old_Disc
))
3129 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
3131 Set_Next_Entity
(Last_Entity
(Derived_Type
),
3132 Next_Entity
(Old_Disc
));
3136 Next_Discriminant
(Old_Disc
);
3140 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
3141 if Has_Discriminants
(Parent_Type
) then
3142 Set_Discriminant_Constraint
(
3143 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
3147 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
3149 Set_Has_Completion
(Derived_Type
);
3150 end Build_Derived_Concurrent_Type
;
3152 ------------------------------------
3153 -- Build_Derived_Enumeration_Type --
3154 ------------------------------------
3156 procedure Build_Derived_Enumeration_Type
3158 Parent_Type
: Entity_Id
;
3159 Derived_Type
: Entity_Id
)
3161 Loc
: constant Source_Ptr
:= Sloc
(N
);
3162 Def
: constant Node_Id
:= Type_Definition
(N
);
3163 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
3164 Implicit_Base
: Entity_Id
;
3165 Literal
: Entity_Id
;
3166 New_Lit
: Entity_Id
;
3167 Literals_List
: List_Id
;
3168 Type_Decl
: Node_Id
;
3170 Rang_Expr
: Node_Id
;
3173 -- Since types Standard.Character and Standard.Wide_Character do
3174 -- not have explicit literals lists we need to process types derived
3175 -- from them specially. This is handled by Derived_Standard_Character.
3176 -- If the parent type is a generic type, there are no literals either,
3177 -- and we construct the same skeletal representation as for the generic
3180 if Root_Type
(Parent_Type
) = Standard_Character
3181 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
3183 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
3185 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
3192 Make_Attribute_Reference
(Loc
,
3193 Attribute_Name
=> Name_First
,
3194 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
3195 Set_Etype
(Lo
, Derived_Type
);
3198 Make_Attribute_Reference
(Loc
,
3199 Attribute_Name
=> Name_Last
,
3200 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
3201 Set_Etype
(Hi
, Derived_Type
);
3203 Set_Scalar_Range
(Derived_Type
,
3210 -- If a constraint is present, analyze the bounds to catch
3211 -- premature usage of the derived literals.
3213 if Nkind
(Indic
) = N_Subtype_Indication
3214 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
3216 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
3217 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
3220 -- Introduce an implicit base type for the derived type even
3221 -- if there is no constraint attached to it, since this seems
3222 -- closer to the Ada semantics. Build a full type declaration
3223 -- tree for the derived type using the implicit base type as
3224 -- the defining identifier. The build a subtype declaration
3225 -- tree which applies the constraint (if any) have it replace
3226 -- the derived type declaration.
3228 Literal
:= First_Literal
(Parent_Type
);
3229 Literals_List
:= New_List
;
3231 while Present
(Literal
)
3232 and then Ekind
(Literal
) = E_Enumeration_Literal
3234 -- Literals of the derived type have the same representation as
3235 -- those of the parent type, but this representation can be
3236 -- overridden by an explicit representation clause. Indicate
3237 -- that there is no explicit representation given yet. These
3238 -- derived literals are implicit operations of the new type,
3239 -- and can be overriden by explicit ones.
3241 if Nkind
(Literal
) = N_Defining_Character_Literal
then
3243 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
3245 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
3248 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
3249 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
3250 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
3251 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
3252 Set_Alias
(New_Lit
, Literal
);
3253 Set_Is_Known_Valid
(New_Lit
, True);
3255 Append
(New_Lit
, Literals_List
);
3256 Next_Literal
(Literal
);
3260 Make_Defining_Identifier
(Sloc
(Derived_Type
),
3261 New_External_Name
(Chars
(Derived_Type
), 'B'));
3263 -- Indicate the proper nature of the derived type. This must
3264 -- be done before analysis of the literals, to recognize cases
3265 -- when a literal may be hidden by a previous explicit function
3266 -- definition (cf. c83031a).
3268 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
3269 Set_Etype
(Derived_Type
, Implicit_Base
);
3272 Make_Full_Type_Declaration
(Loc
,
3273 Defining_Identifier
=> Implicit_Base
,
3274 Discriminant_Specifications
=> No_List
,
3276 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
3278 Mark_Rewrite_Insertion
(Type_Decl
);
3279 Insert_Before
(N
, Type_Decl
);
3280 Analyze
(Type_Decl
);
3282 -- After the implicit base is analyzed its Etype needs to be
3283 -- changed to reflect the fact that it is derived from the
3284 -- parent type which was ignored during analysis. We also set
3285 -- the size at this point.
3287 Set_Etype
(Implicit_Base
, Parent_Type
);
3289 Set_Size_Info
(Implicit_Base
, Parent_Type
);
3290 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
3291 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
3293 Set_Has_Non_Standard_Rep
3294 (Implicit_Base
, Has_Non_Standard_Rep
3296 Set_Has_Delayed_Freeze
(Implicit_Base
);
3298 -- Process the subtype indication including a validation check
3299 -- on the constraint, if any. If a constraint is given, its bounds
3300 -- must be implicitly converted to the new type.
3302 if Nkind
(Indic
) = N_Subtype_Indication
then
3305 R
: constant Node_Id
:=
3306 Range_Expression
(Constraint
(Indic
));
3309 if Nkind
(R
) = N_Range
then
3310 Hi
:= Build_Scalar_Bound
3311 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
3312 Lo
:= Build_Scalar_Bound
3313 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
3316 -- Constraint is a Range attribute. Replace with the
3317 -- explicit mention of the bounds of the prefix, which
3318 -- must be a subtype.
3320 Analyze
(Prefix
(R
));
3322 Convert_To
(Implicit_Base
,
3323 Make_Attribute_Reference
(Loc
,
3324 Attribute_Name
=> Name_Last
,
3326 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
3329 Convert_To
(Implicit_Base
,
3330 Make_Attribute_Reference
(Loc
,
3331 Attribute_Name
=> Name_First
,
3333 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
3341 (Type_High_Bound
(Parent_Type
),
3342 Parent_Type
, Implicit_Base
);
3345 (Type_Low_Bound
(Parent_Type
),
3346 Parent_Type
, Implicit_Base
);
3354 -- If we constructed a default range for the case where no range
3355 -- was given, then the expressions in the range must not freeze
3356 -- since they do not correspond to expressions in the source.
3358 if Nkind
(Indic
) /= N_Subtype_Indication
then
3359 Set_Must_Not_Freeze
(Lo
);
3360 Set_Must_Not_Freeze
(Hi
);
3361 Set_Must_Not_Freeze
(Rang_Expr
);
3365 Make_Subtype_Declaration
(Loc
,
3366 Defining_Identifier
=> Derived_Type
,
3367 Subtype_Indication
=>
3368 Make_Subtype_Indication
(Loc
,
3369 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
3371 Make_Range_Constraint
(Loc
,
3372 Range_Expression
=> Rang_Expr
))));
3376 -- If pragma Discard_Names applies on the first subtype
3377 -- of the parent type, then it must be applied on this
3380 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
3381 Set_Discard_Names
(Derived_Type
);
3384 -- Apply a range check. Since this range expression doesn't
3385 -- have an Etype, we have to specifically pass the Source_Typ
3386 -- parameter. Is this right???
3388 if Nkind
(Indic
) = N_Subtype_Indication
then
3389 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
3391 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
3395 end Build_Derived_Enumeration_Type
;
3397 --------------------------------
3398 -- Build_Derived_Numeric_Type --
3399 --------------------------------
3401 procedure Build_Derived_Numeric_Type
3403 Parent_Type
: Entity_Id
;
3404 Derived_Type
: Entity_Id
)
3406 Loc
: constant Source_Ptr
:= Sloc
(N
);
3407 Tdef
: constant Node_Id
:= Type_Definition
(N
);
3408 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
3409 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3410 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
3411 N_Subtype_Indication
;
3412 Implicit_Base
: Entity_Id
;
3419 -- Process the subtype indication including a validation check on
3420 -- the constraint if any.
3422 T
:= Process_Subtype
(Indic
, N
);
3424 -- Introduce an implicit base type for the derived type even if
3425 -- there is no constraint attached to it, since this seems closer
3426 -- to the Ada semantics.
3429 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
3431 Set_Etype
(Implicit_Base
, Parent_Base
);
3432 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
3433 Set_Size_Info
(Implicit_Base
, Parent_Base
);
3434 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
3435 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
3436 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
3438 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
3439 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
3442 Set_Has_Delayed_Freeze
(Implicit_Base
);
3444 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
3445 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
3447 Set_Scalar_Range
(Implicit_Base
,
3452 if Has_Infinities
(Parent_Base
) then
3453 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
3456 -- The Derived_Type, which is the entity of the declaration, is
3457 -- a subtype of the implicit base. Its Ekind is a subtype, even
3458 -- in the absence of an explicit constraint.
3460 Set_Etype
(Derived_Type
, Implicit_Base
);
3462 -- If we did not have a constraint, then the Ekind is set from the
3463 -- parent type (otherwise Process_Subtype has set the bounds)
3465 if No_Constraint
then
3466 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
3469 -- If we did not have a range constraint, then set the range
3470 -- from the parent type. Otherwise, the call to Process_Subtype
3471 -- has set the bounds.
3474 or else not Has_Range_Constraint
(Indic
)
3476 Set_Scalar_Range
(Derived_Type
,
3478 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
3479 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
3480 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
3482 if Has_Infinities
(Parent_Type
) then
3483 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
3487 -- Set remaining type-specific fields, depending on numeric type
3489 if Is_Modular_Integer_Type
(Parent_Type
) then
3490 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
3492 Set_Non_Binary_Modulus
3493 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
3495 elsif Is_Floating_Point_Type
(Parent_Type
) then
3497 -- Digits of base type is always copied from the digits value of
3498 -- the parent base type, but the digits of the derived type will
3499 -- already have been set if there was a constraint present.
3501 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
3502 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
3504 if No_Constraint
then
3505 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
3508 elsif Is_Fixed_Point_Type
(Parent_Type
) then
3510 -- Small of base type and derived type are always copied from
3511 -- the parent base type, since smalls never change. The delta
3512 -- of the base type is also copied from the parent base type.
3513 -- However the delta of the derived type will have been set
3514 -- already if a constraint was present.
3516 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
3517 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
3518 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
3520 if No_Constraint
then
3521 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
3524 -- The scale and machine radix in the decimal case are always
3525 -- copied from the parent base type.
3527 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
3528 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
3529 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
3531 Set_Machine_Radix_10
3532 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
3533 Set_Machine_Radix_10
3534 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
3536 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
3538 if No_Constraint
then
3539 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
3542 -- the analysis of the subtype_indication sets the
3543 -- digits value of the derived type.
3550 -- The type of the bounds is that of the parent type, and they
3551 -- must be converted to the derived type.
3553 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
3555 -- The implicit_base should be frozen when the derived type is frozen,
3556 -- but note that it is used in the conversions of the bounds. For
3557 -- fixed types we delay the determination of the bounds until the proper
3558 -- freezing point. For other numeric types this is rejected by GCC, for
3559 -- reasons that are currently unclear (???), so we choose to freeze the
3560 -- implicit base now. In the case of integers and floating point types
3561 -- this is harmless because subsequent representation clauses cannot
3562 -- affect anything, but it is still baffling that we cannot use the
3563 -- same mechanism for all derived numeric types.
3565 if Is_Fixed_Point_Type
(Parent_Type
) then
3566 Conditional_Delay
(Implicit_Base
, Parent_Type
);
3568 Freeze_Before
(N
, Implicit_Base
);
3571 end Build_Derived_Numeric_Type
;
3573 --------------------------------
3574 -- Build_Derived_Private_Type --
3575 --------------------------------
3577 procedure Build_Derived_Private_Type
3579 Parent_Type
: Entity_Id
;
3580 Derived_Type
: Entity_Id
;
3581 Is_Completion
: Boolean;
3582 Derive_Subps
: Boolean := True)
3584 Der_Base
: Entity_Id
;
3586 Full_Decl
: Node_Id
:= Empty
;
3587 Full_Der
: Entity_Id
;
3589 Last_Discr
: Entity_Id
;
3590 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
3591 Swapped
: Boolean := False;
3593 procedure Copy_And_Build
;
3594 -- Copy derived type declaration, replace parent with its full view,
3595 -- and analyze new declaration.
3597 --------------------
3598 -- Copy_And_Build --
3599 --------------------
3601 procedure Copy_And_Build
is
3605 if Ekind
(Parent_Type
) in Record_Kind
3606 or else (Ekind
(Parent_Type
) in Enumeration_Kind
3607 and then Root_Type
(Parent_Type
) /= Standard_Character
3608 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
3609 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
3611 Full_N
:= New_Copy_Tree
(N
);
3612 Insert_After
(N
, Full_N
);
3613 Build_Derived_Type
(
3614 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
3617 Build_Derived_Type
(
3618 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
3622 -- Start of processing for Build_Derived_Private_Type
3625 if Is_Tagged_Type
(Parent_Type
) then
3626 Build_Derived_Record_Type
3627 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
3630 elsif Has_Discriminants
(Parent_Type
) then
3632 if Present
(Full_View
(Parent_Type
)) then
3633 if not Is_Completion
then
3635 -- Copy declaration for subsequent analysis.
3637 Full_Decl
:= New_Copy_Tree
(N
);
3638 Full_Der
:= New_Copy
(Derived_Type
);
3639 Insert_After
(N
, Full_Decl
);
3642 -- If this is a completion, the full view being built is
3643 -- itself private. We build a subtype of the parent with
3644 -- the same constraints as this full view, to convey to the
3645 -- back end the constrained components and the size of this
3646 -- subtype. If the parent is constrained, its full view can
3647 -- serve as the underlying full view of the derived type.
3649 if No
(Discriminant_Specifications
(N
)) then
3651 if Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3652 = N_Subtype_Indication
3654 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
3656 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
3657 Set_Underlying_Full_View
(Derived_Type
,
3658 Full_View
(Parent_Type
));
3662 -- If there are new discriminants, the parent subtype is
3663 -- constrained by them, but it is not clear how to build
3664 -- the underlying_full_view in this case ???
3671 Build_Derived_Record_Type
3672 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
3674 if Present
(Full_View
(Parent_Type
))
3675 and then not Is_Completion
3677 if not In_Open_Scopes
(Par_Scope
)
3678 or else not In_Same_Source_Unit
(N
, Parent_Type
)
3680 -- Swap partial and full views temporarily
3682 Install_Private_Declarations
(Par_Scope
);
3683 Install_Visible_Declarations
(Par_Scope
);
3687 -- Subprograms have been derived on the private view,
3688 -- the completion does not derive them anew.
3690 Build_Derived_Record_Type
3691 (Full_Decl
, Parent_Type
, Full_Der
, False);
3694 Uninstall_Declarations
(Par_Scope
);
3696 if In_Open_Scopes
(Par_Scope
) then
3697 Install_Visible_Declarations
(Par_Scope
);
3701 Der_Base
:= Base_Type
(Derived_Type
);
3702 Set_Full_View
(Derived_Type
, Full_Der
);
3703 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
3705 -- Copy the discriminant list from full view to
3706 -- the partial views (base type and its subtype).
3707 -- Gigi requires that the partial and full views
3708 -- have the same discriminants.
3709 -- ??? Note that since the partial view is pointing
3710 -- to discriminants in the full view, their scope
3711 -- will be that of the full view. This might
3712 -- cause some front end problems and need
3715 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
3716 Set_First_Entity
(Der_Base
, Discr
);
3719 Last_Discr
:= Discr
;
3720 Next_Discriminant
(Discr
);
3721 exit when No
(Discr
);
3724 Set_Last_Entity
(Der_Base
, Last_Discr
);
3726 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
3727 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
3730 -- If this is a completion, the derived type stays private
3731 -- and there is no need to create a further full view, except
3732 -- in the unusual case when the derivation is nested within a
3733 -- child unit, see below.
3738 elsif Present
(Full_View
(Parent_Type
))
3739 and then Has_Discriminants
(Full_View
(Parent_Type
))
3741 if Has_Unknown_Discriminants
(Parent_Type
)
3742 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3743 = N_Subtype_Indication
3746 ("cannot constrain type with unknown discriminants",
3747 Subtype_Indication
(Type_Definition
(N
)));
3751 -- If full view of parent is a record type, Build full view as
3752 -- a derivation from the parent's full view. Partial view remains
3755 if not Is_Private_Type
(Full_View
(Parent_Type
)) then
3756 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
3757 Chars
(Derived_Type
));
3758 Set_Is_Itype
(Full_Der
);
3759 Set_Has_Private_Declaration
(Full_Der
);
3760 Set_Has_Private_Declaration
(Derived_Type
);
3761 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3762 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3763 Set_Full_View
(Derived_Type
, Full_Der
);
3765 Full_P
:= Full_View
(Parent_Type
);
3766 Exchange_Declarations
(Parent_Type
);
3768 Exchange_Declarations
(Full_P
);
3771 Build_Derived_Record_Type
3772 (N
, Full_View
(Parent_Type
), Derived_Type
,
3773 Derive_Subps
=> False);
3776 -- In any case, the primitive operations are inherited from
3777 -- the parent type, not from the internal full view.
3779 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
3781 if Derive_Subps
then
3782 Derive_Subprograms
(Parent_Type
, Derived_Type
);
3786 -- Untagged type, No discriminants on either view
3788 if Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3789 = N_Subtype_Indication
3792 ("illegal constraint on type without discriminants", N
);
3795 if Present
(Discriminant_Specifications
(N
))
3796 and then Present
(Full_View
(Parent_Type
))
3797 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
3800 ("cannot add discriminants to untagged type", N
);
3803 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
3804 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
3805 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
3806 Set_Has_Controlled_Component
3807 (Derived_Type
, Has_Controlled_Component
3810 -- Direct controlled types do not inherit Finalize_Storage_Only flag
3812 if not Is_Controlled
(Parent_Type
) then
3813 Set_Finalize_Storage_Only
3814 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
3817 -- Construct the implicit full view by deriving from full
3818 -- view of the parent type. In order to get proper visiblity,
3819 -- we install the parent scope and its declarations.
3821 -- ??? if the parent is untagged private and its
3822 -- completion is tagged, this mechanism will not
3823 -- work because we cannot derive from the tagged
3824 -- full view unless we have an extension
3826 if Present
(Full_View
(Parent_Type
))
3827 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
3828 and then not Is_Completion
3830 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
3831 Chars
(Derived_Type
));
3832 Set_Is_Itype
(Full_Der
);
3833 Set_Has_Private_Declaration
(Full_Der
);
3834 Set_Has_Private_Declaration
(Derived_Type
);
3835 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3836 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3837 Set_Full_View
(Derived_Type
, Full_Der
);
3839 if not In_Open_Scopes
(Par_Scope
) then
3840 Install_Private_Declarations
(Par_Scope
);
3841 Install_Visible_Declarations
(Par_Scope
);
3843 Uninstall_Declarations
(Par_Scope
);
3845 -- If parent scope is open and in another unit, and
3846 -- parent has a completion, then the derivation is taking
3847 -- place in the visible part of a child unit. In that
3848 -- case retrieve the full view of the parent momentarily.
3850 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
3851 Full_P
:= Full_View
(Parent_Type
);
3852 Exchange_Declarations
(Parent_Type
);
3854 Exchange_Declarations
(Full_P
);
3856 -- Otherwise it is a local derivation.
3862 Set_Scope
(Full_Der
, Current_Scope
);
3863 Set_Is_First_Subtype
(Full_Der
,
3864 Is_First_Subtype
(Derived_Type
));
3865 Set_Has_Size_Clause
(Full_Der
, False);
3866 Set_Has_Alignment_Clause
(Full_Der
, False);
3867 Set_Next_Entity
(Full_Der
, Empty
);
3868 Set_Has_Delayed_Freeze
(Full_Der
);
3869 Set_Is_Frozen
(Full_Der
, False);
3870 Set_Freeze_Node
(Full_Der
, Empty
);
3871 Set_Depends_On_Private
(Full_Der
,
3872 Has_Private_Component
(Full_Der
));
3873 Set_Public_Status
(Full_Der
);
3877 Set_Has_Unknown_Discriminants
(Derived_Type
,
3878 Has_Unknown_Discriminants
(Parent_Type
));
3880 if Is_Private_Type
(Derived_Type
) then
3881 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
3884 if Is_Private_Type
(Parent_Type
)
3885 and then Base_Type
(Parent_Type
) = Parent_Type
3886 and then In_Open_Scopes
(Scope
(Parent_Type
))
3888 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
3890 if Is_Child_Unit
(Scope
(Current_Scope
))
3891 and then Is_Completion
3892 and then In_Private_Part
(Current_Scope
)
3893 and then Scope
(Parent_Type
) /= Current_Scope
3895 -- This is the unusual case where a type completed by a private
3896 -- derivation occurs within a package nested in a child unit,
3897 -- and the parent is declared in an ancestor. In this case, the
3898 -- full view of the parent type will become visible in the body
3899 -- of the enclosing child, and only then will the current type
3900 -- be possibly non-private. We build a underlying full view that
3901 -- will be installed when the enclosing child body is compiled.
3904 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
3908 Make_Defining_Identifier
(Sloc
(Derived_Type
),
3909 Chars
(Derived_Type
));
3910 Set_Is_Itype
(Full_Der
);
3911 Set_Itype
(IR
, Full_Der
);
3912 Insert_After
(N
, IR
);
3914 -- The full view will be used to swap entities on entry/exit
3915 -- to the body, and must appear in the entity list for the
3918 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
3919 Set_Has_Private_Declaration
(Full_Der
);
3920 Set_Has_Private_Declaration
(Derived_Type
);
3921 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3922 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3923 Full_P
:= Full_View
(Parent_Type
);
3924 Exchange_Declarations
(Parent_Type
);
3926 Exchange_Declarations
(Full_P
);
3927 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
3931 end Build_Derived_Private_Type
;
3933 -------------------------------
3934 -- Build_Derived_Record_Type --
3935 -------------------------------
3939 -- Ideally we would like to use the same model of type derivation for
3940 -- tagged and untagged record types. Unfortunately this is not quite
3941 -- possible because the semantics of representation clauses is different
3942 -- for tagged and untagged records under inheritance. Consider the
3945 -- type R (...) is [tagged] record ... end record;
3946 -- type T (...) is new R (...) [with ...];
3948 -- The representation clauses of T can specify a completely different
3949 -- record layout from R's. Hence the same component can be placed in
3950 -- two very different positions in objects of type T and R. If R and T
3951 -- are tagged types, representation clauses for T can only specify the
3952 -- layout of non inherited components, thus components that are common
3953 -- in R and T have the same position in objects of type R and T.
3955 -- This has two implications. The first is that the entire tree for R's
3956 -- declaration needs to be copied for T in the untagged case, so that
3957 -- T can be viewd as a record type of its own with its own derivation
3958 -- clauses. The second implication is the way we handle discriminants.
3959 -- Specifically, in the untagged case we need a way to communicate to Gigi
3960 -- what are the real discriminants in the record, while for the semantics
3961 -- we need to consider those introduced by the user to rename the
3962 -- discriminants in the parent type. This is handled by introducing the
3963 -- notion of girder discriminants. See below for more.
3965 -- Fortunately the way regular components are inherited can be handled in
3966 -- the same way in tagged and untagged types.
3968 -- To complicate things a bit more the private view of a private extension
3969 -- cannot be handled in the same way as the full view (for one thing the
3970 -- semantic rules are somewhat different). We will explain what differs
3973 -- 2. DISCRIMINANTS UNDER INHERITANCE.
3975 -- The semantic rules governing the discriminants of derived types are
3978 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
3979 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
3981 -- If parent type has discriminants, then the discriminants that are
3982 -- declared in the derived type are [3.4 (11)]:
3984 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
3987 -- o Otherwise, each discriminant of the parent type (implicitly
3988 -- declared in the same order with the same specifications). In this
3989 -- case, the discriminants are said to be "inherited", or if unknown in
3990 -- the parent are also unknown in the derived type.
3992 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
3994 -- o The parent subtype shall be constrained;
3996 -- o If the parent type is not a tagged type, then each discriminant of
3997 -- the derived type shall be used in the constraint defining a parent
3998 -- subtype [Implementation note: this ensures that the new discriminant
3999 -- can share storage with an existing discriminant.].
4001 -- For the derived type each discriminant of the parent type is either
4002 -- inherited, constrained to equal some new discriminant of the derived
4003 -- type, or constrained to the value of an expression.
4005 -- When inherited or constrained to equal some new discriminant, the
4006 -- parent discriminant and the discriminant of the derived type are said
4009 -- If a discriminant of the parent type is constrained to a specific value
4010 -- in the derived type definition, then the discriminant is said to be
4011 -- "specified" by that derived type definition.
4013 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
4015 -- We have spoken about girder discriminants in the point 1 (introduction)
4016 -- above. There are two sort of girder discriminants: implicit and
4017 -- explicit. As long as the derived type inherits the same discriminants as
4018 -- the root record type, girder discriminants are the same as regular
4019 -- discriminants, and are said to be implicit. However, if any discriminant
4020 -- in the root type was renamed in the derived type, then the derived
4021 -- type will contain explicit girder discriminants. Explicit girder
4022 -- discriminants are discriminants in addition to the semantically visible
4023 -- discriminants defined for the derived type. Girder discriminants are
4024 -- used by Gigi to figure out what are the physical discriminants in
4025 -- objects of the derived type (see precise definition in einfo.ads).
4026 -- As an example, consider the following:
4028 -- type R (D1, D2, D3 : Int) is record ... end record;
4029 -- type T1 is new R;
4030 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
4031 -- type T3 is new T2;
4032 -- type T4 (Y : Int) is new T3 (Y, 99);
4034 -- The following table summarizes the discriminants and girder
4035 -- discriminants in R and T1 through T4.
4037 -- Type Discrim Girder Discrim Comment
4038 -- R (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in R
4039 -- T1 (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in T1
4040 -- T2 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T2
4041 -- T3 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T3
4042 -- T4 (Y) (D1, D2, D3) Gider discrims are EXPLICIT in T4
4044 -- Field Corresponding_Discriminant (abbreviated CD below) allows to find
4045 -- the corresponding discriminant in the parent type, while
4046 -- Original_Record_Component (abbreviated ORC below), the actual physical
4047 -- component that is renamed. Finally the field Is_Completely_Hidden
4048 -- (abbreaviated ICH below) is set for all explicit girder discriminants
4049 -- (see einfo.ads for more info). For the above example this gives:
4051 -- Discrim CD ORC ICH
4052 -- ^^^^^^^ ^^ ^^^ ^^^
4053 -- D1 in R empty itself no
4054 -- D2 in R empty itself no
4055 -- D3 in R empty itself no
4057 -- D1 in T1 D1 in R itself no
4058 -- D2 in T1 D2 in R itself no
4059 -- D3 in T1 D3 in R itself no
4061 -- X1 in T2 D3 in T1 D3 in T2 no
4062 -- X2 in T2 D1 in T1 D1 in T2 no
4063 -- D1 in T2 empty itself yes
4064 -- D2 in T2 empty itself yes
4065 -- D3 in T2 empty itself yes
4067 -- X1 in T3 X1 in T2 D3 in T3 no
4068 -- X2 in T3 X2 in T2 D1 in T3 no
4069 -- D1 in T3 empty itself yes
4070 -- D2 in T3 empty itself yes
4071 -- D3 in T3 empty itself yes
4073 -- Y in T4 X1 in T3 D3 in T3 no
4074 -- D1 in T3 empty itself yes
4075 -- D2 in T3 empty itself yes
4076 -- D3 in T3 empty itself yes
4078 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES.
4080 -- Type derivation for tagged types is fairly straightforward. if no
4081 -- discriminants are specified by the derived type, these are inherited
4082 -- from the parent. No explicit girder discriminants are ever necessary.
4083 -- The only manipulation that is done to the tree is that of adding a
4084 -- _parent field with parent type and constrained to the same constraint
4085 -- specified for the parent in the derived type definition. For instance:
4087 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
4088 -- type T1 is new R with null record;
4089 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
4091 -- are changed into :
4093 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
4094 -- _parent : R (D1, D2, D3);
4097 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
4098 -- _parent : T1 (X2, 88, X1);
4101 -- The discriminants actually present in R, T1 and T2 as well as their CD,
4102 -- ORC and ICH fields are:
4104 -- Discrim CD ORC ICH
4105 -- ^^^^^^^ ^^ ^^^ ^^^
4106 -- D1 in R empty itself no
4107 -- D2 in R empty itself no
4108 -- D3 in R empty itself no
4110 -- D1 in T1 D1 in R D1 in R no
4111 -- D2 in T1 D2 in R D2 in R no
4112 -- D3 in T1 D3 in R D3 in R no
4114 -- X1 in T2 D3 in T1 D3 in R no
4115 -- X2 in T2 D1 in T1 D1 in R no
4117 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS.
4119 -- Regardless of whether we dealing with a tagged or untagged type
4120 -- we will transform all derived type declarations of the form
4122 -- type T is new R (...) [with ...];
4124 -- subtype S is R (...);
4125 -- type T is new S [with ...];
4127 -- type BT is new R [with ...];
4128 -- subtype T is BT (...);
4130 -- That is, the base derived type is constrained only if it has no
4131 -- discriminants. The reason for doing this is that GNAT's semantic model
4132 -- assumes that a base type with discriminants is unconstrained.
4134 -- Note that, strictly speaking, the above transformation is not always
4135 -- correct. Consider for instance the following exercpt from ACVC b34011a:
4137 -- procedure B34011A is
4138 -- type REC (D : integer := 0) is record
4143 -- type T6 is new Rec;
4144 -- function F return T6;
4149 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
4152 -- The definition of Q6.U is illegal. However transforming Q6.U into
4154 -- type BaseU is new T6;
4155 -- subtype U is BaseU (Q6.F.I)
4157 -- turns U into a legal subtype, which is incorrect. To avoid this problem
4158 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
4159 -- the transformation described above.
4161 -- There is another instance where the above transformation is incorrect.
4165 -- type Base (D : Integer) is tagged null record;
4166 -- procedure P (X : Base);
4168 -- type Der is new Base (2) with null record;
4169 -- procedure P (X : Der);
4172 -- Then the above transformation turns this into
4174 -- type Der_Base is new Base with null record;
4175 -- -- procedure P (X : Base) is implicitly inherited here
4176 -- -- as procedure P (X : Der_Base).
4178 -- subtype Der is Der_Base (2);
4179 -- procedure P (X : Der);
4180 -- -- The overriding of P (X : Der_Base) is illegal since we
4181 -- -- have a parameter conformance problem.
4183 -- To get around this problem, after having semantically processed Der_Base
4184 -- and the rewritten subtype declaration for Der, we copy Der_Base field
4185 -- Discriminant_Constraint from Der so that when parameter conformance is
4186 -- checked when P is overridden, no sematic errors are flagged.
4188 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
4190 -- Regardless of the fact that we dealing with a tagged or untagged type
4191 -- we will transform all derived type declarations of the form
4193 -- type R (D1, .., Dn : ...) is [tagged] record ...;
4194 -- type T is new R [with ...];
4196 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
4198 -- The reason for such transformation is that it allows us to implement a
4199 -- very clean form of component inheritance as explained below.
4201 -- Note that this transformation is not achieved by direct tree rewriting
4202 -- and manipulation, but rather by redoing the semantic actions that the
4203 -- above transformation will entail. This is done directly in routine
4204 -- Inherit_Components.
4206 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE.
4208 -- In both tagged and untagged derived types, regular non discriminant
4209 -- components are inherited in the derived type from the parent type. In
4210 -- the absence of discriminants component, inheritance is straightforward
4211 -- as components can simply be copied from the parent.
4212 -- If the parent has discriminants, inheriting components constrained with
4213 -- these discriminants requires caution. Consider the following example:
4215 -- type R (D1, D2 : Positive) is [tagged] record
4216 -- S : String (D1 .. D2);
4219 -- type T1 is new R [with null record];
4220 -- type T2 (X : positive) is new R (1, X) [with null record];
4222 -- As explained in 6. above, T1 is rewritten as
4224 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
4226 -- which makes the treatment for T1 and T2 identical.
4228 -- What we want when inheriting S, is that references to D1 and D2 in R are
4229 -- replaced with references to their correct constraints, ie D1 and D2 in
4230 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
4231 -- with either discriminant references in the derived type or expressions.
4232 -- This replacement is acheived as follows: before inheriting R's
4233 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
4234 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
4235 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
4236 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
4237 -- by String (1 .. X).
4239 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS.
4241 -- We explain here the rules governing private type extensions relevant to
4242 -- type derivation. These rules are explained on the following example:
4244 -- type D [(...)] is new A [(...)] with private; <-- partial view
4245 -- type D [(...)] is new P [(...)] with null record; <-- full view
4247 -- Type A is called the ancestor subtype of the private extension.
4248 -- Type P is the parent type of the full view of the private extension. It
4249 -- must be A or a type derived from A.
4251 -- The rules concerning the discriminants of private type extensions are
4254 -- o If a private extension inherits known discriminants from the ancestor
4255 -- subtype, then the full view shall also inherit its discriminants from
4256 -- the ancestor subtype and the parent subtype of the full view shall be
4257 -- constrained if and only if the ancestor subtype is constrained.
4259 -- o If a partial view has unknown discriminants, then the full view may
4260 -- define a definite or an indefinite subtype, with or without
4263 -- o If a partial view has neither known nor unknown discriminants, then
4264 -- the full view shall define a definite subtype.
4266 -- o If the ancestor subtype of a private extension has constrained
4267 -- discrimiants, then the parent subtype of the full view shall impose a
4268 -- statically matching constraint on those discriminants.
4270 -- This means that only the following forms of private extensions are
4273 -- type D is new A with private; <-- partial view
4274 -- type D is new P with null record; <-- full view
4276 -- If A has no discriminants than P has no discriminants, otherwise P must
4277 -- inherit A's discriminants.
4279 -- type D is new A (...) with private; <-- partial view
4280 -- type D is new P (:::) with null record; <-- full view
4282 -- P must inherit A's discriminants and (...) and (:::) must statically
4285 -- subtype A is R (...);
4286 -- type D is new A with private; <-- partial view
4287 -- type D is new P with null record; <-- full view
4289 -- P must have inherited R's discriminants and must be derived from A or
4290 -- any of its subtypes.
4292 -- type D (..) is new A with private; <-- partial view
4293 -- type D (..) is new P [(:::)] with null record; <-- full view
4295 -- No specific constraints on P's discriminants or constraint (:::).
4296 -- Note that A can be unconstrained, but the parent subtype P must either
4297 -- be constrained or (:::) must be present.
4299 -- type D (..) is new A [(...)] with private; <-- partial view
4300 -- type D (..) is new P [(:::)] with null record; <-- full view
4302 -- P's constraints on A's discriminants must statically match those
4303 -- imposed by (...).
4305 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS.
4307 -- The full view of a private extension is handled exactly as described
4308 -- above. The model chose for the private view of a private extension
4309 -- is the same for what concerns discriminants (ie they receive the same
4310 -- treatment as in the tagged case). However, the private view of the
4311 -- private extension always inherits the components of the parent base,
4312 -- without replacing any discriminant reference. Strictly speacking this
4313 -- is incorrect. However, Gigi never uses this view to generate code so
4314 -- this is a purely semantic issue. In theory, a set of transformations
4315 -- similar to those given in 5. and 6. above could be applied to private
4316 -- views of private extensions to have the same model of component
4317 -- inheritance as for non private extensions. However, this is not done
4318 -- because it would further complicate private type processing.
4319 -- Semantically speaking, this leaves us in an uncomfortable
4320 -- situation. As an example consider:
4323 -- type R (D : integer) is tagged record
4324 -- S : String (1 .. D);
4326 -- procedure P (X : R);
4327 -- type T is new R (1) with private;
4329 -- type T is new R (1) with null record;
4332 -- This is transformed into:
4335 -- type R (D : integer) is tagged record
4336 -- S : String (1 .. D);
4338 -- procedure P (X : R);
4339 -- type T is new R (1) with private;
4341 -- type BaseT is new R with null record;
4342 -- subtype T is BaseT (1);
4345 -- (strictly speaking the above is incorrect Ada).
4347 -- From the semantic standpoint the private view of private extension T
4348 -- should be flagged as constrained since one can clearly have
4352 -- in a unit withing Pack. However, when deriving subprograms for the
4353 -- private view of private extension T, T must be seen as unconstrained
4354 -- since T has discriminants (this is a constraint of the current
4355 -- subprogram derivation model). Thus, when processing the private view of
4356 -- a private extension such as T, we first mark T as unconstrained, we
4357 -- process it, we perform program derivation and just before returning from
4358 -- Build_Derived_Record_Type we mark T as constrained.
4359 -- ??? Are there are other unconfortable cases that we will have to
4362 -- 10. RECORD_TYPE_WITH_PRIVATE complications.
4364 -- Types that are derived from a visible record type and have a private
4365 -- extension present other peculiarities. They behave mostly like private
4366 -- types, but if they have primitive operations defined, these will not
4367 -- have the proper signatures for further inheritance, because other
4368 -- primitive operations will use the implicit base that we define for
4369 -- private derivations below. This affect subprogram inheritance (see
4370 -- Derive_Subprograms for details). We also derive the implicit base from
4371 -- the base type of the full view, so that the implicit base is a record
4372 -- type and not another private type, This avoids infinite loops.
4374 procedure Build_Derived_Record_Type
4376 Parent_Type
: Entity_Id
;
4377 Derived_Type
: Entity_Id
;
4378 Derive_Subps
: Boolean := True)
4380 Loc
: constant Source_Ptr
:= Sloc
(N
);
4381 Parent_Base
: Entity_Id
;
4386 Discrim
: Entity_Id
;
4387 Last_Discrim
: Entity_Id
;
4389 Discs
: Elist_Id
:= New_Elmt_List
;
4390 -- An empty Discs list means that there were no constraints in the
4391 -- subtype indication or that there was an error processing it.
4393 Assoc_List
: Elist_Id
;
4394 New_Discrs
: Elist_Id
;
4396 New_Base
: Entity_Id
;
4398 New_Indic
: Node_Id
;
4400 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
4401 Discriminant_Specs
: constant Boolean :=
4402 Present
(Discriminant_Specifications
(N
));
4403 Private_Extension
: constant Boolean :=
4404 (Nkind
(N
) = N_Private_Extension_Declaration
);
4406 Constraint_Present
: Boolean;
4407 Inherit_Discrims
: Boolean := False;
4409 Save_Etype
: Entity_Id
;
4410 Save_Discr_Constr
: Elist_Id
;
4411 Save_Next_Entity
: Entity_Id
;
4414 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
4415 and then Present
(Full_View
(Parent_Type
))
4416 and then Has_Discriminants
(Parent_Type
)
4418 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
4420 Parent_Base
:= Base_Type
(Parent_Type
);
4423 -- Before we start the previously documented transformations, here is
4424 -- a little fix for size and alignment of tagged types. Normally when
4425 -- we derive type D from type P, we copy the size and alignment of P
4426 -- as the default for D, and in the absence of explicit representation
4427 -- clauses for D, the size and alignment are indeed the same as the
4430 -- But this is wrong for tagged types, since fields may be added,
4431 -- and the default size may need to be larger, and the default
4432 -- alignment may need to be larger.
4434 -- We therefore reset the size and alignment fields in the tagged
4435 -- case. Note that the size and alignment will in any case be at
4436 -- least as large as the parent type (since the derived type has
4437 -- a copy of the parent type in the _parent field)
4440 Init_Size_Align
(Derived_Type
);
4443 -- STEP 0a: figure out what kind of derived type declaration we have.
4445 if Private_Extension
then
4447 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
4450 Type_Def
:= Type_Definition
(N
);
4452 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
4453 -- Parent_Base can be a private type or private extension. However,
4454 -- for tagged types with an extension the newly added fields are
4455 -- visible and hence the Derived_Type is always an E_Record_Type.
4456 -- (except that the parent may have its own private fields).
4457 -- For untagged types we preserve the Ekind of the Parent_Base.
4459 if Present
(Record_Extension_Part
(Type_Def
)) then
4460 Set_Ekind
(Derived_Type
, E_Record_Type
);
4462 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
4466 -- Indic can either be an N_Identifier if the subtype indication
4467 -- contains no constraint or an N_Subtype_Indication if the subtype
4468 -- indication has a constraint.
4470 Indic
:= Subtype_Indication
(Type_Def
);
4471 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
4473 if Constraint_Present
then
4474 if not Has_Discriminants
(Parent_Base
) then
4476 ("invalid constraint: type has no discriminant",
4477 Constraint
(Indic
));
4479 Constraint_Present
:= False;
4480 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
4482 elsif Is_Constrained
(Parent_Type
) then
4484 ("invalid constraint: parent type is already constrained",
4485 Constraint
(Indic
));
4487 Constraint_Present
:= False;
4488 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
4492 -- STEP 0b: If needed, apply transformation given in point 5. above.
4494 if not Private_Extension
4495 and then Has_Discriminants
(Parent_Type
)
4496 and then not Discriminant_Specs
4497 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
4499 -- First, we must analyze the constraint (see comment in point 5.).
4501 if Constraint_Present
then
4502 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
4504 if Has_Discriminants
(Derived_Type
)
4505 and then Has_Private_Declaration
(Derived_Type
)
4506 and then Present
(Discriminant_Constraint
(Derived_Type
))
4508 -- Verify that constraints of the full view conform to those
4509 -- given in partial view.
4515 C1
:= First_Elmt
(New_Discrs
);
4516 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
4518 while Present
(C1
) and then Present
(C2
) loop
4520 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
4523 "constraint not conformant to previous declaration",
4533 -- Insert and analyze the declaration for the unconstrained base type
4535 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
4538 Make_Full_Type_Declaration
(Loc
,
4539 Defining_Identifier
=> New_Base
,
4541 Make_Derived_Type_Definition
(Loc
,
4542 Abstract_Present
=> Abstract_Present
(Type_Def
),
4543 Subtype_Indication
=>
4544 New_Occurrence_Of
(Parent_Base
, Loc
),
4545 Record_Extension_Part
=>
4546 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
4548 Set_Parent
(New_Decl
, Parent
(N
));
4549 Mark_Rewrite_Insertion
(New_Decl
);
4550 Insert_Before
(N
, New_Decl
);
4552 -- Note that this call passes False for the Derive_Subps
4553 -- parameter because subprogram derivation is deferred until
4554 -- after creating the subtype (see below).
4557 (New_Decl
, Parent_Base
, New_Base
,
4558 Is_Completion
=> True, Derive_Subps
=> False);
4560 -- ??? This needs re-examination to determine whether the
4561 -- above call can simply be replaced by a call to Analyze.
4563 Set_Analyzed
(New_Decl
);
4565 -- Insert and analyze the declaration for the constrained subtype
4567 if Constraint_Present
then
4569 Make_Subtype_Indication
(Loc
,
4570 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
4571 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
4576 Constr_List
: List_Id
:= New_List
;
4580 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
4581 while Present
(C
) loop
4584 -- It is safe here to call New_Copy_Tree since
4585 -- Force_Evaluation was called on each constraint in
4586 -- Build_Discriminant_Constraints.
4588 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
4594 Make_Subtype_Indication
(Loc
,
4595 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
4597 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
4602 Make_Subtype_Declaration
(Loc
,
4603 Defining_Identifier
=> Derived_Type
,
4604 Subtype_Indication
=> New_Indic
));
4608 -- Derivation of subprograms must be delayed until the
4609 -- full subtype has been established to ensure proper
4610 -- overriding of subprograms inherited by full types.
4611 -- If the derivations occurred as part of the call to
4612 -- Build_Derived_Type above, then the check for type
4613 -- conformance would fail because earlier primitive
4614 -- subprograms could still refer to the full type prior
4615 -- the change to the new subtype and hence wouldn't
4616 -- match the new base type created here.
4618 Derive_Subprograms
(Parent_Type
, Derived_Type
);
4620 -- For tagged types the Discriminant_Constraint of the new base itype
4621 -- is inherited from the first subtype so that no subtype conformance
4622 -- problem arise when the first subtype overrides primitive
4623 -- operations inherited by the implicit base type.
4626 Set_Discriminant_Constraint
4627 (New_Base
, Discriminant_Constraint
(Derived_Type
));
4633 -- If we get here Derived_Type will have no discriminants or it will be
4634 -- a discriminated unconstrained base type.
4636 -- STEP 1a: perform preliminary actions/checks for derived tagged types
4639 -- The parent type is frozen for non-private extensions (RM 13.14(7))
4641 if not Private_Extension
then
4642 Freeze_Before
(N
, Parent_Type
);
4645 if Type_Access_Level
(Derived_Type
) /= Type_Access_Level
(Parent_Type
)
4646 and then not Is_Generic_Type
(Derived_Type
)
4648 if Is_Controlled
(Parent_Type
) then
4650 ("controlled type must be declared at the library level",
4654 ("type extension at deeper accessibility level than parent",
4660 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
4664 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
4667 ("parent type must not be outside generic body",
4674 -- STEP 1b : preliminary cleanup of the full view of private types
4676 -- If the type is already marked as having discriminants, then it's the
4677 -- completion of a private type or private extension and we need to
4678 -- retain the discriminants from the partial view if the current
4679 -- declaration has Discriminant_Specifications so that we can verify
4680 -- conformance. However, we must remove any existing components that
4681 -- were inherited from the parent (and attached in Copy_Private_To_Full)
4682 -- because the full type inherits all appropriate components anyway, and
4683 -- we don't want the partial view's components interfering.
4685 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
4686 Discrim
:= First_Discriminant
(Derived_Type
);
4688 Last_Discrim
:= Discrim
;
4689 Next_Discriminant
(Discrim
);
4690 exit when No
(Discrim
);
4693 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
4695 -- In all other cases wipe out the list of inherited components (even
4696 -- inherited discriminants), it will be properly rebuilt here.
4699 Set_First_Entity
(Derived_Type
, Empty
);
4700 Set_Last_Entity
(Derived_Type
, Empty
);
4703 -- STEP 1c: Initialize some flags for the Derived_Type
4705 -- The following flags must be initialized here so that
4706 -- Process_Discriminants can check that discriminants of tagged types
4707 -- do not have a default initial value and that access discriminants
4708 -- are only specified for limited records. For completeness, these
4709 -- flags are also initialized along with all the other flags below.
4711 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
4712 Set_Is_Limited_Record
(Derived_Type
, Is_Limited_Record
(Parent_Type
));
4714 -- STEP 2a: process discriminants of derived type if any.
4716 New_Scope
(Derived_Type
);
4718 if Discriminant_Specs
then
4719 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
4721 -- The following call initializes fields Has_Discriminants and
4722 -- Discriminant_Constraint, unless we are processing the completion
4723 -- of a private type declaration.
4725 Check_Or_Process_Discriminants
(N
, Derived_Type
);
4727 -- For non-tagged types the constraint on the Parent_Type must be
4728 -- present and is used to rename the discriminants.
4730 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
4731 Error_Msg_N
("untagged parent must have discriminants", Indic
);
4733 elsif not Is_Tagged
and then not Constraint_Present
then
4735 ("discriminant constraint needed for derived untagged records",
4738 -- Otherwise the parent subtype must be constrained unless we have a
4739 -- private extension.
4741 elsif not Constraint_Present
4742 and then not Private_Extension
4743 and then not Is_Constrained
(Parent_Type
)
4746 ("unconstrained type not allowed in this context", Indic
);
4748 elsif Constraint_Present
then
4749 -- The following call sets the field Corresponding_Discriminant
4750 -- for the discriminants in the Derived_Type.
4752 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
4754 -- For untagged types all new discriminants must rename
4755 -- discriminants in the parent. For private extensions new
4756 -- discriminants cannot rename old ones (implied by [7.3(13)]).
4758 Discrim
:= First_Discriminant
(Derived_Type
);
4760 while Present
(Discrim
) loop
4762 and then not Present
(Corresponding_Discriminant
(Discrim
))
4765 ("new discriminants must constrain old ones", Discrim
);
4767 elsif Private_Extension
4768 and then Present
(Corresponding_Discriminant
(Discrim
))
4771 ("Only static constraints allowed for parent"
4772 & " discriminants in the partial view", Indic
);
4777 -- If a new discriminant is used in the constraint,
4778 -- then its subtype must be statically compatible
4779 -- with the parent discriminant's subtype (3.7(15)).
4781 if Present
(Corresponding_Discriminant
(Discrim
))
4783 not Subtypes_Statically_Compatible
4785 Etype
(Corresponding_Discriminant
(Discrim
)))
4788 ("subtype must be compatible with parent discriminant",
4792 Next_Discriminant
(Discrim
);
4796 -- STEP 2b: No new discriminants, inherit discriminants if any
4799 if Private_Extension
then
4800 Set_Has_Unknown_Discriminants
4801 (Derived_Type
, Has_Unknown_Discriminants
(Parent_Type
)
4802 or else Unknown_Discriminants_Present
(N
));
4804 Set_Has_Unknown_Discriminants
4805 (Derived_Type
, Has_Unknown_Discriminants
(Parent_Type
));
4808 if not Has_Unknown_Discriminants
(Derived_Type
)
4809 and then Has_Discriminants
(Parent_Type
)
4811 Inherit_Discrims
:= True;
4812 Set_Has_Discriminants
4813 (Derived_Type
, True);
4814 Set_Discriminant_Constraint
4815 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
4818 -- The following test is true for private types (remember
4819 -- transformation 5. is not applied to those) and in an error
4822 if Constraint_Present
then
4823 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
4826 -- For now mark a new derived type as cosntrained only if it has no
4827 -- discriminants. At the end of Build_Derived_Record_Type we properly
4828 -- set this flag in the case of private extensions. See comments in
4829 -- point 9. just before body of Build_Derived_Record_Type.
4833 not (Inherit_Discrims
4834 or else Has_Unknown_Discriminants
(Derived_Type
)));
4837 -- STEP 3: initialize fields of derived type.
4839 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
4840 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
4842 -- Fields inherited from the Parent_Type
4845 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
4846 Set_Has_Specified_Layout
4847 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
4848 Set_Is_Limited_Composite
4849 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
4850 Set_Is_Limited_Record
4851 (Derived_Type
, Is_Limited_Record
(Parent_Type
));
4852 Set_Is_Private_Composite
4853 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
4855 -- Fields inherited from the Parent_Base
4857 Set_Has_Controlled_Component
4858 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
4859 Set_Has_Non_Standard_Rep
4860 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
4861 Set_Has_Primitive_Operations
4862 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
4864 -- Direct controlled types do not inherit Finalize_Storage_Only flag
4866 if not Is_Controlled
(Parent_Type
) then
4867 Set_Finalize_Storage_Only
4868 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
4871 -- Set fields for private derived types.
4873 if Is_Private_Type
(Derived_Type
) then
4874 Set_Depends_On_Private
(Derived_Type
, True);
4875 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
4877 -- Inherit fields from non private record types. If this is the
4878 -- completion of a derivation from a private type, the parent itself
4879 -- is private, and the attributes come from its full view, which must
4883 if Is_Private_Type
(Parent_Base
)
4884 and then not Is_Record_Type
(Parent_Base
)
4886 Set_Component_Alignment
4887 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
4889 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
4891 Set_Component_Alignment
4892 (Derived_Type
, Component_Alignment
(Parent_Base
));
4895 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
4899 -- Set fields for tagged types.
4902 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
4904 -- All tagged types defined in Ada.Finalization are controlled
4906 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
4907 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
4908 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
4910 Set_Is_Controlled
(Derived_Type
);
4912 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
4915 Make_Class_Wide_Type
(Derived_Type
);
4916 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
4918 if Has_Discriminants
(Derived_Type
)
4919 and then Constraint_Present
4921 Set_Girder_Constraint
4922 (Derived_Type
, Expand_To_Girder_Constraint
(Parent_Base
, Discs
));
4926 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
4927 Set_Has_Non_Standard_Rep
4928 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
4931 -- STEP 4: Inherit components from the parent base and constrain them.
4932 -- Apply the second transformation described in point 6. above.
4934 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
4935 or else not Has_Discriminants
(Parent_Type
)
4936 or else not Is_Constrained
(Parent_Type
)
4940 Constrs
:= Discriminant_Constraint
(Parent_Type
);
4943 Assoc_List
:= Inherit_Components
(N
,
4944 Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
4946 -- STEP 5a: Copy the parent record declaration for untagged types
4948 if not Is_Tagged
then
4950 -- Discriminant_Constraint (Derived_Type) has been properly
4951 -- constructed. Save it and temporarily set it to Empty because we do
4952 -- not want the call to New_Copy_Tree below to mess this list.
4954 if Has_Discriminants
(Derived_Type
) then
4955 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
4956 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
4958 Save_Discr_Constr
:= No_Elist
;
4961 -- Save the Etype field of Derived_Type. It is correctly set now, but
4962 -- the call to New_Copy tree may remap it to point to itself, which
4963 -- is not what we want. Ditto for the Next_Entity field.
4965 Save_Etype
:= Etype
(Derived_Type
);
4966 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
4968 -- Assoc_List maps all girder discriminants in the Parent_Base to
4969 -- girder discriminants in the Derived_Type. It is fundamental that
4970 -- no types or itypes with discriminants other than the girder
4971 -- discriminants appear in the entities declared inside
4972 -- Derived_Type. Gigi won't like it.
4976 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
4978 -- Restore the fields saved prior to the New_Copy_Tree call
4979 -- and compute the girder constraint.
4981 Set_Etype
(Derived_Type
, Save_Etype
);
4982 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
4984 if Has_Discriminants
(Derived_Type
) then
4985 Set_Discriminant_Constraint
4986 (Derived_Type
, Save_Discr_Constr
);
4987 Set_Girder_Constraint
4988 (Derived_Type
, Expand_To_Girder_Constraint
(Parent_Base
, Discs
));
4989 Replace_Components
(Derived_Type
, New_Decl
);
4992 -- Insert the new derived type declaration
4994 Rewrite
(N
, New_Decl
);
4996 -- STEP 5b: Complete the processing for record extensions in generics
4998 -- There is no completion for record extensions declared in the
4999 -- parameter part of a generic, so we need to complete processing for
5000 -- these generic record extensions here. The call to
5001 -- Record_Type_Definition will change the Ekind of the components
5002 -- from E_Void to E_Component.
5004 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
5005 Record_Type_Definition
(Empty
, Derived_Type
);
5007 -- STEP 5c: Process the record extension for non private tagged types.
5009 elsif not Private_Extension
then
5010 -- Add the _parent field in the derived type.
5012 Expand_Derived_Record
(Derived_Type
, Type_Def
);
5014 -- Analyze the record extension
5016 Record_Type_Definition
5017 (Record_Extension_Part
(Type_Def
), Derived_Type
);
5022 if Etype
(Derived_Type
) = Any_Type
then
5026 -- Set delayed freeze and then derive subprograms, we need to do
5027 -- this in this order so that derived subprograms inherit the
5028 -- derived freeze if necessary.
5030 Set_Has_Delayed_Freeze
(Derived_Type
);
5031 if Derive_Subps
then
5032 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5035 -- If we have a private extension which defines a constrained derived
5036 -- type mark as constrained here after we have derived subprograms. See
5037 -- comment on point 9. just above the body of Build_Derived_Record_Type.
5039 if Private_Extension
and then Inherit_Discrims
then
5040 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
5041 Set_Is_Constrained
(Derived_Type
, True);
5042 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
5044 elsif Is_Constrained
(Parent_Type
) then
5046 (Derived_Type
, True);
5047 Set_Discriminant_Constraint
5048 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
5052 end Build_Derived_Record_Type
;
5054 ------------------------
5055 -- Build_Derived_Type --
5056 ------------------------
5058 procedure Build_Derived_Type
5060 Parent_Type
: Entity_Id
;
5061 Derived_Type
: Entity_Id
;
5062 Is_Completion
: Boolean;
5063 Derive_Subps
: Boolean := True)
5065 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
5068 -- Set common attributes
5070 Set_Scope
(Derived_Type
, Current_Scope
);
5072 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5073 Set_Etype
(Derived_Type
, Parent_Base
);
5074 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
5076 Set_Size_Info
(Derived_Type
, Parent_Type
);
5077 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
5078 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
5079 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
5080 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
5082 case Ekind
(Parent_Type
) is
5083 when Numeric_Kind
=>
5084 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
5087 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
5091 | Class_Wide_Kind
=>
5092 Build_Derived_Record_Type
5093 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
5096 when Enumeration_Kind
=>
5097 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
5100 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
5102 when Incomplete_Or_Private_Kind
=>
5103 Build_Derived_Private_Type
5104 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
5106 -- For discriminated types, the derivation includes deriving
5107 -- primitive operations. For others it is done below.
5109 if Is_Tagged_Type
(Parent_Type
)
5110 or else Has_Discriminants
(Parent_Type
)
5111 or else (Present
(Full_View
(Parent_Type
))
5112 and then Has_Discriminants
(Full_View
(Parent_Type
)))
5117 when Concurrent_Kind
=>
5118 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
5121 raise Program_Error
;
5124 if Etype
(Derived_Type
) = Any_Type
then
5128 -- Set delayed freeze and then derive subprograms, we need to do
5129 -- this in this order so that derived subprograms inherit the
5130 -- derived freeze if necessary.
5132 Set_Has_Delayed_Freeze
(Derived_Type
);
5133 if Derive_Subps
then
5134 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5137 Set_Has_Primitive_Operations
5138 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
5139 end Build_Derived_Type
;
5141 -----------------------
5142 -- Build_Discriminal --
5143 -----------------------
5145 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
5146 D_Minal
: Entity_Id
;
5147 CR_Disc
: Entity_Id
;
5150 -- A discriminal has the same names as the discriminant.
5152 D_Minal
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
5154 Set_Ekind
(D_Minal
, E_In_Parameter
);
5155 Set_Mechanism
(D_Minal
, Default_Mechanism
);
5156 Set_Etype
(D_Minal
, Etype
(Discrim
));
5158 Set_Discriminal
(Discrim
, D_Minal
);
5159 Set_Discriminal_Link
(D_Minal
, Discrim
);
5161 -- For task types, build at once the discriminants of the corresponding
5162 -- record, which are needed if discriminants are used in entry defaults
5163 -- and in family bounds.
5165 if Is_Concurrent_Type
(Current_Scope
)
5166 or else Is_Limited_Type
(Current_Scope
)
5168 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
5170 Set_Ekind
(CR_Disc
, E_In_Parameter
);
5171 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
5172 Set_Etype
(CR_Disc
, Etype
(Discrim
));
5173 Set_CR_Discriminant
(Discrim
, CR_Disc
);
5175 end Build_Discriminal
;
5177 ------------------------------------
5178 -- Build_Discriminant_Constraints --
5179 ------------------------------------
5181 function Build_Discriminant_Constraints
5184 Derived_Def
: Boolean := False)
5187 C
: constant Node_Id
:= Constraint
(Def
);
5188 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
5189 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
5190 -- Saves the expression corresponding to a given discriminant in T.
5192 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
5193 -- Return the Position number within array Discr_Expr of a discriminant
5194 -- D within the discriminant list of the discriminated type T.
5200 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
5204 Disc
:= First_Discriminant
(T
);
5205 for J
in Discr_Expr
'Range loop
5210 Next_Discriminant
(Disc
);
5213 -- Note: Since this function is called on discriminants that are
5214 -- known to belong to the discriminated type, falling through the
5215 -- loop with no match signals an internal compiler error.
5217 raise Program_Error
;
5220 -- Variables local to Build_Discriminant_Constraints
5224 Elist
: Elist_Id
:= New_Elmt_List
;
5232 Discrim_Present
: Boolean := False;
5234 -- Start of processing for Build_Discriminant_Constraints
5237 -- The following loop will process positional associations only.
5238 -- For a positional association, the (single) discriminant is
5239 -- implicitly specified by position, in textual order (RM 3.7.2).
5241 Discr
:= First_Discriminant
(T
);
5242 Constr
:= First
(Constraints
(C
));
5244 for D
in Discr_Expr
'Range loop
5245 exit when Nkind
(Constr
) = N_Discriminant_Association
;
5248 Error_Msg_N
("too few discriminants given in constraint", C
);
5249 return New_Elmt_List
;
5251 elsif Nkind
(Constr
) = N_Range
5252 or else (Nkind
(Constr
) = N_Attribute_Reference
5254 Attribute_Name
(Constr
) = Name_Range
)
5257 ("a range is not a valid discriminant constraint", Constr
);
5258 Discr_Expr
(D
) := Error
;
5261 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
5262 Discr_Expr
(D
) := Constr
;
5265 Next_Discriminant
(Discr
);
5269 if No
(Discr
) and then Present
(Constr
) then
5270 Error_Msg_N
("too many discriminants given in constraint", Constr
);
5271 return New_Elmt_List
;
5274 -- Named associations can be given in any order, but if both positional
5275 -- and named associations are used in the same discriminant constraint,
5276 -- then positional associations must occur first, at their normal
5277 -- position. Hence once a named association is used, the rest of the
5278 -- discriminant constraint must use only named associations.
5280 while Present
(Constr
) loop
5282 -- Positional association forbidden after a named association.
5284 if Nkind
(Constr
) /= N_Discriminant_Association
then
5285 Error_Msg_N
("positional association follows named one", Constr
);
5286 return New_Elmt_List
;
5288 -- Otherwise it is a named association
5291 -- E records the type of the discriminants in the named
5292 -- association. All the discriminants specified in the same name
5293 -- association must have the same type.
5297 -- Search the list of discriminants in T to see if the simple name
5298 -- given in the constraint matches any of them.
5300 Id
:= First
(Selector_Names
(Constr
));
5301 while Present
(Id
) loop
5304 -- If Original_Discriminant is present, we are processing a
5305 -- generic instantiation and this is an instance node. We need
5306 -- to find the name of the corresponding discriminant in the
5307 -- actual record type T and not the name of the discriminant in
5308 -- the generic formal. Example:
5311 -- type G (D : int) is private;
5313 -- subtype W is G (D => 1);
5315 -- type Rec (X : int) is record ... end record;
5316 -- package Q is new P (G => Rec);
5318 -- At the point of the instantiation, formal type G is Rec
5319 -- and therefore when reanalyzing "subtype W is G (D => 1);"
5320 -- which really looks like "subtype W is Rec (D => 1);" at
5321 -- the point of instantiation, we want to find the discriminant
5322 -- that corresponds to D in Rec, ie X.
5324 if Present
(Original_Discriminant
(Id
)) then
5325 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
5329 Discr
:= First_Discriminant
(T
);
5330 while Present
(Discr
) loop
5331 if Chars
(Discr
) = Chars
(Id
) then
5336 Next_Discriminant
(Discr
);
5340 Error_Msg_N
("& does not match any discriminant", Id
);
5341 return New_Elmt_List
;
5343 -- The following is only useful for the benefit of generic
5344 -- instances but it does not interfere with other
5345 -- processing for the non-generic case so we do it in all
5346 -- cases (for generics this statement is executed when
5347 -- processing the generic definition, see comment at the
5348 -- begining of this if statement).
5351 Set_Original_Discriminant
(Id
, Discr
);
5355 Position
:= Pos_Of_Discr
(T
, Discr
);
5357 if Present
(Discr_Expr
(Position
)) then
5358 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
5361 -- Each discriminant specified in the same named association
5362 -- must be associated with a separate copy of the
5363 -- corresponding expression.
5365 if Present
(Next
(Id
)) then
5366 Expr
:= New_Copy_Tree
(Expression
(Constr
));
5367 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
5369 Expr
:= Expression
(Constr
);
5372 Discr_Expr
(Position
) := Expr
;
5373 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
5376 -- A discriminant association with more than one discriminant
5377 -- name is only allowed if the named discriminants are all of
5378 -- the same type (RM 3.7.1(8)).
5381 E
:= Base_Type
(Etype
(Discr
));
5383 elsif Base_Type
(Etype
(Discr
)) /= E
then
5385 ("all discriminants in an association " &
5386 "must have the same type", Id
);
5396 -- A discriminant constraint must provide exactly one value for each
5397 -- discriminant of the type (RM 3.7.1(8)).
5399 for J
in Discr_Expr
'Range loop
5400 if No
(Discr_Expr
(J
)) then
5401 Error_Msg_N
("too few discriminants given in constraint", C
);
5402 return New_Elmt_List
;
5406 -- Determine if there are discriminant expressions in the constraint.
5408 for J
in Discr_Expr
'Range loop
5409 if Denotes_Discriminant
(Discr_Expr
(J
)) then
5410 Discrim_Present
:= True;
5414 -- Build an element list consisting of the expressions given in the
5415 -- discriminant constraint and apply the appropriate range
5416 -- checks. The list is constructed after resolving any named
5417 -- discriminant associations and therefore the expressions appear in
5418 -- the textual order of the discriminants.
5420 Discr
:= First_Discriminant
(T
);
5421 for J
in Discr_Expr
'Range loop
5422 if Discr_Expr
(J
) /= Error
then
5424 Append_Elmt
(Discr_Expr
(J
), Elist
);
5426 -- If any of the discriminant constraints is given by a
5427 -- discriminant and we are in a derived type declaration we
5428 -- have a discriminant renaming. Establish link between new
5429 -- and old discriminant.
5431 if Denotes_Discriminant
(Discr_Expr
(J
)) then
5433 Set_Corresponding_Discriminant
5434 (Entity
(Discr_Expr
(J
)), Discr
);
5437 -- Force the evaluation of non-discriminant expressions.
5438 -- If we have found a discriminant in the constraint 3.4(26)
5439 -- and 3.8(18) demand that no range checks are performed are
5440 -- after evaluation. In all other cases perform a range check.
5443 if not Discrim_Present
then
5444 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
5447 Force_Evaluation
(Discr_Expr
(J
));
5450 -- Check that the designated type of an access discriminant's
5451 -- expression is not a class-wide type unless the discriminant's
5452 -- designated type is also class-wide.
5454 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
5455 and then not Is_Class_Wide_Type
5456 (Designated_Type
(Etype
(Discr
)))
5457 and then Etype
(Discr_Expr
(J
)) /= Any_Type
5458 and then Is_Class_Wide_Type
5459 (Designated_Type
(Etype
(Discr_Expr
(J
))))
5461 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
5465 Next_Discriminant
(Discr
);
5469 end Build_Discriminant_Constraints
;
5471 ---------------------------------
5472 -- Build_Discriminated_Subtype --
5473 ---------------------------------
5475 procedure Build_Discriminated_Subtype
5479 Related_Nod
: Node_Id
;
5480 For_Access
: Boolean := False)
5482 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
5483 Constrained
: constant Boolean
5485 and then not Is_Empty_Elmt_List
(Elist
)
5486 and then not Is_Class_Wide_Type
(T
))
5487 or else Is_Constrained
(T
);
5490 if Ekind
(T
) = E_Record_Type
then
5492 Set_Ekind
(Def_Id
, E_Private_Subtype
);
5493 Set_Is_For_Access_Subtype
(Def_Id
, True);
5495 Set_Ekind
(Def_Id
, E_Record_Subtype
);
5498 elsif Ekind
(T
) = E_Task_Type
then
5499 Set_Ekind
(Def_Id
, E_Task_Subtype
);
5501 elsif Ekind
(T
) = E_Protected_Type
then
5502 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
5504 elsif Is_Private_Type
(T
) then
5505 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
5507 elsif Is_Class_Wide_Type
(T
) then
5508 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
5511 -- Incomplete type. Attach subtype to list of dependents, to be
5512 -- completed with full view of parent type.
5514 Set_Ekind
(Def_Id
, Ekind
(T
));
5515 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
5518 Set_Etype
(Def_Id
, T
);
5519 Init_Size_Align
(Def_Id
);
5520 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
5521 Set_Is_Constrained
(Def_Id
, Constrained
);
5523 Set_First_Entity
(Def_Id
, First_Entity
(T
));
5524 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
5525 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
5527 if Is_Tagged_Type
(T
) then
5528 Set_Is_Tagged_Type
(Def_Id
);
5529 Make_Class_Wide_Type
(Def_Id
);
5532 Set_Girder_Constraint
(Def_Id
, No_Elist
);
5535 Set_Discriminant_Constraint
(Def_Id
, Elist
);
5536 Set_Girder_Constraint_From_Discriminant_Constraint
(Def_Id
);
5539 if Is_Tagged_Type
(T
) then
5540 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
5541 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
5544 -- Subtypes introduced by component declarations do not need to be
5545 -- marked as delayed, and do not get freeze nodes, because the semantics
5546 -- verifies that the parents of the subtypes are frozen before the
5547 -- enclosing record is frozen.
5549 if not Is_Type
(Scope
(Def_Id
)) then
5550 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
5552 if Is_Private_Type
(T
)
5553 and then Present
(Full_View
(T
))
5555 Conditional_Delay
(Def_Id
, Full_View
(T
));
5557 Conditional_Delay
(Def_Id
, T
);
5561 if Is_Record_Type
(T
) then
5562 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
5565 and then not Is_Empty_Elmt_List
(Elist
)
5566 and then not For_Access
5568 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
5569 elsif not For_Access
then
5570 Set_Cloned_Subtype
(Def_Id
, T
);
5574 end Build_Discriminated_Subtype
;
5576 ------------------------
5577 -- Build_Scalar_Bound --
5578 ------------------------
5580 function Build_Scalar_Bound
5586 New_Bound
: Entity_Id
;
5589 -- Note: not clear why this is needed, how can the original bound
5590 -- be unanalyzed at this point? and if it is, what business do we
5591 -- have messing around with it? and why is the base type of the
5592 -- parent type the right type for the resolution. It probably is
5593 -- not! It is OK for the new bound we are creating, but not for
5594 -- the old one??? Still if it never happens, no problem!
5596 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
5598 if Nkind
(Bound
) = N_Integer_Literal
5599 or else Nkind
(Bound
) = N_Real_Literal
5601 New_Bound
:= New_Copy
(Bound
);
5602 Set_Etype
(New_Bound
, Der_T
);
5603 Set_Analyzed
(New_Bound
);
5605 elsif Is_Entity_Name
(Bound
) then
5606 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
5608 -- The following is almost certainly wrong. What business do we have
5609 -- relocating a node (Bound) that is presumably still attached to
5610 -- the tree elsewhere???
5613 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
5616 Set_Etype
(New_Bound
, Der_T
);
5618 end Build_Scalar_Bound
;
5620 --------------------------------
5621 -- Build_Underlying_Full_View --
5622 --------------------------------
5624 procedure Build_Underlying_Full_View
5629 Loc
: constant Source_Ptr
:= Sloc
(N
);
5630 Subt
: constant Entity_Id
:=
5631 Make_Defining_Identifier
5632 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
5640 if Nkind
(N
) = N_Full_Type_Declaration
then
5641 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
5643 -- ??? ??? is this assert right, I assume so otherwise Constr
5644 -- would not be defined below (this used to be an elsif)
5646 else pragma Assert
(Nkind
(N
) = N_Subtype_Declaration
);
5647 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
5650 -- If the constraint has discriminant associations, the discriminant
5651 -- entity is already set, but it denotes a discriminant of the new
5652 -- type, not the original parent, so it must be found anew.
5654 C
:= First
(Constraints
(Constr
));
5656 while Present
(C
) loop
5658 if Nkind
(C
) = N_Discriminant_Association
then
5659 Id
:= First
(Selector_Names
(C
));
5661 while Present
(Id
) loop
5662 Set_Original_Discriminant
(Id
, Empty
);
5670 Indic
:= Make_Subtype_Declaration
(Loc
,
5671 Defining_Identifier
=> Subt
,
5672 Subtype_Indication
=>
5673 Make_Subtype_Indication
(Loc
,
5674 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
5675 Constraint
=> New_Copy_Tree
(Constr
)));
5677 Insert_Before
(N
, Indic
);
5679 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
5680 end Build_Underlying_Full_View
;
5682 -------------------------------
5683 -- Check_Abstract_Overriding --
5684 -------------------------------
5686 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
5693 Op_List
:= Primitive_Operations
(T
);
5695 -- Loop to check primitive operations
5697 Elmt
:= First_Elmt
(Op_List
);
5698 while Present
(Elmt
) loop
5699 Subp
:= Node
(Elmt
);
5701 -- Special exception, do not complain about failure to
5702 -- override _Input and _Output, since we always provide
5703 -- automatic overridings for these subprograms.
5705 if Is_Abstract
(Subp
)
5706 and then Chars
(Subp
) /= Name_uInput
5707 and then Chars
(Subp
) /= Name_uOutput
5708 and then not Is_Abstract
(T
)
5710 if Present
(Alias
(Subp
)) then
5711 -- Only perform the check for a derived subprogram when
5712 -- the type has an explicit record extension. This avoids
5713 -- incorrectly flagging abstract subprograms for the case
5714 -- of a type without an extension derived from a formal type
5715 -- with a tagged actual (can occur within a private part).
5717 Type_Def
:= Type_Definition
(Parent
(T
));
5718 if Nkind
(Type_Def
) = N_Derived_Type_Definition
5719 and then Present
(Record_Extension_Part
(Type_Def
))
5722 ("type must be declared abstract or & overridden",
5727 ("abstract subprogram not allowed for type&",
5730 ("nonabstract type has abstract subprogram&",
5737 end Check_Abstract_Overriding
;
5739 ------------------------------------------------
5740 -- Check_Access_Discriminant_Requires_Limited --
5741 ------------------------------------------------
5743 procedure Check_Access_Discriminant_Requires_Limited
5748 -- A discriminant_specification for an access discriminant
5749 -- shall appear only in the declaration for a task or protected
5750 -- type, or for a type with the reserved word 'limited' in
5751 -- its definition or in one of its ancestors. (RM 3.7(10))
5753 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
5754 and then not Is_Concurrent_Type
(Current_Scope
)
5755 and then not Is_Concurrent_Record_Type
(Current_Scope
)
5756 and then not Is_Limited_Record
(Current_Scope
)
5757 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
5760 ("access discriminants allowed only for limited types", Loc
);
5762 end Check_Access_Discriminant_Requires_Limited
;
5764 -----------------------------------
5765 -- Check_Aliased_Component_Types --
5766 -----------------------------------
5768 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
5772 -- ??? Also need to check components of record extensions,
5773 -- but not components of protected types (which are always
5776 if not Is_Limited_Type
(T
) then
5777 if Ekind
(T
) = E_Record_Type
then
5778 C
:= First_Component
(T
);
5779 while Present
(C
) loop
5781 and then Has_Discriminants
(Etype
(C
))
5782 and then not Is_Constrained
(Etype
(C
))
5783 and then not In_Instance
5786 ("aliased component must be constrained ('R'M 3.6(11))",
5793 elsif Ekind
(T
) = E_Array_Type
then
5794 if Has_Aliased_Components
(T
)
5795 and then Has_Discriminants
(Component_Type
(T
))
5796 and then not Is_Constrained
(Component_Type
(T
))
5797 and then not In_Instance
5800 ("aliased component type must be constrained ('R'M 3.6(11))",
5805 end Check_Aliased_Component_Types
;
5807 ----------------------
5808 -- Check_Completion --
5809 ----------------------
5811 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
5814 procedure Post_Error
;
5815 -- Post error message for lack of completion for entity E
5817 procedure Post_Error
is
5819 if not Comes_From_Source
(E
) then
5821 if (Ekind
(E
) = E_Task_Type
5822 or else Ekind
(E
) = E_Protected_Type
)
5824 -- It may be an anonymous protected type created for a
5825 -- single variable. Post error on variable, if present.
5831 Var
:= First_Entity
(Current_Scope
);
5833 while Present
(Var
) loop
5834 exit when Etype
(Var
) = E
5835 and then Comes_From_Source
(Var
);
5840 if Present
(Var
) then
5847 -- If a generated entity has no completion, then either previous
5848 -- semantic errors have disabled the expansion phase, or else
5849 -- we had missing subunits, or else we are compiling without expan-
5850 -- sion, or else something is very wrong.
5852 if not Comes_From_Source
(E
) then
5854 (Serious_Errors_Detected
> 0
5855 or else Subunits_Missing
5856 or else not Expander_Active
);
5859 -- Here for source entity
5862 -- Here if no body to post the error message, so we post the error
5863 -- on the declaration that has no completion. This is not really
5864 -- the right place to post it, think about this later ???
5866 if No
(Body_Id
) then
5869 ("missing full declaration for }", Parent
(E
), E
);
5872 ("missing body for &", Parent
(E
), E
);
5875 -- Package body has no completion for a declaration that appears
5876 -- in the corresponding spec. Post error on the body, with a
5877 -- reference to the non-completed declaration.
5880 Error_Msg_Sloc
:= Sloc
(E
);
5884 ("missing full declaration for }!", Body_Id
, E
);
5886 elsif Is_Overloadable
(E
)
5887 and then Current_Entity_In_Scope
(E
) /= E
5889 -- It may be that the completion is mistyped and appears
5890 -- as a distinct overloading of the entity.
5893 Candidate
: Entity_Id
:= Current_Entity_In_Scope
(E
);
5894 Decl
: Node_Id
:= Unit_Declaration_Node
(Candidate
);
5897 if Is_Overloadable
(Candidate
)
5898 and then Ekind
(Candidate
) = Ekind
(E
)
5899 and then Nkind
(Decl
) = N_Subprogram_Body
5900 and then Acts_As_Spec
(Decl
)
5902 Check_Type_Conformant
(Candidate
, E
);
5905 Error_Msg_NE
("missing body for & declared#!",
5910 Error_Msg_NE
("missing body for & declared#!",
5917 -- Start processing for Check_Completion
5920 E
:= First_Entity
(Current_Scope
);
5921 while Present
(E
) loop
5922 if Is_Intrinsic_Subprogram
(E
) then
5925 -- The following situation requires special handling: a child
5926 -- unit that appears in the context clause of the body of its
5929 -- procedure Parent.Child (...);
5931 -- with Parent.Child;
5932 -- package body Parent is
5934 -- Here Parent.Child appears as a local entity, but should not
5935 -- be flagged as requiring completion, because it is a
5936 -- compilation unit.
5938 elsif Ekind
(E
) = E_Function
5939 or else Ekind
(E
) = E_Procedure
5940 or else Ekind
(E
) = E_Generic_Function
5941 or else Ekind
(E
) = E_Generic_Procedure
5943 if not Has_Completion
(E
)
5944 and then not Is_Abstract
(E
)
5945 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
5947 and then Chars
(E
) /= Name_uSize
5952 elsif Is_Entry
(E
) then
5953 if not Has_Completion
(E
) and then
5954 (Ekind
(Scope
(E
)) = E_Protected_Object
5955 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
5960 elsif Is_Package
(E
) then
5961 if Unit_Requires_Body
(E
) then
5962 if not Has_Completion
(E
)
5963 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
5969 elsif not Is_Child_Unit
(E
) then
5970 May_Need_Implicit_Body
(E
);
5973 elsif Ekind
(E
) = E_Incomplete_Type
5974 and then No
(Underlying_Type
(E
))
5978 elsif (Ekind
(E
) = E_Task_Type
or else
5979 Ekind
(E
) = E_Protected_Type
)
5980 and then not Has_Completion
(E
)
5984 elsif Ekind
(E
) = E_Constant
5985 and then Ekind
(Etype
(E
)) = E_Task_Type
5986 and then not Has_Completion
(Etype
(E
))
5990 elsif Ekind
(E
) = E_Protected_Object
5991 and then not Has_Completion
(Etype
(E
))
5995 elsif Ekind
(E
) = E_Record_Type
then
5996 if Is_Tagged_Type
(E
) then
5997 Check_Abstract_Overriding
(E
);
6000 Check_Aliased_Component_Types
(E
);
6002 elsif Ekind
(E
) = E_Array_Type
then
6003 Check_Aliased_Component_Types
(E
);
6009 end Check_Completion
;
6011 ----------------------------
6012 -- Check_Delta_Expression --
6013 ----------------------------
6015 procedure Check_Delta_Expression
(E
: Node_Id
) is
6017 if not (Is_Real_Type
(Etype
(E
))) then
6018 Wrong_Type
(E
, Any_Real
);
6020 elsif not Is_OK_Static_Expression
(E
) then
6021 Error_Msg_N
("non-static expression used for delta value", E
);
6023 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
6024 Error_Msg_N
("delta expression must be positive", E
);
6030 -- If any of above errors occurred, then replace the incorrect
6031 -- expression by the real 0.1, which should prevent further errors.
6034 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
6035 Analyze_And_Resolve
(E
, Standard_Float
);
6037 end Check_Delta_Expression
;
6039 -----------------------------
6040 -- Check_Digits_Expression --
6041 -----------------------------
6043 procedure Check_Digits_Expression
(E
: Node_Id
) is
6045 if not (Is_Integer_Type
(Etype
(E
))) then
6046 Wrong_Type
(E
, Any_Integer
);
6048 elsif not Is_OK_Static_Expression
(E
) then
6049 Error_Msg_N
("non-static expression used for digits value", E
);
6051 elsif Expr_Value
(E
) <= 0 then
6052 Error_Msg_N
("digits value must be greater than zero", E
);
6058 -- If any of above errors occurred, then replace the incorrect
6059 -- expression by the integer 1, which should prevent further errors.
6061 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
6062 Analyze_And_Resolve
(E
, Standard_Integer
);
6064 end Check_Digits_Expression
;
6066 ----------------------
6067 -- Check_Incomplete --
6068 ----------------------
6070 procedure Check_Incomplete
(T
: Entity_Id
) is
6072 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
then
6073 Error_Msg_N
("invalid use of type before its full declaration", T
);
6075 end Check_Incomplete
;
6077 --------------------------
6078 -- Check_Initialization --
6079 --------------------------
6081 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
6083 if (Is_Limited_Type
(T
)
6084 or else Is_Limited_Composite
(T
))
6085 and then not In_Instance
6088 ("cannot initialize entities of limited type", Exp
);
6090 end Check_Initialization
;
6092 ------------------------------------
6093 -- Check_Or_Process_Discriminants --
6094 ------------------------------------
6096 -- If an incomplete or private type declaration was already given for
6097 -- the type, the discriminants may have already been processed if they
6098 -- were present on the incomplete declaration. In this case a full
6099 -- conformance check is performed otherwise just process them.
6101 procedure Check_Or_Process_Discriminants
(N
: Node_Id
; T
: Entity_Id
) is
6103 if Has_Discriminants
(T
) then
6105 -- Make the discriminants visible to component declarations.
6108 D
: Entity_Id
:= First_Discriminant
(T
);
6112 while Present
(D
) loop
6113 Prev
:= Current_Entity
(D
);
6114 Set_Current_Entity
(D
);
6115 Set_Is_Immediately_Visible
(D
);
6116 Set_Homonym
(D
, Prev
);
6118 -- This restriction gets applied to the full type here; it
6119 -- has already been applied earlier to the partial view
6121 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
6123 Next_Discriminant
(D
);
6127 elsif Present
(Discriminant_Specifications
(N
)) then
6128 Process_Discriminants
(N
);
6130 end Check_Or_Process_Discriminants
;
6132 ----------------------
6133 -- Check_Real_Bound --
6134 ----------------------
6136 procedure Check_Real_Bound
(Bound
: Node_Id
) is
6138 if not Is_Real_Type
(Etype
(Bound
)) then
6140 ("bound in real type definition must be of real type", Bound
);
6142 elsif not Is_OK_Static_Expression
(Bound
) then
6144 ("non-static expression used for real type bound", Bound
);
6151 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
6153 Resolve
(Bound
, Standard_Float
);
6154 end Check_Real_Bound
;
6156 ------------------------------
6157 -- Complete_Private_Subtype --
6158 ------------------------------
6160 procedure Complete_Private_Subtype
6163 Full_Base
: Entity_Id
;
6164 Related_Nod
: Node_Id
)
6166 Save_Next_Entity
: Entity_Id
;
6167 Save_Homonym
: Entity_Id
;
6170 -- Set semantic attributes for (implicit) private subtype completion.
6171 -- If the full type has no discriminants, then it is a copy of the full
6172 -- view of the base. Otherwise, it is a subtype of the base with a
6173 -- possible discriminant constraint. Save and restore the original
6174 -- Next_Entity field of full to ensure that the calls to Copy_Node
6175 -- do not corrupt the entity chain.
6177 -- Note that the type of the full view is the same entity as the
6178 -- type of the partial view. In this fashion, the subtype has
6179 -- access to the correct view of the parent.
6181 Save_Next_Entity
:= Next_Entity
(Full
);
6182 Save_Homonym
:= Homonym
(Priv
);
6184 case Ekind
(Full_Base
) is
6186 when E_Record_Type |
6192 Copy_Node
(Priv
, Full
);
6194 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
6195 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
6196 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
6199 Copy_Node
(Full_Base
, Full
);
6200 Set_Chars
(Full
, Chars
(Priv
));
6201 Conditional_Delay
(Full
, Priv
);
6202 Set_Sloc
(Full
, Sloc
(Priv
));
6206 Set_Next_Entity
(Full
, Save_Next_Entity
);
6207 Set_Homonym
(Full
, Save_Homonym
);
6208 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
6210 -- Set common attributes for all subtypes.
6212 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
6214 -- The Etype of the full view is inconsistent. Gigi needs to see the
6215 -- structural full view, which is what the current scheme gives:
6216 -- the Etype of the full view is the etype of the full base. However,
6217 -- if the full base is a derived type, the full view then looks like
6218 -- a subtype of the parent, not a subtype of the full base. If instead
6221 -- Set_Etype (Full, Full_Base);
6223 -- then we get inconsistencies in the front-end (confusion between
6224 -- views). Several outstanding bugs are related to this.
6226 Set_Is_First_Subtype
(Full
, False);
6227 Set_Scope
(Full
, Scope
(Priv
));
6228 Set_Size_Info
(Full
, Full_Base
);
6229 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
6230 Set_Is_Itype
(Full
);
6232 -- A subtype of a private-type-without-discriminants, whose full-view
6233 -- has discriminants with default expressions, is not constrained!
6235 if not Has_Discriminants
(Priv
) then
6236 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
6239 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
6240 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
6242 -- Freeze the private subtype entity if its parent is delayed,
6243 -- and not already frozen. We skip this processing if the type
6244 -- is an anonymous subtype of a record component, or is the
6245 -- corresponding record of a protected type, since ???
6247 if not Is_Type
(Scope
(Full
)) then
6248 Set_Has_Delayed_Freeze
(Full
,
6249 Has_Delayed_Freeze
(Full_Base
)
6250 and then (not Is_Frozen
(Full_Base
)));
6253 Set_Freeze_Node
(Full
, Empty
);
6254 Set_Is_Frozen
(Full
, False);
6255 Set_Full_View
(Priv
, Full
);
6257 if Has_Discriminants
(Full
) then
6258 Set_Girder_Constraint_From_Discriminant_Constraint
(Full
);
6259 Set_Girder_Constraint
(Priv
, Girder_Constraint
(Full
));
6260 if Has_Unknown_Discriminants
(Full
) then
6261 Set_Discriminant_Constraint
(Full
, No_Elist
);
6265 if Ekind
(Full_Base
) = E_Record_Type
6266 and then Has_Discriminants
(Full_Base
)
6267 and then Has_Discriminants
(Priv
) -- might not, if errors
6268 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
6270 Create_Constrained_Components
6271 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
6273 -- If the full base is itself derived from private, build a congruent
6274 -- subtype of its underlying type, for use by the back end.
6276 elsif Ekind
(Full_Base
) in Private_Kind
6277 and then Is_Derived_Type
(Full_Base
)
6278 and then Has_Discriminants
(Full_Base
)
6280 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
6282 Build_Underlying_Full_View
(Parent
(Priv
), Full
, Etype
(Full_Base
));
6284 elsif Is_Record_Type
(Full_Base
) then
6286 -- Show Full is simply a renaming of Full_Base.
6288 Set_Cloned_Subtype
(Full
, Full_Base
);
6291 -- It is usafe to share to bounds of a scalar type, because the
6292 -- Itype is elaborated on demand, and if a bound is non-static
6293 -- then different orders of elaboration in different units will
6294 -- lead to different external symbols.
6296 if Is_Scalar_Type
(Full_Base
) then
6297 Set_Scalar_Range
(Full
,
6298 Make_Range
(Sloc
(Related_Nod
),
6299 Low_Bound
=> Duplicate_Subexpr
(Type_Low_Bound
(Full_Base
)),
6300 High_Bound
=> Duplicate_Subexpr
(Type_High_Bound
(Full_Base
))));
6303 -- ??? It seems that a lot of fields are missing that should be
6304 -- copied from Full_Base to Full. Here are some that are introduced
6305 -- in a non-disruptive way but a cleanup is necessary.
6307 if Is_Tagged_Type
(Full_Base
) then
6308 Set_Is_Tagged_Type
(Full
);
6309 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
6311 elsif Is_Concurrent_Type
(Full_Base
) then
6312 if Has_Discriminants
(Full
)
6313 and then Present
(Corresponding_Record_Type
(Full_Base
))
6315 Set_Corresponding_Record_Type
(Full
,
6316 Constrain_Corresponding_Record
6317 (Full
, Corresponding_Record_Type
(Full_Base
),
6318 Related_Nod
, Full_Base
));
6321 Set_Corresponding_Record_Type
(Full
,
6322 Corresponding_Record_Type
(Full_Base
));
6326 end Complete_Private_Subtype
;
6328 ----------------------------
6329 -- Constant_Redeclaration --
6330 ----------------------------
6332 procedure Constant_Redeclaration
6337 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
6338 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
6341 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
6342 -- If deferred constant is an access type initialized with an
6343 -- allocator, check whether there is an illegal recursion in the
6344 -- definition, through a default value of some record subcomponent.
6345 -- This is normally detected when generating init_procs, but requires
6346 -- this additional mechanism when expansion is disabled.
6348 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
6352 if Is_Record_Type
(Typ
) then
6353 Comp
:= First_Component
(Typ
);
6355 while Present
(Comp
) loop
6356 if Comes_From_Source
(Comp
) then
6357 if Present
(Expression
(Parent
(Comp
)))
6358 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
6359 and then Entity
(Expression
(Parent
(Comp
))) = Prev
6361 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
6363 ("illegal circularity with declaration for&#",
6367 elsif Is_Record_Type
(Etype
(Comp
)) then
6368 Check_Recursive_Declaration
(Etype
(Comp
));
6372 Next_Component
(Comp
);
6375 end Check_Recursive_Declaration
;
6377 -- Start of processing for Constant_Redeclaration
6380 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
6381 if Nkind
(Object_Definition
6382 (Parent
(Prev
))) = N_Subtype_Indication
6384 -- Find type of new declaration. The constraints of the two
6385 -- views must match statically, but there is no point in
6386 -- creating an itype for the full view.
6388 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
6389 Find_Type
(Subtype_Mark
(Obj_Def
));
6390 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
6393 Find_Type
(Obj_Def
);
6394 New_T
:= Entity
(Obj_Def
);
6400 -- The full view may impose a constraint, even if the partial
6401 -- view does not, so construct the subtype.
6403 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
6408 -- Current declaration is illegal, diagnosed below in Enter_Name.
6414 -- If previous full declaration exists, or if a homograph is present,
6415 -- let Enter_Name handle it, either with an error, or with the removal
6416 -- of an overridden implicit subprogram.
6418 if Ekind
(Prev
) /= E_Constant
6419 or else Present
(Expression
(Parent
(Prev
)))
6420 or else Present
(Full_View
(Prev
))
6424 -- Verify that types of both declarations match.
6426 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
) then
6427 Error_Msg_Sloc
:= Sloc
(Prev
);
6428 Error_Msg_N
("type does not match declaration#", N
);
6429 Set_Full_View
(Prev
, Id
);
6430 Set_Etype
(Id
, Any_Type
);
6432 -- If so, process the full constant declaration
6435 Set_Full_View
(Prev
, Id
);
6436 Set_Is_Public
(Id
, Is_Public
(Prev
));
6437 Set_Is_Internal
(Id
);
6438 Append_Entity
(Id
, Current_Scope
);
6440 -- Check ALIASED present if present before (RM 7.4(7))
6442 if Is_Aliased
(Prev
)
6443 and then not Aliased_Present
(N
)
6445 Error_Msg_Sloc
:= Sloc
(Prev
);
6446 Error_Msg_N
("ALIASED required (see declaration#)", N
);
6449 -- Check that placement is in private part and that the incomplete
6450 -- declaration appeared in the visible part.
6452 if Ekind
(Current_Scope
) = E_Package
6453 and then not In_Private_Part
(Current_Scope
)
6455 Error_Msg_Sloc
:= Sloc
(Prev
);
6456 Error_Msg_N
("full constant for declaration#"
6457 & " must be in private part", N
);
6459 elsif Ekind
(Current_Scope
) = E_Package
6460 and then List_Containing
(Parent
(Prev
))
6461 /= Visible_Declarations
6462 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
6465 ("deferred constant must be declared in visible part",
6469 if Is_Access_Type
(T
)
6470 and then Nkind
(Expression
(N
)) = N_Allocator
6472 Check_Recursive_Declaration
(Designated_Type
(T
));
6475 end Constant_Redeclaration
;
6477 ----------------------
6478 -- Constrain_Access --
6479 ----------------------
6481 procedure Constrain_Access
6482 (Def_Id
: in out Entity_Id
;
6484 Related_Nod
: Node_Id
)
6486 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
6487 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
6488 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
6489 Constraint_OK
: Boolean := True;
6492 if Is_Array_Type
(Desig_Type
) then
6493 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
6495 elsif (Is_Record_Type
(Desig_Type
)
6496 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
6497 and then not Is_Constrained
(Desig_Type
)
6499 -- ??? The following code is a temporary kludge to ignore
6500 -- discriminant constraint on access type if
6501 -- it is constraining the current record. Avoid creating the
6502 -- implicit subtype of the record we are currently compiling
6503 -- since right now, we cannot handle these.
6504 -- For now, just return the access type itself.
6506 if Desig_Type
= Current_Scope
6507 and then No
(Def_Id
)
6509 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
6510 Def_Id
:= Entity
(Subtype_Mark
(S
));
6512 -- This call added to ensure that the constraint is
6513 -- analyzed (needed for a B test). Note that we
6514 -- still return early from this procedure to avoid
6515 -- recursive processing. ???
6517 Constrain_Discriminated_Type
6518 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
6523 if Ekind
(T
) = E_General_Access_Type
6524 and then Has_Private_Declaration
(Desig_Type
)
6525 and then In_Open_Scopes
(Scope
(Desig_Type
))
6527 -- Enforce rule that the constraint is illegal if there is
6528 -- an unconstrained view of the designated type. This means
6529 -- that the partial view (either a private type declaration or
6530 -- a derivation from a private type) has no discriminants.
6531 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
6532 -- by ACATS B371001).
6535 Pack
: Node_Id
:= Unit_Declaration_Node
(Scope
(Desig_Type
));
6540 if Nkind
(Pack
) = N_Package_Declaration
then
6541 Decls
:= Visible_Declarations
(Specification
(Pack
));
6542 Decl
:= First
(Decls
);
6544 while Present
(Decl
) loop
6545 if (Nkind
(Decl
) = N_Private_Type_Declaration
6547 Chars
(Defining_Identifier
(Decl
)) =
6551 (Nkind
(Decl
) = N_Full_Type_Declaration
6553 Chars
(Defining_Identifier
(Decl
)) =
6555 and then Is_Derived_Type
(Desig_Type
)
6557 Has_Private_Declaration
(Etype
(Desig_Type
)))
6559 if No
(Discriminant_Specifications
(Decl
)) then
6561 ("cannot constrain general access type " &
6562 "if designated type has unconstrained view", S
);
6574 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
6575 For_Access
=> True);
6577 elsif (Is_Task_Type
(Desig_Type
)
6578 or else Is_Protected_Type
(Desig_Type
))
6579 and then not Is_Constrained
(Desig_Type
)
6581 Constrain_Concurrent
6582 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
6585 Error_Msg_N
("invalid constraint on access type", S
);
6586 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
6587 Constraint_OK
:= False;
6591 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
6593 Set_Ekind
(Def_Id
, E_Access_Subtype
);
6596 if Constraint_OK
then
6597 Set_Etype
(Def_Id
, Base_Type
(T
));
6599 if Is_Private_Type
(Desig_Type
) then
6600 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
6603 Set_Etype
(Def_Id
, Any_Type
);
6606 Set_Size_Info
(Def_Id
, T
);
6607 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
6608 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
6609 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
6610 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
6612 -- Itypes created for constrained record components do not receive
6613 -- a freeze node, they are elaborated when first seen.
6615 if not Is_Record_Type
(Current_Scope
) then
6616 Conditional_Delay
(Def_Id
, T
);
6618 end Constrain_Access
;
6620 ---------------------
6621 -- Constrain_Array --
6622 ---------------------
6624 procedure Constrain_Array
6625 (Def_Id
: in out Entity_Id
;
6627 Related_Nod
: Node_Id
;
6628 Related_Id
: Entity_Id
;
6631 C
: constant Node_Id
:= Constraint
(SI
);
6632 Number_Of_Constraints
: Nat
:= 0;
6635 Constraint_OK
: Boolean := True;
6638 T
:= Entity
(Subtype_Mark
(SI
));
6640 if Ekind
(T
) in Access_Kind
then
6641 T
:= Designated_Type
(T
);
6644 -- If an index constraint follows a subtype mark in a subtype indication
6645 -- then the type or subtype denoted by the subtype mark must not already
6646 -- impose an index constraint. The subtype mark must denote either an
6647 -- unconstrained array type or an access type whose designated type
6648 -- is such an array type... (RM 3.6.1)
6650 if Is_Constrained
(T
) then
6652 ("array type is already constrained", Subtype_Mark
(SI
));
6653 Constraint_OK
:= False;
6656 S
:= First
(Constraints
(C
));
6658 while Present
(S
) loop
6659 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
6663 -- In either case, the index constraint must provide a discrete
6664 -- range for each index of the array type and the type of each
6665 -- discrete range must be the same as that of the corresponding
6666 -- index. (RM 3.6.1)
6668 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
6669 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
6670 Constraint_OK
:= False;
6673 S
:= First
(Constraints
(C
));
6674 Index
:= First_Index
(T
);
6677 -- Apply constraints to each index type
6679 for J
in 1 .. Number_Of_Constraints
loop
6680 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
6690 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
6692 Set_Ekind
(Def_Id
, E_Array_Subtype
);
6695 Set_Size_Info
(Def_Id
, (T
));
6696 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
6697 Set_Etype
(Def_Id
, Base_Type
(T
));
6699 if Constraint_OK
then
6700 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
6703 Set_Is_Constrained
(Def_Id
, True);
6704 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
6705 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
6707 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
6708 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
6710 -- If the subtype is not that of a record component, build a freeze
6711 -- node if parent still needs one.
6713 -- If the subtype is not that of a record component, make sure
6714 -- that the Depends_On_Private status is set (explanation ???)
6715 -- and also that a conditional delay is set.
6717 if not Is_Type
(Scope
(Def_Id
)) then
6718 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
6719 Conditional_Delay
(Def_Id
, T
);
6722 end Constrain_Array
;
6724 ------------------------------
6725 -- Constrain_Component_Type --
6726 ------------------------------
6728 function Constrain_Component_Type
6729 (Compon_Type
: Entity_Id
;
6730 Constrained_Typ
: Entity_Id
;
6731 Related_Node
: Node_Id
;
6733 Constraints
: Elist_Id
)
6736 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
6738 function Build_Constrained_Array_Type
6739 (Old_Type
: Entity_Id
)
6741 -- If Old_Type is an array type, one of whose indices is
6742 -- constrained by a discriminant, build an Itype whose constraint
6743 -- replaces the discriminant with its value in the constraint.
6745 function Build_Constrained_Discriminated_Type
6746 (Old_Type
: Entity_Id
)
6748 -- Ditto for record components.
6750 function Build_Constrained_Access_Type
6751 (Old_Type
: Entity_Id
)
6753 -- Ditto for access types. Makes use of previous two functions, to
6754 -- constrain designated type.
6756 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
6757 -- T is an array or discriminated type, C is a list of constraints
6758 -- that apply to T. This routine builds the constrained subtype.
6760 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
6761 -- Returns True if Expr is a discriminant.
6763 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
6764 -- Find the value of discriminant Discrim in Constraint.
6766 -----------------------------------
6767 -- Build_Constrained_Access_Type --
6768 -----------------------------------
6770 function Build_Constrained_Access_Type
6771 (Old_Type
: Entity_Id
)
6774 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
6776 Desig_Subtype
: Entity_Id
;
6780 -- if the original access type was not embedded in the enclosing
6781 -- type definition, there is no need to produce a new access
6782 -- subtype. In fact every access type with an explicit constraint
6783 -- generates an itype whose scope is the enclosing record.
6785 if not Is_Type
(Scope
(Old_Type
)) then
6788 elsif Is_Array_Type
(Desig_Type
) then
6789 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
6791 elsif Has_Discriminants
(Desig_Type
) then
6793 -- This may be an access type to an enclosing record type for
6794 -- which we are constructing the constrained components. Return
6795 -- the enclosing record subtype. This is not always correct,
6796 -- but avoids infinite recursion. ???
6798 Desig_Subtype
:= Any_Type
;
6800 for J
in reverse 0 .. Scope_Stack
.Last
loop
6801 Scop
:= Scope_Stack
.Table
(J
).Entity
;
6804 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
6806 Desig_Subtype
:= Scop
;
6809 exit when not Is_Type
(Scop
);
6812 if Desig_Subtype
= Any_Type
then
6814 Build_Constrained_Discriminated_Type
(Desig_Type
);
6821 if Desig_Subtype
/= Desig_Type
then
6822 -- The Related_Node better be here or else we won't be able
6823 -- to attach new itypes to a node in the tree.
6825 pragma Assert
(Present
(Related_Node
));
6827 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
6829 Set_Etype
(Itype
, Base_Type
(Old_Type
));
6830 Set_Size_Info
(Itype
, (Old_Type
));
6831 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
6832 Set_Depends_On_Private
(Itype
, Has_Private_Component
6834 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
6837 -- The new itype needs freezing when it depends on a not frozen
6838 -- type and the enclosing subtype needs freezing.
6840 if Has_Delayed_Freeze
(Constrained_Typ
)
6841 and then not Is_Frozen
(Constrained_Typ
)
6843 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
6851 end Build_Constrained_Access_Type
;
6853 ----------------------------------
6854 -- Build_Constrained_Array_Type --
6855 ----------------------------------
6857 function Build_Constrained_Array_Type
6858 (Old_Type
: Entity_Id
)
6863 Old_Index
: Node_Id
;
6864 Range_Node
: Node_Id
;
6865 Constr_List
: List_Id
;
6867 Need_To_Create_Itype
: Boolean := False;
6870 Old_Index
:= First_Index
(Old_Type
);
6871 while Present
(Old_Index
) loop
6872 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
6874 if Is_Discriminant
(Lo_Expr
)
6875 or else Is_Discriminant
(Hi_Expr
)
6877 Need_To_Create_Itype
:= True;
6880 Next_Index
(Old_Index
);
6883 if Need_To_Create_Itype
then
6884 Constr_List
:= New_List
;
6886 Old_Index
:= First_Index
(Old_Type
);
6887 while Present
(Old_Index
) loop
6888 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
6890 if Is_Discriminant
(Lo_Expr
) then
6891 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
6894 if Is_Discriminant
(Hi_Expr
) then
6895 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
6900 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
6902 Append
(Range_Node
, To
=> Constr_List
);
6904 Next_Index
(Old_Index
);
6907 return Build_Subtype
(Old_Type
, Constr_List
);
6912 end Build_Constrained_Array_Type
;
6914 ------------------------------------------
6915 -- Build_Constrained_Discriminated_Type --
6916 ------------------------------------------
6918 function Build_Constrained_Discriminated_Type
6919 (Old_Type
: Entity_Id
)
6923 Constr_List
: List_Id
;
6924 Old_Constraint
: Elmt_Id
;
6926 Need_To_Create_Itype
: Boolean := False;
6929 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
6930 while Present
(Old_Constraint
) loop
6931 Expr
:= Node
(Old_Constraint
);
6933 if Is_Discriminant
(Expr
) then
6934 Need_To_Create_Itype
:= True;
6937 Next_Elmt
(Old_Constraint
);
6940 if Need_To_Create_Itype
then
6941 Constr_List
:= New_List
;
6943 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
6944 while Present
(Old_Constraint
) loop
6945 Expr
:= Node
(Old_Constraint
);
6947 if Is_Discriminant
(Expr
) then
6948 Expr
:= Get_Discr_Value
(Expr
);
6951 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
6953 Next_Elmt
(Old_Constraint
);
6956 return Build_Subtype
(Old_Type
, Constr_List
);
6961 end Build_Constrained_Discriminated_Type
;
6967 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
6969 Subtyp_Decl
: Node_Id
;
6971 Btyp
: Entity_Id
:= Base_Type
(T
);
6974 -- The Related_Node better be here or else we won't be able
6975 -- to attach new itypes to a node in the tree.
6977 pragma Assert
(Present
(Related_Node
));
6979 -- If the view of the component's type is incomplete or private
6980 -- with unknown discriminants, then the constraint must be applied
6981 -- to the full type.
6983 if Has_Unknown_Discriminants
(Btyp
)
6984 and then Present
(Underlying_Type
(Btyp
))
6986 Btyp
:= Underlying_Type
(Btyp
);
6990 Make_Subtype_Indication
(Loc
,
6991 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
6992 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
6994 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
6997 Make_Subtype_Declaration
(Loc
,
6998 Defining_Identifier
=> Def_Id
,
6999 Subtype_Indication
=> Indic
);
7000 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
7002 -- Itypes must be analyzed with checks off (see itypes.ads).
7004 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
7009 ---------------------
7010 -- Get_Discr_Value --
7011 ---------------------
7013 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
7014 D
: Entity_Id
:= First_Discriminant
(Typ
);
7015 E
: Elmt_Id
:= First_Elmt
(Constraints
);
7019 -- The discriminant may be declared for the type, in which case we
7020 -- find it by iterating over the list of discriminants. If the
7021 -- discriminant is inherited from a parent type, it appears as the
7022 -- corresponding discriminant of the current type. This will be the
7023 -- case when constraining an inherited component whose constraint is
7024 -- given by a discriminant of the parent.
7026 while Present
(D
) loop
7027 if D
= Entity
(Discrim
)
7028 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
7033 Next_Discriminant
(D
);
7037 -- The corresponding_Discriminant mechanism is incomplete, because
7038 -- the correspondence between new and old discriminants is not one
7039 -- to one: one new discriminant can constrain several old ones.
7040 -- In that case, scan sequentially the girder_constraint, the list
7041 -- of discriminants of the parents, and the constraints.
7043 if Is_Derived_Type
(Typ
)
7044 and then Present
(Girder_Constraint
(Typ
))
7045 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
7047 D
:= First_Discriminant
(Etype
(Typ
));
7048 E
:= First_Elmt
(Constraints
);
7049 G
:= First_Elmt
(Girder_Constraint
(Typ
));
7051 while Present
(D
) loop
7052 if D
= Entity
(Discrim
) then
7056 Next_Discriminant
(D
);
7062 -- Something is wrong if we did not find the value
7064 raise Program_Error
;
7065 end Get_Discr_Value
;
7067 ---------------------
7068 -- Is_Discriminant --
7069 ---------------------
7071 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
7072 Discrim_Scope
: Entity_Id
;
7075 if Denotes_Discriminant
(Expr
) then
7076 Discrim_Scope
:= Scope
(Entity
(Expr
));
7078 -- Either we have a reference to one of Typ's discriminants,
7080 pragma Assert
(Discrim_Scope
= Typ
7082 -- or to the discriminants of the parent type, in the case
7083 -- of a derivation of a tagged type with variants.
7085 or else Discrim_Scope
= Etype
(Typ
)
7086 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
7088 -- or same as above for the case where the discriminants
7089 -- were declared in Typ's private view.
7091 or else (Is_Private_Type
(Discrim_Scope
)
7092 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
7094 -- or else we are deriving from the full view and the
7095 -- discriminant is declared in the private entity.
7097 or else (Is_Private_Type
(Typ
)
7098 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
7100 -- or we have a class-wide type, in which case make sure the
7101 -- discriminant found belongs to the root type.
7103 or else (Is_Class_Wide_Type
(Typ
)
7104 and then Etype
(Typ
) = Discrim_Scope
));
7109 -- In all other cases we have something wrong.
7112 end Is_Discriminant
;
7114 -- Start of processing for Constrain_Component_Type
7117 if Is_Array_Type
(Compon_Type
) then
7118 return Build_Constrained_Array_Type
(Compon_Type
);
7120 elsif Has_Discriminants
(Compon_Type
) then
7121 return Build_Constrained_Discriminated_Type
(Compon_Type
);
7123 elsif Is_Access_Type
(Compon_Type
) then
7124 return Build_Constrained_Access_Type
(Compon_Type
);
7128 end Constrain_Component_Type
;
7130 --------------------------
7131 -- Constrain_Concurrent --
7132 --------------------------
7134 -- For concurrent types, the associated record value type carries the same
7135 -- discriminants, so when we constrain a concurrent type, we must constrain
7136 -- the value type as well.
7138 procedure Constrain_Concurrent
7139 (Def_Id
: in out Entity_Id
;
7141 Related_Nod
: Node_Id
;
7142 Related_Id
: Entity_Id
;
7145 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
7149 if Ekind
(T_Ent
) in Access_Kind
then
7150 T_Ent
:= Designated_Type
(T_Ent
);
7153 T_Val
:= Corresponding_Record_Type
(T_Ent
);
7155 if Present
(T_Val
) then
7158 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
7161 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
7163 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
7164 Set_Corresponding_Record_Type
(Def_Id
,
7165 Constrain_Corresponding_Record
7166 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
7169 -- If there is no associated record, expansion is disabled and this
7170 -- is a generic context. Create a subtype in any case, so that
7171 -- semantic analysis can proceed.
7174 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
7177 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
7179 end Constrain_Concurrent
;
7181 ------------------------------------
7182 -- Constrain_Corresponding_Record --
7183 ------------------------------------
7185 function Constrain_Corresponding_Record
7186 (Prot_Subt
: Entity_Id
;
7187 Corr_Rec
: Entity_Id
;
7188 Related_Nod
: Node_Id
;
7189 Related_Id
: Entity_Id
)
7192 T_Sub
: constant Entity_Id
7193 := Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
7196 Set_Etype
(T_Sub
, Corr_Rec
);
7197 Init_Size_Align
(T_Sub
);
7198 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
7199 Set_Is_Constrained
(T_Sub
, True);
7200 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
7201 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
7203 Conditional_Delay
(T_Sub
, Corr_Rec
);
7205 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
7206 Set_Discriminant_Constraint
(T_Sub
,
7207 Discriminant_Constraint
(Prot_Subt
));
7208 Set_Girder_Constraint_From_Discriminant_Constraint
(T_Sub
);
7209 Create_Constrained_Components
(T_Sub
, Related_Nod
, Corr_Rec
,
7210 Discriminant_Constraint
(T_Sub
));
7213 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
7216 end Constrain_Corresponding_Record
;
7218 -----------------------
7219 -- Constrain_Decimal --
7220 -----------------------
7222 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
7223 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7224 C
: constant Node_Id
:= Constraint
(S
);
7225 Loc
: constant Source_Ptr
:= Sloc
(C
);
7226 Range_Expr
: Node_Id
;
7227 Digits_Expr
: Node_Id
;
7232 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
7234 if Nkind
(C
) = N_Range_Constraint
then
7235 Range_Expr
:= Range_Expression
(C
);
7236 Digits_Val
:= Digits_Value
(T
);
7239 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
7240 Digits_Expr
:= Digits_Expression
(C
);
7241 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
7243 Check_Digits_Expression
(Digits_Expr
);
7244 Digits_Val
:= Expr_Value
(Digits_Expr
);
7246 if Digits_Val
> Digits_Value
(T
) then
7248 ("digits expression is incompatible with subtype", C
);
7249 Digits_Val
:= Digits_Value
(T
);
7252 if Present
(Range_Constraint
(C
)) then
7253 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
7255 Range_Expr
:= Empty
;
7259 Set_Etype
(Def_Id
, Base_Type
(T
));
7260 Set_Size_Info
(Def_Id
, (T
));
7261 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7262 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
7263 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
7264 Set_Small_Value
(Def_Id
, Small_Value
(T
));
7265 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
7266 Set_Digits_Value
(Def_Id
, Digits_Val
);
7268 -- Manufacture range from given digits value if no range present
7270 if No
(Range_Expr
) then
7271 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
7275 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
7277 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
7281 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
7282 Set_Discrete_RM_Size
(Def_Id
);
7284 -- Unconditionally delay the freeze, since we cannot set size
7285 -- information in all cases correctly until the freeze point.
7287 Set_Has_Delayed_Freeze
(Def_Id
);
7288 end Constrain_Decimal
;
7290 ----------------------------------
7291 -- Constrain_Discriminated_Type --
7292 ----------------------------------
7294 procedure Constrain_Discriminated_Type
7295 (Def_Id
: Entity_Id
;
7297 Related_Nod
: Node_Id
;
7298 For_Access
: Boolean := False)
7300 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7303 Elist
: Elist_Id
:= New_Elmt_List
;
7305 procedure Fixup_Bad_Constraint
;
7306 -- This is called after finding a bad constraint, and after having
7307 -- posted an appropriate error message. The mission is to leave the
7308 -- entity T in as reasonable state as possible!
7310 procedure Fixup_Bad_Constraint
is
7312 -- Set a reasonable Ekind for the entity. For an incomplete type,
7313 -- we can't do much, but for other types, we can set the proper
7314 -- corresponding subtype kind.
7316 if Ekind
(T
) = E_Incomplete_Type
then
7317 Set_Ekind
(Def_Id
, Ekind
(T
));
7319 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
7322 Set_Etype
(Def_Id
, Any_Type
);
7323 Set_Error_Posted
(Def_Id
);
7324 end Fixup_Bad_Constraint
;
7326 -- Start of processing for Constrain_Discriminated_Type
7329 C
:= Constraint
(S
);
7331 -- A discriminant constraint is only allowed in a subtype indication,
7332 -- after a subtype mark. This subtype mark must denote either a type
7333 -- with discriminants, or an access type whose designated type is a
7334 -- type with discriminants. A discriminant constraint specifies the
7335 -- values of these discriminants (RM 3.7.2(5)).
7337 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
7339 if Ekind
(T
) in Access_Kind
then
7340 T
:= Designated_Type
(T
);
7343 if not Has_Discriminants
(T
) then
7344 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
7345 Fixup_Bad_Constraint
;
7348 elsif Is_Constrained
(E
)
7349 or else (Ekind
(E
) = E_Class_Wide_Subtype
7350 and then Present
(Discriminant_Constraint
(E
)))
7352 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
7353 Fixup_Bad_Constraint
;
7357 -- T may be an unconstrained subtype (e.g. a generic actual).
7358 -- Constraint applies to the base type.
7362 Elist
:= Build_Discriminant_Constraints
(T
, S
);
7364 -- If the list returned was empty we had an error in building the
7365 -- discriminant constraint. We have also already signalled an error
7366 -- in the incomplete type case
7368 if Is_Empty_Elmt_List
(Elist
) then
7369 Fixup_Bad_Constraint
;
7373 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
7374 end Constrain_Discriminated_Type
;
7376 ---------------------------
7377 -- Constrain_Enumeration --
7378 ---------------------------
7380 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
7381 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7382 C
: constant Node_Id
:= Constraint
(S
);
7385 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
7387 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
7389 Set_Etype
(Def_Id
, Base_Type
(T
));
7390 Set_Size_Info
(Def_Id
, (T
));
7391 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7392 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
7394 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7396 Set_Discrete_RM_Size
(Def_Id
);
7398 end Constrain_Enumeration
;
7400 ----------------------
7401 -- Constrain_Float --
7402 ----------------------
7404 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
7405 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7411 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
7413 Set_Etype
(Def_Id
, Base_Type
(T
));
7414 Set_Size_Info
(Def_Id
, (T
));
7415 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7417 -- Process the constraint
7419 C
:= Constraint
(S
);
7421 -- Digits constraint present
7423 if Nkind
(C
) = N_Digits_Constraint
then
7424 D
:= Digits_Expression
(C
);
7425 Analyze_And_Resolve
(D
, Any_Integer
);
7426 Check_Digits_Expression
(D
);
7427 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
7429 -- Check that digits value is in range. Obviously we can do this
7430 -- at compile time, but it is strictly a runtime check, and of
7431 -- course there is an ACVC test that checks this!
7433 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
7434 Error_Msg_Uint_1
:= Digits_Value
(T
);
7435 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
7437 Make_Raise_Constraint_Error
(Sloc
(D
),
7438 Reason
=> CE_Range_Check_Failed
);
7439 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
7442 C
:= Range_Constraint
(C
);
7444 -- No digits constraint present
7447 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
7450 -- Range constraint present
7452 if Nkind
(C
) = N_Range_Constraint
then
7453 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7455 -- No range constraint present
7458 pragma Assert
(No
(C
));
7459 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
7462 Set_Is_Constrained
(Def_Id
);
7463 end Constrain_Float
;
7465 ---------------------
7466 -- Constrain_Index --
7467 ---------------------
7469 procedure Constrain_Index
7472 Related_Nod
: Node_Id
;
7473 Related_Id
: Entity_Id
;
7478 R
: Node_Id
:= Empty
;
7479 Checks_Off
: Boolean := False;
7480 T
: constant Entity_Id
:= Etype
(Index
);
7483 if Nkind
(S
) = N_Range
7484 or else Nkind
(S
) = N_Attribute_Reference
7486 -- A Range attribute will transformed into N_Range by Resolve.
7492 -- ??? Why on earth do we turn checks of in this very specific case ?
7494 -- From the revision history: (Constrain_Index): Call
7495 -- Process_Range_Expr_In_Decl with range checking off for range
7496 -- bounds that are attributes. This avoids some horrible
7497 -- constraint error checks.
7499 if Nkind
(R
) = N_Range
7500 and then Nkind
(Low_Bound
(R
)) = N_Attribute_Reference
7501 and then Nkind
(High_Bound
(R
)) = N_Attribute_Reference
7506 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
, Checks_Off
);
7508 if not Error_Posted
(S
)
7510 (Nkind
(S
) /= N_Range
7511 or else Base_Type
(T
) /= Base_Type
(Etype
(Low_Bound
(S
)))
7512 or else Base_Type
(T
) /= Base_Type
(Etype
(High_Bound
(S
))))
7514 if Base_Type
(T
) /= Any_Type
7515 and then Etype
(Low_Bound
(S
)) /= Any_Type
7516 and then Etype
(High_Bound
(S
)) /= Any_Type
7518 Error_Msg_N
("range expected", S
);
7522 elsif Nkind
(S
) = N_Subtype_Indication
then
7523 -- the parser has verified that this is a discrete indication.
7525 Resolve_Discrete_Subtype_Indication
(S
, T
);
7526 R
:= Range_Expression
(Constraint
(S
));
7528 elsif Nkind
(S
) = N_Discriminant_Association
then
7530 -- syntactically valid in subtype indication.
7532 Error_Msg_N
("invalid index constraint", S
);
7533 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
7536 -- Subtype_Mark case, no anonymous subtypes to construct
7541 if Is_Entity_Name
(S
) then
7543 if not Is_Type
(Entity
(S
)) then
7544 Error_Msg_N
("expect subtype mark for index constraint", S
);
7546 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
7547 Wrong_Type
(S
, Base_Type
(T
));
7553 Error_Msg_N
("invalid index constraint", S
);
7554 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
7560 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
7562 Set_Etype
(Def_Id
, Base_Type
(T
));
7564 if Is_Modular_Integer_Type
(T
) then
7565 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
7567 elsif Is_Integer_Type
(T
) then
7568 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
7571 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
7572 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
7575 Set_Size_Info
(Def_Id
, (T
));
7576 Set_RM_Size
(Def_Id
, RM_Size
(T
));
7577 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7579 Set_Scalar_Range
(Def_Id
, R
);
7581 Set_Etype
(S
, Def_Id
);
7582 Set_Discrete_RM_Size
(Def_Id
);
7583 end Constrain_Index
;
7585 -----------------------
7586 -- Constrain_Integer --
7587 -----------------------
7589 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
7590 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7591 C
: constant Node_Id
:= Constraint
(S
);
7594 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7596 if Is_Modular_Integer_Type
(T
) then
7597 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
7599 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
7602 Set_Etype
(Def_Id
, Base_Type
(T
));
7603 Set_Size_Info
(Def_Id
, (T
));
7604 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7605 Set_Discrete_RM_Size
(Def_Id
);
7607 end Constrain_Integer
;
7609 ------------------------------
7610 -- Constrain_Ordinary_Fixed --
7611 ------------------------------
7613 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
7614 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7620 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
7621 Set_Etype
(Def_Id
, Base_Type
(T
));
7622 Set_Size_Info
(Def_Id
, (T
));
7623 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7624 Set_Small_Value
(Def_Id
, Small_Value
(T
));
7626 -- Process the constraint
7628 C
:= Constraint
(S
);
7630 -- Delta constraint present
7632 if Nkind
(C
) = N_Delta_Constraint
then
7633 D
:= Delta_Expression
(C
);
7634 Analyze_And_Resolve
(D
, Any_Real
);
7635 Check_Delta_Expression
(D
);
7636 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
7638 -- Check that delta value is in range. Obviously we can do this
7639 -- at compile time, but it is strictly a runtime check, and of
7640 -- course there is an ACVC test that checks this!
7642 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
7643 Error_Msg_N
("?delta value is too small", D
);
7645 Make_Raise_Constraint_Error
(Sloc
(D
),
7646 Reason
=> CE_Range_Check_Failed
);
7647 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
7650 C
:= Range_Constraint
(C
);
7652 -- No delta constraint present
7655 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
7658 -- Range constraint present
7660 if Nkind
(C
) = N_Range_Constraint
then
7661 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7663 -- No range constraint present
7666 pragma Assert
(No
(C
));
7667 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
7671 Set_Discrete_RM_Size
(Def_Id
);
7673 -- Unconditionally delay the freeze, since we cannot set size
7674 -- information in all cases correctly until the freeze point.
7676 Set_Has_Delayed_Freeze
(Def_Id
);
7677 end Constrain_Ordinary_Fixed
;
7679 ---------------------------
7680 -- Convert_Scalar_Bounds --
7681 ---------------------------
7683 procedure Convert_Scalar_Bounds
7685 Parent_Type
: Entity_Id
;
7686 Derived_Type
: Entity_Id
;
7689 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
7696 Lo
:= Build_Scalar_Bound
7697 (Type_Low_Bound
(Derived_Type
),
7698 Parent_Type
, Implicit_Base
);
7700 Hi
:= Build_Scalar_Bound
7701 (Type_High_Bound
(Derived_Type
),
7702 Parent_Type
, Implicit_Base
);
7709 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
7711 Set_Parent
(Rng
, N
);
7712 Set_Scalar_Range
(Derived_Type
, Rng
);
7714 -- Analyze the bounds
7716 Analyze_And_Resolve
(Lo
, Implicit_Base
);
7717 Analyze_And_Resolve
(Hi
, Implicit_Base
);
7719 -- Analyze the range itself, except that we do not analyze it if
7720 -- the bounds are real literals, and we have a fixed-point type.
7721 -- The reason for this is that we delay setting the bounds in this
7722 -- case till we know the final Small and Size values (see circuit
7723 -- in Freeze.Freeze_Fixed_Point_Type for further details).
7725 if Is_Fixed_Point_Type
(Parent_Type
)
7726 and then Nkind
(Lo
) = N_Real_Literal
7727 and then Nkind
(Hi
) = N_Real_Literal
7731 -- Here we do the analysis of the range.
7733 -- Note: we do this manually, since if we do a normal Analyze and
7734 -- Resolve call, there are problems with the conversions used for
7735 -- the derived type range.
7738 Set_Etype
(Rng
, Implicit_Base
);
7739 Set_Analyzed
(Rng
, True);
7741 end Convert_Scalar_Bounds
;
7747 procedure Copy_And_Swap
(Privat
, Full
: Entity_Id
) is
7749 -- Initialize new full declaration entity by copying the pertinent
7750 -- fields of the corresponding private declaration entity.
7752 Copy_Private_To_Full
(Privat
, Full
);
7754 -- Swap the two entities. Now Privat is the full type entity and
7755 -- Full is the private one. They will be swapped back at the end
7756 -- of the private part. This swapping ensures that the entity that
7757 -- is visible in the private part is the full declaration.
7759 Exchange_Entities
(Privat
, Full
);
7760 Append_Entity
(Full
, Scope
(Full
));
7763 -------------------------------------
7764 -- Copy_Array_Base_Type_Attributes --
7765 -------------------------------------
7767 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
7769 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
7770 Set_Component_Type
(T1
, Component_Type
(T2
));
7771 Set_Component_Size
(T1
, Component_Size
(T2
));
7772 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
7773 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
7774 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
7775 Set_Has_Task
(T1
, Has_Task
(T2
));
7776 Set_Is_Packed
(T1
, Is_Packed
(T2
));
7777 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
7778 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
7779 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
7780 end Copy_Array_Base_Type_Attributes
;
7782 -----------------------------------
7783 -- Copy_Array_Subtype_Attributes --
7784 -----------------------------------
7786 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
7788 Set_Size_Info
(T1
, T2
);
7790 Set_First_Index
(T1
, First_Index
(T2
));
7791 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
7792 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
7793 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
7794 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
7795 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
7796 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
7797 Set_Convention
(T1
, Convention
(T2
));
7798 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
7799 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
7800 end Copy_Array_Subtype_Attributes
;
7802 --------------------------
7803 -- Copy_Private_To_Full --
7804 --------------------------
7806 procedure Copy_Private_To_Full
(Priv
, Full
: Entity_Id
) is
7808 -- We temporarily set Ekind to a value appropriate for a type to
7809 -- avoid assert failures in Einfo from checking for setting type
7810 -- attributes on something that is not a type. Ekind (Priv) is an
7811 -- appropriate choice, since it allowed the attributes to be set
7812 -- in the first place. This Ekind value will be modified later.
7814 Set_Ekind
(Full
, Ekind
(Priv
));
7816 -- Also set Etype temporarily to Any_Type, again, in the absence
7817 -- of errors, it will be properly reset, and if there are errors,
7818 -- then we want a value of Any_Type to remain.
7820 Set_Etype
(Full
, Any_Type
);
7822 -- Now start copying attributes
7824 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
7826 if Has_Discriminants
(Full
) then
7827 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
7828 Set_Girder_Constraint
(Full
, Girder_Constraint
(Priv
));
7831 Set_Homonym
(Full
, Homonym
(Priv
));
7832 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
7833 Set_Is_Public
(Full
, Is_Public
(Priv
));
7834 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
7835 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
7837 Conditional_Delay
(Full
, Priv
);
7839 if Is_Tagged_Type
(Full
) then
7840 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
7842 if Priv
= Base_Type
(Priv
) then
7843 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
7847 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
7848 Set_Scope
(Full
, Scope
(Priv
));
7849 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
7850 Set_First_Entity
(Full
, First_Entity
(Priv
));
7851 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
7853 -- If access types have been recorded for later handling, keep them
7854 -- in the full view so that they get handled when the full view freeze
7855 -- node is expanded.
7857 if Present
(Freeze_Node
(Priv
))
7858 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
7860 Ensure_Freeze_Node
(Full
);
7861 Set_Access_Types_To_Process
(Freeze_Node
(Full
),
7862 Access_Types_To_Process
(Freeze_Node
(Priv
)));
7864 end Copy_Private_To_Full
;
7866 -----------------------------------
7867 -- Create_Constrained_Components --
7868 -----------------------------------
7870 procedure Create_Constrained_Components
7872 Decl_Node
: Node_Id
;
7874 Constraints
: Elist_Id
)
7876 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
7877 Assoc_List
: List_Id
:= New_List
;
7878 Comp_List
: Elist_Id
:= New_Elmt_List
;
7879 Discr_Val
: Elmt_Id
;
7883 Is_Static
: Boolean := True;
7884 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
7886 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
7887 -- Collect components of parent type that do not appear in a variant
7890 procedure Create_All_Components
;
7891 -- Iterate over Comp_List to create the components of the subtype.
7893 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
7894 -- Creates a new component from Old_Compon, coppying all the fields from
7895 -- it, including its Etype, inserts the new component in the Subt entity
7896 -- chain and returns the new component.
7898 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
7899 -- If true, and discriminants are static, collect only components from
7900 -- variants selected by discriminant values.
7902 ------------------------------
7903 -- Collect_Fixed_Components --
7904 ------------------------------
7906 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
7908 -- Build association list for discriminants, and find components of
7909 -- the variant part selected by the values of the discriminants.
7911 Old_C
:= First_Discriminant
(Typ
);
7912 Discr_Val
:= First_Elmt
(Constraints
);
7914 while Present
(Old_C
) loop
7915 Append_To
(Assoc_List
,
7916 Make_Component_Association
(Loc
,
7917 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
7918 Expression
=> New_Copy
(Node
(Discr_Val
))));
7920 Next_Elmt
(Discr_Val
);
7921 Next_Discriminant
(Old_C
);
7924 -- The tag, and the possible parent and controller components
7925 -- are unconditionally in the subtype.
7927 if Is_Tagged_Type
(Typ
)
7928 or else Has_Controlled_Component
(Typ
)
7930 Old_C
:= First_Component
(Typ
);
7932 while Present
(Old_C
) loop
7933 if Chars
((Old_C
)) = Name_uTag
7934 or else Chars
((Old_C
)) = Name_uParent
7935 or else Chars
((Old_C
)) = Name_uController
7937 Append_Elmt
(Old_C
, Comp_List
);
7940 Next_Component
(Old_C
);
7943 end Collect_Fixed_Components
;
7945 ---------------------------
7946 -- Create_All_Components --
7947 ---------------------------
7949 procedure Create_All_Components
is
7953 Comp
:= First_Elmt
(Comp_List
);
7955 while Present
(Comp
) loop
7956 Old_C
:= Node
(Comp
);
7957 New_C
:= Create_Component
(Old_C
);
7961 Constrain_Component_Type
7962 (Etype
(Old_C
), Subt
, Decl_Node
, Typ
, Constraints
));
7963 Set_Is_Public
(New_C
, Is_Public
(Subt
));
7967 end Create_All_Components
;
7969 ----------------------
7970 -- Create_Component --
7971 ----------------------
7973 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
7974 New_Compon
: Entity_Id
:= New_Copy
(Old_Compon
);
7977 -- Set the parent so we have a proper link for freezing etc. This
7978 -- is not a real parent pointer, since of course our parent does
7979 -- not own up to us and reference us, we are an illegitimate
7980 -- child of the original parent!
7982 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
7984 -- We do not want this node marked as Comes_From_Source, since
7985 -- otherwise it would get first class status and a separate
7986 -- cross-reference line would be generated. Illegitimate
7987 -- children do not rate such recognition.
7989 Set_Comes_From_Source
(New_Compon
, False);
7991 -- But it is a real entity, and a birth certificate must be
7992 -- properly registered by entering it into the entity list.
7994 Enter_Name
(New_Compon
);
7996 end Create_Component
;
7998 -----------------------
7999 -- Is_Variant_Record --
8000 -----------------------
8002 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
8004 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
8005 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
8006 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
8008 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
8009 end Is_Variant_Record
;
8011 -- Start of processing for Create_Constrained_Components
8014 pragma Assert
(Subt
/= Base_Type
(Subt
));
8015 pragma Assert
(Typ
= Base_Type
(Typ
));
8017 Set_First_Entity
(Subt
, Empty
);
8018 Set_Last_Entity
(Subt
, Empty
);
8020 -- Check whether constraint is fully static, in which case we can
8021 -- optimize the list of components.
8023 Discr_Val
:= First_Elmt
(Constraints
);
8025 while Present
(Discr_Val
) loop
8027 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
8032 Next_Elmt
(Discr_Val
);
8037 -- Inherit the discriminants of the parent type.
8039 Old_C
:= First_Discriminant
(Typ
);
8041 while Present
(Old_C
) loop
8042 New_C
:= Create_Component
(Old_C
);
8043 Set_Is_Public
(New_C
, Is_Public
(Subt
));
8044 Next_Discriminant
(Old_C
);
8048 and then Is_Variant_Record
(Typ
)
8050 Collect_Fixed_Components
(Typ
);
8054 Component_List
(Type_Definition
(Parent
(Typ
))),
8055 Governed_By
=> Assoc_List
,
8057 Report_Errors
=> Errors
);
8058 pragma Assert
(not Errors
);
8060 Create_All_Components
;
8062 -- If the subtype declaration is created for a tagged type derivation
8063 -- with constraints, we retrieve the record definition of the parent
8064 -- type to select the components of the proper variant.
8067 and then Is_Tagged_Type
(Typ
)
8068 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
8070 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
8071 and then Is_Variant_Record
(Parent_Type
)
8073 Collect_Fixed_Components
(Typ
);
8077 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
8078 Governed_By
=> Assoc_List
,
8080 Report_Errors
=> Errors
);
8081 pragma Assert
(not Errors
);
8083 -- If the tagged derivation has a type extension, collect all the
8084 -- new components therein.
8087 Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
8089 Old_C
:= First_Component
(Typ
);
8091 while Present
(Old_C
) loop
8092 if Original_Record_Component
(Old_C
) = Old_C
8093 and then Chars
(Old_C
) /= Name_uTag
8094 and then Chars
(Old_C
) /= Name_uParent
8095 and then Chars
(Old_C
) /= Name_uController
8097 Append_Elmt
(Old_C
, Comp_List
);
8100 Next_Component
(Old_C
);
8104 Create_All_Components
;
8107 -- If the discriminants are not static, or if this is a multi-level
8108 -- type extension, we have to include all the components of the
8111 Old_C
:= First_Component
(Typ
);
8113 while Present
(Old_C
) loop
8114 New_C
:= Create_Component
(Old_C
);
8118 Constrain_Component_Type
8119 (Etype
(Old_C
), Subt
, Decl_Node
, Typ
, Constraints
));
8120 Set_Is_Public
(New_C
, Is_Public
(Subt
));
8122 Next_Component
(Old_C
);
8127 end Create_Constrained_Components
;
8129 ------------------------------------------
8130 -- Decimal_Fixed_Point_Type_Declaration --
8131 ------------------------------------------
8133 procedure Decimal_Fixed_Point_Type_Declaration
8137 Loc
: constant Source_Ptr
:= Sloc
(Def
);
8138 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
8139 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
8140 Implicit_Base
: Entity_Id
;
8146 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
8149 Check_Restriction
(No_Fixed_Point
, Def
);
8151 -- Create implicit base type
8154 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
8155 Set_Etype
(Implicit_Base
, Implicit_Base
);
8157 -- Analyze and process delta expression
8159 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
8161 Check_Delta_Expression
(Delta_Expr
);
8162 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
8164 -- Check delta is power of 10, and determine scale value from it
8167 Val
: Ureal
:= Delta_Val
;
8170 Scale_Val
:= Uint_0
;
8172 if Val
< Ureal_1
then
8173 while Val
< Ureal_1
loop
8174 Val
:= Val
* Ureal_10
;
8175 Scale_Val
:= Scale_Val
+ 1;
8178 if Scale_Val
> 18 then
8179 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
8180 Scale_Val
:= UI_From_Int
(+18);
8184 while Val
> Ureal_1
loop
8185 Val
:= Val
/ Ureal_10
;
8186 Scale_Val
:= Scale_Val
- 1;
8189 if Scale_Val
< -18 then
8190 Error_Msg_N
("scale is less than minimum value of -18", Def
);
8191 Scale_Val
:= UI_From_Int
(-18);
8195 if Val
/= Ureal_1
then
8196 Error_Msg_N
("delta expression must be a power of 10", Def
);
8197 Delta_Val
:= Ureal_10
** (-Scale_Val
);
8201 -- Set delta, scale and small (small = delta for decimal type)
8203 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
8204 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
8205 Set_Small_Value
(Implicit_Base
, Delta_Val
);
8207 -- Analyze and process digits expression
8209 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
8210 Check_Digits_Expression
(Digs_Expr
);
8211 Digs_Val
:= Expr_Value
(Digs_Expr
);
8213 if Digs_Val
> 18 then
8214 Digs_Val
:= UI_From_Int
(+18);
8215 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
8218 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
8219 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
8221 -- Set range of base type from digits value for now. This will be
8222 -- expanded to represent the true underlying base range by Freeze.
8224 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
8226 -- Set size to zero for now, size will be set at freeze time. We have
8227 -- to do this for ordinary fixed-point, because the size depends on
8228 -- the specified small, and we might as well do the same for decimal
8231 Init_Size_Align
(Implicit_Base
);
8233 -- Complete entity for first subtype
8235 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
8236 Set_Etype
(T
, Implicit_Base
);
8237 Set_Size_Info
(T
, Implicit_Base
);
8238 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
8239 Set_Digits_Value
(T
, Digs_Val
);
8240 Set_Delta_Value
(T
, Delta_Val
);
8241 Set_Small_Value
(T
, Delta_Val
);
8242 Set_Scale_Value
(T
, Scale_Val
);
8243 Set_Is_Constrained
(T
);
8245 -- If there are bounds given in the declaration use them as the
8246 -- bounds of the first named subtype.
8248 if Present
(Real_Range_Specification
(Def
)) then
8250 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
8251 Low
: constant Node_Id
:= Low_Bound
(RRS
);
8252 High
: constant Node_Id
:= High_Bound
(RRS
);
8257 Analyze_And_Resolve
(Low
, Any_Real
);
8258 Analyze_And_Resolve
(High
, Any_Real
);
8259 Check_Real_Bound
(Low
);
8260 Check_Real_Bound
(High
);
8261 Low_Val
:= Expr_Value_R
(Low
);
8262 High_Val
:= Expr_Value_R
(High
);
8264 if Low_Val
< (-Bound_Val
) then
8266 ("range low bound too small for digits value", Low
);
8267 Low_Val
:= -Bound_Val
;
8270 if High_Val
> Bound_Val
then
8272 ("range high bound too large for digits value", High
);
8273 High_Val
:= Bound_Val
;
8276 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
8279 -- If no explicit range, use range that corresponds to given
8280 -- digits value. This will end up as the final range for the
8284 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
8287 end Decimal_Fixed_Point_Type_Declaration
;
8289 -----------------------
8290 -- Derive_Subprogram --
8291 -----------------------
8293 procedure Derive_Subprogram
8294 (New_Subp
: in out Entity_Id
;
8295 Parent_Subp
: Entity_Id
;
8296 Derived_Type
: Entity_Id
;
8297 Parent_Type
: Entity_Id
;
8298 Actual_Subp
: Entity_Id
:= Empty
)
8301 New_Formal
: Entity_Id
;
8302 Same_Subt
: constant Boolean :=
8303 Is_Scalar_Type
(Parent_Type
)
8304 and then Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
);
8306 function Is_Private_Overriding
return Boolean;
8307 -- If Subp is a private overriding of a visible operation, the in-
8308 -- herited operation derives from the overridden op (even though
8309 -- its body is the overriding one) and the inherited operation is
8310 -- visible now. See sem_disp to see the details of the handling of
8311 -- the overridden subprogram, which is removed from the list of
8312 -- primitive operations of the type.
8314 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
8315 -- When the type is an anonymous access type, create a new access type
8316 -- designating the derived type.
8318 ---------------------------
8319 -- Is_Private_Overriding --
8320 ---------------------------
8322 function Is_Private_Overriding
return Boolean is
8326 Prev
:= Homonym
(Parent_Subp
);
8328 -- The visible operation that is overriden is a homonym of
8329 -- the parent subprogram. We scan the homonym chain to find
8330 -- the one whose alias is the subprogram we are deriving.
8332 while Present
(Prev
) loop
8333 if Is_Dispatching_Operation
(Parent_Subp
)
8334 and then Present
(Prev
)
8335 and then Ekind
(Prev
) = Ekind
(Parent_Subp
)
8336 and then Alias
(Prev
) = Parent_Subp
8337 and then Scope
(Parent_Subp
) = Scope
(Prev
)
8338 and then not Is_Hidden
(Prev
)
8343 Prev
:= Homonym
(Prev
);
8347 end Is_Private_Overriding
;
8353 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
8354 Acc_Type
: Entity_Id
;
8358 -- When the type is an anonymous access type, create a new access
8359 -- type designating the derived type. This itype must be elaborated
8360 -- at the point of the derivation, not on subsequent calls that may
8361 -- be out of the proper scope for Gigi, so we insert a reference to
8362 -- it after the derivation.
8364 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
8366 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
8369 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
8370 and then Present
(Full_View
(Desig_Typ
))
8371 and then not Is_Private_Type
(Parent_Type
)
8373 Desig_Typ
:= Full_View
(Desig_Typ
);
8376 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
) then
8377 Acc_Type
:= New_Copy
(Etype
(Id
));
8378 Set_Etype
(Acc_Type
, Acc_Type
);
8379 Set_Scope
(Acc_Type
, New_Subp
);
8381 -- Compute size of anonymous access type.
8383 if Is_Array_Type
(Desig_Typ
)
8384 and then not Is_Constrained
(Desig_Typ
)
8386 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
8388 Init_Size
(Acc_Type
, System_Address_Size
);
8391 Init_Alignment
(Acc_Type
);
8393 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
8395 Set_Etype
(New_Id
, Acc_Type
);
8396 Set_Scope
(New_Id
, New_Subp
);
8398 -- Create a reference to it.
8400 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
8401 Set_Itype
(IR
, Acc_Type
);
8402 Insert_After
(Parent
(Derived_Type
), IR
);
8405 Set_Etype
(New_Id
, Etype
(Id
));
8408 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
8410 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
8411 and then Present
(Full_View
(Etype
(Id
)))
8412 and then Base_Type
(Full_View
(Etype
(Id
))) =
8413 Base_Type
(Parent_Type
))
8416 -- Constraint checks on formals are generated during expansion,
8417 -- based on the signature of the original subprogram. The bounds
8418 -- of the derived type are not relevant, and thus we can use
8419 -- the base type for the formals. However, the return type may be
8420 -- used in a context that requires that the proper static bounds
8421 -- be used (a case statement, for example) and for those cases
8422 -- we must use the derived type (first subtype), not its base.
8424 if Etype
(Id
) = Parent_Type
8427 Set_Etype
(New_Id
, Derived_Type
);
8429 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
8433 Set_Etype
(New_Id
, Etype
(Id
));
8437 -- Start of processing for Derive_Subprogram
8441 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
8442 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
8444 -- Check whether the inherited subprogram is a private operation that
8445 -- should be inherited but not yet made visible. Such subprograms can
8446 -- become visible at a later point (e.g., the private part of a public
8447 -- child unit) via Declare_Inherited_Private_Subprograms. If the
8448 -- following predicate is true, then this is not such a private
8449 -- operation and the subprogram simply inherits the name of the parent
8450 -- subprogram. Note the special check for the names of controlled
8451 -- operations, which are currently exempted from being inherited with
8452 -- a hidden name because they must be findable for generation of
8453 -- implicit run-time calls.
8455 if not Is_Hidden
(Parent_Subp
)
8456 or else Is_Internal
(Parent_Subp
)
8457 or else Is_Private_Overriding
8458 or else Is_Internal_Name
(Chars
(Parent_Subp
))
8459 or else Chars
(Parent_Subp
) = Name_Initialize
8460 or else Chars
(Parent_Subp
) = Name_Adjust
8461 or else Chars
(Parent_Subp
) = Name_Finalize
8463 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
8465 -- If parent is hidden, this can be a regular derivation if the
8466 -- parent is immediately visible in a non-instantiating context,
8467 -- or if we are in the private part of an instance. This test
8468 -- should still be refined ???
8470 -- The test for In_Instance_Not_Visible avoids inheriting the
8471 -- derived operation as a non-visible operation in cases where
8472 -- the parent subprogram might not be visible now, but was
8473 -- visible within the original generic, so it would be wrong
8474 -- to make the inherited subprogram non-visible now. (Not
8475 -- clear if this test is fully correct; are there any cases
8476 -- where we should declare the inherited operation as not
8477 -- visible to avoid it being overridden, e.g., when the
8478 -- parent type is a generic actual with private primitives ???)
8480 -- (they should be treated the same as other private inherited
8481 -- subprograms, but it's not clear how to do this cleanly). ???
8483 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
8484 and then Is_Immediately_Visible
(Parent_Subp
)
8485 and then not In_Instance
)
8486 or else In_Instance_Not_Visible
8488 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
8490 -- The type is inheriting a private operation, so enter
8491 -- it with a special name so it can't be overridden.
8494 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
8497 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
8498 Replace_Type
(Parent_Subp
, New_Subp
);
8499 Conditional_Delay
(New_Subp
, Parent_Subp
);
8501 Formal
:= First_Formal
(Parent_Subp
);
8502 while Present
(Formal
) loop
8503 New_Formal
:= New_Copy
(Formal
);
8505 -- Normally we do not go copying parents, but in the case of
8506 -- formals, we need to link up to the declaration (which is
8507 -- the parameter specification), and it is fine to link up to
8508 -- the original formal's parameter specification in this case.
8510 Set_Parent
(New_Formal
, Parent
(Formal
));
8512 Append_Entity
(New_Formal
, New_Subp
);
8514 Replace_Type
(Formal
, New_Formal
);
8515 Next_Formal
(Formal
);
8518 -- If this derivation corresponds to a tagged generic actual, then
8519 -- primitive operations rename those of the actual. Otherwise the
8520 -- primitive operations rename those of the parent type.
8522 if No
(Actual_Subp
) then
8523 Set_Alias
(New_Subp
, Parent_Subp
);
8524 Set_Is_Intrinsic_Subprogram
(New_Subp
,
8525 Is_Intrinsic_Subprogram
(Parent_Subp
));
8528 Set_Alias
(New_Subp
, Actual_Subp
);
8531 -- Derived subprograms of a tagged type must inherit the convention
8532 -- of the parent subprogram (a requirement of AI-117). Derived
8533 -- subprograms of untagged types simply get convention Ada by default.
8535 if Is_Tagged_Type
(Derived_Type
) then
8536 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
8539 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
8540 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
8542 if Ekind
(Parent_Subp
) = E_Procedure
then
8543 Set_Is_Valued_Procedure
8544 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
8547 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
8549 -- Check for case of a derived subprogram for the instantiation
8550 -- of a formal derived tagged type, so mark the subprogram as
8551 -- dispatching and inherit the dispatching attributes of the
8552 -- parent subprogram. The derived subprogram is effectively a
8553 -- renaming of the actual subprogram, so it needs to have the
8554 -- same attributes as the actual.
8556 if Present
(Actual_Subp
)
8557 and then Is_Dispatching_Operation
(Parent_Subp
)
8559 Set_Is_Dispatching_Operation
(New_Subp
);
8560 if Present
(DTC_Entity
(Parent_Subp
)) then
8561 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
8562 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
8566 -- Indicate that a derived subprogram does not require a body
8567 -- and that it does not require processing of default expressions.
8569 Set_Has_Completion
(New_Subp
);
8570 Set_Default_Expressions_Processed
(New_Subp
);
8572 -- A derived function with a controlling result is abstract.
8573 -- If the Derived_Type is a nonabstract formal generic derived
8574 -- type, then inherited operations are not abstract: check is
8575 -- done at instantiation time. If the derivation is for a generic
8576 -- actual, the function is not abstract unless the actual is.
8578 if Is_Generic_Type
(Derived_Type
)
8579 and then not Is_Abstract
(Derived_Type
)
8583 elsif Is_Abstract
(Alias
(New_Subp
))
8584 or else (Is_Tagged_Type
(Derived_Type
)
8585 and then Etype
(New_Subp
) = Derived_Type
8586 and then No
(Actual_Subp
))
8588 Set_Is_Abstract
(New_Subp
);
8591 if Ekind
(New_Subp
) = E_Function
then
8592 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
8594 end Derive_Subprogram
;
8596 ------------------------
8597 -- Derive_Subprograms --
8598 ------------------------
8600 procedure Derive_Subprograms
8601 (Parent_Type
: Entity_Id
;
8602 Derived_Type
: Entity_Id
;
8603 Generic_Actual
: Entity_Id
:= Empty
)
8605 Op_List
: Elist_Id
:= Collect_Primitive_Operations
(Parent_Type
);
8606 Act_List
: Elist_Id
;
8610 New_Subp
: Entity_Id
:= Empty
;
8611 Parent_Base
: Entity_Id
;
8614 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
8615 and then Has_Discriminants
(Parent_Type
)
8616 and then Present
(Full_View
(Parent_Type
))
8618 Parent_Base
:= Full_View
(Parent_Type
);
8620 Parent_Base
:= Parent_Type
;
8623 Elmt
:= First_Elmt
(Op_List
);
8625 if Present
(Generic_Actual
) then
8626 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
8627 Act_Elmt
:= First_Elmt
(Act_List
);
8629 Act_Elmt
:= No_Elmt
;
8632 -- Literals are derived earlier in the process of building the
8633 -- derived type, and are skipped here.
8635 while Present
(Elmt
) loop
8636 Subp
:= Node
(Elmt
);
8638 if Ekind
(Subp
) /= E_Enumeration_Literal
then
8639 if No
(Generic_Actual
) then
8641 (New_Subp
, Subp
, Derived_Type
, Parent_Base
);
8644 Derive_Subprogram
(New_Subp
, Subp
,
8645 Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
8646 Next_Elmt
(Act_Elmt
);
8652 end Derive_Subprograms
;
8654 --------------------------------
8655 -- Derived_Standard_Character --
8656 --------------------------------
8658 procedure Derived_Standard_Character
8660 Parent_Type
: Entity_Id
;
8661 Derived_Type
: Entity_Id
)
8663 Loc
: constant Source_Ptr
:= Sloc
(N
);
8664 Def
: constant Node_Id
:= Type_Definition
(N
);
8665 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8666 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
8667 Implicit_Base
: constant Entity_Id
:=
8669 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
8676 T
:= Process_Subtype
(Indic
, N
);
8678 Set_Etype
(Implicit_Base
, Parent_Base
);
8679 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
8680 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
8682 Set_Is_Character_Type
(Implicit_Base
, True);
8683 Set_Has_Delayed_Freeze
(Implicit_Base
);
8685 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
8686 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
8688 Set_Scalar_Range
(Implicit_Base
,
8693 Conditional_Delay
(Derived_Type
, Parent_Type
);
8695 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
8696 Set_Etype
(Derived_Type
, Implicit_Base
);
8697 Set_Size_Info
(Derived_Type
, Parent_Type
);
8699 if Unknown_RM_Size
(Derived_Type
) then
8700 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
8703 Set_Is_Character_Type
(Derived_Type
, True);
8705 if Nkind
(Indic
) /= N_Subtype_Indication
then
8706 Set_Scalar_Range
(Derived_Type
, Scalar_Range
(Implicit_Base
));
8709 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
8711 -- Because the implicit base is used in the conversion of the bounds,
8712 -- we have to freeze it now. This is similar to what is done for
8713 -- numeric types, and it equally suspicious, but otherwise a non-
8714 -- static bound will have a reference to an unfrozen type, which is
8715 -- rejected by Gigi (???).
8717 Freeze_Before
(N
, Implicit_Base
);
8719 end Derived_Standard_Character
;
8721 ------------------------------
8722 -- Derived_Type_Declaration --
8723 ------------------------------
8725 procedure Derived_Type_Declaration
8728 Is_Completion
: Boolean)
8730 Def
: constant Node_Id
:= Type_Definition
(N
);
8731 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8732 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
8733 Parent_Type
: Entity_Id
;
8734 Parent_Scope
: Entity_Id
;
8738 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
8740 if Parent_Type
= Any_Type
8741 or else Etype
(Parent_Type
) = Any_Type
8742 or else (Is_Class_Wide_Type
(Parent_Type
)
8743 and then Etype
(Parent_Type
) = T
)
8745 -- If Parent_Type is undefined or illegal, make new type into
8746 -- a subtype of Any_Type, and set a few attributes to prevent
8747 -- cascaded errors. If this is a self-definition, emit error now.
8750 or else T
= Etype
(Parent_Type
)
8752 Error_Msg_N
("type cannot be used in its own definition", Indic
);
8755 Set_Ekind
(T
, Ekind
(Parent_Type
));
8756 Set_Etype
(T
, Any_Type
);
8757 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
8759 if Is_Tagged_Type
(T
) then
8760 Set_Primitive_Operations
(T
, New_Elmt_List
);
8765 elsif Is_Unchecked_Union
(Parent_Type
) then
8766 Error_Msg_N
("cannot derive from Unchecked_Union type", N
);
8769 -- Only composite types other than array types are allowed to have
8772 if Present
(Discriminant_Specifications
(N
))
8773 and then (Is_Elementary_Type
(Parent_Type
)
8774 or else Is_Array_Type
(Parent_Type
))
8775 and then not Error_Posted
(N
)
8778 ("elementary or array type cannot have discriminants",
8779 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
8780 Set_Has_Discriminants
(T
, False);
8783 -- In Ada 83, a derived type defined in a package specification cannot
8784 -- be used for further derivation until the end of its visible part.
8785 -- Note that derivation in the private part of the package is allowed.
8788 and then Is_Derived_Type
(Parent_Type
)
8789 and then In_Visible_Part
(Scope
(Parent_Type
))
8791 if Ada_83
and then Comes_From_Source
(Indic
) then
8793 ("(Ada 83): premature use of type for derivation", Indic
);
8797 -- Check for early use of incomplete or private type
8799 if Ekind
(Parent_Type
) = E_Void
8800 or else Ekind
(Parent_Type
) = E_Incomplete_Type
8802 Error_Msg_N
("premature derivation of incomplete type", Indic
);
8805 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
8806 and then not Is_Generic_Type
(Parent_Type
)
8807 and then not Is_Generic_Type
(Root_Type
(Parent_Type
))
8808 and then not Is_Generic_Actual_Type
(Parent_Type
))
8809 or else Has_Private_Component
(Parent_Type
)
8811 -- The ancestor type of a formal type can be incomplete, in which
8812 -- case only the operations of the partial view are available in
8813 -- the generic. Subsequent checks may be required when the full
8814 -- view is analyzed, to verify that derivation from a tagged type
8815 -- has an extension.
8817 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
8820 elsif No
(Underlying_Type
(Parent_Type
))
8821 or else Has_Private_Component
(Parent_Type
)
8824 ("premature derivation of derived or private type", Indic
);
8826 -- Flag the type itself as being in error, this prevents some
8827 -- nasty problems with people looking at the malformed type.
8829 Set_Error_Posted
(T
);
8831 -- Check that within the immediate scope of an untagged partial
8832 -- view it's illegal to derive from the partial view if the
8833 -- full view is tagged. (7.3(7))
8835 -- We verify that the Parent_Type is a partial view by checking
8836 -- that it is not a Full_Type_Declaration (i.e. a private type or
8837 -- private extension declaration), to distinguish a partial view
8838 -- from a derivation from a private type which also appears as
8841 elsif Present
(Full_View
(Parent_Type
))
8842 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
8843 and then not Is_Tagged_Type
(Parent_Type
)
8844 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
8846 Parent_Scope
:= Scope
(T
);
8847 while Present
(Parent_Scope
)
8848 and then Parent_Scope
/= Standard_Standard
8850 if Parent_Scope
= Scope
(Parent_Type
) then
8852 ("premature derivation from type with tagged full view",
8856 Parent_Scope
:= Scope
(Parent_Scope
);
8861 -- Check that form of derivation is appropriate
8863 Taggd
:= Is_Tagged_Type
(Parent_Type
);
8865 -- Perhaps the parent type should be changed to the class-wide type's
8866 -- specific type in this case to prevent cascading errors ???
8868 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
8869 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
8873 if Present
(Extension
) and then not Taggd
then
8875 ("type derived from untagged type cannot have extension", Indic
);
8877 elsif No
(Extension
) and then Taggd
then
8878 -- If this is within a private part (or body) of a generic
8879 -- instantiation then the derivation is allowed (the parent
8880 -- type can only appear tagged in this case if it's a generic
8881 -- actual type, since it would otherwise have been rejected
8882 -- in the analysis of the generic template).
8884 if not Is_Generic_Actual_Type
(Parent_Type
)
8885 or else In_Visible_Part
(Scope
(Parent_Type
))
8888 ("type derived from tagged type must have extension", Indic
);
8892 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
8893 end Derived_Type_Declaration
;
8895 ----------------------------------
8896 -- Enumeration_Type_Declaration --
8897 ----------------------------------
8899 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
8906 -- Create identifier node representing lower bound
8908 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
8909 L
:= First
(Literals
(Def
));
8910 Set_Chars
(B_Node
, Chars
(L
));
8911 Set_Entity
(B_Node
, L
);
8912 Set_Etype
(B_Node
, T
);
8913 Set_Is_Static_Expression
(B_Node
, True);
8915 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
8916 Set_Low_Bound
(R_Node
, B_Node
);
8918 Set_Ekind
(T
, E_Enumeration_Type
);
8919 Set_First_Literal
(T
, L
);
8921 Set_Is_Constrained
(T
);
8925 -- Loop through literals of enumeration type setting pos and rep values
8926 -- except that if the Ekind is already set, then it means that the
8927 -- literal was already constructed (case of a derived type declaration
8928 -- and we should not disturb the Pos and Rep values.
8930 while Present
(L
) loop
8931 if Ekind
(L
) /= E_Enumeration_Literal
then
8932 Set_Ekind
(L
, E_Enumeration_Literal
);
8933 Set_Enumeration_Pos
(L
, Ev
);
8934 Set_Enumeration_Rep
(L
, Ev
);
8935 Set_Is_Known_Valid
(L
, True);
8939 New_Overloaded_Entity
(L
);
8940 Generate_Definition
(L
);
8941 Set_Convention
(L
, Convention_Intrinsic
);
8943 if Nkind
(L
) = N_Defining_Character_Literal
then
8944 Set_Is_Character_Type
(T
, True);
8951 -- Now create a node representing upper bound
8953 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
8954 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
8955 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
8956 Set_Etype
(B_Node
, T
);
8957 Set_Is_Static_Expression
(B_Node
, True);
8959 Set_High_Bound
(R_Node
, B_Node
);
8960 Set_Scalar_Range
(T
, R_Node
);
8961 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
8964 -- Set Discard_Names if configuration pragma setg, or if there is
8965 -- a parameterless pragma in the current declarative region
8967 if Global_Discard_Names
8968 or else Discard_Names
(Scope
(T
))
8970 Set_Discard_Names
(T
);
8973 -- Process end label if there is one
8975 if Present
(Def
) then
8976 Process_End_Label
(Def
, 'e', T
);
8978 end Enumeration_Type_Declaration
;
8980 --------------------------
8981 -- Expand_Others_Choice --
8982 --------------------------
8984 procedure Expand_Others_Choice
8985 (Case_Table
: Choice_Table_Type
;
8986 Others_Choice
: Node_Id
;
8987 Choice_Type
: Entity_Id
)
8990 Choice_List
: List_Id
:= New_List
;
8995 Loc
: Source_Ptr
:= Sloc
(Others_Choice
);
8998 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
8999 -- Builds a node representing the missing choices given by the
9000 -- Value1 and Value2. A N_Range node is built if there is more than
9001 -- one literal value missing. Otherwise a single N_Integer_Literal,
9002 -- N_Identifier or N_Character_Literal is built depending on what
9005 function Lit_Of
(Value
: Uint
) return Node_Id
;
9006 -- Returns the Node_Id for the enumeration literal corresponding to the
9007 -- position given by Value within the enumeration type Choice_Type.
9013 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
9018 -- If there is only one choice value missing between Value1 and
9019 -- Value2, build an integer or enumeration literal to represent it.
9021 if (Value2
- Value1
) = 0 then
9022 if Is_Integer_Type
(Choice_Type
) then
9023 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
9024 Set_Etype
(Lit_Node
, Choice_Type
);
9026 Lit_Node
:= Lit_Of
(Value1
);
9029 -- Otherwise is more that one choice value that is missing between
9030 -- Value1 and Value2, therefore build a N_Range node of either
9031 -- integer or enumeration literals.
9034 if Is_Integer_Type
(Choice_Type
) then
9035 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
9036 Set_Etype
(Lo
, Choice_Type
);
9037 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
9038 Set_Etype
(Hi
, Choice_Type
);
9047 Low_Bound
=> Lit_Of
(Value1
),
9048 High_Bound
=> Lit_Of
(Value2
));
9059 function Lit_Of
(Value
: Uint
) return Node_Id
is
9063 -- In the case where the literal is of type Character, there needs
9064 -- to be some special handling since there is no explicit chain
9065 -- of literals to search. Instead, a N_Character_Literal node
9066 -- is created with the appropriate Char_Code and Chars fields.
9068 if Root_Type
(Choice_Type
) = Standard_Character
then
9069 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
9070 Lit
:= New_Node
(N_Character_Literal
, Loc
);
9071 Set_Chars
(Lit
, Name_Find
);
9072 Set_Char_Literal_Value
(Lit
, Char_Code
(UI_To_Int
(Value
)));
9073 Set_Etype
(Lit
, Choice_Type
);
9074 Set_Is_Static_Expression
(Lit
, True);
9077 -- Otherwise, iterate through the literals list of Choice_Type
9078 -- "Value" number of times until the desired literal is reached
9079 -- and then return an occurrence of it.
9082 Lit
:= First_Literal
(Choice_Type
);
9083 for J
in 1 .. UI_To_Int
(Value
) loop
9087 return New_Occurrence_Of
(Lit
, Loc
);
9091 -- Start of processing for Expand_Others_Choice
9094 if Case_Table
'Length = 0 then
9096 -- Pathological case: only an others case is present.
9097 -- The others case covers the full range of the type.
9099 if Is_Static_Subtype
(Choice_Type
) then
9100 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
9102 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
9105 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
9109 -- Establish the bound values for the variant depending upon whether
9110 -- the type of the discriminant name is static or not.
9112 if Is_OK_Static_Subtype
(Choice_Type
) then
9113 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
9114 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
9116 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
9117 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
9120 Lo
:= Expr_Value
(Case_Table
(Case_Table
'First).Lo
);
9121 Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
9122 Previous_Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
9124 -- Build the node for any missing choices that are smaller than any
9125 -- explicit choices given in the variant.
9127 if Expr_Value
(Exp_Lo
) < Lo
then
9128 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
9131 -- Build the nodes representing any missing choices that lie between
9132 -- the explicit ones given in the variant.
9134 for J
in Case_Table
'First + 1 .. Case_Table
'Last loop
9135 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
9136 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
9138 if Lo
/= (Previous_Hi
+ 1) then
9139 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
9145 -- Build the node for any missing choices that are greater than any
9146 -- explicit choices given in the variant.
9148 if Expr_Value
(Exp_Hi
) > Hi
then
9149 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
9152 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
9153 end Expand_Others_Choice
;
9155 ---------------------------------
9156 -- Expand_To_Girder_Constraint --
9157 ---------------------------------
9159 function Expand_To_Girder_Constraint
9161 Constraint
: Elist_Id
)
9164 Explicitly_Discriminated_Type
: Entity_Id
;
9165 Expansion
: Elist_Id
;
9166 Discriminant
: Entity_Id
;
9168 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
9169 -- Find the nearest type that actually specifies discriminants.
9171 ---------------------------------
9172 -- Type_With_Explicit_Discrims --
9173 ---------------------------------
9175 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
9176 Typ
: constant E
:= Base_Type
(Id
);
9179 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
9180 if Present
(Full_View
(Typ
)) then
9181 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
9185 if Has_Discriminants
(Typ
) then
9190 if Etype
(Typ
) = Typ
then
9192 elsif Has_Discriminants
(Typ
) then
9195 return Type_With_Explicit_Discrims
(Etype
(Typ
));
9198 end Type_With_Explicit_Discrims
;
9200 -- Start of processing for Expand_To_Girder_Constraint
9204 or else Is_Empty_Elmt_List
(Constraint
)
9209 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
9211 if No
(Explicitly_Discriminated_Type
) then
9215 Expansion
:= New_Elmt_List
;
9218 First_Girder_Discriminant
(Explicitly_Discriminated_Type
);
9220 while Present
(Discriminant
) loop
9223 Get_Discriminant_Value
(
9224 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
9227 Next_Girder_Discriminant
(Discriminant
);
9231 end Expand_To_Girder_Constraint
;
9233 --------------------
9234 -- Find_Type_Name --
9235 --------------------
9237 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
9238 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
9244 -- Find incomplete declaration, if some was given.
9246 Prev
:= Current_Entity_In_Scope
(Id
);
9248 if Present
(Prev
) then
9250 -- Previous declaration exists. Error if not incomplete/private case
9251 -- except if previous declaration is implicit, etc. Enter_Name will
9252 -- emit error if appropriate.
9254 Prev_Par
:= Parent
(Prev
);
9256 if not Is_Incomplete_Or_Private_Type
(Prev
) then
9260 elsif Nkind
(N
) /= N_Full_Type_Declaration
9261 and then Nkind
(N
) /= N_Task_Type_Declaration
9262 and then Nkind
(N
) /= N_Protected_Type_Declaration
9264 -- Completion must be a full type declarations (RM 7.3(4))
9266 Error_Msg_Sloc
:= Sloc
(Prev
);
9267 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
9269 -- Set scope of Id to avoid cascaded errors. Entity is never
9270 -- examined again, except when saving globals in generics.
9272 Set_Scope
(Id
, Current_Scope
);
9275 -- Case of full declaration of incomplete type
9277 elsif Ekind
(Prev
) = E_Incomplete_Type
then
9279 -- Indicate that the incomplete declaration has a matching
9280 -- full declaration. The defining occurrence of the incomplete
9281 -- declaration remains the visible one, and the procedure
9282 -- Get_Full_View dereferences it whenever the type is used.
9284 if Present
(Full_View
(Prev
)) then
9285 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
9288 Set_Full_View
(Prev
, Id
);
9289 Append_Entity
(Id
, Current_Scope
);
9290 Set_Is_Public
(Id
, Is_Public
(Prev
));
9291 Set_Is_Internal
(Id
);
9294 -- Case of full declaration of private type
9297 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
9298 if Etype
(Prev
) /= Prev
then
9300 -- Prev is a private subtype or a derived type, and needs
9303 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
9306 elsif Ekind
(Prev
) = E_Private_Type
9308 (Nkind
(N
) = N_Task_Type_Declaration
9309 or else Nkind
(N
) = N_Protected_Type_Declaration
)
9312 ("completion of nonlimited type cannot be limited", N
);
9315 elsif Nkind
(N
) /= N_Full_Type_Declaration
9316 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
9318 Error_Msg_N
("full view of private extension must be"
9319 & " an extension", N
);
9321 elsif not (Abstract_Present
(Parent
(Prev
)))
9322 and then Abstract_Present
(Type_Definition
(N
))
9324 Error_Msg_N
("full view of non-abstract extension cannot"
9325 & " be abstract", N
);
9328 if not In_Private_Part
(Current_Scope
) then
9330 ("declaration of full view must appear in private part", N
);
9333 Copy_And_Swap
(Prev
, Id
);
9334 Set_Has_Private_Declaration
(Prev
);
9335 Set_Has_Private_Declaration
(Id
);
9337 -- If no error, propagate freeze_node from private to full view.
9338 -- It may have been generated for an early operational item.
9340 if Present
(Freeze_Node
(Id
))
9341 and then Serious_Errors_Detected
= 0
9342 and then No
(Full_View
(Id
))
9344 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
9345 Set_Freeze_Node
(Id
, Empty
);
9346 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
9349 Set_Full_View
(Id
, Prev
);
9353 -- Verify that full declaration conforms to incomplete one
9355 if Is_Incomplete_Or_Private_Type
(Prev
)
9356 and then Present
(Discriminant_Specifications
(Prev_Par
))
9358 if Present
(Discriminant_Specifications
(N
)) then
9359 if Ekind
(Prev
) = E_Incomplete_Type
then
9360 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
9362 Check_Discriminant_Conformance
(N
, Prev
, Id
);
9367 ("missing discriminants in full type declaration", N
);
9369 -- To avoid cascaded errors on subsequent use, share the
9370 -- discriminants of the partial view.
9372 Set_Discriminant_Specifications
(N
,
9373 Discriminant_Specifications
(Prev_Par
));
9377 -- A prior untagged private type can have an associated
9378 -- class-wide type due to use of the class attribute,
9379 -- and in this case also the full type is required to
9383 and then (Is_Tagged_Type
(Prev
)
9384 or else Present
(Class_Wide_Type
(Prev
)))
9386 -- The full declaration is either a tagged record or an
9387 -- extension otherwise this is an error
9389 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
9390 if not Tagged_Present
(Type_Definition
(N
)) then
9392 ("full declaration of } must be tagged", Prev
, Id
);
9393 Set_Is_Tagged_Type
(Id
);
9394 Set_Primitive_Operations
(Id
, New_Elmt_List
);
9397 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
9398 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
9400 "full declaration of } must be a record extension",
9402 Set_Is_Tagged_Type
(Id
);
9403 Set_Primitive_Operations
(Id
, New_Elmt_List
);
9408 ("full declaration of } must be a tagged type", Prev
, Id
);
9416 -- New type declaration
9423 -------------------------
9424 -- Find_Type_Of_Object --
9425 -------------------------
9427 function Find_Type_Of_Object
9429 Related_Nod
: Node_Id
)
9432 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
9433 P
: constant Node_Id
:= Parent
(Obj_Def
);
9438 -- Case of an anonymous array subtype
9440 if Def_Kind
= N_Constrained_Array_Definition
9441 or else Def_Kind
= N_Unconstrained_Array_Definition
9444 Array_Type_Declaration
(T
, Obj_Def
);
9446 -- Create an explicit subtype whenever possible.
9448 elsif Nkind
(P
) /= N_Component_Declaration
9449 and then Def_Kind
= N_Subtype_Indication
9451 -- Base name of subtype on object name, which will be unique in
9452 -- the current scope.
9454 -- If this is a duplicate declaration, return base type, to avoid
9455 -- generating duplicate anonymous types.
9457 if Error_Posted
(P
) then
9458 Analyze
(Subtype_Mark
(Obj_Def
));
9459 return Entity
(Subtype_Mark
(Obj_Def
));
9464 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
9466 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
9468 Insert_Action
(Obj_Def
,
9469 Make_Subtype_Declaration
(Sloc
(P
),
9470 Defining_Identifier
=> T
,
9471 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
9473 -- This subtype may need freezing and it will not be done
9474 -- automatically if the object declaration is not in a
9475 -- declarative part. Since this is an object declaration, the
9476 -- type cannot always be frozen here. Deferred constants do not
9477 -- freeze their type (which often enough will be private).
9479 if Nkind
(P
) = N_Object_Declaration
9480 and then Constant_Present
(P
)
9481 and then No
(Expression
(P
))
9486 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
9490 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
9494 end Find_Type_Of_Object
;
9496 --------------------------------
9497 -- Find_Type_Of_Subtype_Indic --
9498 --------------------------------
9500 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
9504 -- Case of subtype mark with a constraint
9506 if Nkind
(S
) = N_Subtype_Indication
then
9507 Find_Type
(Subtype_Mark
(S
));
9508 Typ
:= Entity
(Subtype_Mark
(S
));
9511 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
9514 ("incorrect constraint for this kind of type", Constraint
(S
));
9515 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
9518 -- Otherwise we have a subtype mark without a constraint
9520 elsif Error_Posted
(S
) then
9521 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
9529 if Typ
= Standard_Wide_Character
9530 or else Typ
= Standard_Wide_String
9532 Check_Restriction
(No_Wide_Characters
, S
);
9536 end Find_Type_Of_Subtype_Indic
;
9538 -------------------------------------
9539 -- Floating_Point_Type_Declaration --
9540 -------------------------------------
9542 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
9543 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
9545 Base_Typ
: Entity_Id
;
9546 Implicit_Base
: Entity_Id
;
9549 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
9550 -- Find if given digits value allows derivation from specified type
9552 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
9553 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
9556 if Digs_Val
> Digits_Value
(E
) then
9560 if Present
(Spec
) then
9561 if Expr_Value_R
(Type_Low_Bound
(E
)) >
9562 Expr_Value_R
(Low_Bound
(Spec
))
9567 if Expr_Value_R
(Type_High_Bound
(E
)) <
9568 Expr_Value_R
(High_Bound
(Spec
))
9575 end Can_Derive_From
;
9577 -- Start of processing for Floating_Point_Type_Declaration
9580 Check_Restriction
(No_Floating_Point
, Def
);
9582 -- Create an implicit base type
9585 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
9587 -- Analyze and verify digits value
9589 Analyze_And_Resolve
(Digs
, Any_Integer
);
9590 Check_Digits_Expression
(Digs
);
9591 Digs_Val
:= Expr_Value
(Digs
);
9593 -- Process possible range spec and find correct type to derive from
9595 Process_Real_Range_Specification
(Def
);
9597 if Can_Derive_From
(Standard_Short_Float
) then
9598 Base_Typ
:= Standard_Short_Float
;
9599 elsif Can_Derive_From
(Standard_Float
) then
9600 Base_Typ
:= Standard_Float
;
9601 elsif Can_Derive_From
(Standard_Long_Float
) then
9602 Base_Typ
:= Standard_Long_Float
;
9603 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
9604 Base_Typ
:= Standard_Long_Long_Float
;
9606 -- If we can't derive from any existing type, use long long float
9607 -- and give appropriate message explaining the problem.
9610 Base_Typ
:= Standard_Long_Long_Float
;
9612 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
9613 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
9614 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
9618 ("range too large for any predefined type",
9619 Real_Range_Specification
(Def
));
9623 -- If there are bounds given in the declaration use them as the bounds
9624 -- of the type, otherwise use the bounds of the predefined base type
9625 -- that was chosen based on the Digits value.
9627 if Present
(Real_Range_Specification
(Def
)) then
9628 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
9629 Set_Is_Constrained
(T
);
9631 -- The bounds of this range must be converted to machine numbers
9632 -- in accordance with RM 4.9(38).
9634 Bound
:= Type_Low_Bound
(T
);
9636 if Nkind
(Bound
) = N_Real_Literal
then
9637 Set_Realval
(Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
));
9638 Set_Is_Machine_Number
(Bound
);
9641 Bound
:= Type_High_Bound
(T
);
9643 if Nkind
(Bound
) = N_Real_Literal
then
9644 Set_Realval
(Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
));
9645 Set_Is_Machine_Number
(Bound
);
9649 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
9652 -- Complete definition of implicit base and declared first subtype
9654 Set_Etype
(Implicit_Base
, Base_Typ
);
9656 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
9657 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
9658 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
9659 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
9660 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
9661 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
9663 Set_Ekind
(T
, E_Floating_Point_Subtype
);
9664 Set_Etype
(T
, Implicit_Base
);
9666 Set_Size_Info
(T
, (Implicit_Base
));
9667 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
9668 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
9669 Set_Digits_Value
(T
, Digs_Val
);
9671 end Floating_Point_Type_Declaration
;
9673 ----------------------------
9674 -- Get_Discriminant_Value --
9675 ----------------------------
9677 -- This is the situation...
9679 -- There is a non-derived type
9681 -- type T0 (Dx, Dy, Dz...)
9683 -- There are zero or more levels of derivation, with each
9684 -- derivation either purely inheriting the discriminants, or
9685 -- defining its own.
9687 -- type Ti is new Ti-1
9689 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
9691 -- subtype Ti is ...
9693 -- The subtype issue is avoided by the use of
9694 -- Original_Record_Component, and the fact that derived subtypes
9695 -- also derive the constraits.
9697 -- This chain leads back from
9699 -- Typ_For_Constraint
9701 -- Typ_For_Constraint has discriminants, and the value for each
9702 -- discriminant is given by its corresponding Elmt of Constraints.
9704 -- Discriminant is some discriminant in this hierarchy.
9706 -- We need to return its value.
9708 -- We do this by recursively searching each level, and looking for
9709 -- Discriminant. Once we get to the bottom, we start backing up
9710 -- returning the value for it which may in turn be a discriminant
9711 -- further up, so on the backup we continue the substitution.
9713 function Get_Discriminant_Value
9714 (Discriminant
: Entity_Id
;
9715 Typ_For_Constraint
: Entity_Id
;
9716 Constraint
: Elist_Id
)
9721 Discrim_Values
: Elist_Id
;
9722 Girder_Discrim_Values
: Boolean)
9723 return Node_Or_Entity_Id
;
9724 -- This is the routine that performs the recursive search of levels
9725 -- as described above.
9729 Discrim_Values
: Elist_Id
;
9730 Girder_Discrim_Values
: Boolean)
9731 return Node_Or_Entity_Id
9735 Result
: Node_Or_Entity_Id
;
9736 Result_Entity
: Node_Id
;
9739 -- If inappropriate type, return Error, this happens only in
9740 -- cascaded error situations, and we want to avoid a blow up.
9742 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
9746 -- Look deeper if possible. Use Girder_Constraints only for
9747 -- untagged types. For tagged types use the given constraint.
9748 -- This asymmetry needs explanation???
9750 if not Girder_Discrim_Values
9751 and then Present
(Girder_Constraint
(Ti
))
9752 and then not Is_Tagged_Type
(Ti
)
9754 Result
:= Recurse
(Ti
, Girder_Constraint
(Ti
), True);
9757 Td
: Entity_Id
:= Etype
(Ti
);
9761 Result
:= Discriminant
;
9764 if Present
(Girder_Constraint
(Ti
)) then
9766 Recurse
(Td
, Girder_Constraint
(Ti
), True);
9769 Recurse
(Td
, Discrim_Values
, Girder_Discrim_Values
);
9775 -- Extra underlying places to search, if not found above. For
9776 -- concurrent types, the relevant discriminant appears in the
9777 -- corresponding record. For a type derived from a private type
9778 -- without discriminant, the full view inherits the discriminants
9779 -- of the full view of the parent.
9781 if Result
= Discriminant
then
9782 if Is_Concurrent_Type
(Ti
)
9783 and then Present
(Corresponding_Record_Type
(Ti
))
9787 Corresponding_Record_Type
(Ti
),
9789 Girder_Discrim_Values
);
9791 elsif Is_Private_Type
(Ti
)
9792 and then not Has_Discriminants
(Ti
)
9793 and then Present
(Full_View
(Ti
))
9794 and then Etype
(Full_View
(Ti
)) /= Ti
9800 Girder_Discrim_Values
);
9804 -- If Result is not a (reference to a) discriminant,
9805 -- return it, otherwise set Result_Entity to the discriminant.
9807 if Nkind
(Result
) = N_Defining_Identifier
then
9809 pragma Assert
(Result
= Discriminant
);
9811 Result_Entity
:= Result
;
9814 if not Denotes_Discriminant
(Result
) then
9818 Result_Entity
:= Entity
(Result
);
9821 -- See if this level of derivation actually has discriminants
9822 -- because tagged derivations can add them, hence the lower
9823 -- levels need not have any.
9825 if not Has_Discriminants
(Ti
) then
9829 -- Scan Ti's discriminants for Result_Entity,
9830 -- and return its corresponding value, if any.
9832 Result_Entity
:= Original_Record_Component
(Result_Entity
);
9834 Assoc
:= First_Elmt
(Discrim_Values
);
9836 if Girder_Discrim_Values
then
9837 Disc
:= First_Girder_Discriminant
(Ti
);
9839 Disc
:= First_Discriminant
(Ti
);
9842 while Present
(Disc
) loop
9844 pragma Assert
(Present
(Assoc
));
9846 if Original_Record_Component
(Disc
) = Result_Entity
then
9847 return Node
(Assoc
);
9852 if Girder_Discrim_Values
then
9853 Next_Girder_Discriminant
(Disc
);
9855 Next_Discriminant
(Disc
);
9859 -- Could not find it
9864 Result
: Node_Or_Entity_Id
;
9866 -- Start of processing for Get_Discriminant_Value
9869 -- ??? this routine is a gigantic mess and will be deleted.
9870 -- for the time being just test for the trivial case before calling
9873 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
9875 D
: Entity_Id
:= First_Discriminant
(Typ_For_Constraint
);
9876 E
: Elmt_Id
:= First_Elmt
(Constraint
);
9878 while Present
(D
) loop
9879 if Chars
(D
) = Chars
(Discriminant
) then
9883 Next_Discriminant
(D
);
9889 Result
:= Recurse
(Typ_For_Constraint
, Constraint
, False);
9891 -- ??? hack to disappear when this routine is gone
9893 if Nkind
(Result
) = N_Defining_Identifier
then
9895 D
: Entity_Id
:= First_Discriminant
(Typ_For_Constraint
);
9896 E
: Elmt_Id
:= First_Elmt
(Constraint
);
9898 while Present
(D
) loop
9899 if Corresponding_Discriminant
(D
) = Discriminant
then
9903 Next_Discriminant
(D
);
9909 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
9911 end Get_Discriminant_Value
;
9913 --------------------------
9914 -- Has_Range_Constraint --
9915 --------------------------
9917 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
9918 C
: constant Node_Id
:= Constraint
(N
);
9921 if Nkind
(C
) = N_Range_Constraint
then
9924 elsif Nkind
(C
) = N_Digits_Constraint
then
9926 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
9928 Present
(Range_Constraint
(C
));
9930 elsif Nkind
(C
) = N_Delta_Constraint
then
9931 return Present
(Range_Constraint
(C
));
9936 end Has_Range_Constraint
;
9938 ------------------------
9939 -- Inherit_Components --
9940 ------------------------
9942 function Inherit_Components
9944 Parent_Base
: Entity_Id
;
9945 Derived_Base
: Entity_Id
;
9946 Is_Tagged
: Boolean;
9947 Inherit_Discr
: Boolean;
9951 Assoc_List
: Elist_Id
:= New_Elmt_List
;
9953 procedure Inherit_Component
9955 Plain_Discrim
: Boolean := False;
9956 Girder_Discrim
: Boolean := False);
9957 -- Inherits component Old_C from Parent_Base to the Derived_Base.
9958 -- If Plain_Discrim is True, Old_C is a discriminant.
9959 -- If Girder_Discrim is True, Old_C is a girder discriminant.
9960 -- If they are both false then Old_C is a regular component.
9962 -----------------------
9963 -- Inherit_Component --
9964 -----------------------
9966 procedure Inherit_Component
9968 Plain_Discrim
: Boolean := False;
9969 Girder_Discrim
: Boolean := False)
9971 New_C
: Entity_Id
:= New_Copy
(Old_C
);
9973 Discrim
: Entity_Id
;
9974 Corr_Discrim
: Entity_Id
;
9977 pragma Assert
(not Is_Tagged
or else not Girder_Discrim
);
9979 Set_Parent
(New_C
, Parent
(Old_C
));
9981 -- Regular discriminants and components must be inserted
9982 -- in the scope of the Derived_Base. Do it here.
9984 if not Girder_Discrim
then
9988 -- For tagged types the Original_Record_Component must point to
9989 -- whatever this field was pointing to in the parent type. This has
9990 -- already been achieved by the call to New_Copy above.
9992 if not Is_Tagged
then
9993 Set_Original_Record_Component
(New_C
, New_C
);
9996 -- If we have inherited a component then see if its Etype contains
9997 -- references to Parent_Base discriminants. In this case, replace
9998 -- these references with the constraints given in Discs. We do not
9999 -- do this for the partial view of private types because this is
10000 -- not needed (only the components of the full view will be used
10001 -- for code generation) and cause problem. We also avoid this
10002 -- transformation in some error situations.
10004 if Ekind
(New_C
) = E_Component
then
10005 if (Is_Private_Type
(Derived_Base
)
10006 and then not Is_Generic_Type
(Derived_Base
))
10007 or else (Is_Empty_Elmt_List
(Discs
)
10008 and then not Expander_Active
)
10010 Set_Etype
(New_C
, Etype
(Old_C
));
10012 Set_Etype
(New_C
, Constrain_Component_Type
(Etype
(Old_C
),
10013 Derived_Base
, N
, Parent_Base
, Discs
));
10017 -- In derived tagged types it is illegal to reference a non
10018 -- discriminant component in the parent type. To catch this, mark
10019 -- these components with an Ekind of E_Void. This will be reset in
10020 -- Record_Type_Definition after processing the record extension of
10021 -- the derived type.
10023 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
10024 Set_Ekind
(New_C
, E_Void
);
10027 if Plain_Discrim
then
10028 Set_Corresponding_Discriminant
(New_C
, Old_C
);
10029 Build_Discriminal
(New_C
);
10031 -- If we are explicitly inheriting a girder discriminant it will be
10032 -- completely hidden.
10034 elsif Girder_Discrim
then
10035 Set_Corresponding_Discriminant
(New_C
, Empty
);
10036 Set_Discriminal
(New_C
, Empty
);
10037 Set_Is_Completely_Hidden
(New_C
);
10039 -- Set the Original_Record_Component of each discriminant in the
10040 -- derived base to point to the corresponding girder that we just
10043 Discrim
:= First_Discriminant
(Derived_Base
);
10044 while Present
(Discrim
) loop
10045 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
10047 -- Corr_Discrimm could be missing in an error situation.
10049 if Present
(Corr_Discrim
)
10050 and then Original_Record_Component
(Corr_Discrim
) = Old_C
10052 Set_Original_Record_Component
(Discrim
, New_C
);
10055 Next_Discriminant
(Discrim
);
10058 Append_Entity
(New_C
, Derived_Base
);
10061 if not Is_Tagged
then
10062 Append_Elmt
(Old_C
, Assoc_List
);
10063 Append_Elmt
(New_C
, Assoc_List
);
10065 end Inherit_Component
;
10067 -- Variables local to Inherit_Components.
10069 Loc
: constant Source_Ptr
:= Sloc
(N
);
10071 Parent_Discrim
: Entity_Id
;
10072 Girder_Discrim
: Entity_Id
;
10075 Component
: Entity_Id
;
10077 -- Start of processing for Inherit_Components
10080 if not Is_Tagged
then
10081 Append_Elmt
(Parent_Base
, Assoc_List
);
10082 Append_Elmt
(Derived_Base
, Assoc_List
);
10085 -- Inherit parent discriminants if needed.
10087 if Inherit_Discr
then
10088 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
10089 while Present
(Parent_Discrim
) loop
10090 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
10091 Next_Discriminant
(Parent_Discrim
);
10095 -- Create explicit girder discrims for untagged types when necessary.
10097 if not Has_Unknown_Discriminants
(Derived_Base
)
10098 and then Has_Discriminants
(Parent_Base
)
10099 and then not Is_Tagged
10102 or else First_Discriminant
(Parent_Base
) /=
10103 First_Girder_Discriminant
(Parent_Base
))
10105 Girder_Discrim
:= First_Girder_Discriminant
(Parent_Base
);
10106 while Present
(Girder_Discrim
) loop
10107 Inherit_Component
(Girder_Discrim
, Girder_Discrim
=> True);
10108 Next_Girder_Discriminant
(Girder_Discrim
);
10112 -- See if we can apply the second transformation for derived types, as
10113 -- explained in point 6. in the comments above Build_Derived_Record_Type
10114 -- This is achieved by appending Derived_Base discriminants into
10115 -- Discs, which has the side effect of returning a non empty Discs
10116 -- list to the caller of Inherit_Components, which is what we want.
10119 and then Is_Empty_Elmt_List
(Discs
)
10120 and then (not Is_Private_Type
(Derived_Base
)
10121 or Is_Generic_Type
(Derived_Base
))
10123 D
:= First_Discriminant
(Derived_Base
);
10124 while Present
(D
) loop
10125 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
10126 Next_Discriminant
(D
);
10130 -- Finally, inherit non-discriminant components unless they are not
10131 -- visible because defined or inherited from the full view of the
10132 -- parent. Don't inherit the _parent field of the parent type.
10134 Component
:= First_Entity
(Parent_Base
);
10135 while Present
(Component
) loop
10136 if Ekind
(Component
) /= E_Component
10137 or else Chars
(Component
) = Name_uParent
10141 -- If the derived type is within the parent type's declarative
10142 -- region, then the components can still be inherited even though
10143 -- they aren't visible at this point. This can occur for cases
10144 -- such as within public child units where the components must
10145 -- become visible upon entering the child unit's private part.
10147 elsif not Is_Visible_Component
(Component
)
10148 and then not In_Open_Scopes
(Scope
(Parent_Base
))
10152 elsif Ekind
(Derived_Base
) = E_Private_Type
10153 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
10158 Inherit_Component
(Component
);
10161 Next_Entity
(Component
);
10164 -- For tagged derived types, inherited discriminants cannot be used in
10165 -- component declarations of the record extension part. To achieve this
10166 -- we mark the inherited discriminants as not visible.
10168 if Is_Tagged
and then Inherit_Discr
then
10169 D
:= First_Discriminant
(Derived_Base
);
10170 while Present
(D
) loop
10171 Set_Is_Immediately_Visible
(D
, False);
10172 Next_Discriminant
(D
);
10177 end Inherit_Components
;
10179 ------------------------------
10180 -- Is_Valid_Constraint_Kind --
10181 ------------------------------
10183 function Is_Valid_Constraint_Kind
10184 (T_Kind
: Type_Kind
;
10185 Constraint_Kind
: Node_Kind
)
10191 when Enumeration_Kind |
10193 return Constraint_Kind
= N_Range_Constraint
;
10195 when Decimal_Fixed_Point_Kind
=>
10197 Constraint_Kind
= N_Digits_Constraint
10199 Constraint_Kind
= N_Range_Constraint
;
10201 when Ordinary_Fixed_Point_Kind
=>
10203 Constraint_Kind
= N_Delta_Constraint
10205 Constraint_Kind
= N_Range_Constraint
;
10209 Constraint_Kind
= N_Digits_Constraint
10211 Constraint_Kind
= N_Range_Constraint
;
10218 E_Incomplete_Type |
10221 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
10224 return True; -- Error will be detected later.
10227 end Is_Valid_Constraint_Kind
;
10229 --------------------------
10230 -- Is_Visible_Component --
10231 --------------------------
10233 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
10234 Original_Comp
: constant Entity_Id
:= Original_Record_Component
(C
);
10235 Original_Scope
: Entity_Id
;
10238 if No
(Original_Comp
) then
10240 -- Premature usage, or previous error
10245 Original_Scope
:= Scope
(Original_Comp
);
10248 -- This test only concern tagged types
10250 if not Is_Tagged_Type
(Original_Scope
) then
10253 -- If it is _Parent or _Tag, there is no visiblity issue
10255 elsif not Comes_From_Source
(Original_Comp
) then
10258 -- If we are in the body of an instantiation, the component is
10259 -- visible even when the parent type (possibly defined in an
10260 -- enclosing unit or in a parent unit) might not.
10262 elsif In_Instance_Body
then
10265 -- Discriminants are always visible.
10267 elsif Ekind
(Original_Comp
) = E_Discriminant
10268 and then not Has_Unknown_Discriminants
(Original_Scope
)
10272 -- If the component has been declared in an ancestor which is
10273 -- currently a private type, then it is not visible. The same
10274 -- applies if the component's containing type is not in an
10275 -- open scope and the original component's enclosing type
10276 -- is a visible full type of a private type (which can occur
10277 -- in cases where an attempt is being made to reference a
10278 -- component in a sibling package that is inherited from
10279 -- a visible component of a type in an ancestor package;
10280 -- the component in the sibling package should not be
10281 -- visible even though the component it inherited from
10282 -- is visible). This does not apply however in the case
10283 -- where the scope of the type is a private child unit.
10284 -- The latter suppression of visibility is needed for cases
10285 -- that are tested in B730006.
10287 elsif (Ekind
(Original_Comp
) /= E_Discriminant
10288 or else Has_Unknown_Discriminants
(Original_Scope
))
10290 (Is_Private_Type
(Original_Scope
)
10292 (not Is_Private_Descendant
(Scope
(Base_Type
(Scope
(C
))))
10293 and then not In_Open_Scopes
(Scope
(Base_Type
(Scope
(C
))))
10294 and then Has_Private_Declaration
(Original_Scope
)))
10298 -- There is another weird way in which a component may be invisible
10299 -- when the private and the full view are not derived from the same
10300 -- ancestor. Here is an example :
10302 -- type A1 is tagged record F1 : integer; end record;
10303 -- type A2 is new A1 with record F2 : integer; end record;
10304 -- type T is new A1 with private;
10306 -- type T is new A2 with private;
10308 -- In this case, the full view of T inherits F1 and F2 but the
10309 -- private view inherits only F1
10313 Ancestor
: Entity_Id
:= Scope
(C
);
10317 if Ancestor
= Original_Scope
then
10319 elsif Ancestor
= Etype
(Ancestor
) then
10323 Ancestor
:= Etype
(Ancestor
);
10329 end Is_Visible_Component
;
10331 --------------------------
10332 -- Make_Class_Wide_Type --
10333 --------------------------
10335 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
10336 CW_Type
: Entity_Id
;
10338 Next_E
: Entity_Id
;
10341 -- The class wide type can have been defined by the partial view in
10342 -- which case everything is already done
10344 if Present
(Class_Wide_Type
(T
)) then
10349 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
10351 -- Inherit root type characteristics
10353 CW_Name
:= Chars
(CW_Type
);
10354 Next_E
:= Next_Entity
(CW_Type
);
10355 Copy_Node
(T
, CW_Type
);
10356 Set_Comes_From_Source
(CW_Type
, False);
10357 Set_Chars
(CW_Type
, CW_Name
);
10358 Set_Parent
(CW_Type
, Parent
(T
));
10359 Set_Next_Entity
(CW_Type
, Next_E
);
10360 Set_Has_Delayed_Freeze
(CW_Type
);
10362 -- Customize the class-wide type: It has no prim. op., it cannot be
10363 -- abstract and its Etype points back to the specific root type.
10365 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
10366 Set_Is_Tagged_Type
(CW_Type
, True);
10367 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
10368 Set_Is_Abstract
(CW_Type
, False);
10369 Set_Is_Constrained
(CW_Type
, False);
10370 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
10371 Init_Size_Align
(CW_Type
);
10373 if Ekind
(T
) = E_Class_Wide_Subtype
then
10374 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
10376 Set_Etype
(CW_Type
, T
);
10379 -- If this is the class_wide type of a constrained subtype, it does
10380 -- not have discriminants.
10382 Set_Has_Discriminants
(CW_Type
,
10383 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
10385 Set_Has_Unknown_Discriminants
(CW_Type
, True);
10386 Set_Class_Wide_Type
(T
, CW_Type
);
10387 Set_Equivalent_Type
(CW_Type
, Empty
);
10389 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
10391 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
10393 end Make_Class_Wide_Type
;
10399 procedure Make_Index
10401 Related_Nod
: Node_Id
;
10402 Related_Id
: Entity_Id
:= Empty
;
10403 Suffix_Index
: Nat
:= 1)
10407 Def_Id
: Entity_Id
:= Empty
;
10408 Found
: Boolean := False;
10411 -- For a discrete range used in a constrained array definition and
10412 -- defined by a range, an implicit conversion to the predefined type
10413 -- INTEGER is assumed if each bound is either a numeric literal, a named
10414 -- number, or an attribute, and the type of both bounds (prior to the
10415 -- implicit conversion) is the type universal_integer. Otherwise, both
10416 -- bounds must be of the same discrete type, other than universal
10417 -- integer; this type must be determinable independently of the
10418 -- context, but using the fact that the type must be discrete and that
10419 -- both bounds must have the same type.
10421 -- Character literals also have a universal type in the absence of
10422 -- of additional context, and are resolved to Standard_Character.
10424 if Nkind
(I
) = N_Range
then
10426 -- The index is given by a range constraint. The bounds are known
10427 -- to be of a consistent type.
10429 if not Is_Overloaded
(I
) then
10432 -- If the bounds are universal, choose the specific predefined
10435 if T
= Universal_Integer
then
10436 T
:= Standard_Integer
;
10438 elsif T
= Any_Character
then
10442 ("ambiguous character literals (could be Wide_Character)",
10446 T
:= Standard_Character
;
10453 Ind
: Interp_Index
;
10457 Get_First_Interp
(I
, Ind
, It
);
10459 while Present
(It
.Typ
) loop
10460 if Is_Discrete_Type
(It
.Typ
) then
10463 and then not Covers
(It
.Typ
, T
)
10464 and then not Covers
(T
, It
.Typ
)
10466 Error_Msg_N
("ambiguous bounds in discrete range", I
);
10474 Get_Next_Interp
(Ind
, It
);
10477 if T
= Any_Type
then
10478 Error_Msg_N
("discrete type required for range", I
);
10479 Set_Etype
(I
, Any_Type
);
10482 elsif T
= Universal_Integer
then
10483 T
:= Standard_Integer
;
10488 if not Is_Discrete_Type
(T
) then
10489 Error_Msg_N
("discrete type required for range", I
);
10490 Set_Etype
(I
, Any_Type
);
10495 Process_Range_Expr_In_Decl
(R
, T
);
10497 elsif Nkind
(I
) = N_Subtype_Indication
then
10499 -- The index is given by a subtype with a range constraint.
10501 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
10503 if not Is_Discrete_Type
(T
) then
10504 Error_Msg_N
("discrete type required for range", I
);
10505 Set_Etype
(I
, Any_Type
);
10509 R
:= Range_Expression
(Constraint
(I
));
10512 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
10514 elsif Nkind
(I
) = N_Attribute_Reference
then
10516 -- The parser guarantees that the attribute is a RANGE attribute
10518 Analyze_And_Resolve
(I
);
10522 -- If none of the above, must be a subtype. We convert this to a
10523 -- range attribute reference because in the case of declared first
10524 -- named subtypes, the types in the range reference can be different
10525 -- from the type of the entity. A range attribute normalizes the
10526 -- reference and obtains the correct types for the bounds.
10528 -- This transformation is in the nature of an expansion, is only
10529 -- done if expansion is active. In particular, it is not done on
10530 -- formal generic types, because we need to retain the name of the
10531 -- original index for instantiation purposes.
10534 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
10535 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
10536 Set_Etype
(I
, Any_Integer
);
10539 -- The type mark may be that of an incomplete type. It is only
10540 -- now that we can get the full view, previous analysis does
10541 -- not look specifically for a type mark.
10543 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
10544 Set_Etype
(I
, Entity
(I
));
10545 Def_Id
:= Entity
(I
);
10547 if not Is_Discrete_Type
(Def_Id
) then
10548 Error_Msg_N
("discrete type required for index", I
);
10549 Set_Etype
(I
, Any_Type
);
10554 if Expander_Active
then
10556 Make_Attribute_Reference
(Sloc
(I
),
10557 Attribute_Name
=> Name_Range
,
10558 Prefix
=> Relocate_Node
(I
)));
10560 -- The original was a subtype mark that does not freeze. This
10561 -- means that the rewritten version must not freeze either.
10563 Set_Must_Not_Freeze
(I
);
10564 Set_Must_Not_Freeze
(Prefix
(I
));
10566 -- Is order critical??? if so, document why, if not
10567 -- use Analyze_And_Resolve
10575 -- Type is legal, nothing else to construct.
10580 if not Is_Discrete_Type
(T
) then
10581 Error_Msg_N
("discrete type required for range", I
);
10582 Set_Etype
(I
, Any_Type
);
10585 elsif T
= Any_Type
then
10586 Set_Etype
(I
, Any_Type
);
10590 -- We will now create the appropriate Itype to describe the
10591 -- range, but first a check. If we originally had a subtype,
10592 -- then we just label the range with this subtype. Not only
10593 -- is there no need to construct a new subtype, but it is wrong
10594 -- to do so for two reasons:
10596 -- 1. A legality concern, if we have a subtype, it must not
10597 -- freeze, and the Itype would cause freezing incorrectly
10599 -- 2. An efficiency concern, if we created an Itype, it would
10600 -- not be recognized as the same type for the purposes of
10601 -- eliminating checks in some circumstances.
10603 -- We signal this case by setting the subtype entity in Def_Id.
10605 -- It would be nice to also do this optimization for the cases
10606 -- of X'Range and also the explicit range X'First .. X'Last,
10607 -- but that is not done yet (it is just an efficiency concern) ???
10609 if No
(Def_Id
) then
10612 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
10613 Set_Etype
(Def_Id
, Base_Type
(T
));
10615 if Is_Signed_Integer_Type
(T
) then
10616 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
10618 elsif Is_Modular_Integer_Type
(T
) then
10619 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
10622 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
10623 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
10626 Set_Size_Info
(Def_Id
, (T
));
10627 Set_RM_Size
(Def_Id
, RM_Size
(T
));
10628 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
10630 Set_Scalar_Range
(Def_Id
, R
);
10631 Conditional_Delay
(Def_Id
, T
);
10633 -- In the subtype indication case, if the immediate parent of the
10634 -- new subtype is non-static, then the subtype we create is non-
10635 -- static, even if its bounds are static.
10637 if Nkind
(I
) = N_Subtype_Indication
10638 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
10640 Set_Is_Non_Static_Subtype
(Def_Id
);
10644 -- Final step is to label the index with this constructed type
10646 Set_Etype
(I
, Def_Id
);
10649 ------------------------------
10650 -- Modular_Type_Declaration --
10651 ------------------------------
10653 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
10654 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
10657 procedure Set_Modular_Size
(Bits
: Int
);
10658 -- Sets RM_Size to Bits, and Esize to normal word size above this
10660 procedure Set_Modular_Size
(Bits
: Int
) is
10662 Set_RM_Size
(T
, UI_From_Int
(Bits
));
10667 elsif Bits
<= 16 then
10668 Init_Esize
(T
, 16);
10670 elsif Bits
<= 32 then
10671 Init_Esize
(T
, 32);
10674 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
10676 end Set_Modular_Size
;
10678 -- Start of processing for Modular_Type_Declaration
10681 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
10683 Set_Ekind
(T
, E_Modular_Integer_Type
);
10684 Init_Alignment
(T
);
10685 Set_Is_Constrained
(T
);
10687 if not Is_OK_Static_Expression
(Mod_Expr
) then
10689 ("non-static expression used for modular type bound", Mod_Expr
);
10690 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
10692 M_Val
:= Expr_Value
(Mod_Expr
);
10696 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
10697 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
10700 Set_Modulus
(T
, M_Val
);
10702 -- Create bounds for the modular type based on the modulus given in
10703 -- the type declaration and then analyze and resolve those bounds.
10705 Set_Scalar_Range
(T
,
10706 Make_Range
(Sloc
(Mod_Expr
),
10708 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
10710 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
10712 -- Properly analyze the literals for the range. We do this manually
10713 -- because we can't go calling Resolve, since we are resolving these
10714 -- bounds with the type, and this type is certainly not complete yet!
10716 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
10717 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
10718 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
10719 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
10721 -- Loop through powers of two to find number of bits required
10723 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
10727 if M_Val
= 2 ** Bits
then
10728 Set_Modular_Size
(Bits
);
10733 elsif M_Val
< 2 ** Bits
then
10734 Set_Non_Binary_Modulus
(T
);
10736 if Bits
> System_Max_Nonbinary_Modulus_Power
then
10737 Error_Msg_Uint_1
:=
10738 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
10740 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
10741 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
10745 -- In the non-binary case, set size as per RM 13.3(55).
10747 Set_Modular_Size
(Bits
);
10754 -- If we fall through, then the size exceed System.Max_Binary_Modulus
10755 -- so we just signal an error and set the maximum size.
10757 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
10758 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
10760 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
10761 Init_Alignment
(T
);
10763 end Modular_Type_Declaration
;
10765 -------------------------
10766 -- New_Binary_Operator --
10767 -------------------------
10769 procedure New_Binary_Operator
(Op_Name
: Name_Id
; Typ
: Entity_Id
) is
10770 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10773 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
10774 -- Create abbreviated declaration for the formal of a predefined
10775 -- Operator 'Op' of type 'Typ'
10777 --------------------
10778 -- Make_Op_Formal --
10779 --------------------
10781 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
10782 Formal
: Entity_Id
;
10785 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
10786 Set_Etype
(Formal
, Typ
);
10787 Set_Mechanism
(Formal
, Default_Mechanism
);
10789 end Make_Op_Formal
;
10791 -- Start of processing for New_Binary_Operator
10794 Op
:= Make_Defining_Operator_Symbol
(Loc
, Op_Name
);
10796 Set_Ekind
(Op
, E_Operator
);
10797 Set_Scope
(Op
, Current_Scope
);
10798 Set_Etype
(Op
, Typ
);
10799 Set_Homonym
(Op
, Get_Name_Entity_Id
(Op_Name
));
10800 Set_Is_Immediately_Visible
(Op
);
10801 Set_Is_Intrinsic_Subprogram
(Op
);
10802 Set_Has_Completion
(Op
);
10803 Append_Entity
(Op
, Current_Scope
);
10805 Set_Name_Entity_Id
(Op_Name
, Op
);
10807 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
10808 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
10810 end New_Binary_Operator
;
10812 -------------------------------------------
10813 -- Ordinary_Fixed_Point_Type_Declaration --
10814 -------------------------------------------
10816 procedure Ordinary_Fixed_Point_Type_Declaration
10820 Loc
: constant Source_Ptr
:= Sloc
(Def
);
10821 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
10822 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
10823 Implicit_Base
: Entity_Id
;
10830 Check_Restriction
(No_Fixed_Point
, Def
);
10832 -- Create implicit base type
10835 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
10836 Set_Etype
(Implicit_Base
, Implicit_Base
);
10838 -- Analyze and process delta expression
10840 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
10842 Check_Delta_Expression
(Delta_Expr
);
10843 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
10845 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
10847 -- Compute default small from given delta, which is the largest
10848 -- power of two that does not exceed the given delta value.
10851 Tmp
: Ureal
:= Ureal_1
;
10855 if Delta_Val
< Ureal_1
then
10856 while Delta_Val
< Tmp
loop
10857 Tmp
:= Tmp
/ Ureal_2
;
10858 Scale
:= Scale
+ 1;
10863 Tmp
:= Tmp
* Ureal_2
;
10864 exit when Tmp
> Delta_Val
;
10865 Scale
:= Scale
- 1;
10869 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
10872 Set_Small_Value
(Implicit_Base
, Small_Val
);
10874 -- If no range was given, set a dummy range
10876 if RRS
<= Empty_Or_Error
then
10877 Low_Val
:= -Small_Val
;
10878 High_Val
:= Small_Val
;
10880 -- Otherwise analyze and process given range
10884 Low
: constant Node_Id
:= Low_Bound
(RRS
);
10885 High
: constant Node_Id
:= High_Bound
(RRS
);
10888 Analyze_And_Resolve
(Low
, Any_Real
);
10889 Analyze_And_Resolve
(High
, Any_Real
);
10890 Check_Real_Bound
(Low
);
10891 Check_Real_Bound
(High
);
10893 -- Obtain and set the range
10895 Low_Val
:= Expr_Value_R
(Low
);
10896 High_Val
:= Expr_Value_R
(High
);
10898 if Low_Val
> High_Val
then
10899 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
10904 -- The range for both the implicit base and the declared first
10905 -- subtype cannot be set yet, so we use the special routine
10906 -- Set_Fixed_Range to set a temporary range in place. Note that
10907 -- the bounds of the base type will be widened to be symmetrical
10908 -- and to fill the available bits when the type is frozen.
10910 -- We could do this with all discrete types, and probably should, but
10911 -- we absolutely have to do it for fixed-point, since the end-points
10912 -- of the range and the size are determined by the small value, which
10913 -- could be reset before the freeze point.
10915 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
10916 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
10918 Init_Size_Align
(Implicit_Base
);
10920 -- Complete definition of first subtype
10922 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
10923 Set_Etype
(T
, Implicit_Base
);
10924 Init_Size_Align
(T
);
10925 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
10926 Set_Small_Value
(T
, Small_Val
);
10927 Set_Delta_Value
(T
, Delta_Val
);
10928 Set_Is_Constrained
(T
);
10930 end Ordinary_Fixed_Point_Type_Declaration
;
10932 ----------------------------------------
10933 -- Prepare_Private_Subtype_Completion --
10934 ----------------------------------------
10936 procedure Prepare_Private_Subtype_Completion
10938 Related_Nod
: Node_Id
)
10940 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
10941 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
10945 if Present
(Full_B
) then
10947 -- The Base_Type is already completed, we can complete the
10948 -- subtype now. We have to create a new entity with the same name,
10949 -- Thus we can't use Create_Itype.
10950 -- This is messy, should be fixed ???
10952 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
10953 Set_Is_Itype
(Full
);
10954 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
10955 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
10958 -- The parent subtype may be private, but the base might not, in some
10959 -- nested instances. In that case, the subtype does not need to be
10960 -- exchanged. It would still be nice to make private subtypes and their
10961 -- bases consistent at all times ???
10963 if Is_Private_Type
(Id_B
) then
10964 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
10967 end Prepare_Private_Subtype_Completion
;
10969 ---------------------------
10970 -- Process_Discriminants --
10971 ---------------------------
10973 procedure Process_Discriminants
(N
: Node_Id
) is
10976 Discr_Number
: Uint
;
10977 Discr_Type
: Entity_Id
;
10978 Default_Present
: Boolean := False;
10979 Default_Not_Present
: Boolean := False;
10980 Elist
: Elist_Id
:= New_Elmt_List
;
10983 -- A composite type other than an array type can have discriminants.
10984 -- Discriminants of non-limited types must have a discrete type.
10985 -- On entry, the current scope is the composite type.
10987 -- The discriminants are initially entered into the scope of the type
10988 -- via Enter_Name with the default Ekind of E_Void to prevent premature
10989 -- use, as explained at the end of this procedure.
10991 Discr
:= First
(Discriminant_Specifications
(N
));
10992 while Present
(Discr
) loop
10993 Enter_Name
(Defining_Identifier
(Discr
));
10995 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
10996 Discr_Type
:= Access_Definition
(N
, Discriminant_Type
(Discr
));
10999 Find_Type
(Discriminant_Type
(Discr
));
11000 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
11002 if Error_Posted
(Discriminant_Type
(Discr
)) then
11003 Discr_Type
:= Any_Type
;
11007 if Is_Access_Type
(Discr_Type
) then
11008 Check_Access_Discriminant_Requires_Limited
11009 (Discr
, Discriminant_Type
(Discr
));
11011 if Ada_83
and then Comes_From_Source
(Discr
) then
11013 ("(Ada 83) access discriminant not allowed", Discr
);
11016 elsif not Is_Discrete_Type
(Discr_Type
) then
11017 Error_Msg_N
("discriminants must have a discrete or access type",
11018 Discriminant_Type
(Discr
));
11021 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
11023 -- If a discriminant specification includes the assignment compound
11024 -- delimiter followed by an expression, the expression is the default
11025 -- expression of the discriminant; the default expression must be of
11026 -- the type of the discriminant. (RM 3.7.1) Since this expression is
11027 -- a default expression, we do the special preanalysis, since this
11028 -- expression does not freeze (see "Handling of Default Expressions"
11029 -- in spec of package Sem).
11031 if Present
(Expression
(Discr
)) then
11032 Analyze_Default_Expression
(Expression
(Discr
), Discr_Type
);
11034 if Nkind
(N
) = N_Formal_Type_Declaration
then
11036 ("discriminant defaults not allowed for formal type",
11037 Expression
(Discr
));
11039 elsif Is_Tagged_Type
(Current_Scope
) then
11041 ("discriminants of tagged type cannot have defaults",
11042 Expression
(Discr
));
11045 Default_Present
:= True;
11046 Append_Elmt
(Expression
(Discr
), Elist
);
11048 -- Tag the defining identifiers for the discriminants with
11049 -- their corresponding default expressions from the tree.
11051 Set_Discriminant_Default_Value
11052 (Defining_Identifier
(Discr
), Expression
(Discr
));
11056 Default_Not_Present
:= True;
11062 -- An element list consisting of the default expressions of the
11063 -- discriminants is constructed in the above loop and used to set
11064 -- the Discriminant_Constraint attribute for the type. If an object
11065 -- is declared of this (record or task) type without any explicit
11066 -- discriminant constraint given, this element list will form the
11067 -- actual parameters for the corresponding initialization procedure
11070 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
11071 Set_Girder_Constraint
(Current_Scope
, No_Elist
);
11073 -- Default expressions must be provided either for all or for none
11074 -- of the discriminants of a discriminant part. (RM 3.7.1)
11076 if Default_Present
and then Default_Not_Present
then
11078 ("incomplete specification of defaults for discriminants", N
);
11081 -- The use of the name of a discriminant is not allowed in default
11082 -- expressions of a discriminant part if the specification of the
11083 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
11085 -- To detect this, the discriminant names are entered initially with an
11086 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
11087 -- attempt to use a void entity (for example in an expression that is
11088 -- type-checked) produces the error message: premature usage. Now after
11089 -- completing the semantic analysis of the discriminant part, we can set
11090 -- the Ekind of all the discriminants appropriately.
11092 Discr
:= First
(Discriminant_Specifications
(N
));
11093 Discr_Number
:= Uint_1
;
11095 while Present
(Discr
) loop
11096 Id
:= Defining_Identifier
(Discr
);
11097 Set_Ekind
(Id
, E_Discriminant
);
11098 Init_Component_Location
(Id
);
11100 Set_Discriminant_Number
(Id
, Discr_Number
);
11102 -- Make sure this is always set, even in illegal programs
11104 Set_Corresponding_Discriminant
(Id
, Empty
);
11106 -- Initialize the Original_Record_Component to the entity itself.
11107 -- Inherit_Components will propagate the right value to
11108 -- discriminants in derived record types.
11110 Set_Original_Record_Component
(Id
, Id
);
11112 -- Create the discriminal for the discriminant.
11114 Build_Discriminal
(Id
);
11117 Discr_Number
:= Discr_Number
+ 1;
11120 Set_Has_Discriminants
(Current_Scope
);
11121 end Process_Discriminants
;
11123 -----------------------
11124 -- Process_Full_View --
11125 -----------------------
11127 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
11128 Priv_Parent
: Entity_Id
;
11129 Full_Parent
: Entity_Id
;
11130 Full_Indic
: Node_Id
;
11133 -- First some sanity checks that must be done after semantic
11134 -- decoration of the full view and thus cannot be placed with other
11135 -- similar checks in Find_Type_Name
11137 if not Is_Limited_Type
(Priv_T
)
11138 and then (Is_Limited_Type
(Full_T
)
11139 or else Is_Limited_Composite
(Full_T
))
11142 ("completion of nonlimited type cannot be limited", Full_T
);
11144 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
11146 ("completion of nonabstract type cannot be abstract", Full_T
);
11148 elsif Is_Tagged_Type
(Priv_T
)
11149 and then Is_Limited_Type
(Priv_T
)
11150 and then not Is_Limited_Type
(Full_T
)
11152 -- GNAT allow its own definition of Limited_Controlled to disobey
11153 -- this rule in order in ease the implementation. The next test is
11154 -- safe because Root_Controlled is defined in a private system child
11156 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
11157 Set_Is_Limited_Composite
(Full_T
);
11160 ("completion of limited tagged type must be limited", Full_T
);
11163 elsif Is_Generic_Type
(Priv_T
) then
11164 Error_Msg_N
("generic type cannot have a completion", Full_T
);
11167 if Is_Tagged_Type
(Priv_T
)
11168 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
11169 and then Is_Derived_Type
(Full_T
)
11171 Priv_Parent
:= Etype
(Priv_T
);
11173 -- The full view of a private extension may have been transformed
11174 -- into an unconstrained derived type declaration and a subtype
11175 -- declaration (see build_derived_record_type for details).
11177 if Nkind
(N
) = N_Subtype_Declaration
then
11178 Full_Indic
:= Subtype_Indication
(N
);
11179 Full_Parent
:= Etype
(Base_Type
(Full_T
));
11181 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
11182 Full_Parent
:= Etype
(Full_T
);
11185 -- Check that the parent type of the full type is a descendant of
11186 -- the ancestor subtype given in the private extension. If either
11187 -- entity has an Etype equal to Any_Type then we had some previous
11188 -- error situation [7.3(8)].
11190 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
11193 elsif not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
) then
11195 ("parent of full type must descend from parent"
11196 & " of private extension", Full_Indic
);
11198 -- Check the rules of 7.3(10): if the private extension inherits
11199 -- known discriminants, then the full type must also inherit those
11200 -- discriminants from the same (ancestor) type, and the parent
11201 -- subtype of the full type must be constrained if and only if
11202 -- the ancestor subtype of the private extension is constrained.
11204 elsif not Present
(Discriminant_Specifications
(Parent
(Priv_T
)))
11205 and then not Has_Unknown_Discriminants
(Priv_T
)
11206 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
11209 Priv_Indic
: constant Node_Id
:=
11210 Subtype_Indication
(Parent
(Priv_T
));
11212 Priv_Constr
: constant Boolean :=
11213 Is_Constrained
(Priv_Parent
)
11215 Nkind
(Priv_Indic
) = N_Subtype_Indication
11216 or else Is_Constrained
(Entity
(Priv_Indic
));
11218 Full_Constr
: constant Boolean :=
11219 Is_Constrained
(Full_Parent
)
11221 Nkind
(Full_Indic
) = N_Subtype_Indication
11222 or else Is_Constrained
(Entity
(Full_Indic
));
11224 Priv_Discr
: Entity_Id
;
11225 Full_Discr
: Entity_Id
;
11228 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
11229 Full_Discr
:= First_Discriminant
(Full_Parent
);
11231 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
11232 if Original_Record_Component
(Priv_Discr
) =
11233 Original_Record_Component
(Full_Discr
)
11235 Corresponding_Discriminant
(Priv_Discr
) =
11236 Corresponding_Discriminant
(Full_Discr
)
11243 Next_Discriminant
(Priv_Discr
);
11244 Next_Discriminant
(Full_Discr
);
11247 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
11249 ("full view must inherit discriminants of the parent type"
11250 & " used in the private extension", Full_Indic
);
11252 elsif Priv_Constr
and then not Full_Constr
then
11254 ("parent subtype of full type must be constrained",
11257 elsif Full_Constr
and then not Priv_Constr
then
11259 ("parent subtype of full type must be unconstrained",
11264 -- Check the rules of 7.3(12): if a partial view has neither known
11265 -- or unknown discriminants, then the full type declaration shall
11266 -- define a definite subtype.
11268 elsif not Has_Unknown_Discriminants
(Priv_T
)
11269 and then not Has_Discriminants
(Priv_T
)
11270 and then not Is_Constrained
(Full_T
)
11273 ("full view must define a constrained type if partial view"
11274 & " has no discriminants", Full_T
);
11277 -- ??????? Do we implement the following properly ?????
11278 -- If the ancestor subtype of a private extension has constrained
11279 -- discriminants, then the parent subtype of the full view shall
11280 -- impose a statically matching constraint on those discriminants
11284 -- For untagged types, verify that a type without discriminants
11285 -- is not completed with an unconstrained type.
11287 if not Is_Indefinite_Subtype
(Priv_T
)
11288 and then Is_Indefinite_Subtype
(Full_T
)
11290 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
11294 -- Create a full declaration for all its subtypes recorded in
11295 -- Private_Dependents and swap them similarly to the base type.
11296 -- These are subtypes that have been define before the full
11297 -- declaration of the private type. We also swap the entry in
11298 -- Private_Dependents list so we can properly restore the
11299 -- private view on exit from the scope.
11302 Priv_Elmt
: Elmt_Id
;
11307 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
11308 while Present
(Priv_Elmt
) loop
11309 Priv
:= Node
(Priv_Elmt
);
11311 if Ekind
(Priv
) = E_Private_Subtype
11312 or else Ekind
(Priv
) = E_Limited_Private_Subtype
11313 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
11315 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
11316 Set_Is_Itype
(Full
);
11317 Set_Parent
(Full
, Parent
(Priv
));
11318 Set_Associated_Node_For_Itype
(Full
, N
);
11320 -- Now we need to complete the private subtype, but since the
11321 -- base type has already been swapped, we must also swap the
11322 -- subtypes (and thus, reverse the arguments in the call to
11323 -- Complete_Private_Subtype).
11325 Copy_And_Swap
(Priv
, Full
);
11326 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
11327 Replace_Elmt
(Priv_Elmt
, Full
);
11330 Next_Elmt
(Priv_Elmt
);
11334 -- If the private view was tagged, copy the new Primitive
11335 -- operations from the private view to the full view.
11337 if Is_Tagged_Type
(Full_T
) then
11339 Priv_List
: Elist_Id
;
11340 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
11343 D_Type
: Entity_Id
;
11346 if Is_Tagged_Type
(Priv_T
) then
11347 Priv_List
:= Primitive_Operations
(Priv_T
);
11349 P1
:= First_Elmt
(Priv_List
);
11350 while Present
(P1
) loop
11353 -- Transfer explicit primitives, not those inherited from
11354 -- parent of partial view, which will be re-inherited on
11357 if Comes_From_Source
(Prim
) then
11358 P2
:= First_Elmt
(Full_List
);
11359 while Present
(P2
) and then Node
(P2
) /= Prim
loop
11363 -- If not found, that is a new one
11366 Append_Elmt
(Prim
, Full_List
);
11374 -- In this case the partial view is untagged, so here we
11375 -- locate all of the earlier primitives that need to be
11376 -- treated as dispatching (those that appear between the
11377 -- two views). Note that these additional operations must
11378 -- all be new operations (any earlier operations that
11379 -- override inherited operations of the full view will
11380 -- already have been inserted in the primitives list and
11381 -- marked as dispatching by Check_Operation_From_Private_View.
11382 -- Note that implicit "/=" operators are excluded from being
11383 -- added to the primitives list since they shouldn't be
11384 -- treated as dispatching (tagged "/=" is handled specially).
11386 Prim
:= Next_Entity
(Full_T
);
11387 while Present
(Prim
) and then Prim
/= Priv_T
loop
11388 if (Ekind
(Prim
) = E_Procedure
11389 or else Ekind
(Prim
) = E_Function
)
11392 D_Type
:= Find_Dispatching_Type
(Prim
);
11395 and then (Chars
(Prim
) /= Name_Op_Ne
11396 or else Comes_From_Source
(Prim
))
11398 Check_Controlling_Formals
(Full_T
, Prim
);
11400 if not Is_Dispatching_Operation
(Prim
) then
11401 Append_Elmt
(Prim
, Full_List
);
11402 Set_Is_Dispatching_Operation
(Prim
, True);
11403 Set_DT_Position
(Prim
, No_Uint
);
11406 elsif Is_Dispatching_Operation
(Prim
)
11407 and then D_Type
/= Full_T
11410 -- Verify that it is not otherwise controlled by
11411 -- a formal or a return value ot type T.
11413 Check_Controlling_Formals
(D_Type
, Prim
);
11417 Next_Entity
(Prim
);
11421 -- For the tagged case, the two views can share the same
11422 -- Primitive Operation list and the same class wide type.
11423 -- Update attributes of the class-wide type which depend on
11424 -- the full declaration.
11426 if Is_Tagged_Type
(Priv_T
) then
11427 Set_Primitive_Operations
(Priv_T
, Full_List
);
11428 Set_Class_Wide_Type
11429 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
11431 -- Any other attributes should be propagated to C_W ???
11433 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
11438 end Process_Full_View
;
11440 -----------------------------------
11441 -- Process_Incomplete_Dependents --
11442 -----------------------------------
11444 procedure Process_Incomplete_Dependents
11446 Full_T
: Entity_Id
;
11449 Inc_Elmt
: Elmt_Id
;
11450 Priv_Dep
: Entity_Id
;
11451 New_Subt
: Entity_Id
;
11453 Disc_Constraint
: Elist_Id
;
11456 if No
(Private_Dependents
(Inc_T
)) then
11460 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
11462 -- Itypes that may be generated by the completion of an incomplete
11463 -- subtype are not used by the back-end and not attached to the tree.
11464 -- They are created only for constraint-checking purposes.
11467 while Present
(Inc_Elmt
) loop
11468 Priv_Dep
:= Node
(Inc_Elmt
);
11470 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
11472 -- An Access_To_Subprogram type may have a return type or a
11473 -- parameter type that is incomplete. Replace with the full view.
11475 if Etype
(Priv_Dep
) = Inc_T
then
11476 Set_Etype
(Priv_Dep
, Full_T
);
11480 Formal
: Entity_Id
;
11483 Formal
:= First_Formal
(Priv_Dep
);
11485 while Present
(Formal
) loop
11487 if Etype
(Formal
) = Inc_T
then
11488 Set_Etype
(Formal
, Full_T
);
11491 Next_Formal
(Formal
);
11495 elsif Is_Overloadable
(Priv_Dep
) then
11497 if Is_Tagged_Type
(Full_T
) then
11499 -- Subprogram has an access parameter whose designated type
11500 -- was incomplete. Reexamine declaration now, because it may
11501 -- be a primitive operation of the full type.
11503 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
11504 Set_Is_Dispatching_Operation
(Priv_Dep
);
11505 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
11508 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
11510 -- Can happen during processing of a body before the completion
11511 -- of a TA type. Ignore, because spec is also on dependent list.
11515 -- Dependent is a subtype
11518 -- We build a new subtype indication using the full view of the
11519 -- incomplete parent. The discriminant constraints have been
11520 -- elaborated already at the point of the subtype declaration.
11522 New_Subt
:= Create_Itype
(E_Void
, N
);
11524 if Has_Discriminants
(Full_T
) then
11525 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
11527 Disc_Constraint
:= No_Elist
;
11530 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
11531 Set_Full_View
(Priv_Dep
, New_Subt
);
11534 Next_Elmt
(Inc_Elmt
);
11537 end Process_Incomplete_Dependents
;
11539 --------------------------------
11540 -- Process_Range_Expr_In_Decl --
11541 --------------------------------
11543 procedure Process_Range_Expr_In_Decl
11546 Check_List
: List_Id
:= Empty_List
;
11547 R_Check_Off
: Boolean := False)
11550 R_Checks
: Check_Result
;
11551 Type_Decl
: Node_Id
;
11552 Def_Id
: Entity_Id
;
11555 Analyze_And_Resolve
(R
, Base_Type
(T
));
11557 if Nkind
(R
) = N_Range
then
11558 Lo
:= Low_Bound
(R
);
11559 Hi
:= High_Bound
(R
);
11561 -- If there were errors in the declaration, try and patch up some
11562 -- common mistakes in the bounds. The cases handled are literals
11563 -- which are Integer where the expected type is Real and vice versa.
11564 -- These corrections allow the compilation process to proceed further
11565 -- along since some basic assumptions of the format of the bounds
11568 if Etype
(R
) = Any_Type
then
11570 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
11572 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
11574 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
11576 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
11578 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
11580 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
11582 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
11584 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
11591 -- If the bounds of the range have been mistakenly given as
11592 -- string literals (perhaps in place of character literals),
11593 -- then an error has already been reported, but we rewrite
11594 -- the string literal as a bound of the range's type to
11595 -- avoid blowups in later processing that looks at static
11598 if Nkind
(Lo
) = N_String_Literal
then
11600 Make_Attribute_Reference
(Sloc
(Lo
),
11601 Attribute_Name
=> Name_First
,
11602 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
11603 Analyze_And_Resolve
(Lo
);
11606 if Nkind
(Hi
) = N_String_Literal
then
11608 Make_Attribute_Reference
(Sloc
(Hi
),
11609 Attribute_Name
=> Name_First
,
11610 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
11611 Analyze_And_Resolve
(Hi
);
11614 -- If bounds aren't scalar at this point then exit, avoiding
11615 -- problems with further processing of the range in this procedure.
11617 if not Is_Scalar_Type
(Etype
(Lo
)) then
11621 -- Resolve (actually Sem_Eval) has checked that the bounds are in
11622 -- then range of the base type. Here we check whether the bounds
11623 -- are in the range of the subtype itself. Note that if the bounds
11624 -- represent the null range the Constraint_Error exception should
11627 -- ??? The following code should be cleaned up as follows
11628 -- 1. The Is_Null_Range (Lo, Hi) test should disapper since it
11629 -- is done in the call to Range_Check (R, T); below
11630 -- 2. The use of R_Check_Off should be investigated and possibly
11631 -- removed, this would clean up things a bit.
11633 if Is_Null_Range
(Lo
, Hi
) then
11637 -- We use a flag here instead of suppressing checks on the
11638 -- type because the type we check against isn't necessarily the
11639 -- place where we put the check.
11641 if not R_Check_Off
then
11642 R_Checks
:= Range_Check
(R
, T
);
11643 Type_Decl
:= Parent
(R
);
11645 -- Look up tree to find an appropriate insertion point.
11646 -- This seems really junk code, and very brittle, couldn't
11647 -- we just use an insert actions call of some kind ???
11649 while Present
(Type_Decl
) and then not
11650 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
11652 Nkind
(Type_Decl
) = N_Subtype_Declaration
11654 Nkind
(Type_Decl
) = N_Loop_Statement
11656 Nkind
(Type_Decl
) = N_Task_Type_Declaration
11658 Nkind
(Type_Decl
) = N_Single_Task_Declaration
11660 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
11662 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
11664 Type_Decl
:= Parent
(Type_Decl
);
11667 -- Why would Type_Decl not be present??? Without this test,
11668 -- short regression tests fail.
11670 if Present
(Type_Decl
) then
11671 if Nkind
(Type_Decl
) = N_Loop_Statement
then
11673 Indic
: Node_Id
:= Parent
(R
);
11675 while Present
(Indic
) and then not
11676 (Nkind
(Indic
) = N_Subtype_Indication
)
11678 Indic
:= Parent
(Indic
);
11681 if Present
(Indic
) then
11682 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
11684 Insert_Range_Checks
11690 Do_Before
=> True);
11694 Def_Id
:= Defining_Identifier
(Type_Decl
);
11696 if (Ekind
(Def_Id
) = E_Record_Type
11697 and then Depends_On_Discriminant
(R
))
11699 (Ekind
(Def_Id
) = E_Protected_Type
11700 and then Has_Discriminants
(Def_Id
))
11702 Append_Range_Checks
11703 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
11706 Insert_Range_Checks
11707 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
11716 Get_Index_Bounds
(R
, Lo
, Hi
);
11718 if Expander_Active
then
11719 Force_Evaluation
(Lo
);
11720 Force_Evaluation
(Hi
);
11723 end Process_Range_Expr_In_Decl
;
11725 --------------------------------------
11726 -- Process_Real_Range_Specification --
11727 --------------------------------------
11729 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
11730 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
11733 Err
: Boolean := False;
11735 procedure Analyze_Bound
(N
: Node_Id
);
11736 -- Analyze and check one bound
11738 procedure Analyze_Bound
(N
: Node_Id
) is
11740 Analyze_And_Resolve
(N
, Any_Real
);
11742 if not Is_OK_Static_Expression
(N
) then
11744 ("bound in real type definition is not static", N
);
11750 if Present
(Spec
) then
11751 Lo
:= Low_Bound
(Spec
);
11752 Hi
:= High_Bound
(Spec
);
11753 Analyze_Bound
(Lo
);
11754 Analyze_Bound
(Hi
);
11756 -- If error, clear away junk range specification
11759 Set_Real_Range_Specification
(Def
, Empty
);
11762 end Process_Real_Range_Specification
;
11764 ---------------------
11765 -- Process_Subtype --
11766 ---------------------
11768 function Process_Subtype
11770 Related_Nod
: Node_Id
;
11771 Related_Id
: Entity_Id
:= Empty
;
11772 Suffix
: Character := ' ')
11776 Def_Id
: Entity_Id
;
11777 Full_View_Id
: Entity_Id
;
11778 Subtype_Mark_Id
: Entity_Id
;
11779 N_Dynamic_Ityp
: Node_Id
:= Empty
;
11782 -- Case of constraint present, so that we have an N_Subtype_Indication
11783 -- node (this node is created only if constraints are present).
11785 if Nkind
(S
) = N_Subtype_Indication
then
11786 Find_Type
(Subtype_Mark
(S
));
11788 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
11790 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
11792 Is_Itype
(Defining_Identifier
(Parent
(S
))))
11794 Check_Incomplete
(Subtype_Mark
(S
));
11798 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
11800 if Is_Unchecked_Union
(Subtype_Mark_Id
)
11801 and then Comes_From_Source
(Related_Nod
)
11804 ("cannot create subtype of Unchecked_Union", Related_Nod
);
11807 -- Explicit subtype declaration case
11809 if Nkind
(P
) = N_Subtype_Declaration
then
11810 Def_Id
:= Defining_Identifier
(P
);
11812 -- Explicit derived type definition case
11814 elsif Nkind
(P
) = N_Derived_Type_Definition
then
11815 Def_Id
:= Defining_Identifier
(Parent
(P
));
11817 -- Implicit case, the Def_Id must be created as an implicit type.
11818 -- The one exception arises in the case of concurrent types,
11819 -- array and access types, where other subsidiary implicit types
11820 -- may be created and must appear before the main implicit type.
11821 -- In these cases we leave Def_Id set to Empty as a signal that
11822 -- Create_Itype has not yet been called to create Def_Id.
11825 if Is_Array_Type
(Subtype_Mark_Id
)
11826 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
11827 or else Is_Access_Type
(Subtype_Mark_Id
)
11831 -- For the other cases, we create a new unattached Itype,
11832 -- and set the indication to ensure it gets attached later.
11836 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
11839 N_Dynamic_Ityp
:= Related_Nod
;
11842 -- If the kind of constraint is invalid for this kind of type,
11843 -- then give an error, and then pretend no constraint was given.
11845 if not Is_Valid_Constraint_Kind
11846 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
11849 ("incorrect constraint for this kind of type", Constraint
(S
));
11851 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11853 -- Make recursive call, having got rid of the bogus constraint
11855 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
11858 -- Remaining processing depends on type
11860 case Ekind
(Subtype_Mark_Id
) is
11862 when Access_Kind
=>
11863 Constrain_Access
(Def_Id
, S
, Related_Nod
);
11866 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
11868 when Decimal_Fixed_Point_Kind
=>
11869 Constrain_Decimal
(Def_Id
, S
);
11871 when Enumeration_Kind
=>
11872 Constrain_Enumeration
(Def_Id
, S
);
11874 when Ordinary_Fixed_Point_Kind
=>
11875 Constrain_Ordinary_Fixed
(Def_Id
, S
);
11878 Constrain_Float
(Def_Id
, S
);
11880 when Integer_Kind
=>
11881 Constrain_Integer
(Def_Id
, S
);
11883 when E_Record_Type |
11886 E_Incomplete_Type
=>
11887 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
11889 when Private_Kind
=>
11890 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
11891 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
11893 -- In case of an invalid constraint prevent further processing
11894 -- since the type constructed is missing expected fields.
11896 if Etype
(Def_Id
) = Any_Type
then
11900 -- If the full view is that of a task with discriminants,
11901 -- we must constrain both the concurrent type and its
11902 -- corresponding record type. Otherwise we will just propagate
11903 -- the constraint to the full view, if available.
11905 if Present
(Full_View
(Subtype_Mark_Id
))
11906 and then Has_Discriminants
(Subtype_Mark_Id
)
11907 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
11910 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
11912 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
11913 Constrain_Concurrent
(Full_View_Id
, S
,
11914 Related_Nod
, Related_Id
, Suffix
);
11915 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
11916 Set_Full_View
(Def_Id
, Full_View_Id
);
11919 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
11922 when Concurrent_Kind
=>
11923 Constrain_Concurrent
(Def_Id
, S
,
11924 Related_Nod
, Related_Id
, Suffix
);
11927 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
11930 -- Size and Convention are always inherited from the base type
11932 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
11933 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
11937 -- Case of no constraints present
11941 Check_Incomplete
(S
);
11944 end Process_Subtype
;
11946 -----------------------------
11947 -- Record_Type_Declaration --
11948 -----------------------------
11950 procedure Record_Type_Declaration
(T
: Entity_Id
; N
: Node_Id
) is
11951 Def
: constant Node_Id
:= Type_Definition
(N
);
11952 Range_Checks_Suppressed_Flag
: Boolean := False;
11954 Is_Tagged
: Boolean;
11955 Tag_Comp
: Entity_Id
;
11958 -- The flag Is_Tagged_Type might have already been set by Find_Type_Name
11959 -- if it detected an error for declaration T. This arises in the case of
11960 -- private tagged types where the full view omits the word tagged.
11962 Is_Tagged
:= Tagged_Present
(Def
)
11963 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
11965 -- Records constitute a scope for the component declarations within.
11966 -- The scope is created prior to the processing of these declarations.
11967 -- Discriminants are processed first, so that they are visible when
11968 -- processing the other components. The Ekind of the record type itself
11969 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
11971 -- Enter record scope
11975 -- These flags must be initialized before calling Process_Discriminants
11976 -- because this routine makes use of them.
11978 Set_Is_Tagged_Type
(T
, Is_Tagged
);
11979 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
11981 -- Type is abstract if full declaration carries keyword, or if
11982 -- previous partial view did.
11984 Set_Is_Abstract
(T
, Is_Abstract
(T
) or else Abstract_Present
(Def
));
11986 Set_Ekind
(T
, E_Record_Type
);
11988 Init_Size_Align
(T
);
11990 Set_Girder_Constraint
(T
, No_Elist
);
11992 -- If an incomplete or private type declaration was already given for
11993 -- the type, then this scope already exists, and the discriminants have
11994 -- been declared within. We must verify that the full declaration
11995 -- matches the incomplete one.
11997 Check_Or_Process_Discriminants
(N
, T
);
11999 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
12000 Set_Has_Delayed_Freeze
(T
, True);
12002 -- For tagged types add a manually analyzed component corresponding
12003 -- to the component _tag, the corresponding piece of tree will be
12004 -- expanded as part of the freezing actions if it is not a CPP_Class.
12007 -- Do not add the tag unless we are in expansion mode.
12009 if Expander_Active
then
12010 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
12011 Enter_Name
(Tag_Comp
);
12013 Set_Is_Tag
(Tag_Comp
);
12014 Set_Ekind
(Tag_Comp
, E_Component
);
12015 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
12016 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
12017 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
12018 Init_Component_Location
(Tag_Comp
);
12021 Make_Class_Wide_Type
(T
);
12022 Set_Primitive_Operations
(T
, New_Elmt_List
);
12025 -- We must suppress range checks when processing the components
12026 -- of a record in the presence of discriminants, since we don't
12027 -- want spurious checks to be generated during their analysis, but
12028 -- must reset the Suppress_Range_Checks flags after having procesed
12029 -- the record definition.
12031 if Has_Discriminants
(T
) and then not Suppress_Range_Checks
(T
) then
12032 Set_Suppress_Range_Checks
(T
, True);
12033 Range_Checks_Suppressed_Flag
:= True;
12036 Record_Type_Definition
(Def
, T
);
12038 if Range_Checks_Suppressed_Flag
then
12039 Set_Suppress_Range_Checks
(T
, False);
12040 Range_Checks_Suppressed_Flag
:= False;
12043 -- Exit from record scope
12046 end Record_Type_Declaration
;
12048 ----------------------------
12049 -- Record_Type_Definition --
12050 ----------------------------
12052 procedure Record_Type_Definition
(Def
: Node_Id
; T
: Entity_Id
) is
12053 Component
: Entity_Id
;
12054 Ctrl_Components
: Boolean := False;
12055 Final_Storage_Only
: Boolean := not Is_Controlled
(T
);
12058 -- If the component list of a record type is defined by the reserved
12059 -- word null and there is no discriminant part, then the record type has
12060 -- no components and all records of the type are null records (RM 3.7)
12061 -- This procedure is also called to process the extension part of a
12062 -- record extension, in which case the current scope may have inherited
12066 or else No
(Component_List
(Def
))
12067 or else Null_Present
(Component_List
(Def
))
12072 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
12074 if Present
(Variant_Part
(Component_List
(Def
))) then
12075 Analyze
(Variant_Part
(Component_List
(Def
)));
12079 -- After completing the semantic analysis of the record definition,
12080 -- record components, both new and inherited, are accessible. Set
12081 -- their kind accordingly.
12083 Component
:= First_Entity
(Current_Scope
);
12084 while Present
(Component
) loop
12086 if Ekind
(Component
) = E_Void
then
12087 Set_Ekind
(Component
, E_Component
);
12088 Init_Component_Location
(Component
);
12091 if Has_Task
(Etype
(Component
)) then
12095 if Ekind
(Component
) /= E_Component
then
12098 elsif Has_Controlled_Component
(Etype
(Component
))
12099 or else (Chars
(Component
) /= Name_uParent
12100 and then Is_Controlled
(Etype
(Component
)))
12102 Set_Has_Controlled_Component
(T
, True);
12103 Final_Storage_Only
:= Final_Storage_Only
12104 and then Finalize_Storage_Only
(Etype
(Component
));
12105 Ctrl_Components
:= True;
12108 Next_Entity
(Component
);
12111 -- A type is Finalize_Storage_Only only if all its controlled
12112 -- components are so.
12114 if Ctrl_Components
then
12115 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
12118 if Present
(Def
) then
12119 Process_End_Label
(Def
, 'e', T
);
12121 end Record_Type_Definition
;
12123 ------------------------
12124 -- Replace_Components --
12125 ------------------------
12127 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
12128 function Process
(N
: Node_Id
) return Traverse_Result
;
12134 function Process
(N
: Node_Id
) return Traverse_Result
is
12138 if Nkind
(N
) = N_Discriminant_Specification
then
12139 Comp
:= First_Discriminant
(Typ
);
12141 while Present
(Comp
) loop
12142 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
12143 Set_Defining_Identifier
(N
, Comp
);
12147 Next_Discriminant
(Comp
);
12150 elsif Nkind
(N
) = N_Component_Declaration
then
12151 Comp
:= First_Component
(Typ
);
12153 while Present
(Comp
) loop
12154 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
12155 Set_Defining_Identifier
(N
, Comp
);
12159 Next_Component
(Comp
);
12166 procedure Replace
is new Traverse_Proc
(Process
);
12168 -- Start of processing for Replace_Components
12172 end Replace_Components
;
12174 -------------------------------
12175 -- Set_Completion_Referenced --
12176 -------------------------------
12178 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
12180 -- If in main unit, mark entity that is a completion as referenced,
12181 -- warnings go on the partial view when needed.
12183 if In_Extended_Main_Source_Unit
(E
) then
12184 Set_Referenced
(E
);
12186 end Set_Completion_Referenced
;
12188 ---------------------
12189 -- Set_Fixed_Range --
12190 ---------------------
12192 -- The range for fixed-point types is complicated by the fact that we
12193 -- do not know the exact end points at the time of the declaration. This
12194 -- is true for three reasons:
12196 -- A size clause may affect the fudging of the end-points
12197 -- A small clause may affect the values of the end-points
12198 -- We try to include the end-points if it does not affect the size
12200 -- This means that the actual end-points must be established at the
12201 -- point when the type is frozen. Meanwhile, we first narrow the range
12202 -- as permitted (so that it will fit if necessary in a small specified
12203 -- size), and then build a range subtree with these narrowed bounds.
12205 -- Set_Fixed_Range constructs the range from real literal values, and
12206 -- sets the range as the Scalar_Range of the given fixed-point type
12209 -- The parent of this range is set to point to the entity so that it
12210 -- is properly hooked into the tree (unlike normal Scalar_Range entries
12211 -- for other scalar types, which are just pointers to the range in the
12212 -- original tree, this would otherwise be an orphan).
12214 -- The tree is left unanalyzed. When the type is frozen, the processing
12215 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
12216 -- analyzed, and uses this as an indication that it should complete
12217 -- work on the range (it will know the final small and size values).
12219 procedure Set_Fixed_Range
12225 S
: constant Node_Id
:=
12227 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
12228 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
12231 Set_Scalar_Range
(E
, S
);
12233 end Set_Fixed_Range
;
12235 --------------------------------------------------------
12236 -- Set_Girder_Constraint_From_Discriminant_Constraint --
12237 --------------------------------------------------------
12239 procedure Set_Girder_Constraint_From_Discriminant_Constraint
12243 -- Make sure set if encountered during
12244 -- Expand_To_Girder_Constraint
12246 Set_Girder_Constraint
(E
, No_Elist
);
12248 -- Give it the right value
12250 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
12251 Set_Girder_Constraint
(E
,
12252 Expand_To_Girder_Constraint
(E
, Discriminant_Constraint
(E
)));
12255 end Set_Girder_Constraint_From_Discriminant_Constraint
;
12257 ----------------------------------
12258 -- Set_Scalar_Range_For_Subtype --
12259 ----------------------------------
12261 procedure Set_Scalar_Range_For_Subtype
12262 (Def_Id
: Entity_Id
;
12266 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
12268 Set_Scalar_Range
(Def_Id
, R
);
12270 -- We need to link the range into the tree before resolving it so
12271 -- that types that are referenced, including importantly the subtype
12272 -- itself, are properly frozen (Freeze_Expression requires that the
12273 -- expression be properly linked into the tree). Of course if it is
12274 -- already linked in, then we do not disturb the current link.
12276 if No
(Parent
(R
)) then
12277 Set_Parent
(R
, Def_Id
);
12280 -- Reset the kind of the subtype during analysis of the range, to
12281 -- catch possible premature use in the bounds themselves.
12283 Set_Ekind
(Def_Id
, E_Void
);
12284 Process_Range_Expr_In_Decl
(R
, Subt
);
12285 Set_Ekind
(Def_Id
, Kind
);
12287 end Set_Scalar_Range_For_Subtype
;
12289 -------------------------------------
12290 -- Signed_Integer_Type_Declaration --
12291 -------------------------------------
12293 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
12294 Implicit_Base
: Entity_Id
;
12295 Base_Typ
: Entity_Id
;
12298 Errs
: Boolean := False;
12302 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
12303 -- Determine whether given bounds allow derivation from specified type
12305 procedure Check_Bound
(Expr
: Node_Id
);
12306 -- Check bound to make sure it is integral and static. If not, post
12307 -- appropriate error message and set Errs flag
12309 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
12310 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
12311 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
12314 -- Note we check both bounds against both end values, to deal with
12315 -- strange types like ones with a range of 0 .. -12341234.
12317 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
12319 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
12320 end Can_Derive_From
;
12322 procedure Check_Bound
(Expr
: Node_Id
) is
12324 -- If a range constraint is used as an integer type definition, each
12325 -- bound of the range must be defined by a static expression of some
12326 -- integer type, but the two bounds need not have the same integer
12327 -- type (Negative bounds are allowed.) (RM 3.5.4)
12329 if not Is_Integer_Type
(Etype
(Expr
)) then
12331 ("integer type definition bounds must be of integer type", Expr
);
12334 elsif not Is_OK_Static_Expression
(Expr
) then
12336 ("non-static expression used for integer type bound", Expr
);
12339 -- The bounds are folded into literals, and we set their type to be
12340 -- universal, to avoid typing difficulties: we cannot set the type
12341 -- of the literal to the new type, because this would be a forward
12342 -- reference for the back end, and if the original type is user-
12343 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
12346 if Is_Entity_Name
(Expr
) then
12347 Fold_Uint
(Expr
, Expr_Value
(Expr
));
12350 Set_Etype
(Expr
, Universal_Integer
);
12354 -- Start of processing for Signed_Integer_Type_Declaration
12357 -- Create an anonymous base type
12360 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
12362 -- Analyze and check the bounds, they can be of any integer type
12364 Lo
:= Low_Bound
(Def
);
12365 Hi
:= High_Bound
(Def
);
12367 -- Arbitrarily use Integer as the type if either bound had an error
12369 if Hi
= Error
or else Lo
= Error
then
12370 Base_Typ
:= Any_Integer
;
12371 Set_Error_Posted
(T
, True);
12373 -- Here both bounds are OK expressions
12376 Analyze_And_Resolve
(Lo
, Any_Integer
);
12377 Analyze_And_Resolve
(Hi
, Any_Integer
);
12383 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
12384 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
12387 -- Find type to derive from
12389 Lo_Val
:= Expr_Value
(Lo
);
12390 Hi_Val
:= Expr_Value
(Hi
);
12392 if Can_Derive_From
(Standard_Short_Short_Integer
) then
12393 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
12395 elsif Can_Derive_From
(Standard_Short_Integer
) then
12396 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
12398 elsif Can_Derive_From
(Standard_Integer
) then
12399 Base_Typ
:= Base_Type
(Standard_Integer
);
12401 elsif Can_Derive_From
(Standard_Long_Integer
) then
12402 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
12404 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
12405 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
12408 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
12409 Error_Msg_N
("integer type definition bounds out of range", Def
);
12410 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
12411 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
12415 -- Complete both implicit base and declared first subtype entities
12417 Set_Etype
(Implicit_Base
, Base_Typ
);
12418 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
12419 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
12420 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
12421 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
12423 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
12424 Set_Etype
(T
, Implicit_Base
);
12426 Set_Size_Info
(T
, (Implicit_Base
));
12427 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
12428 Set_Scalar_Range
(T
, Def
);
12429 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
12430 Set_Is_Constrained
(T
);
12432 end Signed_Integer_Type_Declaration
;