1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Elists
; use Elists
;
31 with Einfo
; use Einfo
;
32 with Errout
; use Errout
;
33 with Eval_Fat
; use Eval_Fat
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Dist
; use Exp_Dist
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
38 with Itypes
; use Itypes
;
39 with Layout
; use Layout
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Case
; use Sem_Case
;
49 with Sem_Cat
; use Sem_Cat
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch7
; use Sem_Ch7
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Ch13
; use Sem_Ch13
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Dist
; use Sem_Dist
;
56 with Sem_Elim
; use Sem_Elim
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Mech
; use Sem_Mech
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Smem
; use Sem_Smem
;
61 with Sem_Type
; use Sem_Type
;
62 with Sem_Util
; use Sem_Util
;
63 with Stand
; use Stand
;
64 with Sinfo
; use Sinfo
;
65 with Snames
; use Snames
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Uintp
; use Uintp
;
69 with Urealp
; use Urealp
;
71 package body Sem_Ch3
is
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Build_Derived_Type
79 Parent_Type
: Entity_Id
;
80 Derived_Type
: Entity_Id
;
81 Is_Completion
: Boolean;
82 Derive_Subps
: Boolean := True);
83 -- Create and decorate a Derived_Type given the Parent_Type entity.
84 -- N is the N_Full_Type_Declaration node containing the derived type
85 -- definition. Parent_Type is the entity for the parent type in the derived
86 -- type definition and Derived_Type the actual derived type. Is_Completion
87 -- must be set to False if Derived_Type is the N_Defining_Identifier node
88 -- in N (ie Derived_Type = Defining_Identifier (N)). In this case N is not
89 -- the completion of a private type declaration. If Is_Completion is
90 -- set to True, N is the completion of a private type declaration and
91 -- Derived_Type is different from the defining identifier inside N (i.e.
92 -- Derived_Type /= Defining_Identifier (N)). Derive_Subps indicates whether
93 -- the parent subprograms should be derived. The only case where this
94 -- parameter is False is when Build_Derived_Type is recursively called to
95 -- process an implicit derived full type for a type derived from a private
96 -- type (in that case the subprograms must only be derived for the private
98 -- ??? These flags need a bit of re-examination and re-documentation:
99 -- ??? are they both necessary (both seem related to the recursion)?
101 procedure Build_Derived_Access_Type
103 Parent_Type
: Entity_Id
;
104 Derived_Type
: Entity_Id
);
105 -- Subsidiary procedure to Build_Derived_Type. For a derived access type,
106 -- create an implicit base if the parent type is constrained or if the
107 -- subtype indication has a constraint.
109 procedure Build_Derived_Array_Type
111 Parent_Type
: Entity_Id
;
112 Derived_Type
: Entity_Id
);
113 -- Subsidiary procedure to Build_Derived_Type. For a derived array type,
114 -- create an implicit base if the parent type is constrained or if the
115 -- subtype indication has a constraint.
117 procedure Build_Derived_Concurrent_Type
119 Parent_Type
: Entity_Id
;
120 Derived_Type
: Entity_Id
);
121 -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
122 -- tected type, inherit entries and protected subprograms, check legality
123 -- of discriminant constraints if any.
125 procedure Build_Derived_Enumeration_Type
127 Parent_Type
: Entity_Id
;
128 Derived_Type
: Entity_Id
);
129 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
130 -- type, we must create a new list of literals. Types derived from
131 -- Character and Wide_Character are special-cased.
133 procedure Build_Derived_Numeric_Type
135 Parent_Type
: Entity_Id
;
136 Derived_Type
: Entity_Id
);
137 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create
138 -- an anonymous base type, and propagate constraint to subtype if needed.
140 procedure Build_Derived_Private_Type
142 Parent_Type
: Entity_Id
;
143 Derived_Type
: Entity_Id
;
144 Is_Completion
: Boolean;
145 Derive_Subps
: Boolean := True);
146 -- Substidiary procedure to Build_Derived_Type. This procedure is complex
147 -- because the parent may or may not have a completion, and the derivation
148 -- may itself be a completion.
150 procedure Build_Derived_Record_Type
152 Parent_Type
: Entity_Id
;
153 Derived_Type
: Entity_Id
;
154 Derive_Subps
: Boolean := True);
155 -- Subsidiary procedure to Build_Derived_Type and
156 -- Analyze_Private_Extension_Declaration used for tagged and untagged
157 -- record types. All parameters are as in Build_Derived_Type except that
158 -- N, in addition to being an N_Full_Type_Declaration node, can also be an
159 -- N_Private_Extension_Declaration node. See the definition of this routine
160 -- for much more info. Derive_Subps indicates whether subprograms should
161 -- be derived from the parent type. The only case where Derive_Subps is
162 -- False is for an implicit derived full type for a type derived from a
163 -- private type (see Build_Derived_Type).
165 function Inherit_Components
167 Parent_Base
: Entity_Id
;
168 Derived_Base
: Entity_Id
;
170 Inherit_Discr
: Boolean;
173 -- Called from Build_Derived_Record_Type to inherit the components of
174 -- Parent_Base (a base type) into the Derived_Base (the derived base type).
175 -- For more information on derived types and component inheritance please
176 -- consult the comment above the body of Build_Derived_Record_Type.
178 -- N is the original derived type declaration.
179 -- Is_Tagged is set if we are dealing with tagged types.
180 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
181 -- Parent_Base, otherwise no discriminants are inherited.
182 -- Discs gives the list of constraints that apply to Parent_Base in the
183 -- derived type declaration. If Discs is set to No_Elist, then we have the
184 -- following situation:
186 -- type Parent (D1..Dn : ..) is [tagged] record ...;
187 -- type Derived is new Parent [with ...];
189 -- which gets treated as
191 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
193 -- For untagged types the returned value is an association list:
194 -- (Old_Component => New_Component), where Old_Component is the Entity_Id
195 -- of a component in Parent_Base and New_Component is the Entity_Id of the
196 -- corresponding component in Derived_Base. For untagged records, this
197 -- association list is needed when copying the record declaration for the
198 -- derived base. In the tagged case the value returned is irrelevant.
200 procedure Build_Discriminal
(Discrim
: Entity_Id
);
201 -- Create the discriminal corresponding to discriminant Discrim, that is
202 -- the parameter corresponding to Discrim to be used in initialization
203 -- procedures for the type where Discrim is a discriminant. Discriminals
204 -- are not used during semantic analysis, and are not fully defined
205 -- entities until expansion. Thus they are not given a scope until
206 -- initialization procedures are built.
208 function Build_Discriminant_Constraints
211 Derived_Def
: Boolean := False)
213 -- Validate discriminant constraints, and return the list of the
214 -- constraints in order of discriminant declarations. T is the
215 -- discriminated unconstrained type. Def is the N_Subtype_Indication
216 -- node where the discriminants constraints for T are specified.
217 -- Derived_Def is True if we are building the discriminant constraints
218 -- in a derived type definition of the form "type D (...) is new T (xxx)".
219 -- In this case T is the parent type and Def is the constraint "(xxx)" on
220 -- T and this routine sets the Corresponding_Discriminant field of the
221 -- discriminants in the derived type D to point to the corresponding
222 -- discriminants in the parent type T.
224 procedure Build_Discriminated_Subtype
228 Related_Nod
: Node_Id
;
229 For_Access
: Boolean := False);
230 -- Subsidiary procedure to Constrain_Discriminated_Type and to
231 -- Process_Incomplete_Dependents. Given
233 -- T (a possibly discriminated base type)
234 -- Def_Id (a very partially built subtype for T),
236 -- the call completes Def_Id to be the appropriate E_*_Subtype.
238 -- The Elist is the list of discriminant constraints if any (it is set to
239 -- No_Elist if T is not a discriminated type, and to an empty list if
240 -- T has discriminants but there are no discriminant constraints). The
241 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
242 -- The For_Access says whether or not this subtype is really constraining
243 -- an access type. That is its sole purpose is the designated type of an
244 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
245 -- is built to avoid freezing T when the access subtype is frozen.
247 function Build_Scalar_Bound
252 -- The bounds of a derived scalar type are conversions of the bounds of
253 -- the parent type. Optimize the representation if the bounds are literals.
254 -- Needs a more complete spec--what are the parameters exactly, and what
255 -- exactly is the returned value, and how is Bound affected???
257 procedure Build_Underlying_Full_View
261 -- If the completion of a private type is itself derived from a private
262 -- type, or if the full view of a private subtype is itself private, the
263 -- back-end has no way to compute the actual size of this type. We build
264 -- an internal subtype declaration of the proper parent type to convey
265 -- this information. This extra mechanism is needed because a full
266 -- view cannot itself have a full view (it would get clobbered during
269 procedure Check_Access_Discriminant_Requires_Limited
272 -- Check the restriction that the type to which an access discriminant
273 -- belongs must be a concurrent type or a descendant of a type with
274 -- the reserved word 'limited' in its declaration.
276 procedure Check_Delta_Expression
(E
: Node_Id
);
277 -- Check that the expression represented by E is suitable for use as
278 -- a delta expression, i.e. it is of real type and is static.
280 procedure Check_Digits_Expression
(E
: Node_Id
);
281 -- Check that the expression represented by E is suitable for use as
282 -- a digits expression, i.e. it is of integer type, positive and static.
284 procedure Check_Incomplete
(T
: Entity_Id
);
285 -- Called to verify that an incomplete type is not used prematurely
287 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
);
288 -- Validate the initialization of an object declaration. T is the
289 -- required type, and Exp is the initialization expression.
291 procedure Check_Or_Process_Discriminants
(N
: Node_Id
; T
: Entity_Id
);
292 -- If T is the full declaration of an incomplete or private type, check
293 -- the conformance of the discriminants, otherwise process them.
295 procedure Check_Real_Bound
(Bound
: Node_Id
);
296 -- Check given bound for being of real type and static. If not, post an
297 -- appropriate message, and rewrite the bound with the real literal zero.
299 procedure Constant_Redeclaration
303 -- Various checks on legality of full declaration of deferred constant.
304 -- Id is the entity for the redeclaration, N is the N_Object_Declaration,
305 -- node. The caller has not yet set any attributes of this entity.
307 procedure Convert_Scalar_Bounds
309 Parent_Type
: Entity_Id
;
310 Derived_Type
: Entity_Id
;
312 -- For derived scalar types, convert the bounds in the type definition
313 -- to the derived type, and complete their analysis.
315 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
);
316 -- Copies attributes from array base type T2 to array base type T1.
317 -- Copies only attributes that apply to base types, but not subtypes.
319 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
);
320 -- Copies attributes from array subtype T2 to array subtype T1. Copies
321 -- attributes that apply to both subtypes and base types.
323 procedure Create_Constrained_Components
327 Constraints
: Elist_Id
);
328 -- Build the list of entities for a constrained discriminated record
329 -- subtype. If a component depends on a discriminant, replace its subtype
330 -- using the discriminant values in the discriminant constraint.
331 -- Subt is the defining identifier for the subtype whose list of
332 -- constrained entities we will create. Decl_Node is the type declaration
333 -- node where we will attach all the itypes created. Typ is the base
334 -- discriminated type for the subtype Subt. Constraints is the list of
335 -- discriminant constraints for Typ.
337 function Constrain_Component_Type
338 (Compon_Type
: Entity_Id
;
339 Constrained_Typ
: Entity_Id
;
340 Related_Node
: Node_Id
;
342 Constraints
: Elist_Id
)
344 -- Given a discriminated base type Typ, a list of discriminant constraint
345 -- Constraints for Typ and the type of a component of Typ, Compon_Type,
346 -- create and return the type corresponding to Compon_type where all
347 -- discriminant references are replaced with the corresponding
348 -- constraint. If no discriminant references occurr in Compon_Typ then
349 -- return it as is. Constrained_Typ is the final constrained subtype to
350 -- which the constrained Compon_Type belongs. Related_Node is the node
351 -- where we will attach all the itypes created.
353 procedure Constrain_Access
354 (Def_Id
: in out Entity_Id
;
356 Related_Nod
: Node_Id
);
357 -- Apply a list of constraints to an access type. If Def_Id is empty,
358 -- it is an anonymous type created for a subtype indication. In that
359 -- case it is created in the procedure and attached to Related_Nod.
361 procedure Constrain_Array
362 (Def_Id
: in out Entity_Id
;
364 Related_Nod
: Node_Id
;
365 Related_Id
: Entity_Id
;
367 -- Apply a list of index constraints to an unconstrained array type. The
368 -- first parameter is the entity for the resulting subtype. A value of
369 -- Empty for Def_Id indicates that an implicit type must be created, but
370 -- creation is delayed (and must be done by this procedure) because other
371 -- subsidiary implicit types must be created first (which is why Def_Id
372 -- is an in/out parameter). The second parameter is a subtype indication
373 -- node for the constrained array to be created (e.g. something of the
374 -- form string (1 .. 10)). Related_Nod gives the place where this type
375 -- has to be inserted in the tree. The Related_Id and Suffix parameters
376 -- are used to build the associated Implicit type name.
378 procedure Constrain_Concurrent
379 (Def_Id
: in out Entity_Id
;
381 Related_Nod
: Node_Id
;
382 Related_Id
: Entity_Id
;
384 -- Apply list of discriminant constraints to an unconstrained concurrent
387 -- SI is the N_Subtype_Indication node containing the constraint and
388 -- the unconstrained type to constrain.
390 -- Def_Id is the entity for the resulting constrained subtype. A
391 -- value of Empty for Def_Id indicates that an implicit type must be
392 -- created, but creation is delayed (and must be done by this procedure)
393 -- because other subsidiary implicit types must be created first (which
394 -- is why Def_Id is an in/out parameter).
396 -- Related_Nod gives the place where this type has to be inserted
399 -- The last two arguments are used to create its external name if needed.
401 function Constrain_Corresponding_Record
402 (Prot_Subt
: Entity_Id
;
403 Corr_Rec
: Entity_Id
;
404 Related_Nod
: Node_Id
;
405 Related_Id
: Entity_Id
)
407 -- When constraining a protected type or task type with discriminants,
408 -- constrain the corresponding record with the same discriminant values.
410 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
);
411 -- Constrain a decimal fixed point type with a digits constraint and/or a
412 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
414 procedure Constrain_Discriminated_Type
417 Related_Nod
: Node_Id
;
418 For_Access
: Boolean := False);
419 -- Process discriminant constraints of composite type. Verify that values
420 -- have been provided for all discriminants, that the original type is
421 -- unconstrained, and that the types of the supplied expressions match
422 -- the discriminant types. The first three parameters are like in routine
423 -- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
426 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
);
427 -- Constrain an enumeration type with a range constraint. This is
428 -- identical to Constrain_Integer, but for the Ekind of the
429 -- resulting subtype.
431 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
);
432 -- Constrain a floating point type with either a digits constraint
433 -- and/or a range constraint, building a E_Floating_Point_Subtype.
435 procedure Constrain_Index
438 Related_Nod
: Node_Id
;
439 Related_Id
: Entity_Id
;
442 -- Process an index constraint in a constrained array declaration.
443 -- The constraint can be a subtype name, or a range with or without
444 -- an explicit subtype mark. The index is the corresponding index of the
445 -- unconstrained array. The Related_Id and Suffix parameters are used to
446 -- build the associated Implicit type name.
448 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
);
449 -- Build subtype of a signed or modular integer type.
451 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
);
452 -- Constrain an ordinary fixed point type with a range constraint, and
453 -- build an E_Ordinary_Fixed_Point_Subtype entity.
455 procedure Copy_And_Swap
(Privat
, Full
: Entity_Id
);
456 -- Copy the Privat entity into the entity of its full declaration
457 -- then swap the two entities in such a manner that the former private
458 -- type is now seen as a full type.
460 procedure Copy_Private_To_Full
(Priv
, Full
: Entity_Id
);
461 -- Initialize the full view declaration with the relevant fields
462 -- from the private view.
464 procedure Decimal_Fixed_Point_Type_Declaration
467 -- Create a new decimal fixed point type, and apply the constraint to
468 -- obtain a subtype of this new type.
470 procedure Complete_Private_Subtype
473 Full_Base
: Entity_Id
;
474 Related_Nod
: Node_Id
);
475 -- Complete the implicit full view of a private subtype by setting
476 -- the appropriate semantic fields. If the full view of the parent is
477 -- a record type, build constrained components of subtype.
479 procedure Derived_Standard_Character
481 Parent_Type
: Entity_Id
;
482 Derived_Type
: Entity_Id
);
483 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles
484 -- derivations from types Standard.Character and Standard.Wide_Character.
486 procedure Derived_Type_Declaration
489 Is_Completion
: Boolean);
490 -- Process a derived type declaration. This routine will invoke
491 -- Build_Derived_Type to process the actual derived type definition.
492 -- Parameters N and Is_Completion have the same meaning as in
493 -- Build_Derived_Type. T is the N_Defining_Identifier for the entity
494 -- defined in the N_Full_Type_Declaration node N, that is T is the
497 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
;
498 -- Given a subtype indication S (which is really an N_Subtype_Indication
499 -- node or a plain N_Identifier), find the type of the subtype mark.
501 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
502 -- Insert each literal in symbol table, as an overloadable identifier
503 -- Each enumeration type is mapped into a sequence of integers, and
504 -- each literal is defined as a constant with integer value. If any
505 -- of the literals are character literals, the type is a character
506 -- type, which means that strings are legal aggregates for arrays of
507 -- components of the type.
509 procedure Expand_Others_Choice
510 (Case_Table
: Choice_Table_Type
;
511 Others_Choice
: Node_Id
;
512 Choice_Type
: Entity_Id
);
513 -- In the case of a variant part of a record type that has an OTHERS
514 -- choice, this procedure expands the OTHERS into the actual choices
515 -- that it represents. This new list of choice nodes is attached to
516 -- the OTHERS node via the Others_Discrete_Choices field. The Case_Table
517 -- contains all choices that have been given explicitly in the variant.
519 function Find_Type_Of_Object
521 Related_Nod
: Node_Id
)
523 -- Get type entity for object referenced by Obj_Def, attaching the
524 -- implicit types generated to Related_Nod
526 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
527 -- Create a new float, and apply the constraint to obtain subtype of it
529 function Has_Range_Constraint
(N
: Node_Id
) return Boolean;
530 -- Given an N_Subtype_Indication node N, return True if a range constraint
531 -- is present, either directly, or as part of a digits or delta constraint.
532 -- In addition, a digits constraint in the decimal case returns True, since
533 -- it establishes a default range if no explicit range is present.
535 function Is_Valid_Constraint_Kind
537 Constraint_Kind
: Node_Kind
)
539 -- Returns True if it is legal to apply the given kind of constraint
540 -- to the given kind of type (index constraint to an array type,
543 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
544 -- Create new modular type. Verify that modulus is in bounds and is
545 -- a power of two (implementation restriction).
547 procedure New_Binary_Operator
(Op_Name
: Name_Id
; Typ
: Entity_Id
);
548 -- Create an abbreviated declaration for an operator in order to
549 -- materialize minimally operators on derived types.
551 procedure Ordinary_Fixed_Point_Type_Declaration
554 -- Create a new ordinary fixed point type, and apply the constraint
555 -- to obtain subtype of it.
557 procedure Prepare_Private_Subtype_Completion
559 Related_Nod
: Node_Id
);
560 -- Id is a subtype of some private type. Creates the full declaration
561 -- associated with Id whenever possible, i.e. when the full declaration
562 -- of the base type is already known. Records each subtype into
563 -- Private_Dependents of the base type.
565 procedure Process_Incomplete_Dependents
569 -- Process all entities that depend on an incomplete type. There include
570 -- subtypes, subprogram types that mention the incomplete type in their
571 -- profiles, and subprogram with access parameters that designate the
574 -- Inc_T is the defining identifier of an incomplete type declaration, its
575 -- Ekind is E_Incomplete_Type.
577 -- N is the corresponding N_Full_Type_Declaration for Inc_T.
579 -- Full_T is N's defining identifier.
581 -- Subtypes of incomplete types with discriminants are completed when the
582 -- parent type is. This is simpler than private subtypes, because they can
583 -- only appear in the same scope, and there is no need to exchange views.
584 -- Similarly, access_to_subprogram types may have a parameter or a return
585 -- type that is an incomplete type, and that must be replaced with the
588 -- If the full type is tagged, subprogram with access parameters that
589 -- designated the incomplete may be primitive operations of the full type,
590 -- and have to be processed accordingly.
592 procedure Process_Real_Range_Specification
(Def
: Node_Id
);
593 -- Given the type definition for a real type, this procedure processes
594 -- and checks the real range specification of this type definition if
595 -- one is present. If errors are found, error messages are posted, and
596 -- the Real_Range_Specification of Def is reset to Empty.
598 procedure Record_Type_Declaration
(T
: Entity_Id
; N
: Node_Id
);
599 -- Process a record type declaration (for both untagged and tagged
600 -- records). Parameters T and N are exactly like in procedure
601 -- Derived_Type_Declaration, except that no flag Is_Completion is
602 -- needed for this routine.
604 procedure Record_Type_Definition
(Def
: Node_Id
; T
: Entity_Id
);
605 -- This routine is used to process the actual record type definition
606 -- (both for untagged and tagged records). Def is a record type
607 -- definition node. This procedure analyzes the components in this
608 -- record type definition. T is the entity for the enclosing record
609 -- type. It is provided so that its Has_Task flag can be set if any of
610 -- the component have Has_Task set.
612 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
);
613 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
614 -- build a copy of the declaration tree of the parent, and we create
615 -- independently the list of components for the derived type. Semantic
616 -- information uses the component entities, but record representation
617 -- clauses are validated on the declaration tree. This procedure replaces
618 -- discriminants and components in the declaration with those that have
619 -- been created by Inherit_Components.
621 procedure Set_Fixed_Range
626 -- Build a range node with the given bounds and set it as the Scalar_Range
627 -- of the given fixed-point type entity. Loc is the source location used
628 -- for the constructed range. See body for further details.
630 procedure Set_Scalar_Range_For_Subtype
634 -- This routine is used to set the scalar range field for a subtype
635 -- given Def_Id, the entity for the subtype, and R, the range expression
636 -- for the scalar range. Subt provides the parent subtype to be used
637 -- to analyze, resolve, and check the given range.
639 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
);
640 -- Create a new signed integer entity, and apply the constraint to obtain
641 -- the required first named subtype of this type.
643 -----------------------
644 -- Access_Definition --
645 -----------------------
647 function Access_Definition
648 (Related_Nod
: Node_Id
;
652 Anon_Type
: constant Entity_Id
:=
653 Create_Itype
(E_Anonymous_Access_Type
, Related_Nod
,
654 Scope_Id
=> Scope
(Current_Scope
));
655 Desig_Type
: Entity_Id
;
658 if Is_Entry
(Current_Scope
)
659 and then Is_Task_Type
(Etype
(Scope
(Current_Scope
)))
661 Error_Msg_N
("task entries cannot have access parameters", N
);
664 Find_Type
(Subtype_Mark
(N
));
665 Desig_Type
:= Entity
(Subtype_Mark
(N
));
667 Set_Directly_Designated_Type
668 (Anon_Type
, Desig_Type
);
669 Set_Etype
(Anon_Type
, Anon_Type
);
670 Init_Size_Align
(Anon_Type
);
671 Set_Depends_On_Private
(Anon_Type
, Has_Private_Component
(Anon_Type
));
673 -- The anonymous access type is as public as the discriminated type or
674 -- subprogram that defines it. It is imported (for back-end purposes)
675 -- if the designated type is.
677 Set_Is_Public
(Anon_Type
, Is_Public
(Scope
(Anon_Type
)));
678 Set_From_With_Type
(Anon_Type
, From_With_Type
(Desig_Type
));
680 -- The context is either a subprogram declaration or an access
681 -- discriminant, in a private or a full type declaration. In
682 -- the case of a subprogram, If the designated type is incomplete,
683 -- the operation will be a primitive operation of the full type, to
684 -- be updated subsequently.
686 if Ekind
(Desig_Type
) = E_Incomplete_Type
687 and then Is_Overloadable
(Current_Scope
)
689 Append_Elmt
(Current_Scope
, Private_Dependents
(Desig_Type
));
690 Set_Has_Delayed_Freeze
(Current_Scope
);
694 end Access_Definition
;
696 -----------------------------------
697 -- Access_Subprogram_Declaration --
698 -----------------------------------
700 procedure Access_Subprogram_Declaration
704 Formals
: constant List_Id
:= Parameter_Specifications
(T_Def
);
706 Desig_Type
: constant Entity_Id
:=
707 Create_Itype
(E_Subprogram_Type
, Parent
(T_Def
));
710 if Nkind
(T_Def
) = N_Access_Function_Definition
then
711 Analyze
(Subtype_Mark
(T_Def
));
712 Set_Etype
(Desig_Type
, Entity
(Subtype_Mark
(T_Def
)));
714 Set_Etype
(Desig_Type
, Standard_Void_Type
);
717 if Present
(Formals
) then
718 New_Scope
(Desig_Type
);
719 Process_Formals
(Formals
, Parent
(T_Def
));
721 -- A bit of a kludge here, End_Scope requires that the parent
722 -- pointer be set to something reasonable, but Itypes don't
723 -- have parent pointers. So we set it and then unset it ???
724 -- If and when Itypes have proper parent pointers to their
725 -- declarations, this kludge can be removed.
727 Set_Parent
(Desig_Type
, T_Name
);
729 Set_Parent
(Desig_Type
, Empty
);
732 -- The return type and/or any parameter type may be incomplete. Mark
733 -- the subprogram_type as depending on the incomplete type, so that
734 -- it can be updated when the full type declaration is seen.
736 if Present
(Formals
) then
737 Formal
:= First_Formal
(Desig_Type
);
739 while Present
(Formal
) loop
741 if Ekind
(Formal
) /= E_In_Parameter
742 and then Nkind
(T_Def
) = N_Access_Function_Definition
744 Error_Msg_N
("functions can only have IN parameters", Formal
);
747 if Ekind
(Etype
(Formal
)) = E_Incomplete_Type
then
748 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Formal
)));
749 Set_Has_Delayed_Freeze
(Desig_Type
);
752 Next_Formal
(Formal
);
756 if Ekind
(Etype
(Desig_Type
)) = E_Incomplete_Type
757 and then not Has_Delayed_Freeze
(Desig_Type
)
759 Append_Elmt
(Desig_Type
, Private_Dependents
(Etype
(Desig_Type
)));
760 Set_Has_Delayed_Freeze
(Desig_Type
);
763 Check_Delayed_Subprogram
(Desig_Type
);
765 if Protected_Present
(T_Def
) then
766 Set_Ekind
(T_Name
, E_Access_Protected_Subprogram_Type
);
767 Set_Convention
(Desig_Type
, Convention_Protected
);
769 Set_Ekind
(T_Name
, E_Access_Subprogram_Type
);
772 Set_Etype
(T_Name
, T_Name
);
773 Init_Size_Align
(T_Name
);
774 Set_Directly_Designated_Type
(T_Name
, Desig_Type
);
776 Check_Restriction
(No_Access_Subprograms
, T_Def
);
777 end Access_Subprogram_Declaration
;
779 ----------------------------
780 -- Access_Type_Declaration --
781 ----------------------------
783 procedure Access_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
784 S
: constant Node_Id
:= Subtype_Indication
(Def
);
785 P
: constant Node_Id
:= Parent
(Def
);
788 -- Check for permissible use of incomplete type
790 if Nkind
(S
) /= N_Subtype_Indication
then
793 if Ekind
(Root_Type
(Entity
(S
))) = E_Incomplete_Type
then
794 Set_Directly_Designated_Type
(T
, Entity
(S
));
796 Set_Directly_Designated_Type
(T
,
797 Process_Subtype
(S
, P
, T
, 'P'));
801 Set_Directly_Designated_Type
(T
,
802 Process_Subtype
(S
, P
, T
, 'P'));
805 if All_Present
(Def
) or Constant_Present
(Def
) then
806 Set_Ekind
(T
, E_General_Access_Type
);
808 Set_Ekind
(T
, E_Access_Type
);
811 if Base_Type
(Designated_Type
(T
)) = T
then
812 Error_Msg_N
("access type cannot designate itself", S
);
817 -- If the type has appeared already in a with_type clause, it is
818 -- frozen and the pointer size is already set. Else, initialize.
820 if not From_With_Type
(T
) then
824 Set_Is_Access_Constant
(T
, Constant_Present
(Def
));
826 -- If designated type is an imported tagged type, indicate that the
827 -- access type is also imported, and therefore restricted in its use.
828 -- The access type may already be imported, so keep setting otherwise.
830 if From_With_Type
(Designated_Type
(T
)) then
831 Set_From_With_Type
(T
);
834 -- Note that Has_Task is always false, since the access type itself
835 -- is not a task type. See Einfo for more description on this point.
836 -- Exactly the same consideration applies to Has_Controlled_Component.
838 Set_Has_Task
(T
, False);
839 Set_Has_Controlled_Component
(T
, False);
840 end Access_Type_Declaration
;
842 -----------------------------------
843 -- Analyze_Component_Declaration --
844 -----------------------------------
846 procedure Analyze_Component_Declaration
(N
: Node_Id
) is
847 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
852 Generate_Definition
(Id
);
854 T
:= Find_Type_Of_Object
(Subtype_Indication
(N
), N
);
856 -- If the component declaration includes a default expression, then we
857 -- check that the component is not of a limited type (RM 3.7(5)),
858 -- and do the special preanalysis of the expression (see section on
859 -- "Handling of Default Expressions" in the spec of package Sem).
861 if Present
(Expression
(N
)) then
862 Analyze_Default_Expression
(Expression
(N
), T
);
863 Check_Initialization
(T
, Expression
(N
));
866 -- The parent type may be a private view with unknown discriminants,
867 -- and thus unconstrained. Regular components must be constrained.
869 if Is_Indefinite_Subtype
(T
) and then Chars
(Id
) /= Name_uParent
then
871 ("unconstrained subtype in component declaration",
872 Subtype_Indication
(N
));
874 -- Components cannot be abstract, except for the special case of
875 -- the _Parent field (case of extending an abstract tagged type)
877 elsif Is_Abstract
(T
) and then Chars
(Id
) /= Name_uParent
then
878 Error_Msg_N
("type of a component cannot be abstract", N
);
882 Set_Is_Aliased
(Id
, Aliased_Present
(N
));
884 -- If the this component is private (or depends on a private type),
885 -- flag the record type to indicate that some operations are not
888 P
:= Private_Component
(T
);
891 -- Check for circular definitions.
894 Set_Etype
(Id
, Any_Type
);
896 -- There is a gap in the visibility of operations only if the
897 -- component type is not defined in the scope of the record type.
899 elsif Scope
(P
) = Scope
(Current_Scope
) then
902 elsif Is_Limited_Type
(P
) then
903 Set_Is_Limited_Composite
(Current_Scope
);
906 Set_Is_Private_Composite
(Current_Scope
);
911 and then Is_Limited_Type
(T
)
912 and then Chars
(Id
) /= Name_uParent
913 and then Is_Tagged_Type
(Current_Scope
)
915 if Is_Derived_Type
(Current_Scope
)
916 and then not Is_Limited_Record
(Root_Type
(Current_Scope
))
919 ("extension of nonlimited type cannot have limited components",
921 Set_Etype
(Id
, Any_Type
);
922 Set_Is_Limited_Composite
(Current_Scope
, False);
924 elsif not Is_Derived_Type
(Current_Scope
)
925 and then not Is_Limited_Record
(Current_Scope
)
927 Error_Msg_N
("nonlimited type cannot have limited components", N
);
928 Set_Etype
(Id
, Any_Type
);
929 Set_Is_Limited_Composite
(Current_Scope
, False);
933 Set_Original_Record_Component
(Id
, Id
);
934 end Analyze_Component_Declaration
;
936 --------------------------
937 -- Analyze_Declarations --
938 --------------------------
940 procedure Analyze_Declarations
(L
: List_Id
) is
943 Freeze_From
: Entity_Id
:= Empty
;
946 -- Adjust D not to include implicit label declarations, since these
947 -- have strange Sloc values that result in elaboration check problems.
949 procedure Adjust_D
is
951 while Present
(Prev
(D
))
952 and then Nkind
(D
) = N_Implicit_Label_Declaration
958 -- Start of processing for Analyze_Declarations
962 while Present
(D
) loop
964 -- Complete analysis of declaration
967 Next_Node
:= Next
(D
);
969 if No
(Freeze_From
) then
970 Freeze_From
:= First_Entity
(Current_Scope
);
973 -- At the end of a declarative part, freeze remaining entities
974 -- declared in it. The end of the visible declarations of a
975 -- package specification is not the end of a declarative part
976 -- if private declarations are present. The end of a package
977 -- declaration is a freezing point only if it a library package.
978 -- A task definition or protected type definition is not a freeze
979 -- point either. Finally, we do not freeze entities in generic
980 -- scopes, because there is no code generated for them and freeze
981 -- nodes will be generated for the instance.
983 -- The end of a package instantiation is not a freeze point, but
984 -- for now we make it one, because the generic body is inserted
985 -- (currently) immediately after. Generic instantiations will not
986 -- be a freeze point once delayed freezing of bodies is implemented.
987 -- (This is needed in any case for early instantiations ???).
989 if No
(Next_Node
) then
990 if Nkind
(Parent
(L
)) = N_Component_List
991 or else Nkind
(Parent
(L
)) = N_Task_Definition
992 or else Nkind
(Parent
(L
)) = N_Protected_Definition
996 elsif Nkind
(Parent
(L
)) /= N_Package_Specification
then
998 if Nkind
(Parent
(L
)) = N_Package_Body
then
999 Freeze_From
:= First_Entity
(Current_Scope
);
1003 Freeze_All
(Freeze_From
, D
);
1004 Freeze_From
:= Last_Entity
(Current_Scope
);
1006 elsif Scope
(Current_Scope
) /= Standard_Standard
1007 and then not Is_Child_Unit
(Current_Scope
)
1008 and then No
(Generic_Parent
(Parent
(L
)))
1012 elsif L
/= Visible_Declarations
(Parent
(L
))
1013 or else No
(Private_Declarations
(Parent
(L
)))
1014 or else Is_Empty_List
(Private_Declarations
(Parent
(L
)))
1017 Freeze_All
(Freeze_From
, D
);
1018 Freeze_From
:= Last_Entity
(Current_Scope
);
1021 -- If next node is a body then freeze all types before the body.
1022 -- An exception occurs for expander generated bodies, which can
1023 -- be recognized by their already being analyzed. The expander
1024 -- ensures that all types needed by these bodies have been frozen
1025 -- but it is not necessary to freeze all types (and would be wrong
1026 -- since it would not correspond to an RM defined freeze point).
1028 elsif not Analyzed
(Next_Node
)
1029 and then (Nkind
(Next_Node
) = N_Subprogram_Body
1030 or else Nkind
(Next_Node
) = N_Entry_Body
1031 or else Nkind
(Next_Node
) = N_Package_Body
1032 or else Nkind
(Next_Node
) = N_Protected_Body
1033 or else Nkind
(Next_Node
) = N_Task_Body
1034 or else Nkind
(Next_Node
) in N_Body_Stub
)
1037 Freeze_All
(Freeze_From
, D
);
1038 Freeze_From
:= Last_Entity
(Current_Scope
);
1044 end Analyze_Declarations
;
1046 --------------------------------
1047 -- Analyze_Default_Expression --
1048 --------------------------------
1050 procedure Analyze_Default_Expression
(N
: Node_Id
; T
: Entity_Id
) is
1051 Save_In_Default_Expression
: constant Boolean := In_Default_Expression
;
1054 In_Default_Expression
:= True;
1055 Pre_Analyze_And_Resolve
(N
, T
);
1056 In_Default_Expression
:= Save_In_Default_Expression
;
1057 end Analyze_Default_Expression
;
1059 ----------------------------------
1060 -- Analyze_Incomplete_Type_Decl --
1061 ----------------------------------
1063 procedure Analyze_Incomplete_Type_Decl
(N
: Node_Id
) is
1064 F
: constant Boolean := Is_Pure
(Current_Scope
);
1068 Generate_Definition
(Defining_Identifier
(N
));
1070 -- Process an incomplete declaration. The identifier must not have been
1071 -- declared already in the scope. However, an incomplete declaration may
1072 -- appear in the private part of a package, for a private type that has
1073 -- already been declared.
1075 -- In this case, the discriminants (if any) must match.
1077 T
:= Find_Type_Name
(N
);
1079 Set_Ekind
(T
, E_Incomplete_Type
);
1080 Init_Size_Align
(T
);
1081 Set_Is_First_Subtype
(T
, True);
1085 Set_Girder_Constraint
(T
, No_Elist
);
1087 if Present
(Discriminant_Specifications
(N
)) then
1088 Process_Discriminants
(N
);
1093 -- If the type has discriminants, non-trivial subtypes may be
1094 -- be declared before the full view of the type. The full views
1095 -- of those subtypes will be built after the full view of the type.
1097 Set_Private_Dependents
(T
, New_Elmt_List
);
1099 end Analyze_Incomplete_Type_Decl
;
1101 -----------------------------
1102 -- Analyze_Itype_Reference --
1103 -----------------------------
1105 -- Nothing to do. This node is placed in the tree only for the benefit
1106 -- of Gigi processing, and has no effect on the semantic processing.
1108 procedure Analyze_Itype_Reference
(N
: Node_Id
) is
1110 pragma Assert
(Is_Itype
(Itype
(N
)));
1112 end Analyze_Itype_Reference
;
1114 --------------------------------
1115 -- Analyze_Number_Declaration --
1116 --------------------------------
1118 procedure Analyze_Number_Declaration
(N
: Node_Id
) is
1119 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1120 E
: constant Node_Id
:= Expression
(N
);
1122 Index
: Interp_Index
;
1126 Generate_Definition
(Id
);
1129 -- This is an optimization of a common case of an integer literal
1131 if Nkind
(E
) = N_Integer_Literal
then
1132 Set_Is_Static_Expression
(E
, True);
1133 Set_Etype
(E
, Universal_Integer
);
1135 Set_Etype
(Id
, Universal_Integer
);
1136 Set_Ekind
(Id
, E_Named_Integer
);
1137 Set_Is_Frozen
(Id
, True);
1141 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1143 -- Process expression, replacing error by integer zero, to avoid
1144 -- cascaded errors or aborts further along in the processing
1146 -- Replace Error by integer zero, which seems least likely to
1147 -- cause cascaded errors.
1150 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), Uint_0
));
1151 Set_Error_Posted
(E
);
1156 -- Verify that the expression is static and numeric. If
1157 -- the expression is overloaded, we apply the preference
1158 -- rule that favors root numeric types.
1160 if not Is_Overloaded
(E
) then
1165 Get_First_Interp
(E
, Index
, It
);
1167 while Present
(It
.Typ
) loop
1168 if (Is_Integer_Type
(It
.Typ
)
1169 or else Is_Real_Type
(It
.Typ
))
1170 and then (Scope
(Base_Type
(It
.Typ
))) = Standard_Standard
1172 if T
= Any_Type
then
1175 elsif It
.Typ
= Universal_Real
1176 or else It
.Typ
= Universal_Integer
1178 -- Choose universal interpretation over any other.
1185 Get_Next_Interp
(Index
, It
);
1189 if Is_Integer_Type
(T
) then
1191 Set_Etype
(Id
, Universal_Integer
);
1192 Set_Ekind
(Id
, E_Named_Integer
);
1194 elsif Is_Real_Type
(T
) then
1196 -- Because the real value is converted to universal_real, this
1197 -- is a legal context for a universal fixed expression.
1199 if T
= Universal_Fixed
then
1201 Loc
: constant Source_Ptr
:= Sloc
(N
);
1202 Conv
: constant Node_Id
:= Make_Type_Conversion
(Loc
,
1204 New_Occurrence_Of
(Universal_Real
, Loc
),
1205 Expression
=> Relocate_Node
(E
));
1212 elsif T
= Any_Fixed
then
1213 Error_Msg_N
("illegal context for mixed mode operation", E
);
1215 -- Expression is of the form : universal_fixed * integer.
1216 -- Try to resolve as universal_real.
1218 T
:= Universal_Real
;
1223 Set_Etype
(Id
, Universal_Real
);
1224 Set_Ekind
(Id
, E_Named_Real
);
1227 Wrong_Type
(E
, Any_Numeric
);
1230 Set_Ekind
(Id
, E_Constant
);
1231 Set_Not_Source_Assigned
(Id
, True);
1232 Set_Is_True_Constant
(Id
, True);
1236 if Nkind
(E
) = N_Integer_Literal
1237 or else Nkind
(E
) = N_Real_Literal
1239 Set_Etype
(E
, Etype
(Id
));
1242 if not Is_OK_Static_Expression
(E
) then
1243 Error_Msg_N
("non-static expression used in number declaration", E
);
1244 Rewrite
(E
, Make_Integer_Literal
(Sloc
(N
), 1));
1245 Set_Etype
(E
, Any_Type
);
1248 end Analyze_Number_Declaration
;
1250 --------------------------------
1251 -- Analyze_Object_Declaration --
1252 --------------------------------
1254 procedure Analyze_Object_Declaration
(N
: Node_Id
) is
1255 Loc
: constant Source_Ptr
:= Sloc
(N
);
1256 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1260 E
: Node_Id
:= Expression
(N
);
1261 -- E is set to Expression (N) throughout this routine. When
1262 -- Expression (N) is modified, E is changed accordingly.
1264 Prev_Entity
: Entity_Id
:= Empty
;
1266 function Build_Default_Subtype
return Entity_Id
;
1267 -- If the object is limited or aliased, and if the type is unconstrained
1268 -- and there is no expression, the discriminants cannot be modified and
1269 -- the subtype of the object is constrained by the defaults, so it is
1270 -- worthile building the corresponding subtype.
1272 ---------------------------
1273 -- Build_Default_Subtype --
1274 ---------------------------
1276 function Build_Default_Subtype
return Entity_Id
is
1278 Constraints
: List_Id
:= New_List
;
1283 Disc
:= First_Discriminant
(T
);
1285 if No
(Discriminant_Default_Value
(Disc
)) then
1286 return T
; -- previous error.
1289 Act
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1290 while Present
(Disc
) loop
1293 Discriminant_Default_Value
(Disc
)), Constraints
);
1294 Next_Discriminant
(Disc
);
1298 Make_Subtype_Declaration
(Loc
,
1299 Defining_Identifier
=> Act
,
1300 Subtype_Indication
=>
1301 Make_Subtype_Indication
(Loc
,
1302 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1304 Make_Index_Or_Discriminant_Constraint
1305 (Loc
, Constraints
)));
1307 Insert_Before
(N
, Decl
);
1310 end Build_Default_Subtype
;
1312 -- Start of processing for Analyze_Object_Declaration
1315 -- There are three kinds of implicit types generated by an
1316 -- object declaration:
1318 -- 1. Those for generated by the original Object Definition
1320 -- 2. Those generated by the Expression
1322 -- 3. Those used to constrained the Object Definition with the
1323 -- expression constraints when it is unconstrained
1325 -- They must be generated in this order to avoid order of elaboration
1326 -- issues. Thus the first step (after entering the name) is to analyze
1327 -- the object definition.
1329 if Constant_Present
(N
) then
1330 Prev_Entity
:= Current_Entity_In_Scope
(Id
);
1332 -- If homograph is an implicit subprogram, it is overridden by the
1333 -- current declaration.
1335 if Present
(Prev_Entity
)
1336 and then Is_Overloadable
(Prev_Entity
)
1337 and then Is_Inherited_Operation
(Prev_Entity
)
1339 Prev_Entity
:= Empty
;
1343 if Present
(Prev_Entity
) then
1344 Constant_Redeclaration
(Id
, N
, T
);
1346 Generate_Reference
(Prev_Entity
, Id
, 'c');
1347 Set_Completion_Referenced
(Id
);
1349 if Error_Posted
(N
) then
1350 -- Type mismatch or illegal redeclaration, Do not analyze
1351 -- expression to avoid cascaded errors.
1353 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1355 Set_Ekind
(Id
, E_Variable
);
1359 -- In the normal case, enter identifier at the start to catch
1360 -- premature usage in the initialization expression.
1363 Generate_Definition
(Id
);
1366 T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1368 if Error_Posted
(Id
) then
1370 Set_Ekind
(Id
, E_Variable
);
1375 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1377 -- If deferred constant, make sure context is appropriate. We detect
1378 -- a deferred constant as a constant declaration with no expression.
1379 -- A deferred constant can appear in a package body if its completion
1380 -- is by means of an interface pragma.
1382 if Constant_Present
(N
)
1385 if not Is_Package
(Current_Scope
) then
1387 ("invalid context for deferred constant declaration", N
);
1388 Set_Constant_Present
(N
, False);
1390 -- In Ada 83, deferred constant must be of private type
1392 elsif not Is_Private_Type
(T
) then
1393 if Ada_83
and then Comes_From_Source
(N
) then
1395 ("(Ada 83) deferred constant must be private type", N
);
1399 -- If not a deferred constant, then object declaration freezes its type
1402 Check_Fully_Declared
(T
, N
);
1403 Freeze_Before
(N
, T
);
1406 -- If the object was created by a constrained array definition, then
1407 -- set the link in both the anonymous base type and anonymous subtype
1408 -- that are built to represent the array type to point to the object.
1410 if Nkind
(Object_Definition
(Declaration_Node
(Id
))) =
1411 N_Constrained_Array_Definition
1413 Set_Related_Array_Object
(T
, Id
);
1414 Set_Related_Array_Object
(Base_Type
(T
), Id
);
1417 -- Special checks for protected objects not at library level
1419 if Is_Protected_Type
(T
)
1420 and then not Is_Library_Level_Entity
(Id
)
1422 Check_Restriction
(No_Local_Protected_Objects
, Id
);
1424 -- Protected objects with interrupt handlers must be at library level
1426 if Has_Interrupt_Handler
(T
) then
1428 ("interrupt object can only be declared at library level", Id
);
1432 -- The actual subtype of the object is the nominal subtype, unless
1433 -- the nominal one is unconstrained and obtained from the expression.
1437 -- Process initialization expression if present and not in error
1439 if Present
(E
) and then E
/= Error
then
1442 if not Assignment_OK
(N
) then
1443 Check_Initialization
(T
, E
);
1448 -- Check for library level object that will require implicit
1451 if Is_Array_Type
(T
)
1452 and then not Size_Known_At_Compile_Time
(T
)
1453 and then Is_Library_Level_Entity
(Id
)
1455 -- String literals are always allowed
1457 if T
= Standard_String
1458 and then Nkind
(E
) = N_String_Literal
1462 -- Otherwise we do not allow this since it may cause an
1463 -- implicit heap allocation.
1467 (No_Implicit_Heap_Allocations
, Object_Definition
(N
));
1471 -- Check incorrect use of dynamically tagged expressions. Note
1472 -- the use of Is_Tagged_Type (T) which seems redundant but is in
1473 -- fact important to avoid spurious errors due to expanded code
1474 -- for dispatching functions over an anonymous access type
1476 if (Is_Class_Wide_Type
(Etype
(E
)) or else Is_Dynamically_Tagged
(E
))
1477 and then Is_Tagged_Type
(T
)
1478 and then not Is_Class_Wide_Type
(T
)
1480 Error_Msg_N
("dynamically tagged expression not allowed!", E
);
1483 Apply_Scalar_Range_Check
(E
, T
);
1484 Apply_Static_Length_Check
(E
, T
);
1487 -- Abstract type is never permitted for a variable or constant.
1488 -- Note: we inhibit this check for objects that do not come from
1489 -- source because there is at least one case (the expansion of
1490 -- x'class'input where x is abstract) where we legitimately
1491 -- generate an abstract object.
1493 if Is_Abstract
(T
) and then Comes_From_Source
(N
) then
1494 Error_Msg_N
("type of object cannot be abstract",
1495 Object_Definition
(N
));
1496 if Is_CPP_Class
(T
) then
1497 Error_Msg_NE
("\} may need a cpp_constructor",
1498 Object_Definition
(N
), T
);
1501 -- Case of unconstrained type
1503 elsif Is_Indefinite_Subtype
(T
) then
1505 -- Nothing to do in deferred constant case
1507 if Constant_Present
(N
) and then No
(E
) then
1510 -- Case of no initialization present
1513 if No_Initialization
(N
) then
1516 elsif Is_Class_Wide_Type
(T
) then
1518 ("initialization required in class-wide declaration ", N
);
1522 ("unconstrained subtype not allowed (need initialization)",
1523 Object_Definition
(N
));
1526 -- Case of initialization present but in error. Set initial
1527 -- expression as absent (but do not make above complaints)
1529 elsif E
= Error
then
1530 Set_Expression
(N
, Empty
);
1533 -- Case of initialization present
1536 -- Not allowed in Ada 83
1538 if not Constant_Present
(N
) then
1540 and then Comes_From_Source
(Object_Definition
(N
))
1543 ("(Ada 83) unconstrained variable not allowed",
1544 Object_Definition
(N
));
1548 -- Now we constrain the variable from the initializing expression
1550 -- If the expression is an aggregate, it has been expanded into
1551 -- individual assignments. Retrieve the actual type from the
1552 -- expanded construct.
1554 if Is_Array_Type
(T
)
1555 and then No_Initialization
(N
)
1556 and then Nkind
(Original_Node
(E
)) = N_Aggregate
1561 Expand_Subtype_From_Expr
(N
, T
, Object_Definition
(N
), E
);
1562 Act_T
:= Find_Type_Of_Object
(Object_Definition
(N
), N
);
1565 Set_Is_Constr_Subt_For_U_Nominal
(Act_T
);
1567 if Aliased_Present
(N
) then
1568 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
1571 Freeze_Before
(N
, Act_T
);
1572 Freeze_Before
(N
, T
);
1575 elsif Is_Array_Type
(T
)
1576 and then No_Initialization
(N
)
1577 and then Nkind
(Original_Node
(E
)) = N_Aggregate
1579 if not Is_Entity_Name
(Object_Definition
(N
)) then
1582 if Aliased_Present
(N
) then
1583 Set_Is_Constr_Subt_For_UN_Aliased
(Act_T
);
1587 -- When the given object definition and the aggregate are specified
1588 -- independently, and their lengths might differ do a length check.
1589 -- This cannot happen if the aggregate is of the form (others =>...)
1591 if not Is_Constrained
(T
) then
1594 elsif Nkind
(E
) = N_Raise_Constraint_Error
then
1596 -- Aggregate is statically illegal. Place back in declaration
1598 Set_Expression
(N
, E
);
1599 Set_No_Initialization
(N
, False);
1601 elsif T
= Etype
(E
) then
1604 elsif Nkind
(E
) = N_Aggregate
1605 and then Present
(Component_Associations
(E
))
1606 and then Present
(Choices
(First
(Component_Associations
(E
))))
1607 and then Nkind
(First
1608 (Choices
(First
(Component_Associations
(E
))))) = N_Others_Choice
1613 Apply_Length_Check
(E
, T
);
1616 elsif (Is_Limited_Record
(T
)
1617 or else Is_Concurrent_Type
(T
))
1618 and then not Is_Constrained
(T
)
1619 and then Has_Discriminants
(T
)
1621 Act_T
:= Build_Default_Subtype
;
1622 Rewrite
(Object_Definition
(N
), New_Occurrence_Of
(Act_T
, Loc
));
1624 elsif not Is_Constrained
(T
)
1625 and then Has_Discriminants
(T
)
1626 and then Constant_Present
(N
)
1627 and then Nkind
(E
) = N_Function_Call
1629 -- The back-end has problems with constants of a discriminated type
1630 -- with defaults, if the initial value is a function call. We
1631 -- generate an intermediate temporary for the result of the call.
1632 -- It is unclear why this should make it acceptable to gcc. ???
1634 Remove_Side_Effects
(E
);
1637 if T
= Standard_Wide_Character
1638 or else Root_Type
(T
) = Standard_Wide_String
1640 Check_Restriction
(No_Wide_Characters
, Object_Definition
(N
));
1643 -- Now establish the proper kind and type of the object
1645 if Constant_Present
(N
) then
1646 Set_Ekind
(Id
, E_Constant
);
1647 Set_Not_Source_Assigned
(Id
, True);
1648 Set_Is_True_Constant
(Id
, True);
1651 Set_Ekind
(Id
, E_Variable
);
1653 -- A variable is set as shared passive if it appears in a shared
1654 -- passive package, and is at the outer level. This is not done
1655 -- for entities generated during expansion, because those are
1656 -- always manipulated locally.
1658 if Is_Shared_Passive
(Current_Scope
)
1659 and then Is_Library_Level_Entity
(Id
)
1660 and then Comes_From_Source
(Id
)
1662 Set_Is_Shared_Passive
(Id
);
1663 Check_Shared_Var
(Id
, T
, N
);
1666 -- If an initializing expression is present, then the variable
1667 -- is potentially a true constant if no further assignments are
1668 -- present. The code generator can use this for optimization.
1669 -- The flag will be reset if there are any assignments. We only
1670 -- set this flag for non library level entities, since for any
1671 -- library level entities, assignments could exist in other units.
1674 if not Is_Library_Level_Entity
(Id
) then
1676 -- For now we omit this, because it seems to cause some
1677 -- problems. In particular, if you uncomment this out, then
1678 -- test case 4427-002 will fail for unclear reasons ???
1681 Set_Is_True_Constant
(Id
);
1685 -- Case of no initializing expression present. If the type is not
1686 -- fully initialized, then we set Not_Source_Assigned, since this
1687 -- is a case of a potentially uninitialized object. Note that we
1688 -- do not consider access variables to be fully initialized for
1689 -- this purpose, since it still seems dubious if someone declares
1690 -- an access variable and never assigns to it.
1693 if Is_Access_Type
(T
)
1694 or else not Is_Fully_Initialized_Type
(T
)
1696 Set_Not_Source_Assigned
(Id
);
1701 Init_Alignment
(Id
);
1704 if Aliased_Present
(N
) then
1705 Set_Is_Aliased
(Id
);
1708 and then Is_Record_Type
(T
)
1709 and then not Is_Constrained
(T
)
1710 and then Has_Discriminants
(T
)
1712 Set_Actual_Subtype
(Id
, Build_Default_Subtype
);
1716 Set_Etype
(Id
, Act_T
);
1718 if Has_Controlled_Component
(Etype
(Id
))
1719 or else Is_Controlled
(Etype
(Id
))
1721 if not Is_Library_Level_Entity
(Id
) then
1722 Check_Restriction
(No_Nested_Finalization
, N
);
1725 Validate_Controlled_Object
(Id
);
1728 -- Generate a warning when an initialization causes an obvious
1729 -- ABE violation. If the init expression is a simple aggregate
1730 -- there shouldn't be any initialize/adjust call generated. This
1731 -- will be true as soon as aggregates are built in place when
1732 -- possible. ??? at the moment we do not generate warnings for
1733 -- temporaries created for those aggregates although a
1734 -- Program_Error might be generated if compiled with -gnato
1736 if Is_Controlled
(Etype
(Id
))
1737 and then Comes_From_Source
(Id
)
1740 BT
: constant Entity_Id
:= Base_Type
(Etype
(Id
));
1741 Implicit_Call
: Entity_Id
;
1743 function Is_Aggr
(N
: Node_Id
) return Boolean;
1744 -- Check that N is an aggregate
1746 function Is_Aggr
(N
: Node_Id
) return Boolean is
1748 case Nkind
(Original_Node
(N
)) is
1749 when N_Aggregate | N_Extension_Aggregate
=>
1752 when N_Qualified_Expression |
1754 N_Unchecked_Type_Conversion
=>
1755 return Is_Aggr
(Expression
(Original_Node
(N
)));
1763 -- If no underlying type, we already are in an error situation
1764 -- don't try to add a warning since we do not have access
1767 if No
(Underlying_Type
(BT
)) then
1768 Implicit_Call
:= Empty
;
1770 -- A generic type does not have usable primitive operators.
1771 -- Initialization calls are built for instances.
1773 elsif Is_Generic_Type
(BT
) then
1774 Implicit_Call
:= Empty
;
1776 -- if the init expression is not an aggregate, an adjust
1777 -- call will be generated
1779 elsif Present
(E
) and then not Is_Aggr
(E
) then
1780 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Adjust
);
1782 -- if no init expression and we are not in the deferred
1783 -- constant case, an Initialize call will be generated
1785 elsif No
(E
) and then not Constant_Present
(N
) then
1786 Implicit_Call
:= Find_Prim_Op
(BT
, Name_Initialize
);
1789 Implicit_Call
:= Empty
;
1795 if Has_Task
(Etype
(Id
)) then
1796 if not Is_Library_Level_Entity
(Id
) then
1797 Check_Restriction
(No_Task_Hierarchy
, N
);
1798 Check_Potentially_Blocking_Operation
(N
);
1801 -- A rather specialized test. If we see two tasks being declared
1802 -- of the same type in the same object declaration, and the task
1803 -- has an entry with an address clause, we know that program error
1804 -- will be raised at run-time since we can't have two tasks with
1805 -- entries at the same address.
1807 if Is_Task_Type
(Etype
(Id
))
1808 and then More_Ids
(N
)
1814 E
:= First_Entity
(Etype
(Id
));
1815 while Present
(E
) loop
1816 if Ekind
(E
) = E_Entry
1817 and then Present
(Get_Attribute_Definition_Clause
1818 (E
, Attribute_Address
))
1821 ("?more than one task with same entry address", N
);
1823 ("\?Program_Error will be raised at run time", N
);
1825 Make_Raise_Program_Error
(Loc
,
1826 Reason
=> PE_Duplicated_Entry_Address
));
1836 -- Some simple constant-propagation: if the expression is a constant
1837 -- string initialized with a literal, share the literal. This avoids
1841 and then Is_Entity_Name
(E
)
1842 and then Ekind
(Entity
(E
)) = E_Constant
1843 and then Base_Type
(Etype
(E
)) = Standard_String
1846 Val
: constant Node_Id
:= Constant_Value
(Entity
(E
));
1850 and then Nkind
(Val
) = N_String_Literal
1852 Rewrite
(E
, New_Copy
(Val
));
1857 -- Another optimization: if the nominal subtype is unconstrained and
1858 -- the expression is a function call that returns and unconstrained
1859 -- type, rewrite the declararation as a renaming of the result of the
1860 -- call. The exceptions below are cases where the copy is expected,
1861 -- either by the back end (Aliased case) or by the semantics, as for
1862 -- initializing controlled types or copying tags for classwide types.
1865 and then Nkind
(E
) = N_Explicit_Dereference
1866 and then Nkind
(Original_Node
(E
)) = N_Function_Call
1867 and then not Is_Library_Level_Entity
(Id
)
1868 and then not Is_Constrained
(T
)
1869 and then not Is_Aliased
(Id
)
1870 and then not Is_Class_Wide_Type
(T
)
1871 and then not Is_Controlled
(T
)
1872 and then not Has_Controlled_Component
(Base_Type
(T
))
1873 and then Expander_Active
1876 Make_Object_Renaming_Declaration
(Loc
,
1877 Defining_Identifier
=> Id
,
1878 Subtype_Mark
=> New_Occurrence_Of
1879 (Base_Type
(Etype
(Id
)), Loc
),
1882 Set_Renamed_Object
(Id
, E
);
1885 if Present
(Prev_Entity
)
1886 and then Is_Frozen
(Prev_Entity
)
1887 and then not Error_Posted
(Id
)
1889 Error_Msg_N
("full constant declaration appears too late", N
);
1892 Check_Eliminated
(Id
);
1893 end Analyze_Object_Declaration
;
1895 ---------------------------
1896 -- Analyze_Others_Choice --
1897 ---------------------------
1899 -- Nothing to do for the others choice node itself, the semantic analysis
1900 -- of the others choice will occur as part of the processing of the parent
1902 procedure Analyze_Others_Choice
(N
: Node_Id
) is
1903 pragma Warnings
(Off
, N
);
1907 end Analyze_Others_Choice
;
1909 -------------------------------------------
1910 -- Analyze_Private_Extension_Declaration --
1911 -------------------------------------------
1913 procedure Analyze_Private_Extension_Declaration
(N
: Node_Id
) is
1914 T
: Entity_Id
:= Defining_Identifier
(N
);
1915 Indic
: constant Node_Id
:= Subtype_Indication
(N
);
1916 Parent_Type
: Entity_Id
;
1917 Parent_Base
: Entity_Id
;
1920 Generate_Definition
(T
);
1923 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
1924 Parent_Base
:= Base_Type
(Parent_Type
);
1926 if Parent_Type
= Any_Type
1927 or else Etype
(Parent_Type
) = Any_Type
1929 Set_Ekind
(T
, Ekind
(Parent_Type
));
1930 Set_Etype
(T
, Any_Type
);
1933 elsif not Is_Tagged_Type
(Parent_Type
) then
1935 ("parent of type extension must be a tagged type ", Indic
);
1938 elsif Ekind
(Parent_Type
) = E_Void
1939 or else Ekind
(Parent_Type
) = E_Incomplete_Type
1941 Error_Msg_N
("premature derivation of incomplete type", Indic
);
1945 -- Perhaps the parent type should be changed to the class-wide type's
1946 -- specific type in this case to prevent cascading errors ???
1948 if Is_Class_Wide_Type
(Parent_Type
) then
1950 ("parent of type extension must not be a class-wide type", Indic
);
1954 if (not Is_Package
(Current_Scope
)
1955 and then Nkind
(Parent
(N
)) /= N_Generic_Subprogram_Declaration
)
1956 or else In_Private_Part
(Current_Scope
)
1959 Error_Msg_N
("invalid context for private extension", N
);
1962 -- Set common attributes
1964 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
1965 Set_Scope
(T
, Current_Scope
);
1966 Set_Ekind
(T
, E_Record_Type_With_Private
);
1967 Init_Size_Align
(T
);
1969 Set_Etype
(T
, Parent_Base
);
1970 Set_Has_Task
(T
, Has_Task
(Parent_Base
));
1972 Set_Convention
(T
, Convention
(Parent_Type
));
1973 Set_First_Rep_Item
(T
, First_Rep_Item
(Parent_Type
));
1974 Set_Is_First_Subtype
(T
);
1975 Make_Class_Wide_Type
(T
);
1977 Build_Derived_Record_Type
(N
, Parent_Type
, T
);
1978 end Analyze_Private_Extension_Declaration
;
1980 ---------------------------------
1981 -- Analyze_Subtype_Declaration --
1982 ---------------------------------
1984 procedure Analyze_Subtype_Declaration
(N
: Node_Id
) is
1985 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1987 R_Checks
: Check_Result
;
1990 Generate_Definition
(Id
);
1991 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
1992 Init_Size_Align
(Id
);
1994 -- The following guard condition on Enter_Name is to handle cases
1995 -- where the defining identifier has already been entered into the
1996 -- scope but the declaration as a whole needs to be analyzed.
1998 -- This case in particular happens for derived enumeration types.
1999 -- The derived enumeration type is processed as an inserted enumeration
2000 -- type declaration followed by a rewritten subtype declaration. The
2001 -- defining identifier, however, is entered into the name scope very
2002 -- early in the processing of the original type declaration and
2003 -- therefore needs to be avoided here, when the created subtype
2004 -- declaration is analyzed. (See Build_Derived_Types)
2006 -- This also happens when the full view of a private type is a
2007 -- derived type with constraints. In this case the entity has been
2008 -- introduced in the private declaration.
2010 if Present
(Etype
(Id
))
2011 and then (Is_Private_Type
(Etype
(Id
))
2012 or else Is_Task_Type
(Etype
(Id
))
2013 or else Is_Rewrite_Substitution
(N
))
2021 T
:= Process_Subtype
(Subtype_Indication
(N
), N
, Id
, 'P');
2023 -- Inherit common attributes
2025 Set_Is_Generic_Type
(Id
, Is_Generic_Type
(Base_Type
(T
)));
2026 Set_Is_Volatile
(Id
, Is_Volatile
(T
));
2027 Set_Is_Atomic
(Id
, Is_Atomic
(T
));
2029 -- In the case where there is no constraint given in the subtype
2030 -- indication, Process_Subtype just returns the Subtype_Mark,
2031 -- so its semantic attributes must be established here.
2033 if Nkind
(Subtype_Indication
(N
)) /= N_Subtype_Indication
then
2034 Set_Etype
(Id
, Base_Type
(T
));
2038 Set_Ekind
(Id
, E_Array_Subtype
);
2040 -- Shouldn't we call Copy_Array_Subtype_Attributes here???
2042 Set_First_Index
(Id
, First_Index
(T
));
2043 Set_Is_Aliased
(Id
, Is_Aliased
(T
));
2044 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2046 when Decimal_Fixed_Point_Kind
=>
2047 Set_Ekind
(Id
, E_Decimal_Fixed_Point_Subtype
);
2048 Set_Digits_Value
(Id
, Digits_Value
(T
));
2049 Set_Delta_Value
(Id
, Delta_Value
(T
));
2050 Set_Scale_Value
(Id
, Scale_Value
(T
));
2051 Set_Small_Value
(Id
, Small_Value
(T
));
2052 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2053 Set_Machine_Radix_10
(Id
, Machine_Radix_10
(T
));
2054 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2055 Set_RM_Size
(Id
, RM_Size
(T
));
2057 when Enumeration_Kind
=>
2058 Set_Ekind
(Id
, E_Enumeration_Subtype
);
2059 Set_First_Literal
(Id
, First_Literal
(Base_Type
(T
)));
2060 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2061 Set_Is_Character_Type
(Id
, Is_Character_Type
(T
));
2062 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2063 Set_RM_Size
(Id
, RM_Size
(T
));
2065 when Ordinary_Fixed_Point_Kind
=>
2066 Set_Ekind
(Id
, E_Ordinary_Fixed_Point_Subtype
);
2067 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2068 Set_Small_Value
(Id
, Small_Value
(T
));
2069 Set_Delta_Value
(Id
, Delta_Value
(T
));
2070 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2071 Set_RM_Size
(Id
, RM_Size
(T
));
2074 Set_Ekind
(Id
, E_Floating_Point_Subtype
);
2075 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2076 Set_Digits_Value
(Id
, Digits_Value
(T
));
2077 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2079 when Signed_Integer_Kind
=>
2080 Set_Ekind
(Id
, E_Signed_Integer_Subtype
);
2081 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2082 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2083 Set_RM_Size
(Id
, RM_Size
(T
));
2085 when Modular_Integer_Kind
=>
2086 Set_Ekind
(Id
, E_Modular_Integer_Subtype
);
2087 Set_Scalar_Range
(Id
, Scalar_Range
(T
));
2088 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2089 Set_RM_Size
(Id
, RM_Size
(T
));
2091 when Class_Wide_Kind
=>
2092 Set_Ekind
(Id
, E_Class_Wide_Subtype
);
2093 Set_First_Entity
(Id
, First_Entity
(T
));
2094 Set_Last_Entity
(Id
, Last_Entity
(T
));
2095 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2096 Set_Cloned_Subtype
(Id
, T
);
2097 Set_Is_Tagged_Type
(Id
, True);
2098 Set_Has_Unknown_Discriminants
2101 if Ekind
(T
) = E_Class_Wide_Subtype
then
2102 Set_Equivalent_Type
(Id
, Equivalent_Type
(T
));
2105 when E_Record_Type | E_Record_Subtype
=>
2106 Set_Ekind
(Id
, E_Record_Subtype
);
2108 if Ekind
(T
) = E_Record_Subtype
2109 and then Present
(Cloned_Subtype
(T
))
2111 Set_Cloned_Subtype
(Id
, Cloned_Subtype
(T
));
2113 Set_Cloned_Subtype
(Id
, T
);
2116 Set_First_Entity
(Id
, First_Entity
(T
));
2117 Set_Last_Entity
(Id
, Last_Entity
(T
));
2118 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2119 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2120 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2121 Set_Has_Unknown_Discriminants
2122 (Id
, Has_Unknown_Discriminants
(T
));
2124 if Has_Discriminants
(T
) then
2125 Set_Discriminant_Constraint
2126 (Id
, Discriminant_Constraint
(T
));
2127 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2129 elsif Has_Unknown_Discriminants
(Id
) then
2130 Set_Discriminant_Constraint
(Id
, No_Elist
);
2133 if Is_Tagged_Type
(T
) then
2134 Set_Is_Tagged_Type
(Id
);
2135 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2136 Set_Primitive_Operations
2137 (Id
, Primitive_Operations
(T
));
2138 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2141 when Private_Kind
=>
2142 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2143 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2144 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2145 Set_First_Entity
(Id
, First_Entity
(T
));
2146 Set_Last_Entity
(Id
, Last_Entity
(T
));
2147 Set_Private_Dependents
(Id
, New_Elmt_List
);
2148 Set_Is_Limited_Record
(Id
, Is_Limited_Record
(T
));
2149 Set_Has_Unknown_Discriminants
2150 (Id
, Has_Unknown_Discriminants
(T
));
2152 if Is_Tagged_Type
(T
) then
2153 Set_Is_Tagged_Type
(Id
);
2154 Set_Is_Abstract
(Id
, Is_Abstract
(T
));
2155 Set_Class_Wide_Type
(Id
, Class_Wide_Type
(T
));
2158 -- In general the attributes of the subtype of a private
2159 -- type are the attributes of the partial view of parent.
2160 -- However, the full view may be a discriminated type,
2161 -- and the subtype must share the discriminant constraint
2162 -- to generate correct calls to initialization procedures.
2164 if Has_Discriminants
(T
) then
2165 Set_Discriminant_Constraint
2166 (Id
, Discriminant_Constraint
(T
));
2167 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2169 elsif Present
(Full_View
(T
))
2170 and then Has_Discriminants
(Full_View
(T
))
2172 Set_Discriminant_Constraint
2173 (Id
, Discriminant_Constraint
(Full_View
(T
)));
2174 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2176 -- This would seem semantically correct, but apparently
2177 -- confuses the back-end (4412-009). To be explained ???
2179 -- Set_Has_Discriminants (Id);
2182 Prepare_Private_Subtype_Completion
(Id
, N
);
2185 Set_Ekind
(Id
, E_Access_Subtype
);
2186 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2187 Set_Is_Access_Constant
2188 (Id
, Is_Access_Constant
(T
));
2189 Set_Directly_Designated_Type
2190 (Id
, Designated_Type
(T
));
2192 -- A Pure library_item must not contain the declaration of a
2193 -- named access type, except within a subprogram, generic
2194 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
2196 if Comes_From_Source
(Id
)
2197 and then In_Pure_Unit
2198 and then not In_Subprogram_Task_Protected_Unit
2201 ("named access types not allowed in pure unit", N
);
2204 when Concurrent_Kind
=>
2205 Set_Ekind
(Id
, Subtype_Kind
(Ekind
(T
)));
2206 Set_Corresponding_Record_Type
(Id
,
2207 Corresponding_Record_Type
(T
));
2208 Set_First_Entity
(Id
, First_Entity
(T
));
2209 Set_First_Private_Entity
(Id
, First_Private_Entity
(T
));
2210 Set_Has_Discriminants
(Id
, Has_Discriminants
(T
));
2211 Set_Is_Constrained
(Id
, Is_Constrained
(T
));
2212 Set_Last_Entity
(Id
, Last_Entity
(T
));
2214 if Has_Discriminants
(T
) then
2215 Set_Discriminant_Constraint
(Id
,
2216 Discriminant_Constraint
(T
));
2217 Set_Girder_Constraint_From_Discriminant_Constraint
(Id
);
2220 -- If the subtype name denotes an incomplete type
2221 -- an error was already reported by Process_Subtype.
2223 when E_Incomplete_Type
=>
2224 Set_Etype
(Id
, Any_Type
);
2227 raise Program_Error
;
2231 if Etype
(Id
) = Any_Type
then
2235 -- Some common processing on all types
2237 Set_Size_Info
(Id
, T
);
2238 Set_First_Rep_Item
(Id
, First_Rep_Item
(T
));
2242 Set_Is_Immediately_Visible
(Id
, True);
2243 Set_Depends_On_Private
(Id
, Has_Private_Component
(T
));
2245 if Present
(Generic_Parent_Type
(N
))
2248 (Parent
(Generic_Parent_Type
(N
))) /= N_Formal_Type_Declaration
2250 (Formal_Type_Definition
(Parent
(Generic_Parent_Type
(N
))))
2251 /= N_Formal_Private_Type_Definition
)
2253 if Is_Tagged_Type
(Id
) then
2254 if Is_Class_Wide_Type
(Id
) then
2255 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, Etype
(T
));
2257 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
, T
);
2260 elsif Scope
(Etype
(Id
)) /= Standard_Standard
then
2261 Derive_Subprograms
(Generic_Parent_Type
(N
), Id
);
2265 if Is_Private_Type
(T
)
2266 and then Present
(Full_View
(T
))
2268 Conditional_Delay
(Id
, Full_View
(T
));
2270 -- The subtypes of components or subcomponents of protected types
2271 -- do not need freeze nodes, which would otherwise appear in the
2272 -- wrong scope (before the freeze node for the protected type). The
2273 -- proper subtypes are those of the subcomponents of the corresponding
2276 elsif Ekind
(Scope
(Id
)) /= E_Protected_Type
2277 and then Present
(Scope
(Scope
(Id
))) -- error defense!
2278 and then Ekind
(Scope
(Scope
(Id
))) /= E_Protected_Type
2280 Conditional_Delay
(Id
, T
);
2283 -- Check that constraint_error is raised for a scalar subtype
2284 -- indication when the lower or upper bound of a non-null range
2285 -- lies outside the range of the type mark.
2287 if Nkind
(Subtype_Indication
(N
)) = N_Subtype_Indication
then
2288 if Is_Scalar_Type
(Etype
(Id
))
2289 and then Scalar_Range
(Id
) /=
2290 Scalar_Range
(Etype
(Subtype_Mark
2291 (Subtype_Indication
(N
))))
2295 Etype
(Subtype_Mark
(Subtype_Indication
(N
))));
2297 elsif Is_Array_Type
(Etype
(Id
))
2298 and then Present
(First_Index
(Id
))
2300 -- This really should be a subprogram that finds the indications
2303 if ((Nkind
(First_Index
(Id
)) = N_Identifier
2304 and then Ekind
(Entity
(First_Index
(Id
))) in Scalar_Kind
)
2305 or else Nkind
(First_Index
(Id
)) = N_Subtype_Indication
)
2307 Nkind
(Scalar_Range
(Etype
(First_Index
(Id
)))) = N_Range
2310 Target_Typ
: Entity_Id
:=
2313 (Etype
(Subtype_Mark
(Subtype_Indication
(N
)))));
2317 (Scalar_Range
(Etype
(First_Index
(Id
))),
2319 Etype
(First_Index
(Id
)),
2320 Defining_Identifier
(N
));
2326 Sloc
(Defining_Identifier
(N
)));
2332 Check_Eliminated
(Id
);
2333 end Analyze_Subtype_Declaration
;
2335 --------------------------------
2336 -- Analyze_Subtype_Indication --
2337 --------------------------------
2339 procedure Analyze_Subtype_Indication
(N
: Node_Id
) is
2340 T
: constant Entity_Id
:= Subtype_Mark
(N
);
2341 R
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
2348 Set_Etype
(N
, Etype
(R
));
2350 Set_Error_Posted
(R
);
2351 Set_Error_Posted
(T
);
2353 end Analyze_Subtype_Indication
;
2355 ------------------------------
2356 -- Analyze_Type_Declaration --
2357 ------------------------------
2359 procedure Analyze_Type_Declaration
(N
: Node_Id
) is
2360 Def
: constant Node_Id
:= Type_Definition
(N
);
2361 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2366 Prev
:= Find_Type_Name
(N
);
2368 if Ekind
(Prev
) = E_Incomplete_Type
then
2369 T
:= Full_View
(Prev
);
2374 Set_Is_Pure
(T
, Is_Pure
(Current_Scope
));
2376 -- We set the flag Is_First_Subtype here. It is needed to set the
2377 -- corresponding flag for the Implicit class-wide-type created
2378 -- during tagged types processing.
2380 Set_Is_First_Subtype
(T
, True);
2382 -- Only composite types other than array types are allowed to have
2387 -- For derived types, the rule will be checked once we've figured
2388 -- out the parent type.
2390 when N_Derived_Type_Definition
=>
2393 -- For record types, discriminants are allowed.
2395 when N_Record_Definition
=>
2399 if Present
(Discriminant_Specifications
(N
)) then
2401 ("elementary or array type cannot have discriminants",
2403 (First
(Discriminant_Specifications
(N
))));
2407 -- Elaborate the type definition according to kind, and generate
2408 -- susbsidiary (implicit) subtypes where needed. We skip this if
2409 -- it was already done (this happens during the reanalysis that
2410 -- follows a call to the high level optimizer).
2412 if not Analyzed
(T
) then
2417 when N_Access_To_Subprogram_Definition
=>
2418 Access_Subprogram_Declaration
(T
, Def
);
2420 -- If this is a remote access to subprogram, we must create
2421 -- the equivalent fat pointer type, and related subprograms.
2423 if Is_Remote_Types
(Current_Scope
)
2424 or else Is_Remote_Call_Interface
(Current_Scope
)
2426 Validate_Remote_Access_To_Subprogram_Type
(N
);
2427 Process_Remote_AST_Declaration
(N
);
2430 -- Validate categorization rule against access type declaration
2431 -- usually a violation in Pure unit, Shared_Passive unit.
2433 Validate_Access_Type_Declaration
(T
, N
);
2435 when N_Access_To_Object_Definition
=>
2436 Access_Type_Declaration
(T
, Def
);
2438 -- Validate categorization rule against access type declaration
2439 -- usually a violation in Pure unit, Shared_Passive unit.
2441 Validate_Access_Type_Declaration
(T
, N
);
2443 -- If we are in a Remote_Call_Interface package and define
2444 -- a RACW, Read and Write attribute must be added.
2446 if (Is_Remote_Call_Interface
(Current_Scope
)
2447 or else Is_Remote_Types
(Current_Scope
))
2448 and then Is_Remote_Access_To_Class_Wide_Type
(Def_Id
)
2450 Add_RACW_Features
(Def_Id
);
2453 when N_Array_Type_Definition
=>
2454 Array_Type_Declaration
(T
, Def
);
2456 when N_Derived_Type_Definition
=>
2457 Derived_Type_Declaration
(T
, N
, T
/= Def_Id
);
2459 when N_Enumeration_Type_Definition
=>
2460 Enumeration_Type_Declaration
(T
, Def
);
2462 when N_Floating_Point_Definition
=>
2463 Floating_Point_Type_Declaration
(T
, Def
);
2465 when N_Decimal_Fixed_Point_Definition
=>
2466 Decimal_Fixed_Point_Type_Declaration
(T
, Def
);
2468 when N_Ordinary_Fixed_Point_Definition
=>
2469 Ordinary_Fixed_Point_Type_Declaration
(T
, Def
);
2471 when N_Signed_Integer_Type_Definition
=>
2472 Signed_Integer_Type_Declaration
(T
, Def
);
2474 when N_Modular_Type_Definition
=>
2475 Modular_Type_Declaration
(T
, Def
);
2477 when N_Record_Definition
=>
2478 Record_Type_Declaration
(T
, N
);
2481 raise Program_Error
;
2486 if Etype
(T
) = Any_Type
then
2490 -- Some common processing for all types
2492 Set_Depends_On_Private
(T
, Has_Private_Component
(T
));
2494 -- Both the declared entity, and its anonymous base type if one
2495 -- was created, need freeze nodes allocated.
2498 B
: constant Entity_Id
:= Base_Type
(T
);
2501 -- In the case where the base type is different from the first
2502 -- subtype, we pre-allocate a freeze node, and set the proper
2503 -- link to the first subtype. Freeze_Entity will use this
2504 -- preallocated freeze node when it freezes the entity.
2507 Ensure_Freeze_Node
(B
);
2508 Set_First_Subtype_Link
(Freeze_Node
(B
), T
);
2511 if not From_With_Type
(T
) then
2512 Set_Has_Delayed_Freeze
(T
);
2516 -- Case of T is the full declaration of some private type which has
2517 -- been swapped in Defining_Identifier (N).
2519 if T
/= Def_Id
and then Is_Private_Type
(Def_Id
) then
2520 Process_Full_View
(N
, T
, Def_Id
);
2522 -- Record the reference. The form of this is a little strange,
2523 -- since the full declaration has been swapped in. So the first
2524 -- parameter here represents the entity to which a reference is
2525 -- made which is the "real" entity, i.e. the one swapped in,
2526 -- and the second parameter provides the reference location.
2528 Generate_Reference
(T
, T
, 'c');
2529 Set_Completion_Referenced
(Def_Id
);
2531 -- For completion of incomplete type, process incomplete dependents
2532 -- and always mark the full type as referenced (it is the incomplete
2533 -- type that we get for any real reference).
2535 elsif Ekind
(Prev
) = E_Incomplete_Type
then
2536 Process_Incomplete_Dependents
(N
, T
, Prev
);
2537 Generate_Reference
(Prev
, Def_Id
, 'c');
2538 Set_Completion_Referenced
(Def_Id
);
2540 -- If not private type or incomplete type completion, this is a real
2541 -- definition of a new entity, so record it.
2544 Generate_Definition
(Def_Id
);
2547 Check_Eliminated
(Def_Id
);
2548 end Analyze_Type_Declaration
;
2550 --------------------------
2551 -- Analyze_Variant_Part --
2552 --------------------------
2554 procedure Analyze_Variant_Part
(N
: Node_Id
) is
2556 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
2557 -- Error routine invoked by the generic instantiation below when
2558 -- the variant part has a non static choice.
2560 procedure Process_Declarations
(Variant
: Node_Id
);
2561 -- Analyzes all the declarations associated with a Variant.
2562 -- Needed by the generic instantiation below.
2564 package Variant_Choices_Processing
is new
2565 Generic_Choices_Processing
2566 (Get_Alternatives
=> Variants
,
2567 Get_Choices
=> Discrete_Choices
,
2568 Process_Empty_Choice
=> No_OP
,
2569 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
2570 Process_Associated_Node
=> Process_Declarations
);
2571 use Variant_Choices_Processing
;
2572 -- Instantiation of the generic choice processing package.
2574 -----------------------------
2575 -- Non_Static_Choice_Error --
2576 -----------------------------
2578 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
2580 Error_Msg_N
("choice given in variant part is not static", Choice
);
2581 end Non_Static_Choice_Error
;
2583 --------------------------
2584 -- Process_Declarations --
2585 --------------------------
2587 procedure Process_Declarations
(Variant
: Node_Id
) is
2589 if not Null_Present
(Component_List
(Variant
)) then
2590 Analyze_Declarations
(Component_Items
(Component_List
(Variant
)));
2592 if Present
(Variant_Part
(Component_List
(Variant
))) then
2593 Analyze
(Variant_Part
(Component_List
(Variant
)));
2596 end Process_Declarations
;
2598 -- Variables local to Analyze_Case_Statement.
2600 Others_Choice
: Node_Id
;
2602 Discr_Name
: Node_Id
;
2603 Discr_Type
: Entity_Id
;
2605 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
2607 Dont_Care
: Boolean;
2608 Others_Present
: Boolean := False;
2610 -- Start of processing for Analyze_Variant_Part
2613 Discr_Name
:= Name
(N
);
2614 Analyze
(Discr_Name
);
2616 if Ekind
(Entity
(Discr_Name
)) /= E_Discriminant
then
2617 Error_Msg_N
("invalid discriminant name in variant part", Discr_Name
);
2620 Discr_Type
:= Etype
(Entity
(Discr_Name
));
2622 if not Is_Discrete_Type
(Discr_Type
) then
2624 ("discriminant in a variant part must be of a discrete type",
2629 -- Call the instantiated Analyze_Choices which does the rest of the work
2632 (N
, Discr_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
2634 if Others_Present
then
2635 -- Fill in Others_Discrete_Choices field of the OTHERS choice
2637 Others_Choice
:= First
(Discrete_Choices
(Last
(Variants
(N
))));
2638 Expand_Others_Choice
2639 (Case_Table
(1 .. Last_Choice
), Others_Choice
, Discr_Type
);
2642 end Analyze_Variant_Part
;
2644 ----------------------------
2645 -- Array_Type_Declaration --
2646 ----------------------------
2648 procedure Array_Type_Declaration
(T
: in out Entity_Id
; Def
: Node_Id
) is
2649 Component_Def
: constant Node_Id
:= Subtype_Indication
(Def
);
2650 Element_Type
: Entity_Id
;
2651 Implicit_Base
: Entity_Id
;
2653 Related_Id
: Entity_Id
:= Empty
;
2655 P
: constant Node_Id
:= Parent
(Def
);
2659 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2661 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
2663 -- Find proper names for the implicit types which may be public.
2664 -- in case of anonymous arrays we use the name of the first object
2665 -- of that type as prefix.
2668 Related_Id
:= Defining_Identifier
(P
);
2674 Index
:= First
(Subtype_Marks
(Def
));
2679 while Present
(Index
) loop
2681 Make_Index
(Index
, P
, Related_Id
, Nb_Index
);
2683 Nb_Index
:= Nb_Index
+ 1;
2686 Element_Type
:= Process_Subtype
(Component_Def
, P
, Related_Id
, 'C');
2688 -- Constrained array case
2691 T
:= Create_Itype
(E_Void
, P
, Related_Id
, 'T');
2694 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2696 -- Establish Implicit_Base as unconstrained base type
2698 Implicit_Base
:= Create_Itype
(E_Array_Type
, P
, Related_Id
, 'B');
2700 Init_Size_Align
(Implicit_Base
);
2701 Set_Etype
(Implicit_Base
, Implicit_Base
);
2702 Set_Scope
(Implicit_Base
, Current_Scope
);
2703 Set_Has_Delayed_Freeze
(Implicit_Base
);
2705 -- The constrained array type is a subtype of the unconstrained one
2707 Set_Ekind
(T
, E_Array_Subtype
);
2708 Init_Size_Align
(T
);
2709 Set_Etype
(T
, Implicit_Base
);
2710 Set_Scope
(T
, Current_Scope
);
2711 Set_Is_Constrained
(T
, True);
2712 Set_First_Index
(T
, First
(Discrete_Subtype_Definitions
(Def
)));
2713 Set_Has_Delayed_Freeze
(T
);
2715 -- Complete setup of implicit base type
2717 Set_First_Index
(Implicit_Base
, First_Index
(T
));
2718 Set_Component_Type
(Implicit_Base
, Element_Type
);
2719 Set_Has_Task
(Implicit_Base
, Has_Task
(Element_Type
));
2720 Set_Component_Size
(Implicit_Base
, Uint_0
);
2721 Set_Has_Controlled_Component
2722 (Implicit_Base
, Has_Controlled_Component
2725 Is_Controlled
(Element_Type
));
2726 Set_Finalize_Storage_Only
2727 (Implicit_Base
, Finalize_Storage_Only
2730 -- Unconstrained array case
2733 Set_Ekind
(T
, E_Array_Type
);
2734 Init_Size_Align
(T
);
2736 Set_Scope
(T
, Current_Scope
);
2737 Set_Component_Size
(T
, Uint_0
);
2738 Set_Is_Constrained
(T
, False);
2739 Set_First_Index
(T
, First
(Subtype_Marks
(Def
)));
2740 Set_Has_Delayed_Freeze
(T
, True);
2741 Set_Has_Task
(T
, Has_Task
(Element_Type
));
2742 Set_Has_Controlled_Component
(T
, Has_Controlled_Component
2745 Is_Controlled
(Element_Type
));
2746 Set_Finalize_Storage_Only
(T
, Finalize_Storage_Only
2750 Set_Component_Type
(Base_Type
(T
), Element_Type
);
2752 if Aliased_Present
(Def
) then
2753 Set_Has_Aliased_Components
(Etype
(T
));
2756 Priv
:= Private_Component
(Element_Type
);
2758 if Present
(Priv
) then
2760 -- Check for circular definitions
2762 if Priv
= Any_Type
then
2763 Set_Component_Type
(Etype
(T
), Any_Type
);
2765 -- There is a gap in the visiblity of operations on the composite
2766 -- type only if the component type is defined in a different scope.
2768 elsif Scope
(Priv
) = Current_Scope
then
2771 elsif Is_Limited_Type
(Priv
) then
2772 Set_Is_Limited_Composite
(Etype
(T
));
2773 Set_Is_Limited_Composite
(T
);
2775 Set_Is_Private_Composite
(Etype
(T
));
2776 Set_Is_Private_Composite
(T
);
2780 -- Create a concatenation operator for the new type. Internal
2781 -- array types created for packed entities do not need such, they
2782 -- are compatible with the user-defined type.
2784 if Number_Dimensions
(T
) = 1
2785 and then not Is_Packed_Array_Type
(T
)
2787 New_Binary_Operator
(Name_Op_Concat
, T
);
2790 -- In the case of an unconstrained array the parser has already
2791 -- verified that all the indices are unconstrained but we still
2792 -- need to make sure that the element type is constrained.
2794 if Is_Indefinite_Subtype
(Element_Type
) then
2796 ("unconstrained element type in array declaration ",
2799 elsif Is_Abstract
(Element_Type
) then
2800 Error_Msg_N
("The type of a component cannot be abstract ",
2804 end Array_Type_Declaration
;
2806 -------------------------------
2807 -- Build_Derived_Access_Type --
2808 -------------------------------
2810 procedure Build_Derived_Access_Type
2812 Parent_Type
: Entity_Id
;
2813 Derived_Type
: Entity_Id
)
2815 S
: constant Node_Id
:= Subtype_Indication
(Type_Definition
(N
));
2817 Desig_Type
: Entity_Id
;
2819 Discr_Con_Elist
: Elist_Id
;
2820 Discr_Con_El
: Elmt_Id
;
2825 -- Set the designated type so it is available in case this is
2826 -- an access to a self-referential type, e.g. a standard list
2827 -- type with a next pointer. Will be reset after subtype is built.
2829 Set_Directly_Designated_Type
(Derived_Type
,
2830 Designated_Type
(Parent_Type
));
2832 Subt
:= Process_Subtype
(S
, N
);
2834 if Nkind
(S
) /= N_Subtype_Indication
2835 and then Subt
/= Base_Type
(Subt
)
2837 Set_Ekind
(Derived_Type
, E_Access_Subtype
);
2840 if Ekind
(Derived_Type
) = E_Access_Subtype
then
2842 Pbase
: constant Entity_Id
:= Base_Type
(Parent_Type
);
2843 Ibase
: constant Entity_Id
:=
2844 Create_Itype
(Ekind
(Pbase
), N
, Derived_Type
, 'B');
2845 Svg_Chars
: constant Name_Id
:= Chars
(Ibase
);
2846 Svg_Next_E
: constant Entity_Id
:= Next_Entity
(Ibase
);
2849 Copy_Node
(Pbase
, Ibase
);
2851 Set_Chars
(Ibase
, Svg_Chars
);
2852 Set_Next_Entity
(Ibase
, Svg_Next_E
);
2853 Set_Sloc
(Ibase
, Sloc
(Derived_Type
));
2854 Set_Scope
(Ibase
, Scope
(Derived_Type
));
2855 Set_Freeze_Node
(Ibase
, Empty
);
2856 Set_Is_Frozen
(Ibase
, False);
2857 Set_Comes_From_Source
(Ibase
, False);
2858 Set_Is_First_Subtype
(Ibase
, False);
2860 Set_Etype
(Ibase
, Pbase
);
2861 Set_Etype
(Derived_Type
, Ibase
);
2865 Set_Directly_Designated_Type
2866 (Derived_Type
, Designated_Type
(Subt
));
2868 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Subt
));
2869 Set_Is_Access_Constant
(Derived_Type
, Is_Access_Constant
(Parent_Type
));
2870 Set_Size_Info
(Derived_Type
, Parent_Type
);
2871 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
2872 Set_Depends_On_Private
(Derived_Type
,
2873 Has_Private_Component
(Derived_Type
));
2874 Conditional_Delay
(Derived_Type
, Subt
);
2876 -- Note: we do not copy the Storage_Size_Variable, since
2877 -- we always go to the root type for this information.
2879 -- Apply range checks to discriminants for derived record case
2880 -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
2882 Desig_Type
:= Designated_Type
(Derived_Type
);
2883 if Is_Composite_Type
(Desig_Type
)
2884 and then (not Is_Array_Type
(Desig_Type
))
2885 and then Has_Discriminants
(Desig_Type
)
2886 and then Base_Type
(Desig_Type
) /= Desig_Type
2888 Discr_Con_Elist
:= Discriminant_Constraint
(Desig_Type
);
2889 Discr_Con_El
:= First_Elmt
(Discr_Con_Elist
);
2891 Discr
:= First_Discriminant
(Base_Type
(Desig_Type
));
2892 while Present
(Discr_Con_El
) loop
2893 Apply_Range_Check
(Node
(Discr_Con_El
), Etype
(Discr
));
2894 Next_Elmt
(Discr_Con_El
);
2895 Next_Discriminant
(Discr
);
2898 end Build_Derived_Access_Type
;
2900 ------------------------------
2901 -- Build_Derived_Array_Type --
2902 ------------------------------
2904 procedure Build_Derived_Array_Type
2906 Parent_Type
: Entity_Id
;
2907 Derived_Type
: Entity_Id
)
2909 Loc
: constant Source_Ptr
:= Sloc
(N
);
2910 Tdef
: constant Node_Id
:= Type_Definition
(N
);
2911 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
2912 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
2913 Implicit_Base
: Entity_Id
;
2914 New_Indic
: Node_Id
;
2916 procedure Make_Implicit_Base
;
2917 -- If the parent subtype is constrained, the derived type is a
2918 -- subtype of an implicit base type derived from the parent base.
2920 ------------------------
2921 -- Make_Implicit_Base --
2922 ------------------------
2924 procedure Make_Implicit_Base
is
2927 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
2929 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
2930 Set_Etype
(Implicit_Base
, Parent_Base
);
2932 Copy_Array_Subtype_Attributes
(Implicit_Base
, Parent_Base
);
2933 Copy_Array_Base_Type_Attributes
(Implicit_Base
, Parent_Base
);
2935 Set_Has_Delayed_Freeze
(Implicit_Base
, True);
2936 end Make_Implicit_Base
;
2938 -- Start of processing for Build_Derived_Array_Type
2941 if not Is_Constrained
(Parent_Type
) then
2942 if Nkind
(Indic
) /= N_Subtype_Indication
then
2943 Set_Ekind
(Derived_Type
, E_Array_Type
);
2945 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
2946 Copy_Array_Base_Type_Attributes
(Derived_Type
, Parent_Type
);
2948 Set_Has_Delayed_Freeze
(Derived_Type
, True);
2952 Set_Etype
(Derived_Type
, Implicit_Base
);
2955 Make_Subtype_Declaration
(Loc
,
2956 Defining_Identifier
=> Derived_Type
,
2957 Subtype_Indication
=>
2958 Make_Subtype_Indication
(Loc
,
2959 Subtype_Mark
=> New_Reference_To
(Implicit_Base
, Loc
),
2960 Constraint
=> Constraint
(Indic
)));
2962 Rewrite
(N
, New_Indic
);
2967 if Nkind
(Indic
) /= N_Subtype_Indication
then
2970 Set_Ekind
(Derived_Type
, Ekind
(Parent_Type
));
2971 Set_Etype
(Derived_Type
, Implicit_Base
);
2972 Copy_Array_Subtype_Attributes
(Derived_Type
, Parent_Type
);
2975 Error_Msg_N
("illegal constraint on constrained type", Indic
);
2979 -- If the parent type is not a derived type itself, and is
2980 -- declared in a closed scope (e.g., a subprogram), then we
2981 -- need to explicitly introduce the new type's concatenation
2982 -- operator since Derive_Subprograms will not inherit the
2983 -- parent's operator.
2985 if Number_Dimensions
(Parent_Type
) = 1
2986 and then not Is_Limited_Type
(Parent_Type
)
2987 and then not Is_Derived_Type
(Parent_Type
)
2988 and then not Is_Package
(Scope
(Base_Type
(Parent_Type
)))
2990 New_Binary_Operator
(Name_Op_Concat
, Derived_Type
);
2992 end Build_Derived_Array_Type
;
2994 -----------------------------------
2995 -- Build_Derived_Concurrent_Type --
2996 -----------------------------------
2998 procedure Build_Derived_Concurrent_Type
3000 Parent_Type
: Entity_Id
;
3001 Derived_Type
: Entity_Id
)
3003 D_Constraint
: Node_Id
;
3004 Disc_Spec
: Node_Id
;
3005 Old_Disc
: Entity_Id
;
3006 New_Disc
: Entity_Id
;
3008 Constraint_Present
: constant Boolean :=
3009 Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3010 = N_Subtype_Indication
;
3013 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
3015 if Is_Task_Type
(Parent_Type
) then
3016 Set_Storage_Size_Variable
(Derived_Type
,
3017 Storage_Size_Variable
(Parent_Type
));
3020 if Present
(Discriminant_Specifications
(N
)) then
3021 New_Scope
(Derived_Type
);
3022 Check_Or_Process_Discriminants
(N
, Derived_Type
);
3025 elsif Constraint_Present
then
3027 -- Build constrained subtype and derive from it
3030 Loc
: constant Source_Ptr
:= Sloc
(N
);
3032 Make_Defining_Identifier
(Loc
,
3033 New_External_Name
(Chars
(Derived_Type
), 'T'));
3038 Make_Subtype_Declaration
(Loc
,
3039 Defining_Identifier
=> Anon
,
3040 Subtype_Indication
=>
3041 New_Copy_Tree
(Subtype_Indication
(Type_Definition
(N
))));
3042 Insert_Before
(N
, Decl
);
3043 Rewrite
(Subtype_Indication
(Type_Definition
(N
)),
3044 New_Occurrence_Of
(Anon
, Loc
));
3046 Set_Analyzed
(Derived_Type
, False);
3052 -- All attributes are inherited from parent. In particular,
3053 -- entries and the corresponding record type are the same.
3054 -- Discriminants may be renamed, and must be treated separately.
3056 Set_Has_Discriminants
3057 (Derived_Type
, Has_Discriminants
(Parent_Type
));
3058 Set_Corresponding_Record_Type
3059 (Derived_Type
, Corresponding_Record_Type
(Parent_Type
));
3061 if Constraint_Present
then
3063 if not Has_Discriminants
(Parent_Type
) then
3064 Error_Msg_N
("untagged parent must have discriminants", N
);
3066 elsif Present
(Discriminant_Specifications
(N
)) then
3068 -- Verify that new discriminants are used to constrain
3071 Old_Disc
:= First_Discriminant
(Parent_Type
);
3072 New_Disc
:= First_Discriminant
(Derived_Type
);
3073 Disc_Spec
:= First
(Discriminant_Specifications
(N
));
3077 (Constraint
(Subtype_Indication
(Type_Definition
(N
)))));
3079 while Present
(Old_Disc
) and then Present
(Disc_Spec
) loop
3081 if Nkind
(Discriminant_Type
(Disc_Spec
)) /=
3084 Analyze
(Discriminant_Type
(Disc_Spec
));
3086 if not Subtypes_Statically_Compatible
(
3087 Etype
(Discriminant_Type
(Disc_Spec
)),
3091 ("not statically compatible with parent discriminant",
3092 Discriminant_Type
(Disc_Spec
));
3096 if Nkind
(D_Constraint
) = N_Identifier
3097 and then Chars
(D_Constraint
) /=
3098 Chars
(Defining_Identifier
(Disc_Spec
))
3100 Error_Msg_N
("new discriminants must constrain old ones",
3103 Set_Corresponding_Discriminant
(New_Disc
, Old_Disc
);
3106 Next_Discriminant
(Old_Disc
);
3107 Next_Discriminant
(New_Disc
);
3111 if Present
(Old_Disc
) or else Present
(Disc_Spec
) then
3112 Error_Msg_N
("discriminant mismatch in derivation", N
);
3117 elsif Present
(Discriminant_Specifications
(N
)) then
3119 ("missing discriminant constraint in untagged derivation",
3123 if Present
(Discriminant_Specifications
(N
)) then
3125 Old_Disc
:= First_Discriminant
(Parent_Type
);
3127 while Present
(Old_Disc
) loop
3129 if No
(Next_Entity
(Old_Disc
))
3130 or else Ekind
(Next_Entity
(Old_Disc
)) /= E_Discriminant
3132 Set_Next_Entity
(Last_Entity
(Derived_Type
),
3133 Next_Entity
(Old_Disc
));
3137 Next_Discriminant
(Old_Disc
);
3141 Set_First_Entity
(Derived_Type
, First_Entity
(Parent_Type
));
3142 if Has_Discriminants
(Parent_Type
) then
3143 Set_Discriminant_Constraint
(
3144 Derived_Type
, Discriminant_Constraint
(Parent_Type
));
3148 Set_Last_Entity
(Derived_Type
, Last_Entity
(Parent_Type
));
3150 Set_Has_Completion
(Derived_Type
);
3151 end Build_Derived_Concurrent_Type
;
3153 ------------------------------------
3154 -- Build_Derived_Enumeration_Type --
3155 ------------------------------------
3157 procedure Build_Derived_Enumeration_Type
3159 Parent_Type
: Entity_Id
;
3160 Derived_Type
: Entity_Id
)
3162 Loc
: constant Source_Ptr
:= Sloc
(N
);
3163 Def
: constant Node_Id
:= Type_Definition
(N
);
3164 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
3165 Implicit_Base
: Entity_Id
;
3166 Literal
: Entity_Id
;
3167 New_Lit
: Entity_Id
;
3168 Literals_List
: List_Id
;
3169 Type_Decl
: Node_Id
;
3171 Rang_Expr
: Node_Id
;
3174 -- Since types Standard.Character and Standard.Wide_Character do
3175 -- not have explicit literals lists we need to process types derived
3176 -- from them specially. This is handled by Derived_Standard_Character.
3177 -- If the parent type is a generic type, there are no literals either,
3178 -- and we construct the same skeletal representation as for the generic
3181 if Root_Type
(Parent_Type
) = Standard_Character
3182 or else Root_Type
(Parent_Type
) = Standard_Wide_Character
3184 Derived_Standard_Character
(N
, Parent_Type
, Derived_Type
);
3186 elsif Is_Generic_Type
(Root_Type
(Parent_Type
)) then
3193 Make_Attribute_Reference
(Loc
,
3194 Attribute_Name
=> Name_First
,
3195 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
3196 Set_Etype
(Lo
, Derived_Type
);
3199 Make_Attribute_Reference
(Loc
,
3200 Attribute_Name
=> Name_Last
,
3201 Prefix
=> New_Reference_To
(Derived_Type
, Loc
));
3202 Set_Etype
(Hi
, Derived_Type
);
3204 Set_Scalar_Range
(Derived_Type
,
3211 -- If a constraint is present, analyze the bounds to catch
3212 -- premature usage of the derived literals.
3214 if Nkind
(Indic
) = N_Subtype_Indication
3215 and then Nkind
(Range_Expression
(Constraint
(Indic
))) = N_Range
3217 Analyze
(Low_Bound
(Range_Expression
(Constraint
(Indic
))));
3218 Analyze
(High_Bound
(Range_Expression
(Constraint
(Indic
))));
3221 -- Introduce an implicit base type for the derived type even
3222 -- if there is no constraint attached to it, since this seems
3223 -- closer to the Ada semantics. Build a full type declaration
3224 -- tree for the derived type using the implicit base type as
3225 -- the defining identifier. The build a subtype declaration
3226 -- tree which applies the constraint (if any) have it replace
3227 -- the derived type declaration.
3229 Literal
:= First_Literal
(Parent_Type
);
3230 Literals_List
:= New_List
;
3232 while Present
(Literal
)
3233 and then Ekind
(Literal
) = E_Enumeration_Literal
3235 -- Literals of the derived type have the same representation as
3236 -- those of the parent type, but this representation can be
3237 -- overridden by an explicit representation clause. Indicate
3238 -- that there is no explicit representation given yet. These
3239 -- derived literals are implicit operations of the new type,
3240 -- and can be overriden by explicit ones.
3242 if Nkind
(Literal
) = N_Defining_Character_Literal
then
3244 Make_Defining_Character_Literal
(Loc
, Chars
(Literal
));
3246 New_Lit
:= Make_Defining_Identifier
(Loc
, Chars
(Literal
));
3249 Set_Ekind
(New_Lit
, E_Enumeration_Literal
);
3250 Set_Enumeration_Pos
(New_Lit
, Enumeration_Pos
(Literal
));
3251 Set_Enumeration_Rep
(New_Lit
, Enumeration_Rep
(Literal
));
3252 Set_Enumeration_Rep_Expr
(New_Lit
, Empty
);
3253 Set_Alias
(New_Lit
, Literal
);
3254 Set_Is_Known_Valid
(New_Lit
, True);
3256 Append
(New_Lit
, Literals_List
);
3257 Next_Literal
(Literal
);
3261 Make_Defining_Identifier
(Sloc
(Derived_Type
),
3262 New_External_Name
(Chars
(Derived_Type
), 'B'));
3264 -- Indicate the proper nature of the derived type. This must
3265 -- be done before analysis of the literals, to recognize cases
3266 -- when a literal may be hidden by a previous explicit function
3267 -- definition (cf. c83031a).
3269 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
3270 Set_Etype
(Derived_Type
, Implicit_Base
);
3273 Make_Full_Type_Declaration
(Loc
,
3274 Defining_Identifier
=> Implicit_Base
,
3275 Discriminant_Specifications
=> No_List
,
3277 Make_Enumeration_Type_Definition
(Loc
, Literals_List
));
3279 Mark_Rewrite_Insertion
(Type_Decl
);
3280 Insert_Before
(N
, Type_Decl
);
3281 Analyze
(Type_Decl
);
3283 -- After the implicit base is analyzed its Etype needs to be
3284 -- changed to reflect the fact that it is derived from the
3285 -- parent type which was ignored during analysis. We also set
3286 -- the size at this point.
3288 Set_Etype
(Implicit_Base
, Parent_Type
);
3290 Set_Size_Info
(Implicit_Base
, Parent_Type
);
3291 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Type
));
3292 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Type
));
3294 Set_Has_Non_Standard_Rep
3295 (Implicit_Base
, Has_Non_Standard_Rep
3297 Set_Has_Delayed_Freeze
(Implicit_Base
);
3299 -- Process the subtype indication including a validation check
3300 -- on the constraint, if any. If a constraint is given, its bounds
3301 -- must be implicitly converted to the new type.
3303 if Nkind
(Indic
) = N_Subtype_Indication
then
3306 R
: constant Node_Id
:=
3307 Range_Expression
(Constraint
(Indic
));
3310 if Nkind
(R
) = N_Range
then
3311 Hi
:= Build_Scalar_Bound
3312 (High_Bound
(R
), Parent_Type
, Implicit_Base
);
3313 Lo
:= Build_Scalar_Bound
3314 (Low_Bound
(R
), Parent_Type
, Implicit_Base
);
3317 -- Constraint is a Range attribute. Replace with the
3318 -- explicit mention of the bounds of the prefix, which
3319 -- must be a subtype.
3321 Analyze
(Prefix
(R
));
3323 Convert_To
(Implicit_Base
,
3324 Make_Attribute_Reference
(Loc
,
3325 Attribute_Name
=> Name_Last
,
3327 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
3330 Convert_To
(Implicit_Base
,
3331 Make_Attribute_Reference
(Loc
,
3332 Attribute_Name
=> Name_First
,
3334 New_Occurrence_Of
(Entity
(Prefix
(R
)), Loc
)));
3342 (Type_High_Bound
(Parent_Type
),
3343 Parent_Type
, Implicit_Base
);
3346 (Type_Low_Bound
(Parent_Type
),
3347 Parent_Type
, Implicit_Base
);
3355 -- If we constructed a default range for the case where no range
3356 -- was given, then the expressions in the range must not freeze
3357 -- since they do not correspond to expressions in the source.
3359 if Nkind
(Indic
) /= N_Subtype_Indication
then
3360 Set_Must_Not_Freeze
(Lo
);
3361 Set_Must_Not_Freeze
(Hi
);
3362 Set_Must_Not_Freeze
(Rang_Expr
);
3366 Make_Subtype_Declaration
(Loc
,
3367 Defining_Identifier
=> Derived_Type
,
3368 Subtype_Indication
=>
3369 Make_Subtype_Indication
(Loc
,
3370 Subtype_Mark
=> New_Occurrence_Of
(Implicit_Base
, Loc
),
3372 Make_Range_Constraint
(Loc
,
3373 Range_Expression
=> Rang_Expr
))));
3377 -- If pragma Discard_Names applies on the first subtype
3378 -- of the parent type, then it must be applied on this
3381 if Einfo
.Discard_Names
(First_Subtype
(Parent_Type
)) then
3382 Set_Discard_Names
(Derived_Type
);
3385 -- Apply a range check. Since this range expression doesn't
3386 -- have an Etype, we have to specifically pass the Source_Typ
3387 -- parameter. Is this right???
3389 if Nkind
(Indic
) = N_Subtype_Indication
then
3390 Apply_Range_Check
(Range_Expression
(Constraint
(Indic
)),
3392 Source_Typ
=> Entity
(Subtype_Mark
(Indic
)));
3396 end Build_Derived_Enumeration_Type
;
3398 --------------------------------
3399 -- Build_Derived_Numeric_Type --
3400 --------------------------------
3402 procedure Build_Derived_Numeric_Type
3404 Parent_Type
: Entity_Id
;
3405 Derived_Type
: Entity_Id
)
3407 Loc
: constant Source_Ptr
:= Sloc
(N
);
3408 Tdef
: constant Node_Id
:= Type_Definition
(N
);
3409 Indic
: constant Node_Id
:= Subtype_Indication
(Tdef
);
3410 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
3411 No_Constraint
: constant Boolean := Nkind
(Indic
) /=
3412 N_Subtype_Indication
;
3413 Implicit_Base
: Entity_Id
;
3420 -- Process the subtype indication including a validation check on
3421 -- the constraint if any.
3423 T
:= Process_Subtype
(Indic
, N
);
3425 -- Introduce an implicit base type for the derived type even if
3426 -- there is no constraint attached to it, since this seems closer
3427 -- to the Ada semantics.
3430 Create_Itype
(Ekind
(Parent_Base
), N
, Derived_Type
, 'B');
3432 Set_Etype
(Implicit_Base
, Parent_Base
);
3433 Set_Ekind
(Implicit_Base
, Ekind
(Parent_Base
));
3434 Set_Size_Info
(Implicit_Base
, Parent_Base
);
3435 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
3436 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Parent_Base
));
3437 Set_Parent
(Implicit_Base
, Parent
(Derived_Type
));
3439 if Is_Discrete_Or_Fixed_Point_Type
(Parent_Base
) then
3440 Set_RM_Size
(Implicit_Base
, RM_Size
(Parent_Base
));
3443 Set_Has_Delayed_Freeze
(Implicit_Base
);
3445 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Base
));
3446 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Base
));
3448 Set_Scalar_Range
(Implicit_Base
,
3453 if Has_Infinities
(Parent_Base
) then
3454 Set_Includes_Infinities
(Scalar_Range
(Implicit_Base
));
3457 -- The Derived_Type, which is the entity of the declaration, is
3458 -- a subtype of the implicit base. Its Ekind is a subtype, even
3459 -- in the absence of an explicit constraint.
3461 Set_Etype
(Derived_Type
, Implicit_Base
);
3463 -- If we did not have a constraint, then the Ekind is set from the
3464 -- parent type (otherwise Process_Subtype has set the bounds)
3466 if No_Constraint
then
3467 Set_Ekind
(Derived_Type
, Subtype_Kind
(Ekind
(Parent_Type
)));
3470 -- If we did not have a range constraint, then set the range
3471 -- from the parent type. Otherwise, the call to Process_Subtype
3472 -- has set the bounds.
3475 or else not Has_Range_Constraint
(Indic
)
3477 Set_Scalar_Range
(Derived_Type
,
3479 Low_Bound
=> New_Copy_Tree
(Type_Low_Bound
(Parent_Type
)),
3480 High_Bound
=> New_Copy_Tree
(Type_High_Bound
(Parent_Type
))));
3481 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
3483 if Has_Infinities
(Parent_Type
) then
3484 Set_Includes_Infinities
(Scalar_Range
(Derived_Type
));
3488 -- Set remaining type-specific fields, depending on numeric type
3490 if Is_Modular_Integer_Type
(Parent_Type
) then
3491 Set_Modulus
(Implicit_Base
, Modulus
(Parent_Base
));
3493 Set_Non_Binary_Modulus
3494 (Implicit_Base
, Non_Binary_Modulus
(Parent_Base
));
3496 elsif Is_Floating_Point_Type
(Parent_Type
) then
3498 -- Digits of base type is always copied from the digits value of
3499 -- the parent base type, but the digits of the derived type will
3500 -- already have been set if there was a constraint present.
3502 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
3503 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Parent_Base
));
3505 if No_Constraint
then
3506 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Type
));
3509 elsif Is_Fixed_Point_Type
(Parent_Type
) then
3511 -- Small of base type and derived type are always copied from
3512 -- the parent base type, since smalls never change. The delta
3513 -- of the base type is also copied from the parent base type.
3514 -- However the delta of the derived type will have been set
3515 -- already if a constraint was present.
3517 Set_Small_Value
(Derived_Type
, Small_Value
(Parent_Base
));
3518 Set_Small_Value
(Implicit_Base
, Small_Value
(Parent_Base
));
3519 Set_Delta_Value
(Implicit_Base
, Delta_Value
(Parent_Base
));
3521 if No_Constraint
then
3522 Set_Delta_Value
(Derived_Type
, Delta_Value
(Parent_Type
));
3525 -- The scale and machine radix in the decimal case are always
3526 -- copied from the parent base type.
3528 if Is_Decimal_Fixed_Point_Type
(Parent_Type
) then
3529 Set_Scale_Value
(Derived_Type
, Scale_Value
(Parent_Base
));
3530 Set_Scale_Value
(Implicit_Base
, Scale_Value
(Parent_Base
));
3532 Set_Machine_Radix_10
3533 (Derived_Type
, Machine_Radix_10
(Parent_Base
));
3534 Set_Machine_Radix_10
3535 (Implicit_Base
, Machine_Radix_10
(Parent_Base
));
3537 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Parent_Base
));
3539 if No_Constraint
then
3540 Set_Digits_Value
(Derived_Type
, Digits_Value
(Parent_Base
));
3543 -- the analysis of the subtype_indication sets the
3544 -- digits value of the derived type.
3551 -- The type of the bounds is that of the parent type, and they
3552 -- must be converted to the derived type.
3554 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
3556 -- The implicit_base should be frozen when the derived type is frozen,
3557 -- but note that it is used in the conversions of the bounds. For
3558 -- fixed types we delay the determination of the bounds until the proper
3559 -- freezing point. For other numeric types this is rejected by GCC, for
3560 -- reasons that are currently unclear (???), so we choose to freeze the
3561 -- implicit base now. In the case of integers and floating point types
3562 -- this is harmless because subsequent representation clauses cannot
3563 -- affect anything, but it is still baffling that we cannot use the
3564 -- same mechanism for all derived numeric types.
3566 if Is_Fixed_Point_Type
(Parent_Type
) then
3567 Conditional_Delay
(Implicit_Base
, Parent_Type
);
3569 Freeze_Before
(N
, Implicit_Base
);
3572 end Build_Derived_Numeric_Type
;
3574 --------------------------------
3575 -- Build_Derived_Private_Type --
3576 --------------------------------
3578 procedure Build_Derived_Private_Type
3580 Parent_Type
: Entity_Id
;
3581 Derived_Type
: Entity_Id
;
3582 Is_Completion
: Boolean;
3583 Derive_Subps
: Boolean := True)
3585 Der_Base
: Entity_Id
;
3587 Full_Decl
: Node_Id
:= Empty
;
3588 Full_Der
: Entity_Id
;
3590 Last_Discr
: Entity_Id
;
3591 Par_Scope
: constant Entity_Id
:= Scope
(Base_Type
(Parent_Type
));
3592 Swapped
: Boolean := False;
3594 procedure Copy_And_Build
;
3595 -- Copy derived type declaration, replace parent with its full view,
3596 -- and analyze new declaration.
3598 --------------------
3599 -- Copy_And_Build --
3600 --------------------
3602 procedure Copy_And_Build
is
3606 if Ekind
(Parent_Type
) in Record_Kind
3607 or else (Ekind
(Parent_Type
) in Enumeration_Kind
3608 and then Root_Type
(Parent_Type
) /= Standard_Character
3609 and then Root_Type
(Parent_Type
) /= Standard_Wide_Character
3610 and then not Is_Generic_Type
(Root_Type
(Parent_Type
)))
3612 Full_N
:= New_Copy_Tree
(N
);
3613 Insert_After
(N
, Full_N
);
3614 Build_Derived_Type
(
3615 Full_N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
3618 Build_Derived_Type
(
3619 N
, Parent_Type
, Full_Der
, True, Derive_Subps
=> False);
3623 -- Start of processing for Build_Derived_Private_Type
3626 if Is_Tagged_Type
(Parent_Type
) then
3627 Build_Derived_Record_Type
3628 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
3631 elsif Has_Discriminants
(Parent_Type
) then
3633 if Present
(Full_View
(Parent_Type
)) then
3634 if not Is_Completion
then
3636 -- Copy declaration for subsequent analysis.
3638 Full_Decl
:= New_Copy_Tree
(N
);
3639 Full_Der
:= New_Copy
(Derived_Type
);
3640 Insert_After
(N
, Full_Decl
);
3643 -- If this is a completion, the full view being built is
3644 -- itself private. We build a subtype of the parent with
3645 -- the same constraints as this full view, to convey to the
3646 -- back end the constrained components and the size of this
3647 -- subtype. If the parent is constrained, its full view can
3648 -- serve as the underlying full view of the derived type.
3650 if No
(Discriminant_Specifications
(N
)) then
3652 if Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3653 = N_Subtype_Indication
3655 Build_Underlying_Full_View
(N
, Derived_Type
, Parent_Type
);
3657 elsif Is_Constrained
(Full_View
(Parent_Type
)) then
3658 Set_Underlying_Full_View
(Derived_Type
,
3659 Full_View
(Parent_Type
));
3663 -- If there are new discriminants, the parent subtype is
3664 -- constrained by them, but it is not clear how to build
3665 -- the underlying_full_view in this case ???
3672 Build_Derived_Record_Type
3673 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
3675 if Present
(Full_View
(Parent_Type
))
3676 and then not Is_Completion
3678 if not In_Open_Scopes
(Par_Scope
)
3679 or else not In_Same_Source_Unit
(N
, Parent_Type
)
3681 -- Swap partial and full views temporarily
3683 Install_Private_Declarations
(Par_Scope
);
3684 Install_Visible_Declarations
(Par_Scope
);
3688 -- Subprograms have been derived on the private view,
3689 -- the completion does not derive them anew.
3691 Build_Derived_Record_Type
3692 (Full_Decl
, Parent_Type
, Full_Der
, False);
3695 Uninstall_Declarations
(Par_Scope
);
3697 if In_Open_Scopes
(Par_Scope
) then
3698 Install_Visible_Declarations
(Par_Scope
);
3702 Der_Base
:= Base_Type
(Derived_Type
);
3703 Set_Full_View
(Derived_Type
, Full_Der
);
3704 Set_Full_View
(Der_Base
, Base_Type
(Full_Der
));
3706 -- Copy the discriminant list from full view to
3707 -- the partial views (base type and its subtype).
3708 -- Gigi requires that the partial and full views
3709 -- have the same discriminants.
3710 -- ??? Note that since the partial view is pointing
3711 -- to discriminants in the full view, their scope
3712 -- will be that of the full view. This might
3713 -- cause some front end problems and need
3716 Discr
:= First_Discriminant
(Base_Type
(Full_Der
));
3717 Set_First_Entity
(Der_Base
, Discr
);
3720 Last_Discr
:= Discr
;
3721 Next_Discriminant
(Discr
);
3722 exit when No
(Discr
);
3725 Set_Last_Entity
(Der_Base
, Last_Discr
);
3727 Set_First_Entity
(Derived_Type
, First_Entity
(Der_Base
));
3728 Set_Last_Entity
(Derived_Type
, Last_Entity
(Der_Base
));
3731 -- If this is a completion, the derived type stays private
3732 -- and there is no need to create a further full view, except
3733 -- in the unusual case when the derivation is nested within a
3734 -- child unit, see below.
3739 elsif Present
(Full_View
(Parent_Type
))
3740 and then Has_Discriminants
(Full_View
(Parent_Type
))
3742 if Has_Unknown_Discriminants
(Parent_Type
)
3743 and then Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3744 = N_Subtype_Indication
3747 ("cannot constrain type with unknown discriminants",
3748 Subtype_Indication
(Type_Definition
(N
)));
3752 -- If full view of parent is a record type, Build full view as
3753 -- a derivation from the parent's full view. Partial view remains
3756 if not Is_Private_Type
(Full_View
(Parent_Type
)) then
3757 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
3758 Chars
(Derived_Type
));
3759 Set_Is_Itype
(Full_Der
);
3760 Set_Has_Private_Declaration
(Full_Der
);
3761 Set_Has_Private_Declaration
(Derived_Type
);
3762 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3763 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3764 Set_Full_View
(Derived_Type
, Full_Der
);
3766 Full_P
:= Full_View
(Parent_Type
);
3767 Exchange_Declarations
(Parent_Type
);
3769 Exchange_Declarations
(Full_P
);
3772 Build_Derived_Record_Type
3773 (N
, Full_View
(Parent_Type
), Derived_Type
,
3774 Derive_Subps
=> False);
3777 -- In any case, the primitive operations are inherited from
3778 -- the parent type, not from the internal full view.
3780 Set_Etype
(Base_Type
(Derived_Type
), Base_Type
(Parent_Type
));
3782 if Derive_Subps
then
3783 Derive_Subprograms
(Parent_Type
, Derived_Type
);
3787 -- Untagged type, No discriminants on either view
3789 if Nkind
(Subtype_Indication
(Type_Definition
(N
)))
3790 = N_Subtype_Indication
3793 ("illegal constraint on type without discriminants", N
);
3796 if Present
(Discriminant_Specifications
(N
))
3797 and then Present
(Full_View
(Parent_Type
))
3798 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
3801 ("cannot add discriminants to untagged type", N
);
3804 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
3805 Set_Is_Constrained
(Derived_Type
, Is_Constrained
(Parent_Type
));
3806 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
3807 Set_Has_Controlled_Component
3808 (Derived_Type
, Has_Controlled_Component
3811 -- Direct controlled types do not inherit Finalize_Storage_Only flag
3813 if not Is_Controlled
(Parent_Type
) then
3814 Set_Finalize_Storage_Only
3815 (Base_Type
(Derived_Type
), Finalize_Storage_Only
(Parent_Type
));
3818 -- Construct the implicit full view by deriving from full
3819 -- view of the parent type. In order to get proper visiblity,
3820 -- we install the parent scope and its declarations.
3822 -- ??? if the parent is untagged private and its
3823 -- completion is tagged, this mechanism will not
3824 -- work because we cannot derive from the tagged
3825 -- full view unless we have an extension
3827 if Present
(Full_View
(Parent_Type
))
3828 and then not Is_Tagged_Type
(Full_View
(Parent_Type
))
3829 and then not Is_Completion
3831 Full_Der
:= Make_Defining_Identifier
(Sloc
(Derived_Type
),
3832 Chars
(Derived_Type
));
3833 Set_Is_Itype
(Full_Der
);
3834 Set_Has_Private_Declaration
(Full_Der
);
3835 Set_Has_Private_Declaration
(Derived_Type
);
3836 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3837 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3838 Set_Full_View
(Derived_Type
, Full_Der
);
3840 if not In_Open_Scopes
(Par_Scope
) then
3841 Install_Private_Declarations
(Par_Scope
);
3842 Install_Visible_Declarations
(Par_Scope
);
3844 Uninstall_Declarations
(Par_Scope
);
3846 -- If parent scope is open and in another unit, and
3847 -- parent has a completion, then the derivation is taking
3848 -- place in the visible part of a child unit. In that
3849 -- case retrieve the full view of the parent momentarily.
3851 elsif not In_Same_Source_Unit
(N
, Parent_Type
) then
3852 Full_P
:= Full_View
(Parent_Type
);
3853 Exchange_Declarations
(Parent_Type
);
3855 Exchange_Declarations
(Full_P
);
3857 -- Otherwise it is a local derivation.
3863 Set_Scope
(Full_Der
, Current_Scope
);
3864 Set_Is_First_Subtype
(Full_Der
,
3865 Is_First_Subtype
(Derived_Type
));
3866 Set_Has_Size_Clause
(Full_Der
, False);
3867 Set_Has_Alignment_Clause
(Full_Der
, False);
3868 Set_Next_Entity
(Full_Der
, Empty
);
3869 Set_Has_Delayed_Freeze
(Full_Der
);
3870 Set_Is_Frozen
(Full_Der
, False);
3871 Set_Freeze_Node
(Full_Der
, Empty
);
3872 Set_Depends_On_Private
(Full_Der
,
3873 Has_Private_Component
(Full_Der
));
3874 Set_Public_Status
(Full_Der
);
3878 Set_Has_Unknown_Discriminants
(Derived_Type
,
3879 Has_Unknown_Discriminants
(Parent_Type
));
3881 if Is_Private_Type
(Derived_Type
) then
3882 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
3885 if Is_Private_Type
(Parent_Type
)
3886 and then Base_Type
(Parent_Type
) = Parent_Type
3887 and then In_Open_Scopes
(Scope
(Parent_Type
))
3889 Append_Elmt
(Derived_Type
, Private_Dependents
(Parent_Type
));
3891 if Is_Child_Unit
(Scope
(Current_Scope
))
3892 and then Is_Completion
3893 and then In_Private_Part
(Current_Scope
)
3894 and then Scope
(Parent_Type
) /= Current_Scope
3896 -- This is the unusual case where a type completed by a private
3897 -- derivation occurs within a package nested in a child unit,
3898 -- and the parent is declared in an ancestor. In this case, the
3899 -- full view of the parent type will become visible in the body
3900 -- of the enclosing child, and only then will the current type
3901 -- be possibly non-private. We build a underlying full view that
3902 -- will be installed when the enclosing child body is compiled.
3905 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
3909 Make_Defining_Identifier
(Sloc
(Derived_Type
),
3910 Chars
(Derived_Type
));
3911 Set_Is_Itype
(Full_Der
);
3912 Set_Itype
(IR
, Full_Der
);
3913 Insert_After
(N
, IR
);
3915 -- The full view will be used to swap entities on entry/exit
3916 -- to the body, and must appear in the entity list for the
3919 Append_Entity
(Full_Der
, Scope
(Derived_Type
));
3920 Set_Has_Private_Declaration
(Full_Der
);
3921 Set_Has_Private_Declaration
(Derived_Type
);
3922 Set_Associated_Node_For_Itype
(Full_Der
, N
);
3923 Set_Parent
(Full_Der
, Parent
(Derived_Type
));
3924 Full_P
:= Full_View
(Parent_Type
);
3925 Exchange_Declarations
(Parent_Type
);
3927 Exchange_Declarations
(Full_P
);
3928 Set_Underlying_Full_View
(Derived_Type
, Full_Der
);
3932 end Build_Derived_Private_Type
;
3934 -------------------------------
3935 -- Build_Derived_Record_Type --
3936 -------------------------------
3940 -- Ideally we would like to use the same model of type derivation for
3941 -- tagged and untagged record types. Unfortunately this is not quite
3942 -- possible because the semantics of representation clauses is different
3943 -- for tagged and untagged records under inheritance. Consider the
3946 -- type R (...) is [tagged] record ... end record;
3947 -- type T (...) is new R (...) [with ...];
3949 -- The representation clauses of T can specify a completely different
3950 -- record layout from R's. Hence the same component can be placed in
3951 -- two very different positions in objects of type T and R. If R and T
3952 -- are tagged types, representation clauses for T can only specify the
3953 -- layout of non inherited components, thus components that are common
3954 -- in R and T have the same position in objects of type R and T.
3956 -- This has two implications. The first is that the entire tree for R's
3957 -- declaration needs to be copied for T in the untagged case, so that
3958 -- T can be viewd as a record type of its own with its own derivation
3959 -- clauses. The second implication is the way we handle discriminants.
3960 -- Specifically, in the untagged case we need a way to communicate to Gigi
3961 -- what are the real discriminants in the record, while for the semantics
3962 -- we need to consider those introduced by the user to rename the
3963 -- discriminants in the parent type. This is handled by introducing the
3964 -- notion of girder discriminants. See below for more.
3966 -- Fortunately the way regular components are inherited can be handled in
3967 -- the same way in tagged and untagged types.
3969 -- To complicate things a bit more the private view of a private extension
3970 -- cannot be handled in the same way as the full view (for one thing the
3971 -- semantic rules are somewhat different). We will explain what differs
3974 -- 2. DISCRIMINANTS UNDER INHERITANCE.
3976 -- The semantic rules governing the discriminants of derived types are
3979 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
3980 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
3982 -- If parent type has discriminants, then the discriminants that are
3983 -- declared in the derived type are [3.4 (11)]:
3985 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
3988 -- o Otherwise, each discriminant of the parent type (implicitly
3989 -- declared in the same order with the same specifications). In this
3990 -- case, the discriminants are said to be "inherited", or if unknown in
3991 -- the parent are also unknown in the derived type.
3993 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
3995 -- o The parent subtype shall be constrained;
3997 -- o If the parent type is not a tagged type, then each discriminant of
3998 -- the derived type shall be used in the constraint defining a parent
3999 -- subtype [Implementation note: this ensures that the new discriminant
4000 -- can share storage with an existing discriminant.].
4002 -- For the derived type each discriminant of the parent type is either
4003 -- inherited, constrained to equal some new discriminant of the derived
4004 -- type, or constrained to the value of an expression.
4006 -- When inherited or constrained to equal some new discriminant, the
4007 -- parent discriminant and the discriminant of the derived type are said
4010 -- If a discriminant of the parent type is constrained to a specific value
4011 -- in the derived type definition, then the discriminant is said to be
4012 -- "specified" by that derived type definition.
4014 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
4016 -- We have spoken about girder discriminants in the point 1 (introduction)
4017 -- above. There are two sort of girder discriminants: implicit and
4018 -- explicit. As long as the derived type inherits the same discriminants as
4019 -- the root record type, girder discriminants are the same as regular
4020 -- discriminants, and are said to be implicit. However, if any discriminant
4021 -- in the root type was renamed in the derived type, then the derived
4022 -- type will contain explicit girder discriminants. Explicit girder
4023 -- discriminants are discriminants in addition to the semantically visible
4024 -- discriminants defined for the derived type. Girder discriminants are
4025 -- used by Gigi to figure out what are the physical discriminants in
4026 -- objects of the derived type (see precise definition in einfo.ads).
4027 -- As an example, consider the following:
4029 -- type R (D1, D2, D3 : Int) is record ... end record;
4030 -- type T1 is new R;
4031 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
4032 -- type T3 is new T2;
4033 -- type T4 (Y : Int) is new T3 (Y, 99);
4035 -- The following table summarizes the discriminants and girder
4036 -- discriminants in R and T1 through T4.
4038 -- Type Discrim Girder Discrim Comment
4039 -- R (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in R
4040 -- T1 (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in T1
4041 -- T2 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T2
4042 -- T3 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T3
4043 -- T4 (Y) (D1, D2, D3) Gider discrims are EXPLICIT in T4
4045 -- Field Corresponding_Discriminant (abbreviated CD below) allows to find
4046 -- the corresponding discriminant in the parent type, while
4047 -- Original_Record_Component (abbreviated ORC below), the actual physical
4048 -- component that is renamed. Finally the field Is_Completely_Hidden
4049 -- (abbreaviated ICH below) is set for all explicit girder discriminants
4050 -- (see einfo.ads for more info). For the above example this gives:
4052 -- Discrim CD ORC ICH
4053 -- ^^^^^^^ ^^ ^^^ ^^^
4054 -- D1 in R empty itself no
4055 -- D2 in R empty itself no
4056 -- D3 in R empty itself no
4058 -- D1 in T1 D1 in R itself no
4059 -- D2 in T1 D2 in R itself no
4060 -- D3 in T1 D3 in R itself no
4062 -- X1 in T2 D3 in T1 D3 in T2 no
4063 -- X2 in T2 D1 in T1 D1 in T2 no
4064 -- D1 in T2 empty itself yes
4065 -- D2 in T2 empty itself yes
4066 -- D3 in T2 empty itself yes
4068 -- X1 in T3 X1 in T2 D3 in T3 no
4069 -- X2 in T3 X2 in T2 D1 in T3 no
4070 -- D1 in T3 empty itself yes
4071 -- D2 in T3 empty itself yes
4072 -- D3 in T3 empty itself yes
4074 -- Y in T4 X1 in T3 D3 in T3 no
4075 -- D1 in T3 empty itself yes
4076 -- D2 in T3 empty itself yes
4077 -- D3 in T3 empty itself yes
4079 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES.
4081 -- Type derivation for tagged types is fairly straightforward. if no
4082 -- discriminants are specified by the derived type, these are inherited
4083 -- from the parent. No explicit girder discriminants are ever necessary.
4084 -- The only manipulation that is done to the tree is that of adding a
4085 -- _parent field with parent type and constrained to the same constraint
4086 -- specified for the parent in the derived type definition. For instance:
4088 -- type R (D1, D2, D3 : Int) is tagged record ... end record;
4089 -- type T1 is new R with null record;
4090 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
4092 -- are changed into :
4094 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
4095 -- _parent : R (D1, D2, D3);
4098 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
4099 -- _parent : T1 (X2, 88, X1);
4102 -- The discriminants actually present in R, T1 and T2 as well as their CD,
4103 -- ORC and ICH fields are:
4105 -- Discrim CD ORC ICH
4106 -- ^^^^^^^ ^^ ^^^ ^^^
4107 -- D1 in R empty itself no
4108 -- D2 in R empty itself no
4109 -- D3 in R empty itself no
4111 -- D1 in T1 D1 in R D1 in R no
4112 -- D2 in T1 D2 in R D2 in R no
4113 -- D3 in T1 D3 in R D3 in R no
4115 -- X1 in T2 D3 in T1 D3 in R no
4116 -- X2 in T2 D1 in T1 D1 in R no
4118 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS.
4120 -- Regardless of whether we dealing with a tagged or untagged type
4121 -- we will transform all derived type declarations of the form
4123 -- type T is new R (...) [with ...];
4125 -- subtype S is R (...);
4126 -- type T is new S [with ...];
4128 -- type BT is new R [with ...];
4129 -- subtype T is BT (...);
4131 -- That is, the base derived type is constrained only if it has no
4132 -- discriminants. The reason for doing this is that GNAT's semantic model
4133 -- assumes that a base type with discriminants is unconstrained.
4135 -- Note that, strictly speaking, the above transformation is not always
4136 -- correct. Consider for instance the following exercpt from ACVC b34011a:
4138 -- procedure B34011A is
4139 -- type REC (D : integer := 0) is record
4144 -- type T6 is new Rec;
4145 -- function F return T6;
4150 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F.
4153 -- The definition of Q6.U is illegal. However transforming Q6.U into
4155 -- type BaseU is new T6;
4156 -- subtype U is BaseU (Q6.F.I)
4158 -- turns U into a legal subtype, which is incorrect. To avoid this problem
4159 -- we always analyze the constraint (in this case (Q6.F.I)) before applying
4160 -- the transformation described above.
4162 -- There is another instance where the above transformation is incorrect.
4166 -- type Base (D : Integer) is tagged null record;
4167 -- procedure P (X : Base);
4169 -- type Der is new Base (2) with null record;
4170 -- procedure P (X : Der);
4173 -- Then the above transformation turns this into
4175 -- type Der_Base is new Base with null record;
4176 -- -- procedure P (X : Base) is implicitly inherited here
4177 -- -- as procedure P (X : Der_Base).
4179 -- subtype Der is Der_Base (2);
4180 -- procedure P (X : Der);
4181 -- -- The overriding of P (X : Der_Base) is illegal since we
4182 -- -- have a parameter conformance problem.
4184 -- To get around this problem, after having semantically processed Der_Base
4185 -- and the rewritten subtype declaration for Der, we copy Der_Base field
4186 -- Discriminant_Constraint from Der so that when parameter conformance is
4187 -- checked when P is overridden, no sematic errors are flagged.
4189 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
4191 -- Regardless of the fact that we dealing with a tagged or untagged type
4192 -- we will transform all derived type declarations of the form
4194 -- type R (D1, .., Dn : ...) is [tagged] record ...;
4195 -- type T is new R [with ...];
4197 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
4199 -- The reason for such transformation is that it allows us to implement a
4200 -- very clean form of component inheritance as explained below.
4202 -- Note that this transformation is not achieved by direct tree rewriting
4203 -- and manipulation, but rather by redoing the semantic actions that the
4204 -- above transformation will entail. This is done directly in routine
4205 -- Inherit_Components.
4207 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE.
4209 -- In both tagged and untagged derived types, regular non discriminant
4210 -- components are inherited in the derived type from the parent type. In
4211 -- the absence of discriminants component, inheritance is straightforward
4212 -- as components can simply be copied from the parent.
4213 -- If the parent has discriminants, inheriting components constrained with
4214 -- these discriminants requires caution. Consider the following example:
4216 -- type R (D1, D2 : Positive) is [tagged] record
4217 -- S : String (D1 .. D2);
4220 -- type T1 is new R [with null record];
4221 -- type T2 (X : positive) is new R (1, X) [with null record];
4223 -- As explained in 6. above, T1 is rewritten as
4225 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
4227 -- which makes the treatment for T1 and T2 identical.
4229 -- What we want when inheriting S, is that references to D1 and D2 in R are
4230 -- replaced with references to their correct constraints, ie D1 and D2 in
4231 -- T1 and 1 and X in T2. So all R's discriminant references are replaced
4232 -- with either discriminant references in the derived type or expressions.
4233 -- This replacement is acheived as follows: before inheriting R's
4234 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
4235 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1
4236 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
4237 -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
4238 -- by String (1 .. X).
4240 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS.
4242 -- We explain here the rules governing private type extensions relevant to
4243 -- type derivation. These rules are explained on the following example:
4245 -- type D [(...)] is new A [(...)] with private; <-- partial view
4246 -- type D [(...)] is new P [(...)] with null record; <-- full view
4248 -- Type A is called the ancestor subtype of the private extension.
4249 -- Type P is the parent type of the full view of the private extension. It
4250 -- must be A or a type derived from A.
4252 -- The rules concerning the discriminants of private type extensions are
4255 -- o If a private extension inherits known discriminants from the ancestor
4256 -- subtype, then the full view shall also inherit its discriminants from
4257 -- the ancestor subtype and the parent subtype of the full view shall be
4258 -- constrained if and only if the ancestor subtype is constrained.
4260 -- o If a partial view has unknown discriminants, then the full view may
4261 -- define a definite or an indefinite subtype, with or without
4264 -- o If a partial view has neither known nor unknown discriminants, then
4265 -- the full view shall define a definite subtype.
4267 -- o If the ancestor subtype of a private extension has constrained
4268 -- discrimiants, then the parent subtype of the full view shall impose a
4269 -- statically matching constraint on those discriminants.
4271 -- This means that only the following forms of private extensions are
4274 -- type D is new A with private; <-- partial view
4275 -- type D is new P with null record; <-- full view
4277 -- If A has no discriminants than P has no discriminants, otherwise P must
4278 -- inherit A's discriminants.
4280 -- type D is new A (...) with private; <-- partial view
4281 -- type D is new P (:::) with null record; <-- full view
4283 -- P must inherit A's discriminants and (...) and (:::) must statically
4286 -- subtype A is R (...);
4287 -- type D is new A with private; <-- partial view
4288 -- type D is new P with null record; <-- full view
4290 -- P must have inherited R's discriminants and must be derived from A or
4291 -- any of its subtypes.
4293 -- type D (..) is new A with private; <-- partial view
4294 -- type D (..) is new P [(:::)] with null record; <-- full view
4296 -- No specific constraints on P's discriminants or constraint (:::).
4297 -- Note that A can be unconstrained, but the parent subtype P must either
4298 -- be constrained or (:::) must be present.
4300 -- type D (..) is new A [(...)] with private; <-- partial view
4301 -- type D (..) is new P [(:::)] with null record; <-- full view
4303 -- P's constraints on A's discriminants must statically match those
4304 -- imposed by (...).
4306 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS.
4308 -- The full view of a private extension is handled exactly as described
4309 -- above. The model chose for the private view of a private extension
4310 -- is the same for what concerns discriminants (ie they receive the same
4311 -- treatment as in the tagged case). However, the private view of the
4312 -- private extension always inherits the components of the parent base,
4313 -- without replacing any discriminant reference. Strictly speacking this
4314 -- is incorrect. However, Gigi never uses this view to generate code so
4315 -- this is a purely semantic issue. In theory, a set of transformations
4316 -- similar to those given in 5. and 6. above could be applied to private
4317 -- views of private extensions to have the same model of component
4318 -- inheritance as for non private extensions. However, this is not done
4319 -- because it would further complicate private type processing.
4320 -- Semantically speaking, this leaves us in an uncomfortable
4321 -- situation. As an example consider:
4324 -- type R (D : integer) is tagged record
4325 -- S : String (1 .. D);
4327 -- procedure P (X : R);
4328 -- type T is new R (1) with private;
4330 -- type T is new R (1) with null record;
4333 -- This is transformed into:
4336 -- type R (D : integer) is tagged record
4337 -- S : String (1 .. D);
4339 -- procedure P (X : R);
4340 -- type T is new R (1) with private;
4342 -- type BaseT is new R with null record;
4343 -- subtype T is BaseT (1);
4346 -- (strictly speaking the above is incorrect Ada).
4348 -- From the semantic standpoint the private view of private extension T
4349 -- should be flagged as constrained since one can clearly have
4353 -- in a unit withing Pack. However, when deriving subprograms for the
4354 -- private view of private extension T, T must be seen as unconstrained
4355 -- since T has discriminants (this is a constraint of the current
4356 -- subprogram derivation model). Thus, when processing the private view of
4357 -- a private extension such as T, we first mark T as unconstrained, we
4358 -- process it, we perform program derivation and just before returning from
4359 -- Build_Derived_Record_Type we mark T as constrained.
4360 -- ??? Are there are other unconfortable cases that we will have to
4363 -- 10. RECORD_TYPE_WITH_PRIVATE complications.
4365 -- Types that are derived from a visible record type and have a private
4366 -- extension present other peculiarities. They behave mostly like private
4367 -- types, but if they have primitive operations defined, these will not
4368 -- have the proper signatures for further inheritance, because other
4369 -- primitive operations will use the implicit base that we define for
4370 -- private derivations below. This affect subprogram inheritance (see
4371 -- Derive_Subprograms for details). We also derive the implicit base from
4372 -- the base type of the full view, so that the implicit base is a record
4373 -- type and not another private type, This avoids infinite loops.
4375 procedure Build_Derived_Record_Type
4377 Parent_Type
: Entity_Id
;
4378 Derived_Type
: Entity_Id
;
4379 Derive_Subps
: Boolean := True)
4381 Loc
: constant Source_Ptr
:= Sloc
(N
);
4382 Parent_Base
: Entity_Id
;
4387 Discrim
: Entity_Id
;
4388 Last_Discrim
: Entity_Id
;
4390 Discs
: Elist_Id
:= New_Elmt_List
;
4391 -- An empty Discs list means that there were no constraints in the
4392 -- subtype indication or that there was an error processing it.
4394 Assoc_List
: Elist_Id
;
4395 New_Discrs
: Elist_Id
;
4397 New_Base
: Entity_Id
;
4399 New_Indic
: Node_Id
;
4401 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Parent_Type
);
4402 Discriminant_Specs
: constant Boolean :=
4403 Present
(Discriminant_Specifications
(N
));
4404 Private_Extension
: constant Boolean :=
4405 (Nkind
(N
) = N_Private_Extension_Declaration
);
4407 Constraint_Present
: Boolean;
4408 Inherit_Discrims
: Boolean := False;
4410 Save_Etype
: Entity_Id
;
4411 Save_Discr_Constr
: Elist_Id
;
4412 Save_Next_Entity
: Entity_Id
;
4415 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
4416 and then Present
(Full_View
(Parent_Type
))
4417 and then Has_Discriminants
(Parent_Type
)
4419 Parent_Base
:= Base_Type
(Full_View
(Parent_Type
));
4421 Parent_Base
:= Base_Type
(Parent_Type
);
4424 -- Before we start the previously documented transformations, here is
4425 -- a little fix for size and alignment of tagged types. Normally when
4426 -- we derive type D from type P, we copy the size and alignment of P
4427 -- as the default for D, and in the absence of explicit representation
4428 -- clauses for D, the size and alignment are indeed the same as the
4431 -- But this is wrong for tagged types, since fields may be added,
4432 -- and the default size may need to be larger, and the default
4433 -- alignment may need to be larger.
4435 -- We therefore reset the size and alignment fields in the tagged
4436 -- case. Note that the size and alignment will in any case be at
4437 -- least as large as the parent type (since the derived type has
4438 -- a copy of the parent type in the _parent field)
4441 Init_Size_Align
(Derived_Type
);
4444 -- STEP 0a: figure out what kind of derived type declaration we have.
4446 if Private_Extension
then
4448 Set_Ekind
(Derived_Type
, E_Record_Type_With_Private
);
4451 Type_Def
:= Type_Definition
(N
);
4453 -- Ekind (Parent_Base) in not necessarily E_Record_Type since
4454 -- Parent_Base can be a private type or private extension. However,
4455 -- for tagged types with an extension the newly added fields are
4456 -- visible and hence the Derived_Type is always an E_Record_Type.
4457 -- (except that the parent may have its own private fields).
4458 -- For untagged types we preserve the Ekind of the Parent_Base.
4460 if Present
(Record_Extension_Part
(Type_Def
)) then
4461 Set_Ekind
(Derived_Type
, E_Record_Type
);
4463 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
4467 -- Indic can either be an N_Identifier if the subtype indication
4468 -- contains no constraint or an N_Subtype_Indication if the subtype
4469 -- indication has a constraint.
4471 Indic
:= Subtype_Indication
(Type_Def
);
4472 Constraint_Present
:= (Nkind
(Indic
) = N_Subtype_Indication
);
4474 if Constraint_Present
then
4475 if not Has_Discriminants
(Parent_Base
) then
4477 ("invalid constraint: type has no discriminant",
4478 Constraint
(Indic
));
4480 Constraint_Present
:= False;
4481 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
4483 elsif Is_Constrained
(Parent_Type
) then
4485 ("invalid constraint: parent type is already constrained",
4486 Constraint
(Indic
));
4488 Constraint_Present
:= False;
4489 Rewrite
(Indic
, New_Copy_Tree
(Subtype_Mark
(Indic
)));
4493 -- STEP 0b: If needed, apply transformation given in point 5. above.
4495 if not Private_Extension
4496 and then Has_Discriminants
(Parent_Type
)
4497 and then not Discriminant_Specs
4498 and then (Is_Constrained
(Parent_Type
) or else Constraint_Present
)
4500 -- First, we must analyze the constraint (see comment in point 5.).
4502 if Constraint_Present
then
4503 New_Discrs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
4505 if Has_Discriminants
(Derived_Type
)
4506 and then Has_Private_Declaration
(Derived_Type
)
4507 and then Present
(Discriminant_Constraint
(Derived_Type
))
4509 -- Verify that constraints of the full view conform to those
4510 -- given in partial view.
4516 C1
:= First_Elmt
(New_Discrs
);
4517 C2
:= First_Elmt
(Discriminant_Constraint
(Derived_Type
));
4519 while Present
(C1
) and then Present
(C2
) loop
4521 Fully_Conformant_Expressions
(Node
(C1
), Node
(C2
))
4524 "constraint not conformant to previous declaration",
4534 -- Insert and analyze the declaration for the unconstrained base type
4536 New_Base
:= Create_Itype
(Ekind
(Derived_Type
), N
, Derived_Type
, 'B');
4539 Make_Full_Type_Declaration
(Loc
,
4540 Defining_Identifier
=> New_Base
,
4542 Make_Derived_Type_Definition
(Loc
,
4543 Abstract_Present
=> Abstract_Present
(Type_Def
),
4544 Subtype_Indication
=>
4545 New_Occurrence_Of
(Parent_Base
, Loc
),
4546 Record_Extension_Part
=>
4547 Relocate_Node
(Record_Extension_Part
(Type_Def
))));
4549 Set_Parent
(New_Decl
, Parent
(N
));
4550 Mark_Rewrite_Insertion
(New_Decl
);
4551 Insert_Before
(N
, New_Decl
);
4553 -- Note that this call passes False for the Derive_Subps
4554 -- parameter because subprogram derivation is deferred until
4555 -- after creating the subtype (see below).
4558 (New_Decl
, Parent_Base
, New_Base
,
4559 Is_Completion
=> True, Derive_Subps
=> False);
4561 -- ??? This needs re-examination to determine whether the
4562 -- above call can simply be replaced by a call to Analyze.
4564 Set_Analyzed
(New_Decl
);
4566 -- Insert and analyze the declaration for the constrained subtype
4568 if Constraint_Present
then
4570 Make_Subtype_Indication
(Loc
,
4571 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
4572 Constraint
=> Relocate_Node
(Constraint
(Indic
)));
4577 Constr_List
: List_Id
:= New_List
;
4581 C
:= First_Elmt
(Discriminant_Constraint
(Parent_Type
));
4582 while Present
(C
) loop
4585 -- It is safe here to call New_Copy_Tree since
4586 -- Force_Evaluation was called on each constraint in
4587 -- Build_Discriminant_Constraints.
4589 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
4595 Make_Subtype_Indication
(Loc
,
4596 Subtype_Mark
=> New_Occurrence_Of
(New_Base
, Loc
),
4598 Make_Index_Or_Discriminant_Constraint
(Loc
, Constr_List
));
4603 Make_Subtype_Declaration
(Loc
,
4604 Defining_Identifier
=> Derived_Type
,
4605 Subtype_Indication
=> New_Indic
));
4609 -- Derivation of subprograms must be delayed until the
4610 -- full subtype has been established to ensure proper
4611 -- overriding of subprograms inherited by full types.
4612 -- If the derivations occurred as part of the call to
4613 -- Build_Derived_Type above, then the check for type
4614 -- conformance would fail because earlier primitive
4615 -- subprograms could still refer to the full type prior
4616 -- the change to the new subtype and hence wouldn't
4617 -- match the new base type created here.
4619 Derive_Subprograms
(Parent_Type
, Derived_Type
);
4621 -- For tagged types the Discriminant_Constraint of the new base itype
4622 -- is inherited from the first subtype so that no subtype conformance
4623 -- problem arise when the first subtype overrides primitive
4624 -- operations inherited by the implicit base type.
4627 Set_Discriminant_Constraint
4628 (New_Base
, Discriminant_Constraint
(Derived_Type
));
4634 -- If we get here Derived_Type will have no discriminants or it will be
4635 -- a discriminated unconstrained base type.
4637 -- STEP 1a: perform preliminary actions/checks for derived tagged types
4640 -- The parent type is frozen for non-private extensions (RM 13.14(7))
4642 if not Private_Extension
then
4643 Freeze_Before
(N
, Parent_Type
);
4646 if Type_Access_Level
(Derived_Type
) /= Type_Access_Level
(Parent_Type
)
4647 and then not Is_Generic_Type
(Derived_Type
)
4649 if Is_Controlled
(Parent_Type
) then
4651 ("controlled type must be declared at the library level",
4655 ("type extension at deeper accessibility level than parent",
4661 GB
: constant Node_Id
:= Enclosing_Generic_Body
(Derived_Type
);
4665 and then GB
/= Enclosing_Generic_Body
(Parent_Base
)
4668 ("parent type must not be outside generic body",
4675 -- STEP 1b : preliminary cleanup of the full view of private types
4677 -- If the type is already marked as having discriminants, then it's the
4678 -- completion of a private type or private extension and we need to
4679 -- retain the discriminants from the partial view if the current
4680 -- declaration has Discriminant_Specifications so that we can verify
4681 -- conformance. However, we must remove any existing components that
4682 -- were inherited from the parent (and attached in Copy_Private_To_Full)
4683 -- because the full type inherits all appropriate components anyway, and
4684 -- we don't want the partial view's components interfering.
4686 if Has_Discriminants
(Derived_Type
) and then Discriminant_Specs
then
4687 Discrim
:= First_Discriminant
(Derived_Type
);
4689 Last_Discrim
:= Discrim
;
4690 Next_Discriminant
(Discrim
);
4691 exit when No
(Discrim
);
4694 Set_Last_Entity
(Derived_Type
, Last_Discrim
);
4696 -- In all other cases wipe out the list of inherited components (even
4697 -- inherited discriminants), it will be properly rebuilt here.
4700 Set_First_Entity
(Derived_Type
, Empty
);
4701 Set_Last_Entity
(Derived_Type
, Empty
);
4704 -- STEP 1c: Initialize some flags for the Derived_Type
4706 -- The following flags must be initialized here so that
4707 -- Process_Discriminants can check that discriminants of tagged types
4708 -- do not have a default initial value and that access discriminants
4709 -- are only specified for limited records. For completeness, these
4710 -- flags are also initialized along with all the other flags below.
4712 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
4713 Set_Is_Limited_Record
(Derived_Type
, Is_Limited_Record
(Parent_Type
));
4715 -- STEP 2a: process discriminants of derived type if any.
4717 New_Scope
(Derived_Type
);
4719 if Discriminant_Specs
then
4720 Set_Has_Unknown_Discriminants
(Derived_Type
, False);
4722 -- The following call initializes fields Has_Discriminants and
4723 -- Discriminant_Constraint, unless we are processing the completion
4724 -- of a private type declaration.
4726 Check_Or_Process_Discriminants
(N
, Derived_Type
);
4728 -- For non-tagged types the constraint on the Parent_Type must be
4729 -- present and is used to rename the discriminants.
4731 if not Is_Tagged
and then not Has_Discriminants
(Parent_Type
) then
4732 Error_Msg_N
("untagged parent must have discriminants", Indic
);
4734 elsif not Is_Tagged
and then not Constraint_Present
then
4736 ("discriminant constraint needed for derived untagged records",
4739 -- Otherwise the parent subtype must be constrained unless we have a
4740 -- private extension.
4742 elsif not Constraint_Present
4743 and then not Private_Extension
4744 and then not Is_Constrained
(Parent_Type
)
4747 ("unconstrained type not allowed in this context", Indic
);
4749 elsif Constraint_Present
then
4750 -- The following call sets the field Corresponding_Discriminant
4751 -- for the discriminants in the Derived_Type.
4753 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
, True);
4755 -- For untagged types all new discriminants must rename
4756 -- discriminants in the parent. For private extensions new
4757 -- discriminants cannot rename old ones (implied by [7.3(13)]).
4759 Discrim
:= First_Discriminant
(Derived_Type
);
4761 while Present
(Discrim
) loop
4763 and then not Present
(Corresponding_Discriminant
(Discrim
))
4766 ("new discriminants must constrain old ones", Discrim
);
4768 elsif Private_Extension
4769 and then Present
(Corresponding_Discriminant
(Discrim
))
4772 ("Only static constraints allowed for parent"
4773 & " discriminants in the partial view", Indic
);
4778 -- If a new discriminant is used in the constraint,
4779 -- then its subtype must be statically compatible
4780 -- with the parent discriminant's subtype (3.7(15)).
4782 if Present
(Corresponding_Discriminant
(Discrim
))
4784 not Subtypes_Statically_Compatible
4786 Etype
(Corresponding_Discriminant
(Discrim
)))
4789 ("subtype must be compatible with parent discriminant",
4793 Next_Discriminant
(Discrim
);
4797 -- STEP 2b: No new discriminants, inherit discriminants if any
4800 if Private_Extension
then
4801 Set_Has_Unknown_Discriminants
4802 (Derived_Type
, Has_Unknown_Discriminants
(Parent_Type
)
4803 or else Unknown_Discriminants_Present
(N
));
4805 Set_Has_Unknown_Discriminants
4806 (Derived_Type
, Has_Unknown_Discriminants
(Parent_Type
));
4809 if not Has_Unknown_Discriminants
(Derived_Type
)
4810 and then Has_Discriminants
(Parent_Type
)
4812 Inherit_Discrims
:= True;
4813 Set_Has_Discriminants
4814 (Derived_Type
, True);
4815 Set_Discriminant_Constraint
4816 (Derived_Type
, Discriminant_Constraint
(Parent_Base
));
4819 -- The following test is true for private types (remember
4820 -- transformation 5. is not applied to those) and in an error
4823 if Constraint_Present
then
4824 Discs
:= Build_Discriminant_Constraints
(Parent_Type
, Indic
);
4827 -- For now mark a new derived type as cosntrained only if it has no
4828 -- discriminants. At the end of Build_Derived_Record_Type we properly
4829 -- set this flag in the case of private extensions. See comments in
4830 -- point 9. just before body of Build_Derived_Record_Type.
4834 not (Inherit_Discrims
4835 or else Has_Unknown_Discriminants
(Derived_Type
)));
4838 -- STEP 3: initialize fields of derived type.
4840 Set_Is_Tagged_Type
(Derived_Type
, Is_Tagged
);
4841 Set_Girder_Constraint
(Derived_Type
, No_Elist
);
4843 -- Fields inherited from the Parent_Type
4846 (Derived_Type
, Einfo
.Discard_Names
(Parent_Type
));
4847 Set_Has_Specified_Layout
4848 (Derived_Type
, Has_Specified_Layout
(Parent_Type
));
4849 Set_Is_Limited_Composite
4850 (Derived_Type
, Is_Limited_Composite
(Parent_Type
));
4851 Set_Is_Limited_Record
4852 (Derived_Type
, Is_Limited_Record
(Parent_Type
));
4853 Set_Is_Private_Composite
4854 (Derived_Type
, Is_Private_Composite
(Parent_Type
));
4856 -- Fields inherited from the Parent_Base
4858 Set_Has_Controlled_Component
4859 (Derived_Type
, Has_Controlled_Component
(Parent_Base
));
4860 Set_Has_Non_Standard_Rep
4861 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
4862 Set_Has_Primitive_Operations
4863 (Derived_Type
, Has_Primitive_Operations
(Parent_Base
));
4865 -- Direct controlled types do not inherit Finalize_Storage_Only flag
4867 if not Is_Controlled
(Parent_Type
) then
4868 Set_Finalize_Storage_Only
4869 (Derived_Type
, Finalize_Storage_Only
(Parent_Type
));
4872 -- Set fields for private derived types.
4874 if Is_Private_Type
(Derived_Type
) then
4875 Set_Depends_On_Private
(Derived_Type
, True);
4876 Set_Private_Dependents
(Derived_Type
, New_Elmt_List
);
4878 -- Inherit fields from non private record types. If this is the
4879 -- completion of a derivation from a private type, the parent itself
4880 -- is private, and the attributes come from its full view, which must
4884 if Is_Private_Type
(Parent_Base
)
4885 and then not Is_Record_Type
(Parent_Base
)
4887 Set_Component_Alignment
4888 (Derived_Type
, Component_Alignment
(Full_View
(Parent_Base
)));
4890 (Derived_Type
, C_Pass_By_Copy
(Full_View
(Parent_Base
)));
4892 Set_Component_Alignment
4893 (Derived_Type
, Component_Alignment
(Parent_Base
));
4896 (Derived_Type
, C_Pass_By_Copy
(Parent_Base
));
4900 -- Set fields for tagged types.
4903 Set_Primitive_Operations
(Derived_Type
, New_Elmt_List
);
4905 -- All tagged types defined in Ada.Finalization are controlled
4907 if Chars
(Scope
(Derived_Type
)) = Name_Finalization
4908 and then Chars
(Scope
(Scope
(Derived_Type
))) = Name_Ada
4909 and then Scope
(Scope
(Scope
(Derived_Type
))) = Standard_Standard
4911 Set_Is_Controlled
(Derived_Type
);
4913 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Base
));
4916 Make_Class_Wide_Type
(Derived_Type
);
4917 Set_Is_Abstract
(Derived_Type
, Abstract_Present
(Type_Def
));
4919 if Has_Discriminants
(Derived_Type
)
4920 and then Constraint_Present
4922 Set_Girder_Constraint
4923 (Derived_Type
, Expand_To_Girder_Constraint
(Parent_Base
, Discs
));
4927 Set_Is_Packed
(Derived_Type
, Is_Packed
(Parent_Base
));
4928 Set_Has_Non_Standard_Rep
4929 (Derived_Type
, Has_Non_Standard_Rep
(Parent_Base
));
4932 -- STEP 4: Inherit components from the parent base and constrain them.
4933 -- Apply the second transformation described in point 6. above.
4935 if (not Is_Empty_Elmt_List
(Discs
) or else Inherit_Discrims
)
4936 or else not Has_Discriminants
(Parent_Type
)
4937 or else not Is_Constrained
(Parent_Type
)
4941 Constrs
:= Discriminant_Constraint
(Parent_Type
);
4944 Assoc_List
:= Inherit_Components
(N
,
4945 Parent_Base
, Derived_Type
, Is_Tagged
, Inherit_Discrims
, Constrs
);
4947 -- STEP 5a: Copy the parent record declaration for untagged types
4949 if not Is_Tagged
then
4951 -- Discriminant_Constraint (Derived_Type) has been properly
4952 -- constructed. Save it and temporarily set it to Empty because we do
4953 -- not want the call to New_Copy_Tree below to mess this list.
4955 if Has_Discriminants
(Derived_Type
) then
4956 Save_Discr_Constr
:= Discriminant_Constraint
(Derived_Type
);
4957 Set_Discriminant_Constraint
(Derived_Type
, No_Elist
);
4959 Save_Discr_Constr
:= No_Elist
;
4962 -- Save the Etype field of Derived_Type. It is correctly set now, but
4963 -- the call to New_Copy tree may remap it to point to itself, which
4964 -- is not what we want. Ditto for the Next_Entity field.
4966 Save_Etype
:= Etype
(Derived_Type
);
4967 Save_Next_Entity
:= Next_Entity
(Derived_Type
);
4969 -- Assoc_List maps all girder discriminants in the Parent_Base to
4970 -- girder discriminants in the Derived_Type. It is fundamental that
4971 -- no types or itypes with discriminants other than the girder
4972 -- discriminants appear in the entities declared inside
4973 -- Derived_Type. Gigi won't like it.
4977 (Parent
(Parent_Base
), Map
=> Assoc_List
, New_Sloc
=> Loc
);
4979 -- Restore the fields saved prior to the New_Copy_Tree call
4980 -- and compute the girder constraint.
4982 Set_Etype
(Derived_Type
, Save_Etype
);
4983 Set_Next_Entity
(Derived_Type
, Save_Next_Entity
);
4985 if Has_Discriminants
(Derived_Type
) then
4986 Set_Discriminant_Constraint
4987 (Derived_Type
, Save_Discr_Constr
);
4988 Set_Girder_Constraint
4989 (Derived_Type
, Expand_To_Girder_Constraint
(Parent_Base
, Discs
));
4990 Replace_Components
(Derived_Type
, New_Decl
);
4993 -- Insert the new derived type declaration
4995 Rewrite
(N
, New_Decl
);
4997 -- STEP 5b: Complete the processing for record extensions in generics
4999 -- There is no completion for record extensions declared in the
5000 -- parameter part of a generic, so we need to complete processing for
5001 -- these generic record extensions here. The call to
5002 -- Record_Type_Definition will change the Ekind of the components
5003 -- from E_Void to E_Component.
5005 elsif Private_Extension
and then Is_Generic_Type
(Derived_Type
) then
5006 Record_Type_Definition
(Empty
, Derived_Type
);
5008 -- STEP 5c: Process the record extension for non private tagged types.
5010 elsif not Private_Extension
then
5011 -- Add the _parent field in the derived type.
5013 Expand_Derived_Record
(Derived_Type
, Type_Def
);
5015 -- Analyze the record extension
5017 Record_Type_Definition
5018 (Record_Extension_Part
(Type_Def
), Derived_Type
);
5023 if Etype
(Derived_Type
) = Any_Type
then
5027 -- Set delayed freeze and then derive subprograms, we need to do
5028 -- this in this order so that derived subprograms inherit the
5029 -- derived freeze if necessary.
5031 Set_Has_Delayed_Freeze
(Derived_Type
);
5032 if Derive_Subps
then
5033 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5036 -- If we have a private extension which defines a constrained derived
5037 -- type mark as constrained here after we have derived subprograms. See
5038 -- comment on point 9. just above the body of Build_Derived_Record_Type.
5040 if Private_Extension
and then Inherit_Discrims
then
5041 if Constraint_Present
and then not Is_Empty_Elmt_List
(Discs
) then
5042 Set_Is_Constrained
(Derived_Type
, True);
5043 Set_Discriminant_Constraint
(Derived_Type
, Discs
);
5045 elsif Is_Constrained
(Parent_Type
) then
5047 (Derived_Type
, True);
5048 Set_Discriminant_Constraint
5049 (Derived_Type
, Discriminant_Constraint
(Parent_Type
));
5053 end Build_Derived_Record_Type
;
5055 ------------------------
5056 -- Build_Derived_Type --
5057 ------------------------
5059 procedure Build_Derived_Type
5061 Parent_Type
: Entity_Id
;
5062 Derived_Type
: Entity_Id
;
5063 Is_Completion
: Boolean;
5064 Derive_Subps
: Boolean := True)
5066 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
5069 -- Set common attributes
5071 Set_Scope
(Derived_Type
, Current_Scope
);
5073 Set_Ekind
(Derived_Type
, Ekind
(Parent_Base
));
5074 Set_Etype
(Derived_Type
, Parent_Base
);
5075 Set_Has_Task
(Derived_Type
, Has_Task
(Parent_Base
));
5077 Set_Size_Info
(Derived_Type
, Parent_Type
);
5078 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
5079 Set_Convention
(Derived_Type
, Convention
(Parent_Type
));
5080 Set_Is_Controlled
(Derived_Type
, Is_Controlled
(Parent_Type
));
5081 Set_First_Rep_Item
(Derived_Type
, First_Rep_Item
(Parent_Type
));
5083 case Ekind
(Parent_Type
) is
5084 when Numeric_Kind
=>
5085 Build_Derived_Numeric_Type
(N
, Parent_Type
, Derived_Type
);
5088 Build_Derived_Array_Type
(N
, Parent_Type
, Derived_Type
);
5092 | Class_Wide_Kind
=>
5093 Build_Derived_Record_Type
5094 (N
, Parent_Type
, Derived_Type
, Derive_Subps
);
5097 when Enumeration_Kind
=>
5098 Build_Derived_Enumeration_Type
(N
, Parent_Type
, Derived_Type
);
5101 Build_Derived_Access_Type
(N
, Parent_Type
, Derived_Type
);
5103 when Incomplete_Or_Private_Kind
=>
5104 Build_Derived_Private_Type
5105 (N
, Parent_Type
, Derived_Type
, Is_Completion
, Derive_Subps
);
5107 -- For discriminated types, the derivation includes deriving
5108 -- primitive operations. For others it is done below.
5110 if Is_Tagged_Type
(Parent_Type
)
5111 or else Has_Discriminants
(Parent_Type
)
5112 or else (Present
(Full_View
(Parent_Type
))
5113 and then Has_Discriminants
(Full_View
(Parent_Type
)))
5118 when Concurrent_Kind
=>
5119 Build_Derived_Concurrent_Type
(N
, Parent_Type
, Derived_Type
);
5122 raise Program_Error
;
5125 if Etype
(Derived_Type
) = Any_Type
then
5129 -- Set delayed freeze and then derive subprograms, we need to do
5130 -- this in this order so that derived subprograms inherit the
5131 -- derived freeze if necessary.
5133 Set_Has_Delayed_Freeze
(Derived_Type
);
5134 if Derive_Subps
then
5135 Derive_Subprograms
(Parent_Type
, Derived_Type
);
5138 Set_Has_Primitive_Operations
5139 (Base_Type
(Derived_Type
), Has_Primitive_Operations
(Parent_Type
));
5140 end Build_Derived_Type
;
5142 -----------------------
5143 -- Build_Discriminal --
5144 -----------------------
5146 procedure Build_Discriminal
(Discrim
: Entity_Id
) is
5147 D_Minal
: Entity_Id
;
5148 CR_Disc
: Entity_Id
;
5151 -- A discriminal has the same names as the discriminant.
5153 D_Minal
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
5155 Set_Ekind
(D_Minal
, E_In_Parameter
);
5156 Set_Mechanism
(D_Minal
, Default_Mechanism
);
5157 Set_Etype
(D_Minal
, Etype
(Discrim
));
5159 Set_Discriminal
(Discrim
, D_Minal
);
5160 Set_Discriminal_Link
(D_Minal
, Discrim
);
5162 -- For task types, build at once the discriminants of the corresponding
5163 -- record, which are needed if discriminants are used in entry defaults
5164 -- and in family bounds.
5166 if Is_Concurrent_Type
(Current_Scope
)
5167 or else Is_Limited_Type
(Current_Scope
)
5169 CR_Disc
:= Make_Defining_Identifier
(Sloc
(Discrim
), Chars
(Discrim
));
5171 Set_Ekind
(CR_Disc
, E_In_Parameter
);
5172 Set_Mechanism
(CR_Disc
, Default_Mechanism
);
5173 Set_Etype
(CR_Disc
, Etype
(Discrim
));
5174 Set_CR_Discriminant
(Discrim
, CR_Disc
);
5176 end Build_Discriminal
;
5178 ------------------------------------
5179 -- Build_Discriminant_Constraints --
5180 ------------------------------------
5182 function Build_Discriminant_Constraints
5185 Derived_Def
: Boolean := False)
5188 C
: constant Node_Id
:= Constraint
(Def
);
5189 Nb_Discr
: constant Nat
:= Number_Discriminants
(T
);
5190 Discr_Expr
: array (1 .. Nb_Discr
) of Node_Id
:= (others => Empty
);
5191 -- Saves the expression corresponding to a given discriminant in T.
5193 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
;
5194 -- Return the Position number within array Discr_Expr of a discriminant
5195 -- D within the discriminant list of the discriminated type T.
5201 function Pos_Of_Discr
(T
: Entity_Id
; D
: Entity_Id
) return Nat
is
5205 Disc
:= First_Discriminant
(T
);
5206 for J
in Discr_Expr
'Range loop
5211 Next_Discriminant
(Disc
);
5214 -- Note: Since this function is called on discriminants that are
5215 -- known to belong to the discriminated type, falling through the
5216 -- loop with no match signals an internal compiler error.
5218 raise Program_Error
;
5221 -- Variables local to Build_Discriminant_Constraints
5225 Elist
: Elist_Id
:= New_Elmt_List
;
5233 Discrim_Present
: Boolean := False;
5235 -- Start of processing for Build_Discriminant_Constraints
5238 -- The following loop will process positional associations only.
5239 -- For a positional association, the (single) discriminant is
5240 -- implicitly specified by position, in textual order (RM 3.7.2).
5242 Discr
:= First_Discriminant
(T
);
5243 Constr
:= First
(Constraints
(C
));
5245 for D
in Discr_Expr
'Range loop
5246 exit when Nkind
(Constr
) = N_Discriminant_Association
;
5249 Error_Msg_N
("too few discriminants given in constraint", C
);
5250 return New_Elmt_List
;
5252 elsif Nkind
(Constr
) = N_Range
5253 or else (Nkind
(Constr
) = N_Attribute_Reference
5255 Attribute_Name
(Constr
) = Name_Range
)
5258 ("a range is not a valid discriminant constraint", Constr
);
5259 Discr_Expr
(D
) := Error
;
5262 Analyze_And_Resolve
(Constr
, Base_Type
(Etype
(Discr
)));
5263 Discr_Expr
(D
) := Constr
;
5266 Next_Discriminant
(Discr
);
5270 if No
(Discr
) and then Present
(Constr
) then
5271 Error_Msg_N
("too many discriminants given in constraint", Constr
);
5272 return New_Elmt_List
;
5275 -- Named associations can be given in any order, but if both positional
5276 -- and named associations are used in the same discriminant constraint,
5277 -- then positional associations must occur first, at their normal
5278 -- position. Hence once a named association is used, the rest of the
5279 -- discriminant constraint must use only named associations.
5281 while Present
(Constr
) loop
5283 -- Positional association forbidden after a named association.
5285 if Nkind
(Constr
) /= N_Discriminant_Association
then
5286 Error_Msg_N
("positional association follows named one", Constr
);
5287 return New_Elmt_List
;
5289 -- Otherwise it is a named association
5292 -- E records the type of the discriminants in the named
5293 -- association. All the discriminants specified in the same name
5294 -- association must have the same type.
5298 -- Search the list of discriminants in T to see if the simple name
5299 -- given in the constraint matches any of them.
5301 Id
:= First
(Selector_Names
(Constr
));
5302 while Present
(Id
) loop
5305 -- If Original_Discriminant is present, we are processing a
5306 -- generic instantiation and this is an instance node. We need
5307 -- to find the name of the corresponding discriminant in the
5308 -- actual record type T and not the name of the discriminant in
5309 -- the generic formal. Example:
5312 -- type G (D : int) is private;
5314 -- subtype W is G (D => 1);
5316 -- type Rec (X : int) is record ... end record;
5317 -- package Q is new P (G => Rec);
5319 -- At the point of the instantiation, formal type G is Rec
5320 -- and therefore when reanalyzing "subtype W is G (D => 1);"
5321 -- which really looks like "subtype W is Rec (D => 1);" at
5322 -- the point of instantiation, we want to find the discriminant
5323 -- that corresponds to D in Rec, ie X.
5325 if Present
(Original_Discriminant
(Id
)) then
5326 Discr
:= Find_Corresponding_Discriminant
(Id
, T
);
5330 Discr
:= First_Discriminant
(T
);
5331 while Present
(Discr
) loop
5332 if Chars
(Discr
) = Chars
(Id
) then
5337 Next_Discriminant
(Discr
);
5341 Error_Msg_N
("& does not match any discriminant", Id
);
5342 return New_Elmt_List
;
5344 -- The following is only useful for the benefit of generic
5345 -- instances but it does not interfere with other
5346 -- processing for the non-generic case so we do it in all
5347 -- cases (for generics this statement is executed when
5348 -- processing the generic definition, see comment at the
5349 -- begining of this if statement).
5352 Set_Original_Discriminant
(Id
, Discr
);
5356 Position
:= Pos_Of_Discr
(T
, Discr
);
5358 if Present
(Discr_Expr
(Position
)) then
5359 Error_Msg_N
("duplicate constraint for discriminant&", Id
);
5362 -- Each discriminant specified in the same named association
5363 -- must be associated with a separate copy of the
5364 -- corresponding expression.
5366 if Present
(Next
(Id
)) then
5367 Expr
:= New_Copy_Tree
(Expression
(Constr
));
5368 Set_Parent
(Expr
, Parent
(Expression
(Constr
)));
5370 Expr
:= Expression
(Constr
);
5373 Discr_Expr
(Position
) := Expr
;
5374 Analyze_And_Resolve
(Expr
, Base_Type
(Etype
(Discr
)));
5377 -- A discriminant association with more than one discriminant
5378 -- name is only allowed if the named discriminants are all of
5379 -- the same type (RM 3.7.1(8)).
5382 E
:= Base_Type
(Etype
(Discr
));
5384 elsif Base_Type
(Etype
(Discr
)) /= E
then
5386 ("all discriminants in an association " &
5387 "must have the same type", Id
);
5397 -- A discriminant constraint must provide exactly one value for each
5398 -- discriminant of the type (RM 3.7.1(8)).
5400 for J
in Discr_Expr
'Range loop
5401 if No
(Discr_Expr
(J
)) then
5402 Error_Msg_N
("too few discriminants given in constraint", C
);
5403 return New_Elmt_List
;
5407 -- Determine if there are discriminant expressions in the constraint.
5409 for J
in Discr_Expr
'Range loop
5410 if Denotes_Discriminant
(Discr_Expr
(J
)) then
5411 Discrim_Present
:= True;
5415 -- Build an element list consisting of the expressions given in the
5416 -- discriminant constraint and apply the appropriate range
5417 -- checks. The list is constructed after resolving any named
5418 -- discriminant associations and therefore the expressions appear in
5419 -- the textual order of the discriminants.
5421 Discr
:= First_Discriminant
(T
);
5422 for J
in Discr_Expr
'Range loop
5423 if Discr_Expr
(J
) /= Error
then
5425 Append_Elmt
(Discr_Expr
(J
), Elist
);
5427 -- If any of the discriminant constraints is given by a
5428 -- discriminant and we are in a derived type declaration we
5429 -- have a discriminant renaming. Establish link between new
5430 -- and old discriminant.
5432 if Denotes_Discriminant
(Discr_Expr
(J
)) then
5434 Set_Corresponding_Discriminant
5435 (Entity
(Discr_Expr
(J
)), Discr
);
5438 -- Force the evaluation of non-discriminant expressions.
5439 -- If we have found a discriminant in the constraint 3.4(26)
5440 -- and 3.8(18) demand that no range checks are performed are
5441 -- after evaluation. In all other cases perform a range check.
5444 if not Discrim_Present
then
5445 Apply_Range_Check
(Discr_Expr
(J
), Etype
(Discr
));
5448 Force_Evaluation
(Discr_Expr
(J
));
5451 -- Check that the designated type of an access discriminant's
5452 -- expression is not a class-wide type unless the discriminant's
5453 -- designated type is also class-wide.
5455 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
5456 and then not Is_Class_Wide_Type
5457 (Designated_Type
(Etype
(Discr
)))
5458 and then Etype
(Discr_Expr
(J
)) /= Any_Type
5459 and then Is_Class_Wide_Type
5460 (Designated_Type
(Etype
(Discr_Expr
(J
))))
5462 Wrong_Type
(Discr_Expr
(J
), Etype
(Discr
));
5466 Next_Discriminant
(Discr
);
5470 end Build_Discriminant_Constraints
;
5472 ---------------------------------
5473 -- Build_Discriminated_Subtype --
5474 ---------------------------------
5476 procedure Build_Discriminated_Subtype
5480 Related_Nod
: Node_Id
;
5481 For_Access
: Boolean := False)
5483 Has_Discrs
: constant Boolean := Has_Discriminants
(T
);
5484 Constrained
: constant Boolean
5486 and then not Is_Empty_Elmt_List
(Elist
)
5487 and then not Is_Class_Wide_Type
(T
))
5488 or else Is_Constrained
(T
);
5491 if Ekind
(T
) = E_Record_Type
then
5493 Set_Ekind
(Def_Id
, E_Private_Subtype
);
5494 Set_Is_For_Access_Subtype
(Def_Id
, True);
5496 Set_Ekind
(Def_Id
, E_Record_Subtype
);
5499 elsif Ekind
(T
) = E_Task_Type
then
5500 Set_Ekind
(Def_Id
, E_Task_Subtype
);
5502 elsif Ekind
(T
) = E_Protected_Type
then
5503 Set_Ekind
(Def_Id
, E_Protected_Subtype
);
5505 elsif Is_Private_Type
(T
) then
5506 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
5508 elsif Is_Class_Wide_Type
(T
) then
5509 Set_Ekind
(Def_Id
, E_Class_Wide_Subtype
);
5512 -- Incomplete type. Attach subtype to list of dependents, to be
5513 -- completed with full view of parent type.
5515 Set_Ekind
(Def_Id
, Ekind
(T
));
5516 Append_Elmt
(Def_Id
, Private_Dependents
(T
));
5519 Set_Etype
(Def_Id
, T
);
5520 Init_Size_Align
(Def_Id
);
5521 Set_Has_Discriminants
(Def_Id
, Has_Discrs
);
5522 Set_Is_Constrained
(Def_Id
, Constrained
);
5524 Set_First_Entity
(Def_Id
, First_Entity
(T
));
5525 Set_Last_Entity
(Def_Id
, Last_Entity
(T
));
5526 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
5528 if Is_Tagged_Type
(T
) then
5529 Set_Is_Tagged_Type
(Def_Id
);
5530 Make_Class_Wide_Type
(Def_Id
);
5533 Set_Girder_Constraint
(Def_Id
, No_Elist
);
5536 Set_Discriminant_Constraint
(Def_Id
, Elist
);
5537 Set_Girder_Constraint_From_Discriminant_Constraint
(Def_Id
);
5540 if Is_Tagged_Type
(T
) then
5541 Set_Primitive_Operations
(Def_Id
, Primitive_Operations
(T
));
5542 Set_Is_Abstract
(Def_Id
, Is_Abstract
(T
));
5545 -- Subtypes introduced by component declarations do not need to be
5546 -- marked as delayed, and do not get freeze nodes, because the semantics
5547 -- verifies that the parents of the subtypes are frozen before the
5548 -- enclosing record is frozen.
5550 if not Is_Type
(Scope
(Def_Id
)) then
5551 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
5553 if Is_Private_Type
(T
)
5554 and then Present
(Full_View
(T
))
5556 Conditional_Delay
(Def_Id
, Full_View
(T
));
5558 Conditional_Delay
(Def_Id
, T
);
5562 if Is_Record_Type
(T
) then
5563 Set_Is_Limited_Record
(Def_Id
, Is_Limited_Record
(T
));
5566 and then not Is_Empty_Elmt_List
(Elist
)
5567 and then not For_Access
5569 Create_Constrained_Components
(Def_Id
, Related_Nod
, T
, Elist
);
5570 elsif not For_Access
then
5571 Set_Cloned_Subtype
(Def_Id
, T
);
5575 end Build_Discriminated_Subtype
;
5577 ------------------------
5578 -- Build_Scalar_Bound --
5579 ------------------------
5581 function Build_Scalar_Bound
5587 New_Bound
: Entity_Id
;
5590 -- Note: not clear why this is needed, how can the original bound
5591 -- be unanalyzed at this point? and if it is, what business do we
5592 -- have messing around with it? and why is the base type of the
5593 -- parent type the right type for the resolution. It probably is
5594 -- not! It is OK for the new bound we are creating, but not for
5595 -- the old one??? Still if it never happens, no problem!
5597 Analyze_And_Resolve
(Bound
, Base_Type
(Par_T
));
5599 if Nkind
(Bound
) = N_Integer_Literal
5600 or else Nkind
(Bound
) = N_Real_Literal
5602 New_Bound
:= New_Copy
(Bound
);
5603 Set_Etype
(New_Bound
, Der_T
);
5604 Set_Analyzed
(New_Bound
);
5606 elsif Is_Entity_Name
(Bound
) then
5607 New_Bound
:= OK_Convert_To
(Der_T
, New_Copy
(Bound
));
5609 -- The following is almost certainly wrong. What business do we have
5610 -- relocating a node (Bound) that is presumably still attached to
5611 -- the tree elsewhere???
5614 New_Bound
:= OK_Convert_To
(Der_T
, Relocate_Node
(Bound
));
5617 Set_Etype
(New_Bound
, Der_T
);
5619 end Build_Scalar_Bound
;
5621 --------------------------------
5622 -- Build_Underlying_Full_View --
5623 --------------------------------
5625 procedure Build_Underlying_Full_View
5630 Loc
: constant Source_Ptr
:= Sloc
(N
);
5631 Subt
: constant Entity_Id
:=
5632 Make_Defining_Identifier
5633 (Loc
, New_External_Name
(Chars
(Typ
), 'S'));
5641 if Nkind
(N
) = N_Full_Type_Declaration
then
5642 Constr
:= Constraint
(Subtype_Indication
(Type_Definition
(N
)));
5644 -- ??? ??? is this assert right, I assume so otherwise Constr
5645 -- would not be defined below (this used to be an elsif)
5647 else pragma Assert
(Nkind
(N
) = N_Subtype_Declaration
);
5648 Constr
:= New_Copy_Tree
(Constraint
(Subtype_Indication
(N
)));
5651 -- If the constraint has discriminant associations, the discriminant
5652 -- entity is already set, but it denotes a discriminant of the new
5653 -- type, not the original parent, so it must be found anew.
5655 C
:= First
(Constraints
(Constr
));
5657 while Present
(C
) loop
5659 if Nkind
(C
) = N_Discriminant_Association
then
5660 Id
:= First
(Selector_Names
(C
));
5662 while Present
(Id
) loop
5663 Set_Original_Discriminant
(Id
, Empty
);
5671 Indic
:= Make_Subtype_Declaration
(Loc
,
5672 Defining_Identifier
=> Subt
,
5673 Subtype_Indication
=>
5674 Make_Subtype_Indication
(Loc
,
5675 Subtype_Mark
=> New_Reference_To
(Par
, Loc
),
5676 Constraint
=> New_Copy_Tree
(Constr
)));
5678 Insert_Before
(N
, Indic
);
5680 Set_Underlying_Full_View
(Typ
, Full_View
(Subt
));
5681 end Build_Underlying_Full_View
;
5683 -------------------------------
5684 -- Check_Abstract_Overriding --
5685 -------------------------------
5687 procedure Check_Abstract_Overriding
(T
: Entity_Id
) is
5694 Op_List
:= Primitive_Operations
(T
);
5696 -- Loop to check primitive operations
5698 Elmt
:= First_Elmt
(Op_List
);
5699 while Present
(Elmt
) loop
5700 Subp
:= Node
(Elmt
);
5702 -- Special exception, do not complain about failure to
5703 -- override _Input and _Output, since we always provide
5704 -- automatic overridings for these subprograms.
5706 if Is_Abstract
(Subp
)
5707 and then Chars
(Subp
) /= Name_uInput
5708 and then Chars
(Subp
) /= Name_uOutput
5709 and then not Is_Abstract
(T
)
5711 if Present
(Alias
(Subp
)) then
5712 -- Only perform the check for a derived subprogram when
5713 -- the type has an explicit record extension. This avoids
5714 -- incorrectly flagging abstract subprograms for the case
5715 -- of a type without an extension derived from a formal type
5716 -- with a tagged actual (can occur within a private part).
5718 Type_Def
:= Type_Definition
(Parent
(T
));
5719 if Nkind
(Type_Def
) = N_Derived_Type_Definition
5720 and then Present
(Record_Extension_Part
(Type_Def
))
5723 ("type must be declared abstract or & overridden",
5728 ("abstract subprogram not allowed for type&",
5731 ("nonabstract type has abstract subprogram&",
5738 end Check_Abstract_Overriding
;
5740 ------------------------------------------------
5741 -- Check_Access_Discriminant_Requires_Limited --
5742 ------------------------------------------------
5744 procedure Check_Access_Discriminant_Requires_Limited
5749 -- A discriminant_specification for an access discriminant
5750 -- shall appear only in the declaration for a task or protected
5751 -- type, or for a type with the reserved word 'limited' in
5752 -- its definition or in one of its ancestors. (RM 3.7(10))
5754 if Nkind
(Discriminant_Type
(D
)) = N_Access_Definition
5755 and then not Is_Concurrent_Type
(Current_Scope
)
5756 and then not Is_Concurrent_Record_Type
(Current_Scope
)
5757 and then not Is_Limited_Record
(Current_Scope
)
5758 and then Ekind
(Current_Scope
) /= E_Limited_Private_Type
5761 ("access discriminants allowed only for limited types", Loc
);
5763 end Check_Access_Discriminant_Requires_Limited
;
5765 -----------------------------------
5766 -- Check_Aliased_Component_Types --
5767 -----------------------------------
5769 procedure Check_Aliased_Component_Types
(T
: Entity_Id
) is
5773 -- ??? Also need to check components of record extensions,
5774 -- but not components of protected types (which are always
5777 if not Is_Limited_Type
(T
) then
5778 if Ekind
(T
) = E_Record_Type
then
5779 C
:= First_Component
(T
);
5780 while Present
(C
) loop
5782 and then Has_Discriminants
(Etype
(C
))
5783 and then not Is_Constrained
(Etype
(C
))
5784 and then not In_Instance
5787 ("aliased component must be constrained ('R'M 3.6(11))",
5794 elsif Ekind
(T
) = E_Array_Type
then
5795 if Has_Aliased_Components
(T
)
5796 and then Has_Discriminants
(Component_Type
(T
))
5797 and then not Is_Constrained
(Component_Type
(T
))
5798 and then not In_Instance
5801 ("aliased component type must be constrained ('R'M 3.6(11))",
5806 end Check_Aliased_Component_Types
;
5808 ----------------------
5809 -- Check_Completion --
5810 ----------------------
5812 procedure Check_Completion
(Body_Id
: Node_Id
:= Empty
) is
5815 procedure Post_Error
;
5816 -- Post error message for lack of completion for entity E
5818 procedure Post_Error
is
5820 if not Comes_From_Source
(E
) then
5822 if (Ekind
(E
) = E_Task_Type
5823 or else Ekind
(E
) = E_Protected_Type
)
5825 -- It may be an anonymous protected type created for a
5826 -- single variable. Post error on variable, if present.
5832 Var
:= First_Entity
(Current_Scope
);
5834 while Present
(Var
) loop
5835 exit when Etype
(Var
) = E
5836 and then Comes_From_Source
(Var
);
5841 if Present
(Var
) then
5848 -- If a generated entity has no completion, then either previous
5849 -- semantic errors have disabled the expansion phase, or else
5850 -- we had missing subunits, or else we are compiling without expan-
5851 -- sion, or else something is very wrong.
5853 if not Comes_From_Source
(E
) then
5855 (Serious_Errors_Detected
> 0
5856 or else Subunits_Missing
5857 or else not Expander_Active
);
5860 -- Here for source entity
5863 -- Here if no body to post the error message, so we post the error
5864 -- on the declaration that has no completion. This is not really
5865 -- the right place to post it, think about this later ???
5867 if No
(Body_Id
) then
5870 ("missing full declaration for }", Parent
(E
), E
);
5873 ("missing body for &", Parent
(E
), E
);
5876 -- Package body has no completion for a declaration that appears
5877 -- in the corresponding spec. Post error on the body, with a
5878 -- reference to the non-completed declaration.
5881 Error_Msg_Sloc
:= Sloc
(E
);
5885 ("missing full declaration for }!", Body_Id
, E
);
5887 elsif Is_Overloadable
(E
)
5888 and then Current_Entity_In_Scope
(E
) /= E
5890 -- It may be that the completion is mistyped and appears
5891 -- as a distinct overloading of the entity.
5894 Candidate
: Entity_Id
:= Current_Entity_In_Scope
(E
);
5895 Decl
: Node_Id
:= Unit_Declaration_Node
(Candidate
);
5898 if Is_Overloadable
(Candidate
)
5899 and then Ekind
(Candidate
) = Ekind
(E
)
5900 and then Nkind
(Decl
) = N_Subprogram_Body
5901 and then Acts_As_Spec
(Decl
)
5903 Check_Type_Conformant
(Candidate
, E
);
5906 Error_Msg_NE
("missing body for & declared#!",
5911 Error_Msg_NE
("missing body for & declared#!",
5918 -- Start processing for Check_Completion
5921 E
:= First_Entity
(Current_Scope
);
5922 while Present
(E
) loop
5923 if Is_Intrinsic_Subprogram
(E
) then
5926 -- The following situation requires special handling: a child
5927 -- unit that appears in the context clause of the body of its
5930 -- procedure Parent.Child (...);
5932 -- with Parent.Child;
5933 -- package body Parent is
5935 -- Here Parent.Child appears as a local entity, but should not
5936 -- be flagged as requiring completion, because it is a
5937 -- compilation unit.
5939 elsif Ekind
(E
) = E_Function
5940 or else Ekind
(E
) = E_Procedure
5941 or else Ekind
(E
) = E_Generic_Function
5942 or else Ekind
(E
) = E_Generic_Procedure
5944 if not Has_Completion
(E
)
5945 and then not Is_Abstract
(E
)
5946 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
5948 and then Chars
(E
) /= Name_uSize
5953 elsif Is_Entry
(E
) then
5954 if not Has_Completion
(E
) and then
5955 (Ekind
(Scope
(E
)) = E_Protected_Object
5956 or else Ekind
(Scope
(E
)) = E_Protected_Type
)
5961 elsif Is_Package
(E
) then
5962 if Unit_Requires_Body
(E
) then
5963 if not Has_Completion
(E
)
5964 and then Nkind
(Parent
(Unit_Declaration_Node
(E
))) /=
5970 elsif not Is_Child_Unit
(E
) then
5971 May_Need_Implicit_Body
(E
);
5974 elsif Ekind
(E
) = E_Incomplete_Type
5975 and then No
(Underlying_Type
(E
))
5979 elsif (Ekind
(E
) = E_Task_Type
or else
5980 Ekind
(E
) = E_Protected_Type
)
5981 and then not Has_Completion
(E
)
5985 elsif Ekind
(E
) = E_Constant
5986 and then Ekind
(Etype
(E
)) = E_Task_Type
5987 and then not Has_Completion
(Etype
(E
))
5991 elsif Ekind
(E
) = E_Protected_Object
5992 and then not Has_Completion
(Etype
(E
))
5996 elsif Ekind
(E
) = E_Record_Type
then
5997 if Is_Tagged_Type
(E
) then
5998 Check_Abstract_Overriding
(E
);
6001 Check_Aliased_Component_Types
(E
);
6003 elsif Ekind
(E
) = E_Array_Type
then
6004 Check_Aliased_Component_Types
(E
);
6010 end Check_Completion
;
6012 ----------------------------
6013 -- Check_Delta_Expression --
6014 ----------------------------
6016 procedure Check_Delta_Expression
(E
: Node_Id
) is
6018 if not (Is_Real_Type
(Etype
(E
))) then
6019 Wrong_Type
(E
, Any_Real
);
6021 elsif not Is_OK_Static_Expression
(E
) then
6022 Error_Msg_N
("non-static expression used for delta value", E
);
6024 elsif not UR_Is_Positive
(Expr_Value_R
(E
)) then
6025 Error_Msg_N
("delta expression must be positive", E
);
6031 -- If any of above errors occurred, then replace the incorrect
6032 -- expression by the real 0.1, which should prevent further errors.
6035 Make_Real_Literal
(Sloc
(E
), Ureal_Tenth
));
6036 Analyze_And_Resolve
(E
, Standard_Float
);
6038 end Check_Delta_Expression
;
6040 -----------------------------
6041 -- Check_Digits_Expression --
6042 -----------------------------
6044 procedure Check_Digits_Expression
(E
: Node_Id
) is
6046 if not (Is_Integer_Type
(Etype
(E
))) then
6047 Wrong_Type
(E
, Any_Integer
);
6049 elsif not Is_OK_Static_Expression
(E
) then
6050 Error_Msg_N
("non-static expression used for digits value", E
);
6052 elsif Expr_Value
(E
) <= 0 then
6053 Error_Msg_N
("digits value must be greater than zero", E
);
6059 -- If any of above errors occurred, then replace the incorrect
6060 -- expression by the integer 1, which should prevent further errors.
6062 Rewrite
(E
, Make_Integer_Literal
(Sloc
(E
), 1));
6063 Analyze_And_Resolve
(E
, Standard_Integer
);
6065 end Check_Digits_Expression
;
6067 ----------------------
6068 -- Check_Incomplete --
6069 ----------------------
6071 procedure Check_Incomplete
(T
: Entity_Id
) is
6073 if Ekind
(Root_Type
(Entity
(T
))) = E_Incomplete_Type
then
6074 Error_Msg_N
("invalid use of type before its full declaration", T
);
6076 end Check_Incomplete
;
6078 --------------------------
6079 -- Check_Initialization --
6080 --------------------------
6082 procedure Check_Initialization
(T
: Entity_Id
; Exp
: Node_Id
) is
6084 if (Is_Limited_Type
(T
)
6085 or else Is_Limited_Composite
(T
))
6086 and then not In_Instance
6089 ("cannot initialize entities of limited type", Exp
);
6091 end Check_Initialization
;
6093 ------------------------------------
6094 -- Check_Or_Process_Discriminants --
6095 ------------------------------------
6097 -- If an incomplete or private type declaration was already given for
6098 -- the type, the discriminants may have already been processed if they
6099 -- were present on the incomplete declaration. In this case a full
6100 -- conformance check is performed otherwise just process them.
6102 procedure Check_Or_Process_Discriminants
(N
: Node_Id
; T
: Entity_Id
) is
6104 if Has_Discriminants
(T
) then
6106 -- Make the discriminants visible to component declarations.
6109 D
: Entity_Id
:= First_Discriminant
(T
);
6113 while Present
(D
) loop
6114 Prev
:= Current_Entity
(D
);
6115 Set_Current_Entity
(D
);
6116 Set_Is_Immediately_Visible
(D
);
6117 Set_Homonym
(D
, Prev
);
6119 -- This restriction gets applied to the full type here; it
6120 -- has already been applied earlier to the partial view
6122 Check_Access_Discriminant_Requires_Limited
(Parent
(D
), N
);
6124 Next_Discriminant
(D
);
6128 elsif Present
(Discriminant_Specifications
(N
)) then
6129 Process_Discriminants
(N
);
6131 end Check_Or_Process_Discriminants
;
6133 ----------------------
6134 -- Check_Real_Bound --
6135 ----------------------
6137 procedure Check_Real_Bound
(Bound
: Node_Id
) is
6139 if not Is_Real_Type
(Etype
(Bound
)) then
6141 ("bound in real type definition must be of real type", Bound
);
6143 elsif not Is_OK_Static_Expression
(Bound
) then
6145 ("non-static expression used for real type bound", Bound
);
6152 (Bound
, Make_Real_Literal
(Sloc
(Bound
), Ureal_0
));
6154 Resolve
(Bound
, Standard_Float
);
6155 end Check_Real_Bound
;
6157 ------------------------------
6158 -- Complete_Private_Subtype --
6159 ------------------------------
6161 procedure Complete_Private_Subtype
6164 Full_Base
: Entity_Id
;
6165 Related_Nod
: Node_Id
)
6167 Save_Next_Entity
: Entity_Id
;
6168 Save_Homonym
: Entity_Id
;
6171 -- Set semantic attributes for (implicit) private subtype completion.
6172 -- If the full type has no discriminants, then it is a copy of the full
6173 -- view of the base. Otherwise, it is a subtype of the base with a
6174 -- possible discriminant constraint. Save and restore the original
6175 -- Next_Entity field of full to ensure that the calls to Copy_Node
6176 -- do not corrupt the entity chain.
6178 -- Note that the type of the full view is the same entity as the
6179 -- type of the partial view. In this fashion, the subtype has
6180 -- access to the correct view of the parent.
6182 Save_Next_Entity
:= Next_Entity
(Full
);
6183 Save_Homonym
:= Homonym
(Priv
);
6185 case Ekind
(Full_Base
) is
6187 when E_Record_Type |
6193 Copy_Node
(Priv
, Full
);
6195 Set_Has_Discriminants
(Full
, Has_Discriminants
(Full_Base
));
6196 Set_First_Entity
(Full
, First_Entity
(Full_Base
));
6197 Set_Last_Entity
(Full
, Last_Entity
(Full_Base
));
6200 Copy_Node
(Full_Base
, Full
);
6201 Set_Chars
(Full
, Chars
(Priv
));
6202 Conditional_Delay
(Full
, Priv
);
6203 Set_Sloc
(Full
, Sloc
(Priv
));
6207 Set_Next_Entity
(Full
, Save_Next_Entity
);
6208 Set_Homonym
(Full
, Save_Homonym
);
6209 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
6211 -- Set common attributes for all subtypes.
6213 Set_Ekind
(Full
, Subtype_Kind
(Ekind
(Full_Base
)));
6215 -- The Etype of the full view is inconsistent. Gigi needs to see the
6216 -- structural full view, which is what the current scheme gives:
6217 -- the Etype of the full view is the etype of the full base. However,
6218 -- if the full base is a derived type, the full view then looks like
6219 -- a subtype of the parent, not a subtype of the full base. If instead
6222 -- Set_Etype (Full, Full_Base);
6224 -- then we get inconsistencies in the front-end (confusion between
6225 -- views). Several outstanding bugs are related to this.
6227 Set_Is_First_Subtype
(Full
, False);
6228 Set_Scope
(Full
, Scope
(Priv
));
6229 Set_Size_Info
(Full
, Full_Base
);
6230 Set_RM_Size
(Full
, RM_Size
(Full_Base
));
6231 Set_Is_Itype
(Full
);
6233 -- A subtype of a private-type-without-discriminants, whose full-view
6234 -- has discriminants with default expressions, is not constrained!
6236 if not Has_Discriminants
(Priv
) then
6237 Set_Is_Constrained
(Full
, Is_Constrained
(Full_Base
));
6240 Set_First_Rep_Item
(Full
, First_Rep_Item
(Full_Base
));
6241 Set_Depends_On_Private
(Full
, Has_Private_Component
(Full
));
6243 -- Freeze the private subtype entity if its parent is delayed,
6244 -- and not already frozen. We skip this processing if the type
6245 -- is an anonymous subtype of a record component, or is the
6246 -- corresponding record of a protected type, since ???
6248 if not Is_Type
(Scope
(Full
)) then
6249 Set_Has_Delayed_Freeze
(Full
,
6250 Has_Delayed_Freeze
(Full_Base
)
6251 and then (not Is_Frozen
(Full_Base
)));
6254 Set_Freeze_Node
(Full
, Empty
);
6255 Set_Is_Frozen
(Full
, False);
6256 Set_Full_View
(Priv
, Full
);
6258 if Has_Discriminants
(Full
) then
6259 Set_Girder_Constraint_From_Discriminant_Constraint
(Full
);
6260 Set_Girder_Constraint
(Priv
, Girder_Constraint
(Full
));
6261 if Has_Unknown_Discriminants
(Full
) then
6262 Set_Discriminant_Constraint
(Full
, No_Elist
);
6266 if Ekind
(Full_Base
) = E_Record_Type
6267 and then Has_Discriminants
(Full_Base
)
6268 and then Has_Discriminants
(Priv
) -- might not, if errors
6269 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Priv
))
6271 Create_Constrained_Components
6272 (Full
, Related_Nod
, Full_Base
, Discriminant_Constraint
(Priv
));
6274 -- If the full base is itself derived from private, build a congruent
6275 -- subtype of its underlying type, for use by the back end.
6277 elsif Ekind
(Full_Base
) in Private_Kind
6278 and then Is_Derived_Type
(Full_Base
)
6279 and then Has_Discriminants
(Full_Base
)
6281 Nkind
(Subtype_Indication
(Parent
(Priv
))) = N_Subtype_Indication
6283 Build_Underlying_Full_View
(Parent
(Priv
), Full
, Etype
(Full_Base
));
6285 elsif Is_Record_Type
(Full_Base
) then
6287 -- Show Full is simply a renaming of Full_Base.
6289 Set_Cloned_Subtype
(Full
, Full_Base
);
6292 -- It is usafe to share to bounds of a scalar type, because the
6293 -- Itype is elaborated on demand, and if a bound is non-static
6294 -- then different orders of elaboration in different units will
6295 -- lead to different external symbols.
6297 if Is_Scalar_Type
(Full_Base
) then
6298 Set_Scalar_Range
(Full
,
6299 Make_Range
(Sloc
(Related_Nod
),
6300 Low_Bound
=> Duplicate_Subexpr
(Type_Low_Bound
(Full_Base
)),
6301 High_Bound
=> Duplicate_Subexpr
(Type_High_Bound
(Full_Base
))));
6304 -- ??? It seems that a lot of fields are missing that should be
6305 -- copied from Full_Base to Full. Here are some that are introduced
6306 -- in a non-disruptive way but a cleanup is necessary.
6308 if Is_Tagged_Type
(Full_Base
) then
6309 Set_Is_Tagged_Type
(Full
);
6310 Set_Primitive_Operations
(Full
, Primitive_Operations
(Full_Base
));
6312 elsif Is_Concurrent_Type
(Full_Base
) then
6313 if Has_Discriminants
(Full
)
6314 and then Present
(Corresponding_Record_Type
(Full_Base
))
6316 Set_Corresponding_Record_Type
(Full
,
6317 Constrain_Corresponding_Record
6318 (Full
, Corresponding_Record_Type
(Full_Base
),
6319 Related_Nod
, Full_Base
));
6322 Set_Corresponding_Record_Type
(Full
,
6323 Corresponding_Record_Type
(Full_Base
));
6327 end Complete_Private_Subtype
;
6329 ----------------------------
6330 -- Constant_Redeclaration --
6331 ----------------------------
6333 procedure Constant_Redeclaration
6338 Prev
: constant Entity_Id
:= Current_Entity_In_Scope
(Id
);
6339 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
6342 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
);
6343 -- If deferred constant is an access type initialized with an
6344 -- allocator, check whether there is an illegal recursion in the
6345 -- definition, through a default value of some record subcomponent.
6346 -- This is normally detected when generating init_procs, but requires
6347 -- this additional mechanism when expansion is disabled.
6349 procedure Check_Recursive_Declaration
(Typ
: Entity_Id
) is
6353 if Is_Record_Type
(Typ
) then
6354 Comp
:= First_Component
(Typ
);
6356 while Present
(Comp
) loop
6357 if Comes_From_Source
(Comp
) then
6358 if Present
(Expression
(Parent
(Comp
)))
6359 and then Is_Entity_Name
(Expression
(Parent
(Comp
)))
6360 and then Entity
(Expression
(Parent
(Comp
))) = Prev
6362 Error_Msg_Sloc
:= Sloc
(Parent
(Comp
));
6364 ("illegal circularity with declaration for&#",
6368 elsif Is_Record_Type
(Etype
(Comp
)) then
6369 Check_Recursive_Declaration
(Etype
(Comp
));
6373 Next_Component
(Comp
);
6376 end Check_Recursive_Declaration
;
6378 -- Start of processing for Constant_Redeclaration
6381 if Nkind
(Parent
(Prev
)) = N_Object_Declaration
then
6382 if Nkind
(Object_Definition
6383 (Parent
(Prev
))) = N_Subtype_Indication
6385 -- Find type of new declaration. The constraints of the two
6386 -- views must match statically, but there is no point in
6387 -- creating an itype for the full view.
6389 if Nkind
(Obj_Def
) = N_Subtype_Indication
then
6390 Find_Type
(Subtype_Mark
(Obj_Def
));
6391 New_T
:= Entity
(Subtype_Mark
(Obj_Def
));
6394 Find_Type
(Obj_Def
);
6395 New_T
:= Entity
(Obj_Def
);
6401 -- The full view may impose a constraint, even if the partial
6402 -- view does not, so construct the subtype.
6404 New_T
:= Find_Type_Of_Object
(Obj_Def
, N
);
6409 -- Current declaration is illegal, diagnosed below in Enter_Name.
6415 -- If previous full declaration exists, or if a homograph is present,
6416 -- let Enter_Name handle it, either with an error, or with the removal
6417 -- of an overridden implicit subprogram.
6419 if Ekind
(Prev
) /= E_Constant
6420 or else Present
(Expression
(Parent
(Prev
)))
6421 or else Present
(Full_View
(Prev
))
6425 -- Verify that types of both declarations match.
6427 elsif Base_Type
(Etype
(Prev
)) /= Base_Type
(New_T
) then
6428 Error_Msg_Sloc
:= Sloc
(Prev
);
6429 Error_Msg_N
("type does not match declaration#", N
);
6430 Set_Full_View
(Prev
, Id
);
6431 Set_Etype
(Id
, Any_Type
);
6433 -- If so, process the full constant declaration
6436 Set_Full_View
(Prev
, Id
);
6437 Set_Is_Public
(Id
, Is_Public
(Prev
));
6438 Set_Is_Internal
(Id
);
6439 Append_Entity
(Id
, Current_Scope
);
6441 -- Check ALIASED present if present before (RM 7.4(7))
6443 if Is_Aliased
(Prev
)
6444 and then not Aliased_Present
(N
)
6446 Error_Msg_Sloc
:= Sloc
(Prev
);
6447 Error_Msg_N
("ALIASED required (see declaration#)", N
);
6450 -- Check that placement is in private part and that the incomplete
6451 -- declaration appeared in the visible part.
6453 if Ekind
(Current_Scope
) = E_Package
6454 and then not In_Private_Part
(Current_Scope
)
6456 Error_Msg_Sloc
:= Sloc
(Prev
);
6457 Error_Msg_N
("full constant for declaration#"
6458 & " must be in private part", N
);
6460 elsif Ekind
(Current_Scope
) = E_Package
6461 and then List_Containing
(Parent
(Prev
))
6462 /= Visible_Declarations
6463 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
6466 ("deferred constant must be declared in visible part",
6470 if Is_Access_Type
(T
)
6471 and then Nkind
(Expression
(N
)) = N_Allocator
6473 Check_Recursive_Declaration
(Designated_Type
(T
));
6476 end Constant_Redeclaration
;
6478 ----------------------
6479 -- Constrain_Access --
6480 ----------------------
6482 procedure Constrain_Access
6483 (Def_Id
: in out Entity_Id
;
6485 Related_Nod
: Node_Id
)
6487 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
6488 Desig_Type
: constant Entity_Id
:= Designated_Type
(T
);
6489 Desig_Subtype
: Entity_Id
:= Create_Itype
(E_Void
, Related_Nod
);
6490 Constraint_OK
: Boolean := True;
6493 if Is_Array_Type
(Desig_Type
) then
6494 Constrain_Array
(Desig_Subtype
, S
, Related_Nod
, Def_Id
, 'P');
6496 elsif (Is_Record_Type
(Desig_Type
)
6497 or else Is_Incomplete_Or_Private_Type
(Desig_Type
))
6498 and then not Is_Constrained
(Desig_Type
)
6500 -- ??? The following code is a temporary kludge to ignore
6501 -- discriminant constraint on access type if
6502 -- it is constraining the current record. Avoid creating the
6503 -- implicit subtype of the record we are currently compiling
6504 -- since right now, we cannot handle these.
6505 -- For now, just return the access type itself.
6507 if Desig_Type
= Current_Scope
6508 and then No
(Def_Id
)
6510 Set_Ekind
(Desig_Subtype
, E_Record_Subtype
);
6511 Def_Id
:= Entity
(Subtype_Mark
(S
));
6513 -- This call added to ensure that the constraint is
6514 -- analyzed (needed for a B test). Note that we
6515 -- still return early from this procedure to avoid
6516 -- recursive processing. ???
6518 Constrain_Discriminated_Type
6519 (Desig_Subtype
, S
, Related_Nod
, For_Access
=> True);
6524 if Ekind
(T
) = E_General_Access_Type
6525 and then Has_Private_Declaration
(Desig_Type
)
6526 and then In_Open_Scopes
(Scope
(Desig_Type
))
6528 -- Enforce rule that the constraint is illegal if there is
6529 -- an unconstrained view of the designated type. This means
6530 -- that the partial view (either a private type declaration or
6531 -- a derivation from a private type) has no discriminants.
6532 -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
6533 -- by ACATS B371001).
6536 Pack
: Node_Id
:= Unit_Declaration_Node
(Scope
(Desig_Type
));
6541 if Nkind
(Pack
) = N_Package_Declaration
then
6542 Decls
:= Visible_Declarations
(Specification
(Pack
));
6543 Decl
:= First
(Decls
);
6545 while Present
(Decl
) loop
6546 if (Nkind
(Decl
) = N_Private_Type_Declaration
6548 Chars
(Defining_Identifier
(Decl
)) =
6552 (Nkind
(Decl
) = N_Full_Type_Declaration
6554 Chars
(Defining_Identifier
(Decl
)) =
6556 and then Is_Derived_Type
(Desig_Type
)
6558 Has_Private_Declaration
(Etype
(Desig_Type
)))
6560 if No
(Discriminant_Specifications
(Decl
)) then
6562 ("cannot constrain general access type " &
6563 "if designated type has unconstrained view", S
);
6575 Constrain_Discriminated_Type
(Desig_Subtype
, S
, Related_Nod
,
6576 For_Access
=> True);
6578 elsif (Is_Task_Type
(Desig_Type
)
6579 or else Is_Protected_Type
(Desig_Type
))
6580 and then not Is_Constrained
(Desig_Type
)
6582 Constrain_Concurrent
6583 (Desig_Subtype
, S
, Related_Nod
, Desig_Type
, ' ');
6586 Error_Msg_N
("invalid constraint on access type", S
);
6587 Desig_Subtype
:= Desig_Type
; -- Ignore invalid constraint.
6588 Constraint_OK
:= False;
6592 Def_Id
:= Create_Itype
(E_Access_Subtype
, Related_Nod
);
6594 Set_Ekind
(Def_Id
, E_Access_Subtype
);
6597 if Constraint_OK
then
6598 Set_Etype
(Def_Id
, Base_Type
(T
));
6600 if Is_Private_Type
(Desig_Type
) then
6601 Prepare_Private_Subtype_Completion
(Desig_Subtype
, Related_Nod
);
6604 Set_Etype
(Def_Id
, Any_Type
);
6607 Set_Size_Info
(Def_Id
, T
);
6608 Set_Is_Constrained
(Def_Id
, Constraint_OK
);
6609 Set_Directly_Designated_Type
(Def_Id
, Desig_Subtype
);
6610 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
6611 Set_Is_Access_Constant
(Def_Id
, Is_Access_Constant
(T
));
6613 -- Itypes created for constrained record components do not receive
6614 -- a freeze node, they are elaborated when first seen.
6616 if not Is_Record_Type
(Current_Scope
) then
6617 Conditional_Delay
(Def_Id
, T
);
6619 end Constrain_Access
;
6621 ---------------------
6622 -- Constrain_Array --
6623 ---------------------
6625 procedure Constrain_Array
6626 (Def_Id
: in out Entity_Id
;
6628 Related_Nod
: Node_Id
;
6629 Related_Id
: Entity_Id
;
6632 C
: constant Node_Id
:= Constraint
(SI
);
6633 Number_Of_Constraints
: Nat
:= 0;
6636 Constraint_OK
: Boolean := True;
6639 T
:= Entity
(Subtype_Mark
(SI
));
6641 if Ekind
(T
) in Access_Kind
then
6642 T
:= Designated_Type
(T
);
6645 -- If an index constraint follows a subtype mark in a subtype indication
6646 -- then the type or subtype denoted by the subtype mark must not already
6647 -- impose an index constraint. The subtype mark must denote either an
6648 -- unconstrained array type or an access type whose designated type
6649 -- is such an array type... (RM 3.6.1)
6651 if Is_Constrained
(T
) then
6653 ("array type is already constrained", Subtype_Mark
(SI
));
6654 Constraint_OK
:= False;
6657 S
:= First
(Constraints
(C
));
6659 while Present
(S
) loop
6660 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
6664 -- In either case, the index constraint must provide a discrete
6665 -- range for each index of the array type and the type of each
6666 -- discrete range must be the same as that of the corresponding
6667 -- index. (RM 3.6.1)
6669 if Number_Of_Constraints
/= Number_Dimensions
(T
) then
6670 Error_Msg_NE
("incorrect number of index constraints for }", C
, T
);
6671 Constraint_OK
:= False;
6674 S
:= First
(Constraints
(C
));
6675 Index
:= First_Index
(T
);
6678 -- Apply constraints to each index type
6680 for J
in 1 .. Number_Of_Constraints
loop
6681 Constrain_Index
(Index
, S
, Related_Nod
, Related_Id
, Suffix
, J
);
6691 Create_Itype
(E_Array_Subtype
, Related_Nod
, Related_Id
, Suffix
);
6693 Set_Ekind
(Def_Id
, E_Array_Subtype
);
6696 Set_Size_Info
(Def_Id
, (T
));
6697 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
6698 Set_Etype
(Def_Id
, Base_Type
(T
));
6700 if Constraint_OK
then
6701 Set_First_Index
(Def_Id
, First
(Constraints
(C
)));
6704 Set_Is_Constrained
(Def_Id
, True);
6705 Set_Is_Aliased
(Def_Id
, Is_Aliased
(T
));
6706 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
6708 Set_Is_Private_Composite
(Def_Id
, Is_Private_Composite
(T
));
6709 Set_Is_Limited_Composite
(Def_Id
, Is_Limited_Composite
(T
));
6711 -- If the subtype is not that of a record component, build a freeze
6712 -- node if parent still needs one.
6714 -- If the subtype is not that of a record component, make sure
6715 -- that the Depends_On_Private status is set (explanation ???)
6716 -- and also that a conditional delay is set.
6718 if not Is_Type
(Scope
(Def_Id
)) then
6719 Set_Depends_On_Private
(Def_Id
, Depends_On_Private
(T
));
6720 Conditional_Delay
(Def_Id
, T
);
6723 end Constrain_Array
;
6725 ------------------------------
6726 -- Constrain_Component_Type --
6727 ------------------------------
6729 function Constrain_Component_Type
6730 (Compon_Type
: Entity_Id
;
6731 Constrained_Typ
: Entity_Id
;
6732 Related_Node
: Node_Id
;
6734 Constraints
: Elist_Id
)
6737 Loc
: constant Source_Ptr
:= Sloc
(Constrained_Typ
);
6739 function Build_Constrained_Array_Type
6740 (Old_Type
: Entity_Id
)
6742 -- If Old_Type is an array type, one of whose indices is
6743 -- constrained by a discriminant, build an Itype whose constraint
6744 -- replaces the discriminant with its value in the constraint.
6746 function Build_Constrained_Discriminated_Type
6747 (Old_Type
: Entity_Id
)
6749 -- Ditto for record components.
6751 function Build_Constrained_Access_Type
6752 (Old_Type
: Entity_Id
)
6754 -- Ditto for access types. Makes use of previous two functions, to
6755 -- constrain designated type.
6757 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
;
6758 -- T is an array or discriminated type, C is a list of constraints
6759 -- that apply to T. This routine builds the constrained subtype.
6761 function Is_Discriminant
(Expr
: Node_Id
) return Boolean;
6762 -- Returns True if Expr is a discriminant.
6764 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
;
6765 -- Find the value of discriminant Discrim in Constraint.
6767 -----------------------------------
6768 -- Build_Constrained_Access_Type --
6769 -----------------------------------
6771 function Build_Constrained_Access_Type
6772 (Old_Type
: Entity_Id
)
6775 Desig_Type
: constant Entity_Id
:= Designated_Type
(Old_Type
);
6777 Desig_Subtype
: Entity_Id
;
6781 -- if the original access type was not embedded in the enclosing
6782 -- type definition, there is no need to produce a new access
6783 -- subtype. In fact every access type with an explicit constraint
6784 -- generates an itype whose scope is the enclosing record.
6786 if not Is_Type
(Scope
(Old_Type
)) then
6789 elsif Is_Array_Type
(Desig_Type
) then
6790 Desig_Subtype
:= Build_Constrained_Array_Type
(Desig_Type
);
6792 elsif Has_Discriminants
(Desig_Type
) then
6794 -- This may be an access type to an enclosing record type for
6795 -- which we are constructing the constrained components. Return
6796 -- the enclosing record subtype. This is not always correct,
6797 -- but avoids infinite recursion. ???
6799 Desig_Subtype
:= Any_Type
;
6801 for J
in reverse 0 .. Scope_Stack
.Last
loop
6802 Scop
:= Scope_Stack
.Table
(J
).Entity
;
6805 and then Base_Type
(Scop
) = Base_Type
(Desig_Type
)
6807 Desig_Subtype
:= Scop
;
6810 exit when not Is_Type
(Scop
);
6813 if Desig_Subtype
= Any_Type
then
6815 Build_Constrained_Discriminated_Type
(Desig_Type
);
6822 if Desig_Subtype
/= Desig_Type
then
6823 -- The Related_Node better be here or else we won't be able
6824 -- to attach new itypes to a node in the tree.
6826 pragma Assert
(Present
(Related_Node
));
6828 Itype
:= Create_Itype
(E_Access_Subtype
, Related_Node
);
6830 Set_Etype
(Itype
, Base_Type
(Old_Type
));
6831 Set_Size_Info
(Itype
, (Old_Type
));
6832 Set_Directly_Designated_Type
(Itype
, Desig_Subtype
);
6833 Set_Depends_On_Private
(Itype
, Has_Private_Component
6835 Set_Is_Access_Constant
(Itype
, Is_Access_Constant
6838 -- The new itype needs freezing when it depends on a not frozen
6839 -- type and the enclosing subtype needs freezing.
6841 if Has_Delayed_Freeze
(Constrained_Typ
)
6842 and then not Is_Frozen
(Constrained_Typ
)
6844 Conditional_Delay
(Itype
, Base_Type
(Old_Type
));
6852 end Build_Constrained_Access_Type
;
6854 ----------------------------------
6855 -- Build_Constrained_Array_Type --
6856 ----------------------------------
6858 function Build_Constrained_Array_Type
6859 (Old_Type
: Entity_Id
)
6864 Old_Index
: Node_Id
;
6865 Range_Node
: Node_Id
;
6866 Constr_List
: List_Id
;
6868 Need_To_Create_Itype
: Boolean := False;
6871 Old_Index
:= First_Index
(Old_Type
);
6872 while Present
(Old_Index
) loop
6873 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
6875 if Is_Discriminant
(Lo_Expr
)
6876 or else Is_Discriminant
(Hi_Expr
)
6878 Need_To_Create_Itype
:= True;
6881 Next_Index
(Old_Index
);
6884 if Need_To_Create_Itype
then
6885 Constr_List
:= New_List
;
6887 Old_Index
:= First_Index
(Old_Type
);
6888 while Present
(Old_Index
) loop
6889 Get_Index_Bounds
(Old_Index
, Lo_Expr
, Hi_Expr
);
6891 if Is_Discriminant
(Lo_Expr
) then
6892 Lo_Expr
:= Get_Discr_Value
(Lo_Expr
);
6895 if Is_Discriminant
(Hi_Expr
) then
6896 Hi_Expr
:= Get_Discr_Value
(Hi_Expr
);
6901 (Loc
, New_Copy_Tree
(Lo_Expr
), New_Copy_Tree
(Hi_Expr
));
6903 Append
(Range_Node
, To
=> Constr_List
);
6905 Next_Index
(Old_Index
);
6908 return Build_Subtype
(Old_Type
, Constr_List
);
6913 end Build_Constrained_Array_Type
;
6915 ------------------------------------------
6916 -- Build_Constrained_Discriminated_Type --
6917 ------------------------------------------
6919 function Build_Constrained_Discriminated_Type
6920 (Old_Type
: Entity_Id
)
6924 Constr_List
: List_Id
;
6925 Old_Constraint
: Elmt_Id
;
6927 Need_To_Create_Itype
: Boolean := False;
6930 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
6931 while Present
(Old_Constraint
) loop
6932 Expr
:= Node
(Old_Constraint
);
6934 if Is_Discriminant
(Expr
) then
6935 Need_To_Create_Itype
:= True;
6938 Next_Elmt
(Old_Constraint
);
6941 if Need_To_Create_Itype
then
6942 Constr_List
:= New_List
;
6944 Old_Constraint
:= First_Elmt
(Discriminant_Constraint
(Old_Type
));
6945 while Present
(Old_Constraint
) loop
6946 Expr
:= Node
(Old_Constraint
);
6948 if Is_Discriminant
(Expr
) then
6949 Expr
:= Get_Discr_Value
(Expr
);
6952 Append
(New_Copy_Tree
(Expr
), To
=> Constr_List
);
6954 Next_Elmt
(Old_Constraint
);
6957 return Build_Subtype
(Old_Type
, Constr_List
);
6962 end Build_Constrained_Discriminated_Type
;
6968 function Build_Subtype
(T
: Entity_Id
; C
: List_Id
) return Entity_Id
is
6970 Subtyp_Decl
: Node_Id
;
6972 Btyp
: Entity_Id
:= Base_Type
(T
);
6975 -- The Related_Node better be here or else we won't be able
6976 -- to attach new itypes to a node in the tree.
6978 pragma Assert
(Present
(Related_Node
));
6980 -- If the view of the component's type is incomplete or private
6981 -- with unknown discriminants, then the constraint must be applied
6982 -- to the full type.
6984 if Has_Unknown_Discriminants
(Btyp
)
6985 and then Present
(Underlying_Type
(Btyp
))
6987 Btyp
:= Underlying_Type
(Btyp
);
6991 Make_Subtype_Indication
(Loc
,
6992 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
6993 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
, C
));
6995 Def_Id
:= Create_Itype
(Ekind
(T
), Related_Node
);
6998 Make_Subtype_Declaration
(Loc
,
6999 Defining_Identifier
=> Def_Id
,
7000 Subtype_Indication
=> Indic
);
7001 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
7003 -- Itypes must be analyzed with checks off (see itypes.ads).
7005 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
7010 ---------------------
7011 -- Get_Discr_Value --
7012 ---------------------
7014 function Get_Discr_Value
(Discrim
: Entity_Id
) return Node_Id
is
7015 D
: Entity_Id
:= First_Discriminant
(Typ
);
7016 E
: Elmt_Id
:= First_Elmt
(Constraints
);
7020 -- The discriminant may be declared for the type, in which case we
7021 -- find it by iterating over the list of discriminants. If the
7022 -- discriminant is inherited from a parent type, it appears as the
7023 -- corresponding discriminant of the current type. This will be the
7024 -- case when constraining an inherited component whose constraint is
7025 -- given by a discriminant of the parent.
7027 while Present
(D
) loop
7028 if D
= Entity
(Discrim
)
7029 or else Corresponding_Discriminant
(D
) = Entity
(Discrim
)
7034 Next_Discriminant
(D
);
7038 -- The corresponding_Discriminant mechanism is incomplete, because
7039 -- the correspondence between new and old discriminants is not one
7040 -- to one: one new discriminant can constrain several old ones.
7041 -- In that case, scan sequentially the girder_constraint, the list
7042 -- of discriminants of the parents, and the constraints.
7044 if Is_Derived_Type
(Typ
)
7045 and then Present
(Girder_Constraint
(Typ
))
7046 and then Scope
(Entity
(Discrim
)) = Etype
(Typ
)
7048 D
:= First_Discriminant
(Etype
(Typ
));
7049 E
:= First_Elmt
(Constraints
);
7050 G
:= First_Elmt
(Girder_Constraint
(Typ
));
7052 while Present
(D
) loop
7053 if D
= Entity
(Discrim
) then
7057 Next_Discriminant
(D
);
7063 -- Something is wrong if we did not find the value
7065 raise Program_Error
;
7066 end Get_Discr_Value
;
7068 ---------------------
7069 -- Is_Discriminant --
7070 ---------------------
7072 function Is_Discriminant
(Expr
: Node_Id
) return Boolean is
7073 Discrim_Scope
: Entity_Id
;
7076 if Denotes_Discriminant
(Expr
) then
7077 Discrim_Scope
:= Scope
(Entity
(Expr
));
7079 -- Either we have a reference to one of Typ's discriminants,
7081 pragma Assert
(Discrim_Scope
= Typ
7083 -- or to the discriminants of the parent type, in the case
7084 -- of a derivation of a tagged type with variants.
7086 or else Discrim_Scope
= Etype
(Typ
)
7087 or else Full_View
(Discrim_Scope
) = Etype
(Typ
)
7089 -- or same as above for the case where the discriminants
7090 -- were declared in Typ's private view.
7092 or else (Is_Private_Type
(Discrim_Scope
)
7093 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
7095 -- or else we are deriving from the full view and the
7096 -- discriminant is declared in the private entity.
7098 or else (Is_Private_Type
(Typ
)
7099 and then Chars
(Discrim_Scope
) = Chars
(Typ
))
7101 -- or we have a class-wide type, in which case make sure the
7102 -- discriminant found belongs to the root type.
7104 or else (Is_Class_Wide_Type
(Typ
)
7105 and then Etype
(Typ
) = Discrim_Scope
));
7110 -- In all other cases we have something wrong.
7113 end Is_Discriminant
;
7115 -- Start of processing for Constrain_Component_Type
7118 if Is_Array_Type
(Compon_Type
) then
7119 return Build_Constrained_Array_Type
(Compon_Type
);
7121 elsif Has_Discriminants
(Compon_Type
) then
7122 return Build_Constrained_Discriminated_Type
(Compon_Type
);
7124 elsif Is_Access_Type
(Compon_Type
) then
7125 return Build_Constrained_Access_Type
(Compon_Type
);
7129 end Constrain_Component_Type
;
7131 --------------------------
7132 -- Constrain_Concurrent --
7133 --------------------------
7135 -- For concurrent types, the associated record value type carries the same
7136 -- discriminants, so when we constrain a concurrent type, we must constrain
7137 -- the value type as well.
7139 procedure Constrain_Concurrent
7140 (Def_Id
: in out Entity_Id
;
7142 Related_Nod
: Node_Id
;
7143 Related_Id
: Entity_Id
;
7146 T_Ent
: Entity_Id
:= Entity
(Subtype_Mark
(SI
));
7150 if Ekind
(T_Ent
) in Access_Kind
then
7151 T_Ent
:= Designated_Type
(T_Ent
);
7154 T_Val
:= Corresponding_Record_Type
(T_Ent
);
7156 if Present
(T_Val
) then
7159 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
7162 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
7164 Set_Depends_On_Private
(Def_Id
, Has_Private_Component
(Def_Id
));
7165 Set_Corresponding_Record_Type
(Def_Id
,
7166 Constrain_Corresponding_Record
7167 (Def_Id
, T_Val
, Related_Nod
, Related_Id
));
7170 -- If there is no associated record, expansion is disabled and this
7171 -- is a generic context. Create a subtype in any case, so that
7172 -- semantic analysis can proceed.
7175 Def_Id
:= Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
7178 Constrain_Discriminated_Type
(Def_Id
, SI
, Related_Nod
);
7180 end Constrain_Concurrent
;
7182 ------------------------------------
7183 -- Constrain_Corresponding_Record --
7184 ------------------------------------
7186 function Constrain_Corresponding_Record
7187 (Prot_Subt
: Entity_Id
;
7188 Corr_Rec
: Entity_Id
;
7189 Related_Nod
: Node_Id
;
7190 Related_Id
: Entity_Id
)
7193 T_Sub
: constant Entity_Id
7194 := Create_Itype
(E_Record_Subtype
, Related_Nod
, Related_Id
, 'V');
7197 Set_Etype
(T_Sub
, Corr_Rec
);
7198 Init_Size_Align
(T_Sub
);
7199 Set_Has_Discriminants
(T_Sub
, Has_Discriminants
(Prot_Subt
));
7200 Set_Is_Constrained
(T_Sub
, True);
7201 Set_First_Entity
(T_Sub
, First_Entity
(Corr_Rec
));
7202 Set_Last_Entity
(T_Sub
, Last_Entity
(Corr_Rec
));
7204 Conditional_Delay
(T_Sub
, Corr_Rec
);
7206 if Has_Discriminants
(Prot_Subt
) then -- False only if errors.
7207 Set_Discriminant_Constraint
(T_Sub
,
7208 Discriminant_Constraint
(Prot_Subt
));
7209 Set_Girder_Constraint_From_Discriminant_Constraint
(T_Sub
);
7210 Create_Constrained_Components
(T_Sub
, Related_Nod
, Corr_Rec
,
7211 Discriminant_Constraint
(T_Sub
));
7214 Set_Depends_On_Private
(T_Sub
, Has_Private_Component
(T_Sub
));
7217 end Constrain_Corresponding_Record
;
7219 -----------------------
7220 -- Constrain_Decimal --
7221 -----------------------
7223 procedure Constrain_Decimal
(Def_Id
: Node_Id
; S
: Node_Id
) is
7224 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7225 C
: constant Node_Id
:= Constraint
(S
);
7226 Loc
: constant Source_Ptr
:= Sloc
(C
);
7227 Range_Expr
: Node_Id
;
7228 Digits_Expr
: Node_Id
;
7233 Set_Ekind
(Def_Id
, E_Decimal_Fixed_Point_Subtype
);
7235 if Nkind
(C
) = N_Range_Constraint
then
7236 Range_Expr
:= Range_Expression
(C
);
7237 Digits_Val
:= Digits_Value
(T
);
7240 pragma Assert
(Nkind
(C
) = N_Digits_Constraint
);
7241 Digits_Expr
:= Digits_Expression
(C
);
7242 Analyze_And_Resolve
(Digits_Expr
, Any_Integer
);
7244 Check_Digits_Expression
(Digits_Expr
);
7245 Digits_Val
:= Expr_Value
(Digits_Expr
);
7247 if Digits_Val
> Digits_Value
(T
) then
7249 ("digits expression is incompatible with subtype", C
);
7250 Digits_Val
:= Digits_Value
(T
);
7253 if Present
(Range_Constraint
(C
)) then
7254 Range_Expr
:= Range_Expression
(Range_Constraint
(C
));
7256 Range_Expr
:= Empty
;
7260 Set_Etype
(Def_Id
, Base_Type
(T
));
7261 Set_Size_Info
(Def_Id
, (T
));
7262 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7263 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
7264 Set_Scale_Value
(Def_Id
, Scale_Value
(T
));
7265 Set_Small_Value
(Def_Id
, Small_Value
(T
));
7266 Set_Machine_Radix_10
(Def_Id
, Machine_Radix_10
(T
));
7267 Set_Digits_Value
(Def_Id
, Digits_Val
);
7269 -- Manufacture range from given digits value if no range present
7271 if No
(Range_Expr
) then
7272 Bound_Val
:= (Ureal_10
** Digits_Val
- Ureal_1
) * Small_Value
(T
);
7276 Convert_To
(T
, Make_Real_Literal
(Loc
, (-Bound_Val
))),
7278 Convert_To
(T
, Make_Real_Literal
(Loc
, Bound_Val
)));
7282 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expr
, T
);
7283 Set_Discrete_RM_Size
(Def_Id
);
7285 -- Unconditionally delay the freeze, since we cannot set size
7286 -- information in all cases correctly until the freeze point.
7288 Set_Has_Delayed_Freeze
(Def_Id
);
7289 end Constrain_Decimal
;
7291 ----------------------------------
7292 -- Constrain_Discriminated_Type --
7293 ----------------------------------
7295 procedure Constrain_Discriminated_Type
7296 (Def_Id
: Entity_Id
;
7298 Related_Nod
: Node_Id
;
7299 For_Access
: Boolean := False)
7301 E
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7304 Elist
: Elist_Id
:= New_Elmt_List
;
7306 procedure Fixup_Bad_Constraint
;
7307 -- This is called after finding a bad constraint, and after having
7308 -- posted an appropriate error message. The mission is to leave the
7309 -- entity T in as reasonable state as possible!
7311 procedure Fixup_Bad_Constraint
is
7313 -- Set a reasonable Ekind for the entity. For an incomplete type,
7314 -- we can't do much, but for other types, we can set the proper
7315 -- corresponding subtype kind.
7317 if Ekind
(T
) = E_Incomplete_Type
then
7318 Set_Ekind
(Def_Id
, Ekind
(T
));
7320 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(T
)));
7323 Set_Etype
(Def_Id
, Any_Type
);
7324 Set_Error_Posted
(Def_Id
);
7325 end Fixup_Bad_Constraint
;
7327 -- Start of processing for Constrain_Discriminated_Type
7330 C
:= Constraint
(S
);
7332 -- A discriminant constraint is only allowed in a subtype indication,
7333 -- after a subtype mark. This subtype mark must denote either a type
7334 -- with discriminants, or an access type whose designated type is a
7335 -- type with discriminants. A discriminant constraint specifies the
7336 -- values of these discriminants (RM 3.7.2(5)).
7338 T
:= Base_Type
(Entity
(Subtype_Mark
(S
)));
7340 if Ekind
(T
) in Access_Kind
then
7341 T
:= Designated_Type
(T
);
7344 if not Has_Discriminants
(T
) then
7345 Error_Msg_N
("invalid constraint: type has no discriminant", C
);
7346 Fixup_Bad_Constraint
;
7349 elsif Is_Constrained
(E
)
7350 or else (Ekind
(E
) = E_Class_Wide_Subtype
7351 and then Present
(Discriminant_Constraint
(E
)))
7353 Error_Msg_N
("type is already constrained", Subtype_Mark
(S
));
7354 Fixup_Bad_Constraint
;
7358 -- T may be an unconstrained subtype (e.g. a generic actual).
7359 -- Constraint applies to the base type.
7363 Elist
:= Build_Discriminant_Constraints
(T
, S
);
7365 -- If the list returned was empty we had an error in building the
7366 -- discriminant constraint. We have also already signalled an error
7367 -- in the incomplete type case
7369 if Is_Empty_Elmt_List
(Elist
) then
7370 Fixup_Bad_Constraint
;
7374 Build_Discriminated_Subtype
(T
, Def_Id
, Elist
, Related_Nod
, For_Access
);
7375 end Constrain_Discriminated_Type
;
7377 ---------------------------
7378 -- Constrain_Enumeration --
7379 ---------------------------
7381 procedure Constrain_Enumeration
(Def_Id
: Node_Id
; S
: Node_Id
) is
7382 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7383 C
: constant Node_Id
:= Constraint
(S
);
7386 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
7388 Set_First_Literal
(Def_Id
, First_Literal
(Base_Type
(T
)));
7390 Set_Etype
(Def_Id
, Base_Type
(T
));
7391 Set_Size_Info
(Def_Id
, (T
));
7392 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7393 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
7395 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7397 Set_Discrete_RM_Size
(Def_Id
);
7399 end Constrain_Enumeration
;
7401 ----------------------
7402 -- Constrain_Float --
7403 ----------------------
7405 procedure Constrain_Float
(Def_Id
: Node_Id
; S
: Node_Id
) is
7406 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7412 Set_Ekind
(Def_Id
, E_Floating_Point_Subtype
);
7414 Set_Etype
(Def_Id
, Base_Type
(T
));
7415 Set_Size_Info
(Def_Id
, (T
));
7416 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7418 -- Process the constraint
7420 C
:= Constraint
(S
);
7422 -- Digits constraint present
7424 if Nkind
(C
) = N_Digits_Constraint
then
7425 D
:= Digits_Expression
(C
);
7426 Analyze_And_Resolve
(D
, Any_Integer
);
7427 Check_Digits_Expression
(D
);
7428 Set_Digits_Value
(Def_Id
, Expr_Value
(D
));
7430 -- Check that digits value is in range. Obviously we can do this
7431 -- at compile time, but it is strictly a runtime check, and of
7432 -- course there is an ACVC test that checks this!
7434 if Digits_Value
(Def_Id
) > Digits_Value
(T
) then
7435 Error_Msg_Uint_1
:= Digits_Value
(T
);
7436 Error_Msg_N
("?digits value is too large, maximum is ^", D
);
7438 Make_Raise_Constraint_Error
(Sloc
(D
),
7439 Reason
=> CE_Range_Check_Failed
);
7440 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
7443 C
:= Range_Constraint
(C
);
7445 -- No digits constraint present
7448 Set_Digits_Value
(Def_Id
, Digits_Value
(T
));
7451 -- Range constraint present
7453 if Nkind
(C
) = N_Range_Constraint
then
7454 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7456 -- No range constraint present
7459 pragma Assert
(No
(C
));
7460 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
7463 Set_Is_Constrained
(Def_Id
);
7464 end Constrain_Float
;
7466 ---------------------
7467 -- Constrain_Index --
7468 ---------------------
7470 procedure Constrain_Index
7473 Related_Nod
: Node_Id
;
7474 Related_Id
: Entity_Id
;
7479 R
: Node_Id
:= Empty
;
7480 Checks_Off
: Boolean := False;
7481 T
: constant Entity_Id
:= Etype
(Index
);
7484 if Nkind
(S
) = N_Range
7485 or else Nkind
(S
) = N_Attribute_Reference
7487 -- A Range attribute will transformed into N_Range by Resolve.
7493 -- ??? Why on earth do we turn checks of in this very specific case ?
7495 -- From the revision history: (Constrain_Index): Call
7496 -- Process_Range_Expr_In_Decl with range checking off for range
7497 -- bounds that are attributes. This avoids some horrible
7498 -- constraint error checks.
7500 if Nkind
(R
) = N_Range
7501 and then Nkind
(Low_Bound
(R
)) = N_Attribute_Reference
7502 and then Nkind
(High_Bound
(R
)) = N_Attribute_Reference
7507 Process_Range_Expr_In_Decl
(R
, T
, Empty_List
, Checks_Off
);
7509 if not Error_Posted
(S
)
7511 (Nkind
(S
) /= N_Range
7512 or else Base_Type
(T
) /= Base_Type
(Etype
(Low_Bound
(S
)))
7513 or else Base_Type
(T
) /= Base_Type
(Etype
(High_Bound
(S
))))
7515 if Base_Type
(T
) /= Any_Type
7516 and then Etype
(Low_Bound
(S
)) /= Any_Type
7517 and then Etype
(High_Bound
(S
)) /= Any_Type
7519 Error_Msg_N
("range expected", S
);
7523 elsif Nkind
(S
) = N_Subtype_Indication
then
7524 -- the parser has verified that this is a discrete indication.
7526 Resolve_Discrete_Subtype_Indication
(S
, T
);
7527 R
:= Range_Expression
(Constraint
(S
));
7529 elsif Nkind
(S
) = N_Discriminant_Association
then
7531 -- syntactically valid in subtype indication.
7533 Error_Msg_N
("invalid index constraint", S
);
7534 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
7537 -- Subtype_Mark case, no anonymous subtypes to construct
7542 if Is_Entity_Name
(S
) then
7544 if not Is_Type
(Entity
(S
)) then
7545 Error_Msg_N
("expect subtype mark for index constraint", S
);
7547 elsif Base_Type
(Entity
(S
)) /= Base_Type
(T
) then
7548 Wrong_Type
(S
, Base_Type
(T
));
7554 Error_Msg_N
("invalid index constraint", S
);
7555 Rewrite
(S
, New_Occurrence_Of
(T
, Sloc
(S
)));
7561 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
, Suffix_Index
);
7563 Set_Etype
(Def_Id
, Base_Type
(T
));
7565 if Is_Modular_Integer_Type
(T
) then
7566 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
7568 elsif Is_Integer_Type
(T
) then
7569 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
7572 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
7573 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
7576 Set_Size_Info
(Def_Id
, (T
));
7577 Set_RM_Size
(Def_Id
, RM_Size
(T
));
7578 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7580 Set_Scalar_Range
(Def_Id
, R
);
7582 Set_Etype
(S
, Def_Id
);
7583 Set_Discrete_RM_Size
(Def_Id
);
7584 end Constrain_Index
;
7586 -----------------------
7587 -- Constrain_Integer --
7588 -----------------------
7590 procedure Constrain_Integer
(Def_Id
: Node_Id
; S
: Node_Id
) is
7591 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7592 C
: constant Node_Id
:= Constraint
(S
);
7595 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7597 if Is_Modular_Integer_Type
(T
) then
7598 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
7600 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
7603 Set_Etype
(Def_Id
, Base_Type
(T
));
7604 Set_Size_Info
(Def_Id
, (T
));
7605 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7606 Set_Discrete_RM_Size
(Def_Id
);
7608 end Constrain_Integer
;
7610 ------------------------------
7611 -- Constrain_Ordinary_Fixed --
7612 ------------------------------
7614 procedure Constrain_Ordinary_Fixed
(Def_Id
: Node_Id
; S
: Node_Id
) is
7615 T
: constant Entity_Id
:= Entity
(Subtype_Mark
(S
));
7621 Set_Ekind
(Def_Id
, E_Ordinary_Fixed_Point_Subtype
);
7622 Set_Etype
(Def_Id
, Base_Type
(T
));
7623 Set_Size_Info
(Def_Id
, (T
));
7624 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
7625 Set_Small_Value
(Def_Id
, Small_Value
(T
));
7627 -- Process the constraint
7629 C
:= Constraint
(S
);
7631 -- Delta constraint present
7633 if Nkind
(C
) = N_Delta_Constraint
then
7634 D
:= Delta_Expression
(C
);
7635 Analyze_And_Resolve
(D
, Any_Real
);
7636 Check_Delta_Expression
(D
);
7637 Set_Delta_Value
(Def_Id
, Expr_Value_R
(D
));
7639 -- Check that delta value is in range. Obviously we can do this
7640 -- at compile time, but it is strictly a runtime check, and of
7641 -- course there is an ACVC test that checks this!
7643 if Delta_Value
(Def_Id
) < Delta_Value
(T
) then
7644 Error_Msg_N
("?delta value is too small", D
);
7646 Make_Raise_Constraint_Error
(Sloc
(D
),
7647 Reason
=> CE_Range_Check_Failed
);
7648 Insert_Action
(Declaration_Node
(Def_Id
), Rais
);
7651 C
:= Range_Constraint
(C
);
7653 -- No delta constraint present
7656 Set_Delta_Value
(Def_Id
, Delta_Value
(T
));
7659 -- Range constraint present
7661 if Nkind
(C
) = N_Range_Constraint
then
7662 Set_Scalar_Range_For_Subtype
(Def_Id
, Range_Expression
(C
), T
);
7664 -- No range constraint present
7667 pragma Assert
(No
(C
));
7668 Set_Scalar_Range
(Def_Id
, Scalar_Range
(T
));
7672 Set_Discrete_RM_Size
(Def_Id
);
7674 -- Unconditionally delay the freeze, since we cannot set size
7675 -- information in all cases correctly until the freeze point.
7677 Set_Has_Delayed_Freeze
(Def_Id
);
7678 end Constrain_Ordinary_Fixed
;
7680 ---------------------------
7681 -- Convert_Scalar_Bounds --
7682 ---------------------------
7684 procedure Convert_Scalar_Bounds
7686 Parent_Type
: Entity_Id
;
7687 Derived_Type
: Entity_Id
;
7690 Implicit_Base
: constant Entity_Id
:= Base_Type
(Derived_Type
);
7697 Lo
:= Build_Scalar_Bound
7698 (Type_Low_Bound
(Derived_Type
),
7699 Parent_Type
, Implicit_Base
);
7701 Hi
:= Build_Scalar_Bound
7702 (Type_High_Bound
(Derived_Type
),
7703 Parent_Type
, Implicit_Base
);
7710 Set_Includes_Infinities
(Rng
, Has_Infinities
(Derived_Type
));
7712 Set_Parent
(Rng
, N
);
7713 Set_Scalar_Range
(Derived_Type
, Rng
);
7715 -- Analyze the bounds
7717 Analyze_And_Resolve
(Lo
, Implicit_Base
);
7718 Analyze_And_Resolve
(Hi
, Implicit_Base
);
7720 -- Analyze the range itself, except that we do not analyze it if
7721 -- the bounds are real literals, and we have a fixed-point type.
7722 -- The reason for this is that we delay setting the bounds in this
7723 -- case till we know the final Small and Size values (see circuit
7724 -- in Freeze.Freeze_Fixed_Point_Type for further details).
7726 if Is_Fixed_Point_Type
(Parent_Type
)
7727 and then Nkind
(Lo
) = N_Real_Literal
7728 and then Nkind
(Hi
) = N_Real_Literal
7732 -- Here we do the analysis of the range.
7734 -- Note: we do this manually, since if we do a normal Analyze and
7735 -- Resolve call, there are problems with the conversions used for
7736 -- the derived type range.
7739 Set_Etype
(Rng
, Implicit_Base
);
7740 Set_Analyzed
(Rng
, True);
7742 end Convert_Scalar_Bounds
;
7748 procedure Copy_And_Swap
(Privat
, Full
: Entity_Id
) is
7750 -- Initialize new full declaration entity by copying the pertinent
7751 -- fields of the corresponding private declaration entity.
7753 Copy_Private_To_Full
(Privat
, Full
);
7755 -- Swap the two entities. Now Privat is the full type entity and
7756 -- Full is the private one. They will be swapped back at the end
7757 -- of the private part. This swapping ensures that the entity that
7758 -- is visible in the private part is the full declaration.
7760 Exchange_Entities
(Privat
, Full
);
7761 Append_Entity
(Full
, Scope
(Full
));
7764 -------------------------------------
7765 -- Copy_Array_Base_Type_Attributes --
7766 -------------------------------------
7768 procedure Copy_Array_Base_Type_Attributes
(T1
, T2
: Entity_Id
) is
7770 Set_Component_Alignment
(T1
, Component_Alignment
(T2
));
7771 Set_Component_Type
(T1
, Component_Type
(T2
));
7772 Set_Component_Size
(T1
, Component_Size
(T2
));
7773 Set_Has_Controlled_Component
(T1
, Has_Controlled_Component
(T2
));
7774 Set_Finalize_Storage_Only
(T1
, Finalize_Storage_Only
(T2
));
7775 Set_Has_Non_Standard_Rep
(T1
, Has_Non_Standard_Rep
(T2
));
7776 Set_Has_Task
(T1
, Has_Task
(T2
));
7777 Set_Is_Packed
(T1
, Is_Packed
(T2
));
7778 Set_Has_Aliased_Components
(T1
, Has_Aliased_Components
(T2
));
7779 Set_Has_Atomic_Components
(T1
, Has_Atomic_Components
(T2
));
7780 Set_Has_Volatile_Components
(T1
, Has_Volatile_Components
(T2
));
7781 end Copy_Array_Base_Type_Attributes
;
7783 -----------------------------------
7784 -- Copy_Array_Subtype_Attributes --
7785 -----------------------------------
7787 procedure Copy_Array_Subtype_Attributes
(T1
, T2
: Entity_Id
) is
7789 Set_Size_Info
(T1
, T2
);
7791 Set_First_Index
(T1
, First_Index
(T2
));
7792 Set_Is_Aliased
(T1
, Is_Aliased
(T2
));
7793 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
7794 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
7795 Set_Is_Constrained
(T1
, Is_Constrained
(T2
));
7796 Set_Depends_On_Private
(T1
, Has_Private_Component
(T2
));
7797 Set_First_Rep_Item
(T1
, First_Rep_Item
(T2
));
7798 Set_Convention
(T1
, Convention
(T2
));
7799 Set_Is_Limited_Composite
(T1
, Is_Limited_Composite
(T2
));
7800 Set_Is_Private_Composite
(T1
, Is_Private_Composite
(T2
));
7801 end Copy_Array_Subtype_Attributes
;
7803 --------------------------
7804 -- Copy_Private_To_Full --
7805 --------------------------
7807 procedure Copy_Private_To_Full
(Priv
, Full
: Entity_Id
) is
7809 -- We temporarily set Ekind to a value appropriate for a type to
7810 -- avoid assert failures in Einfo from checking for setting type
7811 -- attributes on something that is not a type. Ekind (Priv) is an
7812 -- appropriate choice, since it allowed the attributes to be set
7813 -- in the first place. This Ekind value will be modified later.
7815 Set_Ekind
(Full
, Ekind
(Priv
));
7817 -- Also set Etype temporarily to Any_Type, again, in the absence
7818 -- of errors, it will be properly reset, and if there are errors,
7819 -- then we want a value of Any_Type to remain.
7821 Set_Etype
(Full
, Any_Type
);
7823 -- Now start copying attributes
7825 Set_Has_Discriminants
(Full
, Has_Discriminants
(Priv
));
7827 if Has_Discriminants
(Full
) then
7828 Set_Discriminant_Constraint
(Full
, Discriminant_Constraint
(Priv
));
7829 Set_Girder_Constraint
(Full
, Girder_Constraint
(Priv
));
7832 Set_Homonym
(Full
, Homonym
(Priv
));
7833 Set_Is_Immediately_Visible
(Full
, Is_Immediately_Visible
(Priv
));
7834 Set_Is_Public
(Full
, Is_Public
(Priv
));
7835 Set_Is_Pure
(Full
, Is_Pure
(Priv
));
7836 Set_Is_Tagged_Type
(Full
, Is_Tagged_Type
(Priv
));
7838 Conditional_Delay
(Full
, Priv
);
7840 if Is_Tagged_Type
(Full
) then
7841 Set_Primitive_Operations
(Full
, Primitive_Operations
(Priv
));
7843 if Priv
= Base_Type
(Priv
) then
7844 Set_Class_Wide_Type
(Full
, Class_Wide_Type
(Priv
));
7848 Set_Is_Volatile
(Full
, Is_Volatile
(Priv
));
7849 Set_Scope
(Full
, Scope
(Priv
));
7850 Set_Next_Entity
(Full
, Next_Entity
(Priv
));
7851 Set_First_Entity
(Full
, First_Entity
(Priv
));
7852 Set_Last_Entity
(Full
, Last_Entity
(Priv
));
7854 -- If access types have been recorded for later handling, keep them
7855 -- in the full view so that they get handled when the full view freeze
7856 -- node is expanded.
7858 if Present
(Freeze_Node
(Priv
))
7859 and then Present
(Access_Types_To_Process
(Freeze_Node
(Priv
)))
7861 Ensure_Freeze_Node
(Full
);
7862 Set_Access_Types_To_Process
(Freeze_Node
(Full
),
7863 Access_Types_To_Process
(Freeze_Node
(Priv
)));
7865 end Copy_Private_To_Full
;
7867 -----------------------------------
7868 -- Create_Constrained_Components --
7869 -----------------------------------
7871 procedure Create_Constrained_Components
7873 Decl_Node
: Node_Id
;
7875 Constraints
: Elist_Id
)
7877 Loc
: constant Source_Ptr
:= Sloc
(Subt
);
7878 Assoc_List
: List_Id
:= New_List
;
7879 Comp_List
: Elist_Id
:= New_Elmt_List
;
7880 Discr_Val
: Elmt_Id
;
7884 Is_Static
: Boolean := True;
7885 Parent_Type
: constant Entity_Id
:= Etype
(Typ
);
7887 procedure Collect_Fixed_Components
(Typ
: Entity_Id
);
7888 -- Collect components of parent type that do not appear in a variant
7891 procedure Create_All_Components
;
7892 -- Iterate over Comp_List to create the components of the subtype.
7894 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
;
7895 -- Creates a new component from Old_Compon, coppying all the fields from
7896 -- it, including its Etype, inserts the new component in the Subt entity
7897 -- chain and returns the new component.
7899 function Is_Variant_Record
(T
: Entity_Id
) return Boolean;
7900 -- If true, and discriminants are static, collect only components from
7901 -- variants selected by discriminant values.
7903 ------------------------------
7904 -- Collect_Fixed_Components --
7905 ------------------------------
7907 procedure Collect_Fixed_Components
(Typ
: Entity_Id
) is
7909 -- Build association list for discriminants, and find components of
7910 -- the variant part selected by the values of the discriminants.
7912 Old_C
:= First_Discriminant
(Typ
);
7913 Discr_Val
:= First_Elmt
(Constraints
);
7915 while Present
(Old_C
) loop
7916 Append_To
(Assoc_List
,
7917 Make_Component_Association
(Loc
,
7918 Choices
=> New_List
(New_Occurrence_Of
(Old_C
, Loc
)),
7919 Expression
=> New_Copy
(Node
(Discr_Val
))));
7921 Next_Elmt
(Discr_Val
);
7922 Next_Discriminant
(Old_C
);
7925 -- The tag, and the possible parent and controller components
7926 -- are unconditionally in the subtype.
7928 if Is_Tagged_Type
(Typ
)
7929 or else Has_Controlled_Component
(Typ
)
7931 Old_C
:= First_Component
(Typ
);
7933 while Present
(Old_C
) loop
7934 if Chars
((Old_C
)) = Name_uTag
7935 or else Chars
((Old_C
)) = Name_uParent
7936 or else Chars
((Old_C
)) = Name_uController
7938 Append_Elmt
(Old_C
, Comp_List
);
7941 Next_Component
(Old_C
);
7944 end Collect_Fixed_Components
;
7946 ---------------------------
7947 -- Create_All_Components --
7948 ---------------------------
7950 procedure Create_All_Components
is
7954 Comp
:= First_Elmt
(Comp_List
);
7956 while Present
(Comp
) loop
7957 Old_C
:= Node
(Comp
);
7958 New_C
:= Create_Component
(Old_C
);
7962 Constrain_Component_Type
7963 (Etype
(Old_C
), Subt
, Decl_Node
, Typ
, Constraints
));
7964 Set_Is_Public
(New_C
, Is_Public
(Subt
));
7968 end Create_All_Components
;
7970 ----------------------
7971 -- Create_Component --
7972 ----------------------
7974 function Create_Component
(Old_Compon
: Entity_Id
) return Entity_Id
is
7975 New_Compon
: Entity_Id
:= New_Copy
(Old_Compon
);
7978 -- Set the parent so we have a proper link for freezing etc. This
7979 -- is not a real parent pointer, since of course our parent does
7980 -- not own up to us and reference us, we are an illegitimate
7981 -- child of the original parent!
7983 Set_Parent
(New_Compon
, Parent
(Old_Compon
));
7985 -- We do not want this node marked as Comes_From_Source, since
7986 -- otherwise it would get first class status and a separate
7987 -- cross-reference line would be generated. Illegitimate
7988 -- children do not rate such recognition.
7990 Set_Comes_From_Source
(New_Compon
, False);
7992 -- But it is a real entity, and a birth certificate must be
7993 -- properly registered by entering it into the entity list.
7995 Enter_Name
(New_Compon
);
7997 end Create_Component
;
7999 -----------------------
8000 -- Is_Variant_Record --
8001 -----------------------
8003 function Is_Variant_Record
(T
: Entity_Id
) return Boolean is
8005 return Nkind
(Parent
(T
)) = N_Full_Type_Declaration
8006 and then Nkind
(Type_Definition
(Parent
(T
))) = N_Record_Definition
8007 and then Present
(Component_List
(Type_Definition
(Parent
(T
))))
8009 Variant_Part
(Component_List
(Type_Definition
(Parent
(T
)))));
8010 end Is_Variant_Record
;
8012 -- Start of processing for Create_Constrained_Components
8015 pragma Assert
(Subt
/= Base_Type
(Subt
));
8016 pragma Assert
(Typ
= Base_Type
(Typ
));
8018 Set_First_Entity
(Subt
, Empty
);
8019 Set_Last_Entity
(Subt
, Empty
);
8021 -- Check whether constraint is fully static, in which case we can
8022 -- optimize the list of components.
8024 Discr_Val
:= First_Elmt
(Constraints
);
8026 while Present
(Discr_Val
) loop
8028 if not Is_OK_Static_Expression
(Node
(Discr_Val
)) then
8033 Next_Elmt
(Discr_Val
);
8038 -- Inherit the discriminants of the parent type.
8040 Old_C
:= First_Discriminant
(Typ
);
8042 while Present
(Old_C
) loop
8043 New_C
:= Create_Component
(Old_C
);
8044 Set_Is_Public
(New_C
, Is_Public
(Subt
));
8045 Next_Discriminant
(Old_C
);
8049 and then Is_Variant_Record
(Typ
)
8051 Collect_Fixed_Components
(Typ
);
8055 Component_List
(Type_Definition
(Parent
(Typ
))),
8056 Governed_By
=> Assoc_List
,
8058 Report_Errors
=> Errors
);
8059 pragma Assert
(not Errors
);
8061 Create_All_Components
;
8063 -- If the subtype declaration is created for a tagged type derivation
8064 -- with constraints, we retrieve the record definition of the parent
8065 -- type to select the components of the proper variant.
8068 and then Is_Tagged_Type
(Typ
)
8069 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
8071 Nkind
(Type_Definition
(Parent
(Typ
))) = N_Derived_Type_Definition
8072 and then Is_Variant_Record
(Parent_Type
)
8074 Collect_Fixed_Components
(Typ
);
8078 Component_List
(Type_Definition
(Parent
(Parent_Type
))),
8079 Governed_By
=> Assoc_List
,
8081 Report_Errors
=> Errors
);
8082 pragma Assert
(not Errors
);
8084 -- If the tagged derivation has a type extension, collect all the
8085 -- new components therein.
8088 Record_Extension_Part
(Type_Definition
(Parent
(Typ
))))
8090 Old_C
:= First_Component
(Typ
);
8092 while Present
(Old_C
) loop
8093 if Original_Record_Component
(Old_C
) = Old_C
8094 and then Chars
(Old_C
) /= Name_uTag
8095 and then Chars
(Old_C
) /= Name_uParent
8096 and then Chars
(Old_C
) /= Name_uController
8098 Append_Elmt
(Old_C
, Comp_List
);
8101 Next_Component
(Old_C
);
8105 Create_All_Components
;
8108 -- If the discriminants are not static, or if this is a multi-level
8109 -- type extension, we have to include all the components of the
8112 Old_C
:= First_Component
(Typ
);
8114 while Present
(Old_C
) loop
8115 New_C
:= Create_Component
(Old_C
);
8119 Constrain_Component_Type
8120 (Etype
(Old_C
), Subt
, Decl_Node
, Typ
, Constraints
));
8121 Set_Is_Public
(New_C
, Is_Public
(Subt
));
8123 Next_Component
(Old_C
);
8128 end Create_Constrained_Components
;
8130 ------------------------------------------
8131 -- Decimal_Fixed_Point_Type_Declaration --
8132 ------------------------------------------
8134 procedure Decimal_Fixed_Point_Type_Declaration
8138 Loc
: constant Source_Ptr
:= Sloc
(Def
);
8139 Digs_Expr
: constant Node_Id
:= Digits_Expression
(Def
);
8140 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
8141 Implicit_Base
: Entity_Id
;
8147 -- Start of processing for Decimal_Fixed_Point_Type_Declaration
8150 Check_Restriction
(No_Fixed_Point
, Def
);
8152 -- Create implicit base type
8155 Create_Itype
(E_Decimal_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
8156 Set_Etype
(Implicit_Base
, Implicit_Base
);
8158 -- Analyze and process delta expression
8160 Analyze_And_Resolve
(Delta_Expr
, Universal_Real
);
8162 Check_Delta_Expression
(Delta_Expr
);
8163 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
8165 -- Check delta is power of 10, and determine scale value from it
8168 Val
: Ureal
:= Delta_Val
;
8171 Scale_Val
:= Uint_0
;
8173 if Val
< Ureal_1
then
8174 while Val
< Ureal_1
loop
8175 Val
:= Val
* Ureal_10
;
8176 Scale_Val
:= Scale_Val
+ 1;
8179 if Scale_Val
> 18 then
8180 Error_Msg_N
("scale exceeds maximum value of 18", Def
);
8181 Scale_Val
:= UI_From_Int
(+18);
8185 while Val
> Ureal_1
loop
8186 Val
:= Val
/ Ureal_10
;
8187 Scale_Val
:= Scale_Val
- 1;
8190 if Scale_Val
< -18 then
8191 Error_Msg_N
("scale is less than minimum value of -18", Def
);
8192 Scale_Val
:= UI_From_Int
(-18);
8196 if Val
/= Ureal_1
then
8197 Error_Msg_N
("delta expression must be a power of 10", Def
);
8198 Delta_Val
:= Ureal_10
** (-Scale_Val
);
8202 -- Set delta, scale and small (small = delta for decimal type)
8204 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
8205 Set_Scale_Value
(Implicit_Base
, Scale_Val
);
8206 Set_Small_Value
(Implicit_Base
, Delta_Val
);
8208 -- Analyze and process digits expression
8210 Analyze_And_Resolve
(Digs_Expr
, Any_Integer
);
8211 Check_Digits_Expression
(Digs_Expr
);
8212 Digs_Val
:= Expr_Value
(Digs_Expr
);
8214 if Digs_Val
> 18 then
8215 Digs_Val
:= UI_From_Int
(+18);
8216 Error_Msg_N
("digits value out of range, maximum is 18", Digs_Expr
);
8219 Set_Digits_Value
(Implicit_Base
, Digs_Val
);
8220 Bound_Val
:= UR_From_Uint
(10 ** Digs_Val
- 1) * Delta_Val
;
8222 -- Set range of base type from digits value for now. This will be
8223 -- expanded to represent the true underlying base range by Freeze.
8225 Set_Fixed_Range
(Implicit_Base
, Loc
, -Bound_Val
, Bound_Val
);
8227 -- Set size to zero for now, size will be set at freeze time. We have
8228 -- to do this for ordinary fixed-point, because the size depends on
8229 -- the specified small, and we might as well do the same for decimal
8232 Init_Size_Align
(Implicit_Base
);
8234 -- Complete entity for first subtype
8236 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
8237 Set_Etype
(T
, Implicit_Base
);
8238 Set_Size_Info
(T
, Implicit_Base
);
8239 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
8240 Set_Digits_Value
(T
, Digs_Val
);
8241 Set_Delta_Value
(T
, Delta_Val
);
8242 Set_Small_Value
(T
, Delta_Val
);
8243 Set_Scale_Value
(T
, Scale_Val
);
8244 Set_Is_Constrained
(T
);
8246 -- If there are bounds given in the declaration use them as the
8247 -- bounds of the first named subtype.
8249 if Present
(Real_Range_Specification
(Def
)) then
8251 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
8252 Low
: constant Node_Id
:= Low_Bound
(RRS
);
8253 High
: constant Node_Id
:= High_Bound
(RRS
);
8258 Analyze_And_Resolve
(Low
, Any_Real
);
8259 Analyze_And_Resolve
(High
, Any_Real
);
8260 Check_Real_Bound
(Low
);
8261 Check_Real_Bound
(High
);
8262 Low_Val
:= Expr_Value_R
(Low
);
8263 High_Val
:= Expr_Value_R
(High
);
8265 if Low_Val
< (-Bound_Val
) then
8267 ("range low bound too small for digits value", Low
);
8268 Low_Val
:= -Bound_Val
;
8271 if High_Val
> Bound_Val
then
8273 ("range high bound too large for digits value", High
);
8274 High_Val
:= Bound_Val
;
8277 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
8280 -- If no explicit range, use range that corresponds to given
8281 -- digits value. This will end up as the final range for the
8285 Set_Fixed_Range
(T
, Loc
, -Bound_Val
, Bound_Val
);
8288 end Decimal_Fixed_Point_Type_Declaration
;
8290 -----------------------
8291 -- Derive_Subprogram --
8292 -----------------------
8294 procedure Derive_Subprogram
8295 (New_Subp
: in out Entity_Id
;
8296 Parent_Subp
: Entity_Id
;
8297 Derived_Type
: Entity_Id
;
8298 Parent_Type
: Entity_Id
;
8299 Actual_Subp
: Entity_Id
:= Empty
)
8302 New_Formal
: Entity_Id
;
8303 Same_Subt
: constant Boolean :=
8304 Is_Scalar_Type
(Parent_Type
)
8305 and then Subtypes_Statically_Compatible
(Parent_Type
, Derived_Type
);
8307 function Is_Private_Overriding
return Boolean;
8308 -- If Subp is a private overriding of a visible operation, the in-
8309 -- herited operation derives from the overridden op (even though
8310 -- its body is the overriding one) and the inherited operation is
8311 -- visible now. See sem_disp to see the details of the handling of
8312 -- the overridden subprogram, which is removed from the list of
8313 -- primitive operations of the type.
8315 procedure Replace_Type
(Id
, New_Id
: Entity_Id
);
8316 -- When the type is an anonymous access type, create a new access type
8317 -- designating the derived type.
8319 ---------------------------
8320 -- Is_Private_Overriding --
8321 ---------------------------
8323 function Is_Private_Overriding
return Boolean is
8327 Prev
:= Homonym
(Parent_Subp
);
8329 -- The visible operation that is overriden is a homonym of
8330 -- the parent subprogram. We scan the homonym chain to find
8331 -- the one whose alias is the subprogram we are deriving.
8333 while Present
(Prev
) loop
8334 if Is_Dispatching_Operation
(Parent_Subp
)
8335 and then Present
(Prev
)
8336 and then Ekind
(Prev
) = Ekind
(Parent_Subp
)
8337 and then Alias
(Prev
) = Parent_Subp
8338 and then Scope
(Parent_Subp
) = Scope
(Prev
)
8339 and then not Is_Hidden
(Prev
)
8344 Prev
:= Homonym
(Prev
);
8348 end Is_Private_Overriding
;
8354 procedure Replace_Type
(Id
, New_Id
: Entity_Id
) is
8355 Acc_Type
: Entity_Id
;
8359 -- When the type is an anonymous access type, create a new access
8360 -- type designating the derived type. This itype must be elaborated
8361 -- at the point of the derivation, not on subsequent calls that may
8362 -- be out of the proper scope for Gigi, so we insert a reference to
8363 -- it after the derivation.
8365 if Ekind
(Etype
(Id
)) = E_Anonymous_Access_Type
then
8367 Desig_Typ
: Entity_Id
:= Designated_Type
(Etype
(Id
));
8370 if Ekind
(Desig_Typ
) = E_Record_Type_With_Private
8371 and then Present
(Full_View
(Desig_Typ
))
8372 and then not Is_Private_Type
(Parent_Type
)
8374 Desig_Typ
:= Full_View
(Desig_Typ
);
8377 if Base_Type
(Desig_Typ
) = Base_Type
(Parent_Type
) then
8378 Acc_Type
:= New_Copy
(Etype
(Id
));
8379 Set_Etype
(Acc_Type
, Acc_Type
);
8380 Set_Scope
(Acc_Type
, New_Subp
);
8382 -- Compute size of anonymous access type.
8384 if Is_Array_Type
(Desig_Typ
)
8385 and then not Is_Constrained
(Desig_Typ
)
8387 Init_Size
(Acc_Type
, 2 * System_Address_Size
);
8389 Init_Size
(Acc_Type
, System_Address_Size
);
8392 Init_Alignment
(Acc_Type
);
8394 Set_Directly_Designated_Type
(Acc_Type
, Derived_Type
);
8396 Set_Etype
(New_Id
, Acc_Type
);
8397 Set_Scope
(New_Id
, New_Subp
);
8399 -- Create a reference to it.
8401 IR
:= Make_Itype_Reference
(Sloc
(Parent
(Derived_Type
)));
8402 Set_Itype
(IR
, Acc_Type
);
8403 Insert_After
(Parent
(Derived_Type
), IR
);
8406 Set_Etype
(New_Id
, Etype
(Id
));
8409 elsif Base_Type
(Etype
(Id
)) = Base_Type
(Parent_Type
)
8411 (Ekind
(Etype
(Id
)) = E_Record_Type_With_Private
8412 and then Present
(Full_View
(Etype
(Id
)))
8413 and then Base_Type
(Full_View
(Etype
(Id
))) =
8414 Base_Type
(Parent_Type
))
8417 -- Constraint checks on formals are generated during expansion,
8418 -- based on the signature of the original subprogram. The bounds
8419 -- of the derived type are not relevant, and thus we can use
8420 -- the base type for the formals. However, the return type may be
8421 -- used in a context that requires that the proper static bounds
8422 -- be used (a case statement, for example) and for those cases
8423 -- we must use the derived type (first subtype), not its base.
8425 if Etype
(Id
) = Parent_Type
8428 Set_Etype
(New_Id
, Derived_Type
);
8430 Set_Etype
(New_Id
, Base_Type
(Derived_Type
));
8434 Set_Etype
(New_Id
, Etype
(Id
));
8438 -- Start of processing for Derive_Subprogram
8442 New_Entity
(Nkind
(Parent_Subp
), Sloc
(Derived_Type
));
8443 Set_Ekind
(New_Subp
, Ekind
(Parent_Subp
));
8445 -- Check whether the inherited subprogram is a private operation that
8446 -- should be inherited but not yet made visible. Such subprograms can
8447 -- become visible at a later point (e.g., the private part of a public
8448 -- child unit) via Declare_Inherited_Private_Subprograms. If the
8449 -- following predicate is true, then this is not such a private
8450 -- operation and the subprogram simply inherits the name of the parent
8451 -- subprogram. Note the special check for the names of controlled
8452 -- operations, which are currently exempted from being inherited with
8453 -- a hidden name because they must be findable for generation of
8454 -- implicit run-time calls.
8456 if not Is_Hidden
(Parent_Subp
)
8457 or else Is_Internal
(Parent_Subp
)
8458 or else Is_Private_Overriding
8459 or else Is_Internal_Name
(Chars
(Parent_Subp
))
8460 or else Chars
(Parent_Subp
) = Name_Initialize
8461 or else Chars
(Parent_Subp
) = Name_Adjust
8462 or else Chars
(Parent_Subp
) = Name_Finalize
8464 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
8466 -- If parent is hidden, this can be a regular derivation if the
8467 -- parent is immediately visible in a non-instantiating context,
8468 -- or if we are in the private part of an instance. This test
8469 -- should still be refined ???
8471 -- The test for In_Instance_Not_Visible avoids inheriting the
8472 -- derived operation as a non-visible operation in cases where
8473 -- the parent subprogram might not be visible now, but was
8474 -- visible within the original generic, so it would be wrong
8475 -- to make the inherited subprogram non-visible now. (Not
8476 -- clear if this test is fully correct; are there any cases
8477 -- where we should declare the inherited operation as not
8478 -- visible to avoid it being overridden, e.g., when the
8479 -- parent type is a generic actual with private primitives ???)
8481 -- (they should be treated the same as other private inherited
8482 -- subprograms, but it's not clear how to do this cleanly). ???
8484 elsif (In_Open_Scopes
(Scope
(Base_Type
(Parent_Type
)))
8485 and then Is_Immediately_Visible
(Parent_Subp
)
8486 and then not In_Instance
)
8487 or else In_Instance_Not_Visible
8489 Set_Chars
(New_Subp
, Chars
(Parent_Subp
));
8491 -- The type is inheriting a private operation, so enter
8492 -- it with a special name so it can't be overridden.
8495 Set_Chars
(New_Subp
, New_External_Name
(Chars
(Parent_Subp
), 'P'));
8498 Set_Parent
(New_Subp
, Parent
(Derived_Type
));
8499 Replace_Type
(Parent_Subp
, New_Subp
);
8500 Conditional_Delay
(New_Subp
, Parent_Subp
);
8502 Formal
:= First_Formal
(Parent_Subp
);
8503 while Present
(Formal
) loop
8504 New_Formal
:= New_Copy
(Formal
);
8506 -- Normally we do not go copying parents, but in the case of
8507 -- formals, we need to link up to the declaration (which is
8508 -- the parameter specification), and it is fine to link up to
8509 -- the original formal's parameter specification in this case.
8511 Set_Parent
(New_Formal
, Parent
(Formal
));
8513 Append_Entity
(New_Formal
, New_Subp
);
8515 Replace_Type
(Formal
, New_Formal
);
8516 Next_Formal
(Formal
);
8519 -- If this derivation corresponds to a tagged generic actual, then
8520 -- primitive operations rename those of the actual. Otherwise the
8521 -- primitive operations rename those of the parent type.
8523 if No
(Actual_Subp
) then
8524 Set_Alias
(New_Subp
, Parent_Subp
);
8525 Set_Is_Intrinsic_Subprogram
(New_Subp
,
8526 Is_Intrinsic_Subprogram
(Parent_Subp
));
8529 Set_Alias
(New_Subp
, Actual_Subp
);
8532 -- Derived subprograms of a tagged type must inherit the convention
8533 -- of the parent subprogram (a requirement of AI-117). Derived
8534 -- subprograms of untagged types simply get convention Ada by default.
8536 if Is_Tagged_Type
(Derived_Type
) then
8537 Set_Convention
(New_Subp
, Convention
(Parent_Subp
));
8540 Set_Is_Imported
(New_Subp
, Is_Imported
(Parent_Subp
));
8541 Set_Is_Exported
(New_Subp
, Is_Exported
(Parent_Subp
));
8543 if Ekind
(Parent_Subp
) = E_Procedure
then
8544 Set_Is_Valued_Procedure
8545 (New_Subp
, Is_Valued_Procedure
(Parent_Subp
));
8548 New_Overloaded_Entity
(New_Subp
, Derived_Type
);
8550 -- Check for case of a derived subprogram for the instantiation
8551 -- of a formal derived tagged type, so mark the subprogram as
8552 -- dispatching and inherit the dispatching attributes of the
8553 -- parent subprogram. The derived subprogram is effectively a
8554 -- renaming of the actual subprogram, so it needs to have the
8555 -- same attributes as the actual.
8557 if Present
(Actual_Subp
)
8558 and then Is_Dispatching_Operation
(Parent_Subp
)
8560 Set_Is_Dispatching_Operation
(New_Subp
);
8561 if Present
(DTC_Entity
(Parent_Subp
)) then
8562 Set_DTC_Entity
(New_Subp
, DTC_Entity
(Parent_Subp
));
8563 Set_DT_Position
(New_Subp
, DT_Position
(Parent_Subp
));
8567 -- Indicate that a derived subprogram does not require a body
8568 -- and that it does not require processing of default expressions.
8570 Set_Has_Completion
(New_Subp
);
8571 Set_Default_Expressions_Processed
(New_Subp
);
8573 -- A derived function with a controlling result is abstract.
8574 -- If the Derived_Type is a nonabstract formal generic derived
8575 -- type, then inherited operations are not abstract: check is
8576 -- done at instantiation time. If the derivation is for a generic
8577 -- actual, the function is not abstract unless the actual is.
8579 if Is_Generic_Type
(Derived_Type
)
8580 and then not Is_Abstract
(Derived_Type
)
8584 elsif Is_Abstract
(Alias
(New_Subp
))
8585 or else (Is_Tagged_Type
(Derived_Type
)
8586 and then Etype
(New_Subp
) = Derived_Type
8587 and then No
(Actual_Subp
))
8589 Set_Is_Abstract
(New_Subp
);
8592 if Ekind
(New_Subp
) = E_Function
then
8593 Set_Mechanism
(New_Subp
, Mechanism
(Parent_Subp
));
8595 end Derive_Subprogram
;
8597 ------------------------
8598 -- Derive_Subprograms --
8599 ------------------------
8601 procedure Derive_Subprograms
8602 (Parent_Type
: Entity_Id
;
8603 Derived_Type
: Entity_Id
;
8604 Generic_Actual
: Entity_Id
:= Empty
)
8606 Op_List
: Elist_Id
:= Collect_Primitive_Operations
(Parent_Type
);
8607 Act_List
: Elist_Id
;
8611 New_Subp
: Entity_Id
:= Empty
;
8612 Parent_Base
: Entity_Id
;
8615 if Ekind
(Parent_Type
) = E_Record_Type_With_Private
8616 and then Has_Discriminants
(Parent_Type
)
8617 and then Present
(Full_View
(Parent_Type
))
8619 Parent_Base
:= Full_View
(Parent_Type
);
8621 Parent_Base
:= Parent_Type
;
8624 Elmt
:= First_Elmt
(Op_List
);
8626 if Present
(Generic_Actual
) then
8627 Act_List
:= Collect_Primitive_Operations
(Generic_Actual
);
8628 Act_Elmt
:= First_Elmt
(Act_List
);
8630 Act_Elmt
:= No_Elmt
;
8633 -- Literals are derived earlier in the process of building the
8634 -- derived type, and are skipped here.
8636 while Present
(Elmt
) loop
8637 Subp
:= Node
(Elmt
);
8639 if Ekind
(Subp
) /= E_Enumeration_Literal
then
8640 if No
(Generic_Actual
) then
8642 (New_Subp
, Subp
, Derived_Type
, Parent_Base
);
8645 Derive_Subprogram
(New_Subp
, Subp
,
8646 Derived_Type
, Parent_Base
, Node
(Act_Elmt
));
8647 Next_Elmt
(Act_Elmt
);
8653 end Derive_Subprograms
;
8655 --------------------------------
8656 -- Derived_Standard_Character --
8657 --------------------------------
8659 procedure Derived_Standard_Character
8661 Parent_Type
: Entity_Id
;
8662 Derived_Type
: Entity_Id
)
8664 Loc
: constant Source_Ptr
:= Sloc
(N
);
8665 Def
: constant Node_Id
:= Type_Definition
(N
);
8666 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8667 Parent_Base
: constant Entity_Id
:= Base_Type
(Parent_Type
);
8668 Implicit_Base
: constant Entity_Id
:=
8670 (E_Enumeration_Type
, N
, Derived_Type
, 'B');
8677 T
:= Process_Subtype
(Indic
, N
);
8679 Set_Etype
(Implicit_Base
, Parent_Base
);
8680 Set_Size_Info
(Implicit_Base
, Root_Type
(Parent_Type
));
8681 Set_RM_Size
(Implicit_Base
, RM_Size
(Root_Type
(Parent_Type
)));
8683 Set_Is_Character_Type
(Implicit_Base
, True);
8684 Set_Has_Delayed_Freeze
(Implicit_Base
);
8686 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Parent_Type
));
8687 Hi
:= New_Copy_Tree
(Type_High_Bound
(Parent_Type
));
8689 Set_Scalar_Range
(Implicit_Base
,
8694 Conditional_Delay
(Derived_Type
, Parent_Type
);
8696 Set_Ekind
(Derived_Type
, E_Enumeration_Subtype
);
8697 Set_Etype
(Derived_Type
, Implicit_Base
);
8698 Set_Size_Info
(Derived_Type
, Parent_Type
);
8700 if Unknown_RM_Size
(Derived_Type
) then
8701 Set_RM_Size
(Derived_Type
, RM_Size
(Parent_Type
));
8704 Set_Is_Character_Type
(Derived_Type
, True);
8706 if Nkind
(Indic
) /= N_Subtype_Indication
then
8707 Set_Scalar_Range
(Derived_Type
, Scalar_Range
(Implicit_Base
));
8710 Convert_Scalar_Bounds
(N
, Parent_Type
, Derived_Type
, Loc
);
8712 -- Because the implicit base is used in the conversion of the bounds,
8713 -- we have to freeze it now. This is similar to what is done for
8714 -- numeric types, and it equally suspicious, but otherwise a non-
8715 -- static bound will have a reference to an unfrozen type, which is
8716 -- rejected by Gigi (???).
8718 Freeze_Before
(N
, Implicit_Base
);
8720 end Derived_Standard_Character
;
8722 ------------------------------
8723 -- Derived_Type_Declaration --
8724 ------------------------------
8726 procedure Derived_Type_Declaration
8729 Is_Completion
: Boolean)
8731 Def
: constant Node_Id
:= Type_Definition
(N
);
8732 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8733 Extension
: constant Node_Id
:= Record_Extension_Part
(Def
);
8734 Parent_Type
: Entity_Id
;
8735 Parent_Scope
: Entity_Id
;
8739 Parent_Type
:= Find_Type_Of_Subtype_Indic
(Indic
);
8741 if Parent_Type
= Any_Type
8742 or else Etype
(Parent_Type
) = Any_Type
8743 or else (Is_Class_Wide_Type
(Parent_Type
)
8744 and then Etype
(Parent_Type
) = T
)
8746 -- If Parent_Type is undefined or illegal, make new type into
8747 -- a subtype of Any_Type, and set a few attributes to prevent
8748 -- cascaded errors. If this is a self-definition, emit error now.
8751 or else T
= Etype
(Parent_Type
)
8753 Error_Msg_N
("type cannot be used in its own definition", Indic
);
8756 Set_Ekind
(T
, Ekind
(Parent_Type
));
8757 Set_Etype
(T
, Any_Type
);
8758 Set_Scalar_Range
(T
, Scalar_Range
(Any_Type
));
8760 if Is_Tagged_Type
(T
) then
8761 Set_Primitive_Operations
(T
, New_Elmt_List
);
8766 elsif Is_Unchecked_Union
(Parent_Type
) then
8767 Error_Msg_N
("cannot derive from Unchecked_Union type", N
);
8770 -- Only composite types other than array types are allowed to have
8773 if Present
(Discriminant_Specifications
(N
))
8774 and then (Is_Elementary_Type
(Parent_Type
)
8775 or else Is_Array_Type
(Parent_Type
))
8776 and then not Error_Posted
(N
)
8779 ("elementary or array type cannot have discriminants",
8780 Defining_Identifier
(First
(Discriminant_Specifications
(N
))));
8781 Set_Has_Discriminants
(T
, False);
8784 -- In Ada 83, a derived type defined in a package specification cannot
8785 -- be used for further derivation until the end of its visible part.
8786 -- Note that derivation in the private part of the package is allowed.
8789 and then Is_Derived_Type
(Parent_Type
)
8790 and then In_Visible_Part
(Scope
(Parent_Type
))
8792 if Ada_83
and then Comes_From_Source
(Indic
) then
8794 ("(Ada 83): premature use of type for derivation", Indic
);
8798 -- Check for early use of incomplete or private type
8800 if Ekind
(Parent_Type
) = E_Void
8801 or else Ekind
(Parent_Type
) = E_Incomplete_Type
8803 Error_Msg_N
("premature derivation of incomplete type", Indic
);
8806 elsif (Is_Incomplete_Or_Private_Type
(Parent_Type
)
8807 and then not Is_Generic_Type
(Parent_Type
)
8808 and then not Is_Generic_Type
(Root_Type
(Parent_Type
))
8809 and then not Is_Generic_Actual_Type
(Parent_Type
))
8810 or else Has_Private_Component
(Parent_Type
)
8812 -- The ancestor type of a formal type can be incomplete, in which
8813 -- case only the operations of the partial view are available in
8814 -- the generic. Subsequent checks may be required when the full
8815 -- view is analyzed, to verify that derivation from a tagged type
8816 -- has an extension.
8818 if Nkind
(Original_Node
(N
)) = N_Formal_Type_Declaration
then
8821 elsif No
(Underlying_Type
(Parent_Type
))
8822 or else Has_Private_Component
(Parent_Type
)
8825 ("premature derivation of derived or private type", Indic
);
8827 -- Flag the type itself as being in error, this prevents some
8828 -- nasty problems with people looking at the malformed type.
8830 Set_Error_Posted
(T
);
8832 -- Check that within the immediate scope of an untagged partial
8833 -- view it's illegal to derive from the partial view if the
8834 -- full view is tagged. (7.3(7))
8836 -- We verify that the Parent_Type is a partial view by checking
8837 -- that it is not a Full_Type_Declaration (i.e. a private type or
8838 -- private extension declaration), to distinguish a partial view
8839 -- from a derivation from a private type which also appears as
8842 elsif Present
(Full_View
(Parent_Type
))
8843 and then Nkind
(Parent
(Parent_Type
)) /= N_Full_Type_Declaration
8844 and then not Is_Tagged_Type
(Parent_Type
)
8845 and then Is_Tagged_Type
(Full_View
(Parent_Type
))
8847 Parent_Scope
:= Scope
(T
);
8848 while Present
(Parent_Scope
)
8849 and then Parent_Scope
/= Standard_Standard
8851 if Parent_Scope
= Scope
(Parent_Type
) then
8853 ("premature derivation from type with tagged full view",
8857 Parent_Scope
:= Scope
(Parent_Scope
);
8862 -- Check that form of derivation is appropriate
8864 Taggd
:= Is_Tagged_Type
(Parent_Type
);
8866 -- Perhaps the parent type should be changed to the class-wide type's
8867 -- specific type in this case to prevent cascading errors ???
8869 if Present
(Extension
) and then Is_Class_Wide_Type
(Parent_Type
) then
8870 Error_Msg_N
("parent type must not be a class-wide type", Indic
);
8874 if Present
(Extension
) and then not Taggd
then
8876 ("type derived from untagged type cannot have extension", Indic
);
8878 elsif No
(Extension
) and then Taggd
then
8879 -- If this is within a private part (or body) of a generic
8880 -- instantiation then the derivation is allowed (the parent
8881 -- type can only appear tagged in this case if it's a generic
8882 -- actual type, since it would otherwise have been rejected
8883 -- in the analysis of the generic template).
8885 if not Is_Generic_Actual_Type
(Parent_Type
)
8886 or else In_Visible_Part
(Scope
(Parent_Type
))
8889 ("type derived from tagged type must have extension", Indic
);
8893 Build_Derived_Type
(N
, Parent_Type
, T
, Is_Completion
);
8894 end Derived_Type_Declaration
;
8896 ----------------------------------
8897 -- Enumeration_Type_Declaration --
8898 ----------------------------------
8900 procedure Enumeration_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
8907 -- Create identifier node representing lower bound
8909 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
8910 L
:= First
(Literals
(Def
));
8911 Set_Chars
(B_Node
, Chars
(L
));
8912 Set_Entity
(B_Node
, L
);
8913 Set_Etype
(B_Node
, T
);
8914 Set_Is_Static_Expression
(B_Node
, True);
8916 R_Node
:= New_Node
(N_Range
, Sloc
(Def
));
8917 Set_Low_Bound
(R_Node
, B_Node
);
8919 Set_Ekind
(T
, E_Enumeration_Type
);
8920 Set_First_Literal
(T
, L
);
8922 Set_Is_Constrained
(T
);
8926 -- Loop through literals of enumeration type setting pos and rep values
8927 -- except that if the Ekind is already set, then it means that the
8928 -- literal was already constructed (case of a derived type declaration
8929 -- and we should not disturb the Pos and Rep values.
8931 while Present
(L
) loop
8932 if Ekind
(L
) /= E_Enumeration_Literal
then
8933 Set_Ekind
(L
, E_Enumeration_Literal
);
8934 Set_Enumeration_Pos
(L
, Ev
);
8935 Set_Enumeration_Rep
(L
, Ev
);
8936 Set_Is_Known_Valid
(L
, True);
8940 New_Overloaded_Entity
(L
);
8941 Generate_Definition
(L
);
8942 Set_Convention
(L
, Convention_Intrinsic
);
8944 if Nkind
(L
) = N_Defining_Character_Literal
then
8945 Set_Is_Character_Type
(T
, True);
8952 -- Now create a node representing upper bound
8954 B_Node
:= New_Node
(N_Identifier
, Sloc
(Def
));
8955 Set_Chars
(B_Node
, Chars
(Last
(Literals
(Def
))));
8956 Set_Entity
(B_Node
, Last
(Literals
(Def
)));
8957 Set_Etype
(B_Node
, T
);
8958 Set_Is_Static_Expression
(B_Node
, True);
8960 Set_High_Bound
(R_Node
, B_Node
);
8961 Set_Scalar_Range
(T
, R_Node
);
8962 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
8965 -- Set Discard_Names if configuration pragma setg, or if there is
8966 -- a parameterless pragma in the current declarative region
8968 if Global_Discard_Names
8969 or else Discard_Names
(Scope
(T
))
8971 Set_Discard_Names
(T
);
8974 -- Process end label if there is one
8976 if Present
(Def
) then
8977 Process_End_Label
(Def
, 'e', T
);
8979 end Enumeration_Type_Declaration
;
8981 --------------------------
8982 -- Expand_Others_Choice --
8983 --------------------------
8985 procedure Expand_Others_Choice
8986 (Case_Table
: Choice_Table_Type
;
8987 Others_Choice
: Node_Id
;
8988 Choice_Type
: Entity_Id
)
8991 Choice_List
: List_Id
:= New_List
;
8996 Loc
: Source_Ptr
:= Sloc
(Others_Choice
);
8999 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
9000 -- Builds a node representing the missing choices given by the
9001 -- Value1 and Value2. A N_Range node is built if there is more than
9002 -- one literal value missing. Otherwise a single N_Integer_Literal,
9003 -- N_Identifier or N_Character_Literal is built depending on what
9006 function Lit_Of
(Value
: Uint
) return Node_Id
;
9007 -- Returns the Node_Id for the enumeration literal corresponding to the
9008 -- position given by Value within the enumeration type Choice_Type.
9014 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
9019 -- If there is only one choice value missing between Value1 and
9020 -- Value2, build an integer or enumeration literal to represent it.
9022 if (Value2
- Value1
) = 0 then
9023 if Is_Integer_Type
(Choice_Type
) then
9024 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
9025 Set_Etype
(Lit_Node
, Choice_Type
);
9027 Lit_Node
:= Lit_Of
(Value1
);
9030 -- Otherwise is more that one choice value that is missing between
9031 -- Value1 and Value2, therefore build a N_Range node of either
9032 -- integer or enumeration literals.
9035 if Is_Integer_Type
(Choice_Type
) then
9036 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
9037 Set_Etype
(Lo
, Choice_Type
);
9038 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
9039 Set_Etype
(Hi
, Choice_Type
);
9048 Low_Bound
=> Lit_Of
(Value1
),
9049 High_Bound
=> Lit_Of
(Value2
));
9060 function Lit_Of
(Value
: Uint
) return Node_Id
is
9064 -- In the case where the literal is of type Character, there needs
9065 -- to be some special handling since there is no explicit chain
9066 -- of literals to search. Instead, a N_Character_Literal node
9067 -- is created with the appropriate Char_Code and Chars fields.
9069 if Root_Type
(Choice_Type
) = Standard_Character
then
9070 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
9071 Lit
:= New_Node
(N_Character_Literal
, Loc
);
9072 Set_Chars
(Lit
, Name_Find
);
9073 Set_Char_Literal_Value
(Lit
, Char_Code
(UI_To_Int
(Value
)));
9074 Set_Etype
(Lit
, Choice_Type
);
9075 Set_Is_Static_Expression
(Lit
, True);
9078 -- Otherwise, iterate through the literals list of Choice_Type
9079 -- "Value" number of times until the desired literal is reached
9080 -- and then return an occurrence of it.
9083 Lit
:= First_Literal
(Choice_Type
);
9084 for J
in 1 .. UI_To_Int
(Value
) loop
9088 return New_Occurrence_Of
(Lit
, Loc
);
9092 -- Start of processing for Expand_Others_Choice
9095 if Case_Table
'Length = 0 then
9097 -- Pathological case: only an others case is present.
9098 -- The others case covers the full range of the type.
9100 if Is_Static_Subtype
(Choice_Type
) then
9101 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
9103 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
9106 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
9110 -- Establish the bound values for the variant depending upon whether
9111 -- the type of the discriminant name is static or not.
9113 if Is_OK_Static_Subtype
(Choice_Type
) then
9114 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
9115 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
9117 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
9118 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
9121 Lo
:= Expr_Value
(Case_Table
(Case_Table
'First).Lo
);
9122 Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
9123 Previous_Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
9125 -- Build the node for any missing choices that are smaller than any
9126 -- explicit choices given in the variant.
9128 if Expr_Value
(Exp_Lo
) < Lo
then
9129 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
9132 -- Build the nodes representing any missing choices that lie between
9133 -- the explicit ones given in the variant.
9135 for J
in Case_Table
'First + 1 .. Case_Table
'Last loop
9136 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
9137 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
9139 if Lo
/= (Previous_Hi
+ 1) then
9140 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
9146 -- Build the node for any missing choices that are greater than any
9147 -- explicit choices given in the variant.
9149 if Expr_Value
(Exp_Hi
) > Hi
then
9150 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
9153 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
9154 end Expand_Others_Choice
;
9156 ---------------------------------
9157 -- Expand_To_Girder_Constraint --
9158 ---------------------------------
9160 function Expand_To_Girder_Constraint
9162 Constraint
: Elist_Id
)
9165 Explicitly_Discriminated_Type
: Entity_Id
;
9166 Expansion
: Elist_Id
;
9167 Discriminant
: Entity_Id
;
9169 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
;
9170 -- Find the nearest type that actually specifies discriminants.
9172 ---------------------------------
9173 -- Type_With_Explicit_Discrims --
9174 ---------------------------------
9176 function Type_With_Explicit_Discrims
(Id
: Entity_Id
) return Entity_Id
is
9177 Typ
: constant E
:= Base_Type
(Id
);
9180 if Ekind
(Typ
) in Incomplete_Or_Private_Kind
then
9181 if Present
(Full_View
(Typ
)) then
9182 return Type_With_Explicit_Discrims
(Full_View
(Typ
));
9186 if Has_Discriminants
(Typ
) then
9191 if Etype
(Typ
) = Typ
then
9193 elsif Has_Discriminants
(Typ
) then
9196 return Type_With_Explicit_Discrims
(Etype
(Typ
));
9199 end Type_With_Explicit_Discrims
;
9201 -- Start of processing for Expand_To_Girder_Constraint
9205 or else Is_Empty_Elmt_List
(Constraint
)
9210 Explicitly_Discriminated_Type
:= Type_With_Explicit_Discrims
(Typ
);
9212 if No
(Explicitly_Discriminated_Type
) then
9216 Expansion
:= New_Elmt_List
;
9219 First_Girder_Discriminant
(Explicitly_Discriminated_Type
);
9221 while Present
(Discriminant
) loop
9224 Get_Discriminant_Value
(
9225 Discriminant
, Explicitly_Discriminated_Type
, Constraint
),
9228 Next_Girder_Discriminant
(Discriminant
);
9232 end Expand_To_Girder_Constraint
;
9234 --------------------
9235 -- Find_Type_Name --
9236 --------------------
9238 function Find_Type_Name
(N
: Node_Id
) return Entity_Id
is
9239 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
9245 -- Find incomplete declaration, if some was given.
9247 Prev
:= Current_Entity_In_Scope
(Id
);
9249 if Present
(Prev
) then
9251 -- Previous declaration exists. Error if not incomplete/private case
9252 -- except if previous declaration is implicit, etc. Enter_Name will
9253 -- emit error if appropriate.
9255 Prev_Par
:= Parent
(Prev
);
9257 if not Is_Incomplete_Or_Private_Type
(Prev
) then
9261 elsif Nkind
(N
) /= N_Full_Type_Declaration
9262 and then Nkind
(N
) /= N_Task_Type_Declaration
9263 and then Nkind
(N
) /= N_Protected_Type_Declaration
9265 -- Completion must be a full type declarations (RM 7.3(4))
9267 Error_Msg_Sloc
:= Sloc
(Prev
);
9268 Error_Msg_NE
("invalid completion of }", Id
, Prev
);
9270 -- Set scope of Id to avoid cascaded errors. Entity is never
9271 -- examined again, except when saving globals in generics.
9273 Set_Scope
(Id
, Current_Scope
);
9276 -- Case of full declaration of incomplete type
9278 elsif Ekind
(Prev
) = E_Incomplete_Type
then
9280 -- Indicate that the incomplete declaration has a matching
9281 -- full declaration. The defining occurrence of the incomplete
9282 -- declaration remains the visible one, and the procedure
9283 -- Get_Full_View dereferences it whenever the type is used.
9285 if Present
(Full_View
(Prev
)) then
9286 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
9289 Set_Full_View
(Prev
, Id
);
9290 Append_Entity
(Id
, Current_Scope
);
9291 Set_Is_Public
(Id
, Is_Public
(Prev
));
9292 Set_Is_Internal
(Id
);
9295 -- Case of full declaration of private type
9298 if Nkind
(Parent
(Prev
)) /= N_Private_Extension_Declaration
then
9299 if Etype
(Prev
) /= Prev
then
9301 -- Prev is a private subtype or a derived type, and needs
9304 Error_Msg_NE
("invalid redeclaration of }", Id
, Prev
);
9307 elsif Ekind
(Prev
) = E_Private_Type
9309 (Nkind
(N
) = N_Task_Type_Declaration
9310 or else Nkind
(N
) = N_Protected_Type_Declaration
)
9313 ("completion of nonlimited type cannot be limited", N
);
9316 elsif Nkind
(N
) /= N_Full_Type_Declaration
9317 or else Nkind
(Type_Definition
(N
)) /= N_Derived_Type_Definition
9319 Error_Msg_N
("full view of private extension must be"
9320 & " an extension", N
);
9322 elsif not (Abstract_Present
(Parent
(Prev
)))
9323 and then Abstract_Present
(Type_Definition
(N
))
9325 Error_Msg_N
("full view of non-abstract extension cannot"
9326 & " be abstract", N
);
9329 if not In_Private_Part
(Current_Scope
) then
9331 ("declaration of full view must appear in private part", N
);
9334 Copy_And_Swap
(Prev
, Id
);
9335 Set_Has_Private_Declaration
(Prev
);
9336 Set_Has_Private_Declaration
(Id
);
9338 -- If no error, propagate freeze_node from private to full view.
9339 -- It may have been generated for an early operational item.
9341 if Present
(Freeze_Node
(Id
))
9342 and then Serious_Errors_Detected
= 0
9343 and then No
(Full_View
(Id
))
9345 Set_Freeze_Node
(Prev
, Freeze_Node
(Id
));
9346 Set_Freeze_Node
(Id
, Empty
);
9347 Set_First_Rep_Item
(Prev
, First_Rep_Item
(Id
));
9350 Set_Full_View
(Id
, Prev
);
9354 -- Verify that full declaration conforms to incomplete one
9356 if Is_Incomplete_Or_Private_Type
(Prev
)
9357 and then Present
(Discriminant_Specifications
(Prev_Par
))
9359 if Present
(Discriminant_Specifications
(N
)) then
9360 if Ekind
(Prev
) = E_Incomplete_Type
then
9361 Check_Discriminant_Conformance
(N
, Prev
, Prev
);
9363 Check_Discriminant_Conformance
(N
, Prev
, Id
);
9368 ("missing discriminants in full type declaration", N
);
9370 -- To avoid cascaded errors on subsequent use, share the
9371 -- discriminants of the partial view.
9373 Set_Discriminant_Specifications
(N
,
9374 Discriminant_Specifications
(Prev_Par
));
9378 -- A prior untagged private type can have an associated
9379 -- class-wide type due to use of the class attribute,
9380 -- and in this case also the full type is required to
9384 and then (Is_Tagged_Type
(Prev
)
9385 or else Present
(Class_Wide_Type
(Prev
)))
9387 -- The full declaration is either a tagged record or an
9388 -- extension otherwise this is an error
9390 if Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
9391 if not Tagged_Present
(Type_Definition
(N
)) then
9393 ("full declaration of } must be tagged", Prev
, Id
);
9394 Set_Is_Tagged_Type
(Id
);
9395 Set_Primitive_Operations
(Id
, New_Elmt_List
);
9398 elsif Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
then
9399 if No
(Record_Extension_Part
(Type_Definition
(N
))) then
9401 "full declaration of } must be a record extension",
9403 Set_Is_Tagged_Type
(Id
);
9404 Set_Primitive_Operations
(Id
, New_Elmt_List
);
9409 ("full declaration of } must be a tagged type", Prev
, Id
);
9417 -- New type declaration
9424 -------------------------
9425 -- Find_Type_Of_Object --
9426 -------------------------
9428 function Find_Type_Of_Object
9430 Related_Nod
: Node_Id
)
9433 Def_Kind
: constant Node_Kind
:= Nkind
(Obj_Def
);
9434 P
: constant Node_Id
:= Parent
(Obj_Def
);
9439 -- Case of an anonymous array subtype
9441 if Def_Kind
= N_Constrained_Array_Definition
9442 or else Def_Kind
= N_Unconstrained_Array_Definition
9445 Array_Type_Declaration
(T
, Obj_Def
);
9447 -- Create an explicit subtype whenever possible.
9449 elsif Nkind
(P
) /= N_Component_Declaration
9450 and then Def_Kind
= N_Subtype_Indication
9452 -- Base name of subtype on object name, which will be unique in
9453 -- the current scope.
9455 -- If this is a duplicate declaration, return base type, to avoid
9456 -- generating duplicate anonymous types.
9458 if Error_Posted
(P
) then
9459 Analyze
(Subtype_Mark
(Obj_Def
));
9460 return Entity
(Subtype_Mark
(Obj_Def
));
9465 (Chars
(Defining_Identifier
(Related_Nod
)), 'S', 0, 'T');
9467 T
:= Make_Defining_Identifier
(Sloc
(P
), Nam
);
9469 Insert_Action
(Obj_Def
,
9470 Make_Subtype_Declaration
(Sloc
(P
),
9471 Defining_Identifier
=> T
,
9472 Subtype_Indication
=> Relocate_Node
(Obj_Def
)));
9474 -- This subtype may need freezing and it will not be done
9475 -- automatically if the object declaration is not in a
9476 -- declarative part. Since this is an object declaration, the
9477 -- type cannot always be frozen here. Deferred constants do not
9478 -- freeze their type (which often enough will be private).
9480 if Nkind
(P
) = N_Object_Declaration
9481 and then Constant_Present
(P
)
9482 and then No
(Expression
(P
))
9487 Insert_Actions
(Obj_Def
, Freeze_Entity
(T
, Sloc
(P
)));
9491 T
:= Process_Subtype
(Obj_Def
, Related_Nod
);
9495 end Find_Type_Of_Object
;
9497 --------------------------------
9498 -- Find_Type_Of_Subtype_Indic --
9499 --------------------------------
9501 function Find_Type_Of_Subtype_Indic
(S
: Node_Id
) return Entity_Id
is
9505 -- Case of subtype mark with a constraint
9507 if Nkind
(S
) = N_Subtype_Indication
then
9508 Find_Type
(Subtype_Mark
(S
));
9509 Typ
:= Entity
(Subtype_Mark
(S
));
9512 Is_Valid_Constraint_Kind
(Ekind
(Typ
), Nkind
(Constraint
(S
)))
9515 ("incorrect constraint for this kind of type", Constraint
(S
));
9516 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
9519 -- Otherwise we have a subtype mark without a constraint
9521 elsif Error_Posted
(S
) then
9522 Rewrite
(S
, New_Occurrence_Of
(Any_Id
, Sloc
(S
)));
9530 if Typ
= Standard_Wide_Character
9531 or else Typ
= Standard_Wide_String
9533 Check_Restriction
(No_Wide_Characters
, S
);
9537 end Find_Type_Of_Subtype_Indic
;
9539 -------------------------------------
9540 -- Floating_Point_Type_Declaration --
9541 -------------------------------------
9543 procedure Floating_Point_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
9544 Digs
: constant Node_Id
:= Digits_Expression
(Def
);
9546 Base_Typ
: Entity_Id
;
9547 Implicit_Base
: Entity_Id
;
9550 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
9551 -- Find if given digits value allows derivation from specified type
9553 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
9554 Spec
: constant Entity_Id
:= Real_Range_Specification
(Def
);
9557 if Digs_Val
> Digits_Value
(E
) then
9561 if Present
(Spec
) then
9562 if Expr_Value_R
(Type_Low_Bound
(E
)) >
9563 Expr_Value_R
(Low_Bound
(Spec
))
9568 if Expr_Value_R
(Type_High_Bound
(E
)) <
9569 Expr_Value_R
(High_Bound
(Spec
))
9576 end Can_Derive_From
;
9578 -- Start of processing for Floating_Point_Type_Declaration
9581 Check_Restriction
(No_Floating_Point
, Def
);
9583 -- Create an implicit base type
9586 Create_Itype
(E_Floating_Point_Type
, Parent
(Def
), T
, 'B');
9588 -- Analyze and verify digits value
9590 Analyze_And_Resolve
(Digs
, Any_Integer
);
9591 Check_Digits_Expression
(Digs
);
9592 Digs_Val
:= Expr_Value
(Digs
);
9594 -- Process possible range spec and find correct type to derive from
9596 Process_Real_Range_Specification
(Def
);
9598 if Can_Derive_From
(Standard_Short_Float
) then
9599 Base_Typ
:= Standard_Short_Float
;
9600 elsif Can_Derive_From
(Standard_Float
) then
9601 Base_Typ
:= Standard_Float
;
9602 elsif Can_Derive_From
(Standard_Long_Float
) then
9603 Base_Typ
:= Standard_Long_Float
;
9604 elsif Can_Derive_From
(Standard_Long_Long_Float
) then
9605 Base_Typ
:= Standard_Long_Long_Float
;
9607 -- If we can't derive from any existing type, use long long float
9608 -- and give appropriate message explaining the problem.
9611 Base_Typ
:= Standard_Long_Long_Float
;
9613 if Digs_Val
>= Digits_Value
(Standard_Long_Long_Float
) then
9614 Error_Msg_Uint_1
:= Digits_Value
(Standard_Long_Long_Float
);
9615 Error_Msg_N
("digits value out of range, maximum is ^", Digs
);
9619 ("range too large for any predefined type",
9620 Real_Range_Specification
(Def
));
9624 -- If there are bounds given in the declaration use them as the bounds
9625 -- of the type, otherwise use the bounds of the predefined base type
9626 -- that was chosen based on the Digits value.
9628 if Present
(Real_Range_Specification
(Def
)) then
9629 Set_Scalar_Range
(T
, Real_Range_Specification
(Def
));
9630 Set_Is_Constrained
(T
);
9632 -- The bounds of this range must be converted to machine numbers
9633 -- in accordance with RM 4.9(38).
9635 Bound
:= Type_Low_Bound
(T
);
9637 if Nkind
(Bound
) = N_Real_Literal
then
9638 Set_Realval
(Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
));
9639 Set_Is_Machine_Number
(Bound
);
9642 Bound
:= Type_High_Bound
(T
);
9644 if Nkind
(Bound
) = N_Real_Literal
then
9645 Set_Realval
(Bound
, Machine
(Base_Typ
, Realval
(Bound
), Round
));
9646 Set_Is_Machine_Number
(Bound
);
9650 Set_Scalar_Range
(T
, Scalar_Range
(Base_Typ
));
9653 -- Complete definition of implicit base and declared first subtype
9655 Set_Etype
(Implicit_Base
, Base_Typ
);
9657 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
9658 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
9659 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
9660 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
9661 Set_Digits_Value
(Implicit_Base
, Digits_Value
(Base_Typ
));
9662 Set_Vax_Float
(Implicit_Base
, Vax_Float
(Base_Typ
));
9664 Set_Ekind
(T
, E_Floating_Point_Subtype
);
9665 Set_Etype
(T
, Implicit_Base
);
9667 Set_Size_Info
(T
, (Implicit_Base
));
9668 Set_RM_Size
(T
, RM_Size
(Implicit_Base
));
9669 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
9670 Set_Digits_Value
(T
, Digs_Val
);
9672 end Floating_Point_Type_Declaration
;
9674 ----------------------------
9675 -- Get_Discriminant_Value --
9676 ----------------------------
9678 -- This is the situation...
9680 -- There is a non-derived type
9682 -- type T0 (Dx, Dy, Dz...)
9684 -- There are zero or more levels of derivation, with each
9685 -- derivation either purely inheriting the discriminants, or
9686 -- defining its own.
9688 -- type Ti is new Ti-1
9690 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
9692 -- subtype Ti is ...
9694 -- The subtype issue is avoided by the use of
9695 -- Original_Record_Component, and the fact that derived subtypes
9696 -- also derive the constraits.
9698 -- This chain leads back from
9700 -- Typ_For_Constraint
9702 -- Typ_For_Constraint has discriminants, and the value for each
9703 -- discriminant is given by its corresponding Elmt of Constraints.
9705 -- Discriminant is some discriminant in this hierarchy.
9707 -- We need to return its value.
9709 -- We do this by recursively searching each level, and looking for
9710 -- Discriminant. Once we get to the bottom, we start backing up
9711 -- returning the value for it which may in turn be a discriminant
9712 -- further up, so on the backup we continue the substitution.
9714 function Get_Discriminant_Value
9715 (Discriminant
: Entity_Id
;
9716 Typ_For_Constraint
: Entity_Id
;
9717 Constraint
: Elist_Id
)
9722 Discrim_Values
: Elist_Id
;
9723 Girder_Discrim_Values
: Boolean)
9724 return Node_Or_Entity_Id
;
9725 -- This is the routine that performs the recursive search of levels
9726 -- as described above.
9730 Discrim_Values
: Elist_Id
;
9731 Girder_Discrim_Values
: Boolean)
9732 return Node_Or_Entity_Id
9736 Result
: Node_Or_Entity_Id
;
9737 Result_Entity
: Node_Id
;
9740 -- If inappropriate type, return Error, this happens only in
9741 -- cascaded error situations, and we want to avoid a blow up.
9743 if not Is_Composite_Type
(Ti
) or else Is_Array_Type
(Ti
) then
9747 -- Look deeper if possible. Use Girder_Constraints only for
9748 -- untagged types. For tagged types use the given constraint.
9749 -- This asymmetry needs explanation???
9751 if not Girder_Discrim_Values
9752 and then Present
(Girder_Constraint
(Ti
))
9753 and then not Is_Tagged_Type
(Ti
)
9755 Result
:= Recurse
(Ti
, Girder_Constraint
(Ti
), True);
9758 Td
: Entity_Id
:= Etype
(Ti
);
9762 Result
:= Discriminant
;
9765 if Present
(Girder_Constraint
(Ti
)) then
9767 Recurse
(Td
, Girder_Constraint
(Ti
), True);
9770 Recurse
(Td
, Discrim_Values
, Girder_Discrim_Values
);
9776 -- Extra underlying places to search, if not found above. For
9777 -- concurrent types, the relevant discriminant appears in the
9778 -- corresponding record. For a type derived from a private type
9779 -- without discriminant, the full view inherits the discriminants
9780 -- of the full view of the parent.
9782 if Result
= Discriminant
then
9783 if Is_Concurrent_Type
(Ti
)
9784 and then Present
(Corresponding_Record_Type
(Ti
))
9788 Corresponding_Record_Type
(Ti
),
9790 Girder_Discrim_Values
);
9792 elsif Is_Private_Type
(Ti
)
9793 and then not Has_Discriminants
(Ti
)
9794 and then Present
(Full_View
(Ti
))
9795 and then Etype
(Full_View
(Ti
)) /= Ti
9801 Girder_Discrim_Values
);
9805 -- If Result is not a (reference to a) discriminant,
9806 -- return it, otherwise set Result_Entity to the discriminant.
9808 if Nkind
(Result
) = N_Defining_Identifier
then
9810 pragma Assert
(Result
= Discriminant
);
9812 Result_Entity
:= Result
;
9815 if not Denotes_Discriminant
(Result
) then
9819 Result_Entity
:= Entity
(Result
);
9822 -- See if this level of derivation actually has discriminants
9823 -- because tagged derivations can add them, hence the lower
9824 -- levels need not have any.
9826 if not Has_Discriminants
(Ti
) then
9830 -- Scan Ti's discriminants for Result_Entity,
9831 -- and return its corresponding value, if any.
9833 Result_Entity
:= Original_Record_Component
(Result_Entity
);
9835 Assoc
:= First_Elmt
(Discrim_Values
);
9837 if Girder_Discrim_Values
then
9838 Disc
:= First_Girder_Discriminant
(Ti
);
9840 Disc
:= First_Discriminant
(Ti
);
9843 while Present
(Disc
) loop
9845 pragma Assert
(Present
(Assoc
));
9847 if Original_Record_Component
(Disc
) = Result_Entity
then
9848 return Node
(Assoc
);
9853 if Girder_Discrim_Values
then
9854 Next_Girder_Discriminant
(Disc
);
9856 Next_Discriminant
(Disc
);
9860 -- Could not find it
9865 Result
: Node_Or_Entity_Id
;
9867 -- Start of processing for Get_Discriminant_Value
9870 -- ??? this routine is a gigantic mess and will be deleted.
9871 -- for the time being just test for the trivial case before calling
9874 if Base_Type
(Scope
(Discriminant
)) = Base_Type
(Typ_For_Constraint
) then
9876 D
: Entity_Id
:= First_Discriminant
(Typ_For_Constraint
);
9877 E
: Elmt_Id
:= First_Elmt
(Constraint
);
9879 while Present
(D
) loop
9880 if Chars
(D
) = Chars
(Discriminant
) then
9884 Next_Discriminant
(D
);
9890 Result
:= Recurse
(Typ_For_Constraint
, Constraint
, False);
9892 -- ??? hack to disappear when this routine is gone
9894 if Nkind
(Result
) = N_Defining_Identifier
then
9896 D
: Entity_Id
:= First_Discriminant
(Typ_For_Constraint
);
9897 E
: Elmt_Id
:= First_Elmt
(Constraint
);
9899 while Present
(D
) loop
9900 if Corresponding_Discriminant
(D
) = Discriminant
then
9904 Next_Discriminant
(D
);
9910 pragma Assert
(Nkind
(Result
) /= N_Defining_Identifier
);
9912 end Get_Discriminant_Value
;
9914 --------------------------
9915 -- Has_Range_Constraint --
9916 --------------------------
9918 function Has_Range_Constraint
(N
: Node_Id
) return Boolean is
9919 C
: constant Node_Id
:= Constraint
(N
);
9922 if Nkind
(C
) = N_Range_Constraint
then
9925 elsif Nkind
(C
) = N_Digits_Constraint
then
9927 Is_Decimal_Fixed_Point_Type
(Entity
(Subtype_Mark
(N
)))
9929 Present
(Range_Constraint
(C
));
9931 elsif Nkind
(C
) = N_Delta_Constraint
then
9932 return Present
(Range_Constraint
(C
));
9937 end Has_Range_Constraint
;
9939 ------------------------
9940 -- Inherit_Components --
9941 ------------------------
9943 function Inherit_Components
9945 Parent_Base
: Entity_Id
;
9946 Derived_Base
: Entity_Id
;
9947 Is_Tagged
: Boolean;
9948 Inherit_Discr
: Boolean;
9952 Assoc_List
: Elist_Id
:= New_Elmt_List
;
9954 procedure Inherit_Component
9956 Plain_Discrim
: Boolean := False;
9957 Girder_Discrim
: Boolean := False);
9958 -- Inherits component Old_C from Parent_Base to the Derived_Base.
9959 -- If Plain_Discrim is True, Old_C is a discriminant.
9960 -- If Girder_Discrim is True, Old_C is a girder discriminant.
9961 -- If they are both false then Old_C is a regular component.
9963 -----------------------
9964 -- Inherit_Component --
9965 -----------------------
9967 procedure Inherit_Component
9969 Plain_Discrim
: Boolean := False;
9970 Girder_Discrim
: Boolean := False)
9972 New_C
: Entity_Id
:= New_Copy
(Old_C
);
9974 Discrim
: Entity_Id
;
9975 Corr_Discrim
: Entity_Id
;
9978 pragma Assert
(not Is_Tagged
or else not Girder_Discrim
);
9980 Set_Parent
(New_C
, Parent
(Old_C
));
9982 -- Regular discriminants and components must be inserted
9983 -- in the scope of the Derived_Base. Do it here.
9985 if not Girder_Discrim
then
9989 -- For tagged types the Original_Record_Component must point to
9990 -- whatever this field was pointing to in the parent type. This has
9991 -- already been achieved by the call to New_Copy above.
9993 if not Is_Tagged
then
9994 Set_Original_Record_Component
(New_C
, New_C
);
9997 -- If we have inherited a component then see if its Etype contains
9998 -- references to Parent_Base discriminants. In this case, replace
9999 -- these references with the constraints given in Discs. We do not
10000 -- do this for the partial view of private types because this is
10001 -- not needed (only the components of the full view will be used
10002 -- for code generation) and cause problem. We also avoid this
10003 -- transformation in some error situations.
10005 if Ekind
(New_C
) = E_Component
then
10006 if (Is_Private_Type
(Derived_Base
)
10007 and then not Is_Generic_Type
(Derived_Base
))
10008 or else (Is_Empty_Elmt_List
(Discs
)
10009 and then not Expander_Active
)
10011 Set_Etype
(New_C
, Etype
(Old_C
));
10013 Set_Etype
(New_C
, Constrain_Component_Type
(Etype
(Old_C
),
10014 Derived_Base
, N
, Parent_Base
, Discs
));
10018 -- In derived tagged types it is illegal to reference a non
10019 -- discriminant component in the parent type. To catch this, mark
10020 -- these components with an Ekind of E_Void. This will be reset in
10021 -- Record_Type_Definition after processing the record extension of
10022 -- the derived type.
10024 if Is_Tagged
and then Ekind
(New_C
) = E_Component
then
10025 Set_Ekind
(New_C
, E_Void
);
10028 if Plain_Discrim
then
10029 Set_Corresponding_Discriminant
(New_C
, Old_C
);
10030 Build_Discriminal
(New_C
);
10032 -- If we are explicitly inheriting a girder discriminant it will be
10033 -- completely hidden.
10035 elsif Girder_Discrim
then
10036 Set_Corresponding_Discriminant
(New_C
, Empty
);
10037 Set_Discriminal
(New_C
, Empty
);
10038 Set_Is_Completely_Hidden
(New_C
);
10040 -- Set the Original_Record_Component of each discriminant in the
10041 -- derived base to point to the corresponding girder that we just
10044 Discrim
:= First_Discriminant
(Derived_Base
);
10045 while Present
(Discrim
) loop
10046 Corr_Discrim
:= Corresponding_Discriminant
(Discrim
);
10048 -- Corr_Discrimm could be missing in an error situation.
10050 if Present
(Corr_Discrim
)
10051 and then Original_Record_Component
(Corr_Discrim
) = Old_C
10053 Set_Original_Record_Component
(Discrim
, New_C
);
10056 Next_Discriminant
(Discrim
);
10059 Append_Entity
(New_C
, Derived_Base
);
10062 if not Is_Tagged
then
10063 Append_Elmt
(Old_C
, Assoc_List
);
10064 Append_Elmt
(New_C
, Assoc_List
);
10066 end Inherit_Component
;
10068 -- Variables local to Inherit_Components.
10070 Loc
: constant Source_Ptr
:= Sloc
(N
);
10072 Parent_Discrim
: Entity_Id
;
10073 Girder_Discrim
: Entity_Id
;
10076 Component
: Entity_Id
;
10078 -- Start of processing for Inherit_Components
10081 if not Is_Tagged
then
10082 Append_Elmt
(Parent_Base
, Assoc_List
);
10083 Append_Elmt
(Derived_Base
, Assoc_List
);
10086 -- Inherit parent discriminants if needed.
10088 if Inherit_Discr
then
10089 Parent_Discrim
:= First_Discriminant
(Parent_Base
);
10090 while Present
(Parent_Discrim
) loop
10091 Inherit_Component
(Parent_Discrim
, Plain_Discrim
=> True);
10092 Next_Discriminant
(Parent_Discrim
);
10096 -- Create explicit girder discrims for untagged types when necessary.
10098 if not Has_Unknown_Discriminants
(Derived_Base
)
10099 and then Has_Discriminants
(Parent_Base
)
10100 and then not Is_Tagged
10103 or else First_Discriminant
(Parent_Base
) /=
10104 First_Girder_Discriminant
(Parent_Base
))
10106 Girder_Discrim
:= First_Girder_Discriminant
(Parent_Base
);
10107 while Present
(Girder_Discrim
) loop
10108 Inherit_Component
(Girder_Discrim
, Girder_Discrim
=> True);
10109 Next_Girder_Discriminant
(Girder_Discrim
);
10113 -- See if we can apply the second transformation for derived types, as
10114 -- explained in point 6. in the comments above Build_Derived_Record_Type
10115 -- This is achieved by appending Derived_Base discriminants into
10116 -- Discs, which has the side effect of returning a non empty Discs
10117 -- list to the caller of Inherit_Components, which is what we want.
10120 and then Is_Empty_Elmt_List
(Discs
)
10121 and then (not Is_Private_Type
(Derived_Base
)
10122 or Is_Generic_Type
(Derived_Base
))
10124 D
:= First_Discriminant
(Derived_Base
);
10125 while Present
(D
) loop
10126 Append_Elmt
(New_Reference_To
(D
, Loc
), Discs
);
10127 Next_Discriminant
(D
);
10131 -- Finally, inherit non-discriminant components unless they are not
10132 -- visible because defined or inherited from the full view of the
10133 -- parent. Don't inherit the _parent field of the parent type.
10135 Component
:= First_Entity
(Parent_Base
);
10136 while Present
(Component
) loop
10137 if Ekind
(Component
) /= E_Component
10138 or else Chars
(Component
) = Name_uParent
10142 -- If the derived type is within the parent type's declarative
10143 -- region, then the components can still be inherited even though
10144 -- they aren't visible at this point. This can occur for cases
10145 -- such as within public child units where the components must
10146 -- become visible upon entering the child unit's private part.
10148 elsif not Is_Visible_Component
(Component
)
10149 and then not In_Open_Scopes
(Scope
(Parent_Base
))
10153 elsif Ekind
(Derived_Base
) = E_Private_Type
10154 or else Ekind
(Derived_Base
) = E_Limited_Private_Type
10159 Inherit_Component
(Component
);
10162 Next_Entity
(Component
);
10165 -- For tagged derived types, inherited discriminants cannot be used in
10166 -- component declarations of the record extension part. To achieve this
10167 -- we mark the inherited discriminants as not visible.
10169 if Is_Tagged
and then Inherit_Discr
then
10170 D
:= First_Discriminant
(Derived_Base
);
10171 while Present
(D
) loop
10172 Set_Is_Immediately_Visible
(D
, False);
10173 Next_Discriminant
(D
);
10178 end Inherit_Components
;
10180 ------------------------------
10181 -- Is_Valid_Constraint_Kind --
10182 ------------------------------
10184 function Is_Valid_Constraint_Kind
10185 (T_Kind
: Type_Kind
;
10186 Constraint_Kind
: Node_Kind
)
10192 when Enumeration_Kind |
10194 return Constraint_Kind
= N_Range_Constraint
;
10196 when Decimal_Fixed_Point_Kind
=>
10198 Constraint_Kind
= N_Digits_Constraint
10200 Constraint_Kind
= N_Range_Constraint
;
10202 when Ordinary_Fixed_Point_Kind
=>
10204 Constraint_Kind
= N_Delta_Constraint
10206 Constraint_Kind
= N_Range_Constraint
;
10210 Constraint_Kind
= N_Digits_Constraint
10212 Constraint_Kind
= N_Range_Constraint
;
10219 E_Incomplete_Type |
10222 return Constraint_Kind
= N_Index_Or_Discriminant_Constraint
;
10225 return True; -- Error will be detected later.
10228 end Is_Valid_Constraint_Kind
;
10230 --------------------------
10231 -- Is_Visible_Component --
10232 --------------------------
10234 function Is_Visible_Component
(C
: Entity_Id
) return Boolean is
10235 Original_Comp
: constant Entity_Id
:= Original_Record_Component
(C
);
10236 Original_Scope
: Entity_Id
;
10239 if No
(Original_Comp
) then
10241 -- Premature usage, or previous error
10246 Original_Scope
:= Scope
(Original_Comp
);
10249 -- This test only concern tagged types
10251 if not Is_Tagged_Type
(Original_Scope
) then
10254 -- If it is _Parent or _Tag, there is no visiblity issue
10256 elsif not Comes_From_Source
(Original_Comp
) then
10259 -- If we are in the body of an instantiation, the component is
10260 -- visible even when the parent type (possibly defined in an
10261 -- enclosing unit or in a parent unit) might not.
10263 elsif In_Instance_Body
then
10266 -- Discriminants are always visible.
10268 elsif Ekind
(Original_Comp
) = E_Discriminant
10269 and then not Has_Unknown_Discriminants
(Original_Scope
)
10273 -- If the component has been declared in an ancestor which is
10274 -- currently a private type, then it is not visible. The same
10275 -- applies if the component's containing type is not in an
10276 -- open scope and the original component's enclosing type
10277 -- is a visible full type of a private type (which can occur
10278 -- in cases where an attempt is being made to reference a
10279 -- component in a sibling package that is inherited from
10280 -- a visible component of a type in an ancestor package;
10281 -- the component in the sibling package should not be
10282 -- visible even though the component it inherited from
10283 -- is visible). This does not apply however in the case
10284 -- where the scope of the type is a private child unit.
10285 -- The latter suppression of visibility is needed for cases
10286 -- that are tested in B730006.
10288 elsif (Ekind
(Original_Comp
) /= E_Discriminant
10289 or else Has_Unknown_Discriminants
(Original_Scope
))
10291 (Is_Private_Type
(Original_Scope
)
10293 (not Is_Private_Descendant
(Scope
(Base_Type
(Scope
(C
))))
10294 and then not In_Open_Scopes
(Scope
(Base_Type
(Scope
(C
))))
10295 and then Has_Private_Declaration
(Original_Scope
)))
10299 -- There is another weird way in which a component may be invisible
10300 -- when the private and the full view are not derived from the same
10301 -- ancestor. Here is an example :
10303 -- type A1 is tagged record F1 : integer; end record;
10304 -- type A2 is new A1 with record F2 : integer; end record;
10305 -- type T is new A1 with private;
10307 -- type T is new A2 with private;
10309 -- In this case, the full view of T inherits F1 and F2 but the
10310 -- private view inherits only F1
10314 Ancestor
: Entity_Id
:= Scope
(C
);
10318 if Ancestor
= Original_Scope
then
10320 elsif Ancestor
= Etype
(Ancestor
) then
10324 Ancestor
:= Etype
(Ancestor
);
10330 end Is_Visible_Component
;
10332 --------------------------
10333 -- Make_Class_Wide_Type --
10334 --------------------------
10336 procedure Make_Class_Wide_Type
(T
: Entity_Id
) is
10337 CW_Type
: Entity_Id
;
10339 Next_E
: Entity_Id
;
10342 -- The class wide type can have been defined by the partial view in
10343 -- which case everything is already done
10345 if Present
(Class_Wide_Type
(T
)) then
10350 New_External_Entity
(E_Void
, Scope
(T
), Sloc
(T
), T
, 'C', 0, 'T');
10352 -- Inherit root type characteristics
10354 CW_Name
:= Chars
(CW_Type
);
10355 Next_E
:= Next_Entity
(CW_Type
);
10356 Copy_Node
(T
, CW_Type
);
10357 Set_Comes_From_Source
(CW_Type
, False);
10358 Set_Chars
(CW_Type
, CW_Name
);
10359 Set_Parent
(CW_Type
, Parent
(T
));
10360 Set_Next_Entity
(CW_Type
, Next_E
);
10361 Set_Has_Delayed_Freeze
(CW_Type
);
10363 -- Customize the class-wide type: It has no prim. op., it cannot be
10364 -- abstract and its Etype points back to the specific root type.
10366 Set_Ekind
(CW_Type
, E_Class_Wide_Type
);
10367 Set_Is_Tagged_Type
(CW_Type
, True);
10368 Set_Primitive_Operations
(CW_Type
, New_Elmt_List
);
10369 Set_Is_Abstract
(CW_Type
, False);
10370 Set_Is_Constrained
(CW_Type
, False);
10371 Set_Is_First_Subtype
(CW_Type
, Is_First_Subtype
(T
));
10372 Init_Size_Align
(CW_Type
);
10374 if Ekind
(T
) = E_Class_Wide_Subtype
then
10375 Set_Etype
(CW_Type
, Etype
(Base_Type
(T
)));
10377 Set_Etype
(CW_Type
, T
);
10380 -- If this is the class_wide type of a constrained subtype, it does
10381 -- not have discriminants.
10383 Set_Has_Discriminants
(CW_Type
,
10384 Has_Discriminants
(T
) and then not Is_Constrained
(T
));
10386 Set_Has_Unknown_Discriminants
(CW_Type
, True);
10387 Set_Class_Wide_Type
(T
, CW_Type
);
10388 Set_Equivalent_Type
(CW_Type
, Empty
);
10390 -- The class-wide type of a class-wide type is itself (RM 3.9(14))
10392 Set_Class_Wide_Type
(CW_Type
, CW_Type
);
10394 end Make_Class_Wide_Type
;
10400 procedure Make_Index
10402 Related_Nod
: Node_Id
;
10403 Related_Id
: Entity_Id
:= Empty
;
10404 Suffix_Index
: Nat
:= 1)
10408 Def_Id
: Entity_Id
:= Empty
;
10409 Found
: Boolean := False;
10412 -- For a discrete range used in a constrained array definition and
10413 -- defined by a range, an implicit conversion to the predefined type
10414 -- INTEGER is assumed if each bound is either a numeric literal, a named
10415 -- number, or an attribute, and the type of both bounds (prior to the
10416 -- implicit conversion) is the type universal_integer. Otherwise, both
10417 -- bounds must be of the same discrete type, other than universal
10418 -- integer; this type must be determinable independently of the
10419 -- context, but using the fact that the type must be discrete and that
10420 -- both bounds must have the same type.
10422 -- Character literals also have a universal type in the absence of
10423 -- of additional context, and are resolved to Standard_Character.
10425 if Nkind
(I
) = N_Range
then
10427 -- The index is given by a range constraint. The bounds are known
10428 -- to be of a consistent type.
10430 if not Is_Overloaded
(I
) then
10433 -- If the bounds are universal, choose the specific predefined
10436 if T
= Universal_Integer
then
10437 T
:= Standard_Integer
;
10439 elsif T
= Any_Character
then
10443 ("ambiguous character literals (could be Wide_Character)",
10447 T
:= Standard_Character
;
10454 Ind
: Interp_Index
;
10458 Get_First_Interp
(I
, Ind
, It
);
10460 while Present
(It
.Typ
) loop
10461 if Is_Discrete_Type
(It
.Typ
) then
10464 and then not Covers
(It
.Typ
, T
)
10465 and then not Covers
(T
, It
.Typ
)
10467 Error_Msg_N
("ambiguous bounds in discrete range", I
);
10475 Get_Next_Interp
(Ind
, It
);
10478 if T
= Any_Type
then
10479 Error_Msg_N
("discrete type required for range", I
);
10480 Set_Etype
(I
, Any_Type
);
10483 elsif T
= Universal_Integer
then
10484 T
:= Standard_Integer
;
10489 if not Is_Discrete_Type
(T
) then
10490 Error_Msg_N
("discrete type required for range", I
);
10491 Set_Etype
(I
, Any_Type
);
10496 Process_Range_Expr_In_Decl
(R
, T
);
10498 elsif Nkind
(I
) = N_Subtype_Indication
then
10500 -- The index is given by a subtype with a range constraint.
10502 T
:= Base_Type
(Entity
(Subtype_Mark
(I
)));
10504 if not Is_Discrete_Type
(T
) then
10505 Error_Msg_N
("discrete type required for range", I
);
10506 Set_Etype
(I
, Any_Type
);
10510 R
:= Range_Expression
(Constraint
(I
));
10513 Process_Range_Expr_In_Decl
(R
, Entity
(Subtype_Mark
(I
)));
10515 elsif Nkind
(I
) = N_Attribute_Reference
then
10517 -- The parser guarantees that the attribute is a RANGE attribute
10519 Analyze_And_Resolve
(I
);
10523 -- If none of the above, must be a subtype. We convert this to a
10524 -- range attribute reference because in the case of declared first
10525 -- named subtypes, the types in the range reference can be different
10526 -- from the type of the entity. A range attribute normalizes the
10527 -- reference and obtains the correct types for the bounds.
10529 -- This transformation is in the nature of an expansion, is only
10530 -- done if expansion is active. In particular, it is not done on
10531 -- formal generic types, because we need to retain the name of the
10532 -- original index for instantiation purposes.
10535 if not Is_Entity_Name
(I
) or else not Is_Type
(Entity
(I
)) then
10536 Error_Msg_N
("invalid subtype mark in discrete range ", I
);
10537 Set_Etype
(I
, Any_Integer
);
10540 -- The type mark may be that of an incomplete type. It is only
10541 -- now that we can get the full view, previous analysis does
10542 -- not look specifically for a type mark.
10544 Set_Entity
(I
, Get_Full_View
(Entity
(I
)));
10545 Set_Etype
(I
, Entity
(I
));
10546 Def_Id
:= Entity
(I
);
10548 if not Is_Discrete_Type
(Def_Id
) then
10549 Error_Msg_N
("discrete type required for index", I
);
10550 Set_Etype
(I
, Any_Type
);
10555 if Expander_Active
then
10557 Make_Attribute_Reference
(Sloc
(I
),
10558 Attribute_Name
=> Name_Range
,
10559 Prefix
=> Relocate_Node
(I
)));
10561 -- The original was a subtype mark that does not freeze. This
10562 -- means that the rewritten version must not freeze either.
10564 Set_Must_Not_Freeze
(I
);
10565 Set_Must_Not_Freeze
(Prefix
(I
));
10567 -- Is order critical??? if so, document why, if not
10568 -- use Analyze_And_Resolve
10576 -- Type is legal, nothing else to construct.
10581 if not Is_Discrete_Type
(T
) then
10582 Error_Msg_N
("discrete type required for range", I
);
10583 Set_Etype
(I
, Any_Type
);
10586 elsif T
= Any_Type
then
10587 Set_Etype
(I
, Any_Type
);
10591 -- We will now create the appropriate Itype to describe the
10592 -- range, but first a check. If we originally had a subtype,
10593 -- then we just label the range with this subtype. Not only
10594 -- is there no need to construct a new subtype, but it is wrong
10595 -- to do so for two reasons:
10597 -- 1. A legality concern, if we have a subtype, it must not
10598 -- freeze, and the Itype would cause freezing incorrectly
10600 -- 2. An efficiency concern, if we created an Itype, it would
10601 -- not be recognized as the same type for the purposes of
10602 -- eliminating checks in some circumstances.
10604 -- We signal this case by setting the subtype entity in Def_Id.
10606 -- It would be nice to also do this optimization for the cases
10607 -- of X'Range and also the explicit range X'First .. X'Last,
10608 -- but that is not done yet (it is just an efficiency concern) ???
10610 if No
(Def_Id
) then
10613 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, 'D', Suffix_Index
);
10614 Set_Etype
(Def_Id
, Base_Type
(T
));
10616 if Is_Signed_Integer_Type
(T
) then
10617 Set_Ekind
(Def_Id
, E_Signed_Integer_Subtype
);
10619 elsif Is_Modular_Integer_Type
(T
) then
10620 Set_Ekind
(Def_Id
, E_Modular_Integer_Subtype
);
10623 Set_Ekind
(Def_Id
, E_Enumeration_Subtype
);
10624 Set_Is_Character_Type
(Def_Id
, Is_Character_Type
(T
));
10627 Set_Size_Info
(Def_Id
, (T
));
10628 Set_RM_Size
(Def_Id
, RM_Size
(T
));
10629 Set_First_Rep_Item
(Def_Id
, First_Rep_Item
(T
));
10631 Set_Scalar_Range
(Def_Id
, R
);
10632 Conditional_Delay
(Def_Id
, T
);
10634 -- In the subtype indication case, if the immediate parent of the
10635 -- new subtype is non-static, then the subtype we create is non-
10636 -- static, even if its bounds are static.
10638 if Nkind
(I
) = N_Subtype_Indication
10639 and then not Is_Static_Subtype
(Entity
(Subtype_Mark
(I
)))
10641 Set_Is_Non_Static_Subtype
(Def_Id
);
10645 -- Final step is to label the index with this constructed type
10647 Set_Etype
(I
, Def_Id
);
10650 ------------------------------
10651 -- Modular_Type_Declaration --
10652 ------------------------------
10654 procedure Modular_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
10655 Mod_Expr
: constant Node_Id
:= Expression
(Def
);
10658 procedure Set_Modular_Size
(Bits
: Int
);
10659 -- Sets RM_Size to Bits, and Esize to normal word size above this
10661 procedure Set_Modular_Size
(Bits
: Int
) is
10663 Set_RM_Size
(T
, UI_From_Int
(Bits
));
10668 elsif Bits
<= 16 then
10669 Init_Esize
(T
, 16);
10671 elsif Bits
<= 32 then
10672 Init_Esize
(T
, 32);
10675 Init_Esize
(T
, System_Max_Binary_Modulus_Power
);
10677 end Set_Modular_Size
;
10679 -- Start of processing for Modular_Type_Declaration
10682 Analyze_And_Resolve
(Mod_Expr
, Any_Integer
);
10684 Set_Ekind
(T
, E_Modular_Integer_Type
);
10685 Init_Alignment
(T
);
10686 Set_Is_Constrained
(T
);
10688 if not Is_OK_Static_Expression
(Mod_Expr
) then
10690 ("non-static expression used for modular type bound", Mod_Expr
);
10691 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
10693 M_Val
:= Expr_Value
(Mod_Expr
);
10697 Error_Msg_N
("modulus value must be positive", Mod_Expr
);
10698 M_Val
:= 2 ** System_Max_Binary_Modulus_Power
;
10701 Set_Modulus
(T
, M_Val
);
10703 -- Create bounds for the modular type based on the modulus given in
10704 -- the type declaration and then analyze and resolve those bounds.
10706 Set_Scalar_Range
(T
,
10707 Make_Range
(Sloc
(Mod_Expr
),
10709 Make_Integer_Literal
(Sloc
(Mod_Expr
), 0),
10711 Make_Integer_Literal
(Sloc
(Mod_Expr
), M_Val
- 1)));
10713 -- Properly analyze the literals for the range. We do this manually
10714 -- because we can't go calling Resolve, since we are resolving these
10715 -- bounds with the type, and this type is certainly not complete yet!
10717 Set_Etype
(Low_Bound
(Scalar_Range
(T
)), T
);
10718 Set_Etype
(High_Bound
(Scalar_Range
(T
)), T
);
10719 Set_Is_Static_Expression
(Low_Bound
(Scalar_Range
(T
)));
10720 Set_Is_Static_Expression
(High_Bound
(Scalar_Range
(T
)));
10722 -- Loop through powers of two to find number of bits required
10724 for Bits
in Int
range 0 .. System_Max_Binary_Modulus_Power
loop
10728 if M_Val
= 2 ** Bits
then
10729 Set_Modular_Size
(Bits
);
10734 elsif M_Val
< 2 ** Bits
then
10735 Set_Non_Binary_Modulus
(T
);
10737 if Bits
> System_Max_Nonbinary_Modulus_Power
then
10738 Error_Msg_Uint_1
:=
10739 UI_From_Int
(System_Max_Nonbinary_Modulus_Power
);
10741 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr
);
10742 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
10746 -- In the non-binary case, set size as per RM 13.3(55).
10748 Set_Modular_Size
(Bits
);
10755 -- If we fall through, then the size exceed System.Max_Binary_Modulus
10756 -- so we just signal an error and set the maximum size.
10758 Error_Msg_Uint_1
:= UI_From_Int
(System_Max_Binary_Modulus_Power
);
10759 Error_Msg_N
("modulus exceeds limit (2 '*'*^)", Mod_Expr
);
10761 Set_Modular_Size
(System_Max_Binary_Modulus_Power
);
10762 Init_Alignment
(T
);
10764 end Modular_Type_Declaration
;
10766 -------------------------
10767 -- New_Binary_Operator --
10768 -------------------------
10770 procedure New_Binary_Operator
(Op_Name
: Name_Id
; Typ
: Entity_Id
) is
10771 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10774 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
;
10775 -- Create abbreviated declaration for the formal of a predefined
10776 -- Operator 'Op' of type 'Typ'
10778 --------------------
10779 -- Make_Op_Formal --
10780 --------------------
10782 function Make_Op_Formal
(Typ
, Op
: Entity_Id
) return Entity_Id
is
10783 Formal
: Entity_Id
;
10786 Formal
:= New_Internal_Entity
(E_In_Parameter
, Op
, Loc
, 'P');
10787 Set_Etype
(Formal
, Typ
);
10788 Set_Mechanism
(Formal
, Default_Mechanism
);
10790 end Make_Op_Formal
;
10792 -- Start of processing for New_Binary_Operator
10795 Op
:= Make_Defining_Operator_Symbol
(Loc
, Op_Name
);
10797 Set_Ekind
(Op
, E_Operator
);
10798 Set_Scope
(Op
, Current_Scope
);
10799 Set_Etype
(Op
, Typ
);
10800 Set_Homonym
(Op
, Get_Name_Entity_Id
(Op_Name
));
10801 Set_Is_Immediately_Visible
(Op
);
10802 Set_Is_Intrinsic_Subprogram
(Op
);
10803 Set_Has_Completion
(Op
);
10804 Append_Entity
(Op
, Current_Scope
);
10806 Set_Name_Entity_Id
(Op_Name
, Op
);
10808 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
10809 Append_Entity
(Make_Op_Formal
(Typ
, Op
), Op
);
10811 end New_Binary_Operator
;
10813 -------------------------------------------
10814 -- Ordinary_Fixed_Point_Type_Declaration --
10815 -------------------------------------------
10817 procedure Ordinary_Fixed_Point_Type_Declaration
10821 Loc
: constant Source_Ptr
:= Sloc
(Def
);
10822 Delta_Expr
: constant Node_Id
:= Delta_Expression
(Def
);
10823 RRS
: constant Node_Id
:= Real_Range_Specification
(Def
);
10824 Implicit_Base
: Entity_Id
;
10831 Check_Restriction
(No_Fixed_Point
, Def
);
10833 -- Create implicit base type
10836 Create_Itype
(E_Ordinary_Fixed_Point_Type
, Parent
(Def
), T
, 'B');
10837 Set_Etype
(Implicit_Base
, Implicit_Base
);
10839 -- Analyze and process delta expression
10841 Analyze_And_Resolve
(Delta_Expr
, Any_Real
);
10843 Check_Delta_Expression
(Delta_Expr
);
10844 Delta_Val
:= Expr_Value_R
(Delta_Expr
);
10846 Set_Delta_Value
(Implicit_Base
, Delta_Val
);
10848 -- Compute default small from given delta, which is the largest
10849 -- power of two that does not exceed the given delta value.
10852 Tmp
: Ureal
:= Ureal_1
;
10856 if Delta_Val
< Ureal_1
then
10857 while Delta_Val
< Tmp
loop
10858 Tmp
:= Tmp
/ Ureal_2
;
10859 Scale
:= Scale
+ 1;
10864 Tmp
:= Tmp
* Ureal_2
;
10865 exit when Tmp
> Delta_Val
;
10866 Scale
:= Scale
- 1;
10870 Small_Val
:= UR_From_Components
(Uint_1
, UI_From_Int
(Scale
), 2);
10873 Set_Small_Value
(Implicit_Base
, Small_Val
);
10875 -- If no range was given, set a dummy range
10877 if RRS
<= Empty_Or_Error
then
10878 Low_Val
:= -Small_Val
;
10879 High_Val
:= Small_Val
;
10881 -- Otherwise analyze and process given range
10885 Low
: constant Node_Id
:= Low_Bound
(RRS
);
10886 High
: constant Node_Id
:= High_Bound
(RRS
);
10889 Analyze_And_Resolve
(Low
, Any_Real
);
10890 Analyze_And_Resolve
(High
, Any_Real
);
10891 Check_Real_Bound
(Low
);
10892 Check_Real_Bound
(High
);
10894 -- Obtain and set the range
10896 Low_Val
:= Expr_Value_R
(Low
);
10897 High_Val
:= Expr_Value_R
(High
);
10899 if Low_Val
> High_Val
then
10900 Error_Msg_NE
("?fixed point type& has null range", Def
, T
);
10905 -- The range for both the implicit base and the declared first
10906 -- subtype cannot be set yet, so we use the special routine
10907 -- Set_Fixed_Range to set a temporary range in place. Note that
10908 -- the bounds of the base type will be widened to be symmetrical
10909 -- and to fill the available bits when the type is frozen.
10911 -- We could do this with all discrete types, and probably should, but
10912 -- we absolutely have to do it for fixed-point, since the end-points
10913 -- of the range and the size are determined by the small value, which
10914 -- could be reset before the freeze point.
10916 Set_Fixed_Range
(Implicit_Base
, Loc
, Low_Val
, High_Val
);
10917 Set_Fixed_Range
(T
, Loc
, Low_Val
, High_Val
);
10919 Init_Size_Align
(Implicit_Base
);
10921 -- Complete definition of first subtype
10923 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
10924 Set_Etype
(T
, Implicit_Base
);
10925 Init_Size_Align
(T
);
10926 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
10927 Set_Small_Value
(T
, Small_Val
);
10928 Set_Delta_Value
(T
, Delta_Val
);
10929 Set_Is_Constrained
(T
);
10931 end Ordinary_Fixed_Point_Type_Declaration
;
10933 ----------------------------------------
10934 -- Prepare_Private_Subtype_Completion --
10935 ----------------------------------------
10937 procedure Prepare_Private_Subtype_Completion
10939 Related_Nod
: Node_Id
)
10941 Id_B
: constant Entity_Id
:= Base_Type
(Id
);
10942 Full_B
: constant Entity_Id
:= Full_View
(Id_B
);
10946 if Present
(Full_B
) then
10948 -- The Base_Type is already completed, we can complete the
10949 -- subtype now. We have to create a new entity with the same name,
10950 -- Thus we can't use Create_Itype.
10951 -- This is messy, should be fixed ???
10953 Full
:= Make_Defining_Identifier
(Sloc
(Id
), Chars
(Id
));
10954 Set_Is_Itype
(Full
);
10955 Set_Associated_Node_For_Itype
(Full
, Related_Nod
);
10956 Complete_Private_Subtype
(Id
, Full
, Full_B
, Related_Nod
);
10959 -- The parent subtype may be private, but the base might not, in some
10960 -- nested instances. In that case, the subtype does not need to be
10961 -- exchanged. It would still be nice to make private subtypes and their
10962 -- bases consistent at all times ???
10964 if Is_Private_Type
(Id_B
) then
10965 Append_Elmt
(Id
, Private_Dependents
(Id_B
));
10968 end Prepare_Private_Subtype_Completion
;
10970 ---------------------------
10971 -- Process_Discriminants --
10972 ---------------------------
10974 procedure Process_Discriminants
(N
: Node_Id
) is
10977 Discr_Number
: Uint
;
10978 Discr_Type
: Entity_Id
;
10979 Default_Present
: Boolean := False;
10980 Default_Not_Present
: Boolean := False;
10981 Elist
: Elist_Id
:= New_Elmt_List
;
10984 -- A composite type other than an array type can have discriminants.
10985 -- Discriminants of non-limited types must have a discrete type.
10986 -- On entry, the current scope is the composite type.
10988 -- The discriminants are initially entered into the scope of the type
10989 -- via Enter_Name with the default Ekind of E_Void to prevent premature
10990 -- use, as explained at the end of this procedure.
10992 Discr
:= First
(Discriminant_Specifications
(N
));
10993 while Present
(Discr
) loop
10994 Enter_Name
(Defining_Identifier
(Discr
));
10996 if Nkind
(Discriminant_Type
(Discr
)) = N_Access_Definition
then
10997 Discr_Type
:= Access_Definition
(N
, Discriminant_Type
(Discr
));
11000 Find_Type
(Discriminant_Type
(Discr
));
11001 Discr_Type
:= Etype
(Discriminant_Type
(Discr
));
11003 if Error_Posted
(Discriminant_Type
(Discr
)) then
11004 Discr_Type
:= Any_Type
;
11008 if Is_Access_Type
(Discr_Type
) then
11009 Check_Access_Discriminant_Requires_Limited
11010 (Discr
, Discriminant_Type
(Discr
));
11012 if Ada_83
and then Comes_From_Source
(Discr
) then
11014 ("(Ada 83) access discriminant not allowed", Discr
);
11017 elsif not Is_Discrete_Type
(Discr_Type
) then
11018 Error_Msg_N
("discriminants must have a discrete or access type",
11019 Discriminant_Type
(Discr
));
11022 Set_Etype
(Defining_Identifier
(Discr
), Discr_Type
);
11024 -- If a discriminant specification includes the assignment compound
11025 -- delimiter followed by an expression, the expression is the default
11026 -- expression of the discriminant; the default expression must be of
11027 -- the type of the discriminant. (RM 3.7.1) Since this expression is
11028 -- a default expression, we do the special preanalysis, since this
11029 -- expression does not freeze (see "Handling of Default Expressions"
11030 -- in spec of package Sem).
11032 if Present
(Expression
(Discr
)) then
11033 Analyze_Default_Expression
(Expression
(Discr
), Discr_Type
);
11035 if Nkind
(N
) = N_Formal_Type_Declaration
then
11037 ("discriminant defaults not allowed for formal type",
11038 Expression
(Discr
));
11040 elsif Is_Tagged_Type
(Current_Scope
) then
11042 ("discriminants of tagged type cannot have defaults",
11043 Expression
(Discr
));
11046 Default_Present
:= True;
11047 Append_Elmt
(Expression
(Discr
), Elist
);
11049 -- Tag the defining identifiers for the discriminants with
11050 -- their corresponding default expressions from the tree.
11052 Set_Discriminant_Default_Value
11053 (Defining_Identifier
(Discr
), Expression
(Discr
));
11057 Default_Not_Present
:= True;
11063 -- An element list consisting of the default expressions of the
11064 -- discriminants is constructed in the above loop and used to set
11065 -- the Discriminant_Constraint attribute for the type. If an object
11066 -- is declared of this (record or task) type without any explicit
11067 -- discriminant constraint given, this element list will form the
11068 -- actual parameters for the corresponding initialization procedure
11071 Set_Discriminant_Constraint
(Current_Scope
, Elist
);
11072 Set_Girder_Constraint
(Current_Scope
, No_Elist
);
11074 -- Default expressions must be provided either for all or for none
11075 -- of the discriminants of a discriminant part. (RM 3.7.1)
11077 if Default_Present
and then Default_Not_Present
then
11079 ("incomplete specification of defaults for discriminants", N
);
11082 -- The use of the name of a discriminant is not allowed in default
11083 -- expressions of a discriminant part if the specification of the
11084 -- discriminant is itself given in the discriminant part. (RM 3.7.1)
11086 -- To detect this, the discriminant names are entered initially with an
11087 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
11088 -- attempt to use a void entity (for example in an expression that is
11089 -- type-checked) produces the error message: premature usage. Now after
11090 -- completing the semantic analysis of the discriminant part, we can set
11091 -- the Ekind of all the discriminants appropriately.
11093 Discr
:= First
(Discriminant_Specifications
(N
));
11094 Discr_Number
:= Uint_1
;
11096 while Present
(Discr
) loop
11097 Id
:= Defining_Identifier
(Discr
);
11098 Set_Ekind
(Id
, E_Discriminant
);
11099 Init_Component_Location
(Id
);
11101 Set_Discriminant_Number
(Id
, Discr_Number
);
11103 -- Make sure this is always set, even in illegal programs
11105 Set_Corresponding_Discriminant
(Id
, Empty
);
11107 -- Initialize the Original_Record_Component to the entity itself.
11108 -- Inherit_Components will propagate the right value to
11109 -- discriminants in derived record types.
11111 Set_Original_Record_Component
(Id
, Id
);
11113 -- Create the discriminal for the discriminant.
11115 Build_Discriminal
(Id
);
11118 Discr_Number
:= Discr_Number
+ 1;
11121 Set_Has_Discriminants
(Current_Scope
);
11122 end Process_Discriminants
;
11124 -----------------------
11125 -- Process_Full_View --
11126 -----------------------
11128 procedure Process_Full_View
(N
: Node_Id
; Full_T
, Priv_T
: Entity_Id
) is
11129 Priv_Parent
: Entity_Id
;
11130 Full_Parent
: Entity_Id
;
11131 Full_Indic
: Node_Id
;
11134 -- First some sanity checks that must be done after semantic
11135 -- decoration of the full view and thus cannot be placed with other
11136 -- similar checks in Find_Type_Name
11138 if not Is_Limited_Type
(Priv_T
)
11139 and then (Is_Limited_Type
(Full_T
)
11140 or else Is_Limited_Composite
(Full_T
))
11143 ("completion of nonlimited type cannot be limited", Full_T
);
11145 elsif Is_Abstract
(Full_T
) and then not Is_Abstract
(Priv_T
) then
11147 ("completion of nonabstract type cannot be abstract", Full_T
);
11149 elsif Is_Tagged_Type
(Priv_T
)
11150 and then Is_Limited_Type
(Priv_T
)
11151 and then not Is_Limited_Type
(Full_T
)
11153 -- GNAT allow its own definition of Limited_Controlled to disobey
11154 -- this rule in order in ease the implementation. The next test is
11155 -- safe because Root_Controlled is defined in a private system child
11157 if Etype
(Full_T
) = Full_View
(RTE
(RE_Root_Controlled
)) then
11158 Set_Is_Limited_Composite
(Full_T
);
11161 ("completion of limited tagged type must be limited", Full_T
);
11164 elsif Is_Generic_Type
(Priv_T
) then
11165 Error_Msg_N
("generic type cannot have a completion", Full_T
);
11168 if Is_Tagged_Type
(Priv_T
)
11169 and then Nkind
(Parent
(Priv_T
)) = N_Private_Extension_Declaration
11170 and then Is_Derived_Type
(Full_T
)
11172 Priv_Parent
:= Etype
(Priv_T
);
11174 -- The full view of a private extension may have been transformed
11175 -- into an unconstrained derived type declaration and a subtype
11176 -- declaration (see build_derived_record_type for details).
11178 if Nkind
(N
) = N_Subtype_Declaration
then
11179 Full_Indic
:= Subtype_Indication
(N
);
11180 Full_Parent
:= Etype
(Base_Type
(Full_T
));
11182 Full_Indic
:= Subtype_Indication
(Type_Definition
(N
));
11183 Full_Parent
:= Etype
(Full_T
);
11186 -- Check that the parent type of the full type is a descendant of
11187 -- the ancestor subtype given in the private extension. If either
11188 -- entity has an Etype equal to Any_Type then we had some previous
11189 -- error situation [7.3(8)].
11191 if Priv_Parent
= Any_Type
or else Full_Parent
= Any_Type
then
11194 elsif not Is_Ancestor
(Base_Type
(Priv_Parent
), Full_Parent
) then
11196 ("parent of full type must descend from parent"
11197 & " of private extension", Full_Indic
);
11199 -- Check the rules of 7.3(10): if the private extension inherits
11200 -- known discriminants, then the full type must also inherit those
11201 -- discriminants from the same (ancestor) type, and the parent
11202 -- subtype of the full type must be constrained if and only if
11203 -- the ancestor subtype of the private extension is constrained.
11205 elsif not Present
(Discriminant_Specifications
(Parent
(Priv_T
)))
11206 and then not Has_Unknown_Discriminants
(Priv_T
)
11207 and then Has_Discriminants
(Base_Type
(Priv_Parent
))
11210 Priv_Indic
: constant Node_Id
:=
11211 Subtype_Indication
(Parent
(Priv_T
));
11213 Priv_Constr
: constant Boolean :=
11214 Is_Constrained
(Priv_Parent
)
11216 Nkind
(Priv_Indic
) = N_Subtype_Indication
11217 or else Is_Constrained
(Entity
(Priv_Indic
));
11219 Full_Constr
: constant Boolean :=
11220 Is_Constrained
(Full_Parent
)
11222 Nkind
(Full_Indic
) = N_Subtype_Indication
11223 or else Is_Constrained
(Entity
(Full_Indic
));
11225 Priv_Discr
: Entity_Id
;
11226 Full_Discr
: Entity_Id
;
11229 Priv_Discr
:= First_Discriminant
(Priv_Parent
);
11230 Full_Discr
:= First_Discriminant
(Full_Parent
);
11232 while Present
(Priv_Discr
) and then Present
(Full_Discr
) loop
11233 if Original_Record_Component
(Priv_Discr
) =
11234 Original_Record_Component
(Full_Discr
)
11236 Corresponding_Discriminant
(Priv_Discr
) =
11237 Corresponding_Discriminant
(Full_Discr
)
11244 Next_Discriminant
(Priv_Discr
);
11245 Next_Discriminant
(Full_Discr
);
11248 if Present
(Priv_Discr
) or else Present
(Full_Discr
) then
11250 ("full view must inherit discriminants of the parent type"
11251 & " used in the private extension", Full_Indic
);
11253 elsif Priv_Constr
and then not Full_Constr
then
11255 ("parent subtype of full type must be constrained",
11258 elsif Full_Constr
and then not Priv_Constr
then
11260 ("parent subtype of full type must be unconstrained",
11265 -- Check the rules of 7.3(12): if a partial view has neither known
11266 -- or unknown discriminants, then the full type declaration shall
11267 -- define a definite subtype.
11269 elsif not Has_Unknown_Discriminants
(Priv_T
)
11270 and then not Has_Discriminants
(Priv_T
)
11271 and then not Is_Constrained
(Full_T
)
11274 ("full view must define a constrained type if partial view"
11275 & " has no discriminants", Full_T
);
11278 -- ??????? Do we implement the following properly ?????
11279 -- If the ancestor subtype of a private extension has constrained
11280 -- discriminants, then the parent subtype of the full view shall
11281 -- impose a statically matching constraint on those discriminants
11285 -- For untagged types, verify that a type without discriminants
11286 -- is not completed with an unconstrained type.
11288 if not Is_Indefinite_Subtype
(Priv_T
)
11289 and then Is_Indefinite_Subtype
(Full_T
)
11291 Error_Msg_N
("full view of type must be definite subtype", Full_T
);
11295 -- Create a full declaration for all its subtypes recorded in
11296 -- Private_Dependents and swap them similarly to the base type.
11297 -- These are subtypes that have been define before the full
11298 -- declaration of the private type. We also swap the entry in
11299 -- Private_Dependents list so we can properly restore the
11300 -- private view on exit from the scope.
11303 Priv_Elmt
: Elmt_Id
;
11308 Priv_Elmt
:= First_Elmt
(Private_Dependents
(Priv_T
));
11309 while Present
(Priv_Elmt
) loop
11310 Priv
:= Node
(Priv_Elmt
);
11312 if Ekind
(Priv
) = E_Private_Subtype
11313 or else Ekind
(Priv
) = E_Limited_Private_Subtype
11314 or else Ekind
(Priv
) = E_Record_Subtype_With_Private
11316 Full
:= Make_Defining_Identifier
(Sloc
(Priv
), Chars
(Priv
));
11317 Set_Is_Itype
(Full
);
11318 Set_Parent
(Full
, Parent
(Priv
));
11319 Set_Associated_Node_For_Itype
(Full
, N
);
11321 -- Now we need to complete the private subtype, but since the
11322 -- base type has already been swapped, we must also swap the
11323 -- subtypes (and thus, reverse the arguments in the call to
11324 -- Complete_Private_Subtype).
11326 Copy_And_Swap
(Priv
, Full
);
11327 Complete_Private_Subtype
(Full
, Priv
, Full_T
, N
);
11328 Replace_Elmt
(Priv_Elmt
, Full
);
11331 Next_Elmt
(Priv_Elmt
);
11335 -- If the private view was tagged, copy the new Primitive
11336 -- operations from the private view to the full view.
11338 if Is_Tagged_Type
(Full_T
) then
11340 Priv_List
: Elist_Id
;
11341 Full_List
: constant Elist_Id
:= Primitive_Operations
(Full_T
);
11344 D_Type
: Entity_Id
;
11347 if Is_Tagged_Type
(Priv_T
) then
11348 Priv_List
:= Primitive_Operations
(Priv_T
);
11350 P1
:= First_Elmt
(Priv_List
);
11351 while Present
(P1
) loop
11354 -- Transfer explicit primitives, not those inherited from
11355 -- parent of partial view, which will be re-inherited on
11358 if Comes_From_Source
(Prim
) then
11359 P2
:= First_Elmt
(Full_List
);
11360 while Present
(P2
) and then Node
(P2
) /= Prim
loop
11364 -- If not found, that is a new one
11367 Append_Elmt
(Prim
, Full_List
);
11375 -- In this case the partial view is untagged, so here we
11376 -- locate all of the earlier primitives that need to be
11377 -- treated as dispatching (those that appear between the
11378 -- two views). Note that these additional operations must
11379 -- all be new operations (any earlier operations that
11380 -- override inherited operations of the full view will
11381 -- already have been inserted in the primitives list and
11382 -- marked as dispatching by Check_Operation_From_Private_View.
11383 -- Note that implicit "/=" operators are excluded from being
11384 -- added to the primitives list since they shouldn't be
11385 -- treated as dispatching (tagged "/=" is handled specially).
11387 Prim
:= Next_Entity
(Full_T
);
11388 while Present
(Prim
) and then Prim
/= Priv_T
loop
11389 if (Ekind
(Prim
) = E_Procedure
11390 or else Ekind
(Prim
) = E_Function
)
11393 D_Type
:= Find_Dispatching_Type
(Prim
);
11396 and then (Chars
(Prim
) /= Name_Op_Ne
11397 or else Comes_From_Source
(Prim
))
11399 Check_Controlling_Formals
(Full_T
, Prim
);
11401 if not Is_Dispatching_Operation
(Prim
) then
11402 Append_Elmt
(Prim
, Full_List
);
11403 Set_Is_Dispatching_Operation
(Prim
, True);
11404 Set_DT_Position
(Prim
, No_Uint
);
11407 elsif Is_Dispatching_Operation
(Prim
)
11408 and then D_Type
/= Full_T
11411 -- Verify that it is not otherwise controlled by
11412 -- a formal or a return value ot type T.
11414 Check_Controlling_Formals
(D_Type
, Prim
);
11418 Next_Entity
(Prim
);
11422 -- For the tagged case, the two views can share the same
11423 -- Primitive Operation list and the same class wide type.
11424 -- Update attributes of the class-wide type which depend on
11425 -- the full declaration.
11427 if Is_Tagged_Type
(Priv_T
) then
11428 Set_Primitive_Operations
(Priv_T
, Full_List
);
11429 Set_Class_Wide_Type
11430 (Base_Type
(Full_T
), Class_Wide_Type
(Priv_T
));
11432 -- Any other attributes should be propagated to C_W ???
11434 Set_Has_Task
(Class_Wide_Type
(Priv_T
), Has_Task
(Full_T
));
11439 end Process_Full_View
;
11441 -----------------------------------
11442 -- Process_Incomplete_Dependents --
11443 -----------------------------------
11445 procedure Process_Incomplete_Dependents
11447 Full_T
: Entity_Id
;
11450 Inc_Elmt
: Elmt_Id
;
11451 Priv_Dep
: Entity_Id
;
11452 New_Subt
: Entity_Id
;
11454 Disc_Constraint
: Elist_Id
;
11457 if No
(Private_Dependents
(Inc_T
)) then
11461 Inc_Elmt
:= First_Elmt
(Private_Dependents
(Inc_T
));
11463 -- Itypes that may be generated by the completion of an incomplete
11464 -- subtype are not used by the back-end and not attached to the tree.
11465 -- They are created only for constraint-checking purposes.
11468 while Present
(Inc_Elmt
) loop
11469 Priv_Dep
:= Node
(Inc_Elmt
);
11471 if Ekind
(Priv_Dep
) = E_Subprogram_Type
then
11473 -- An Access_To_Subprogram type may have a return type or a
11474 -- parameter type that is incomplete. Replace with the full view.
11476 if Etype
(Priv_Dep
) = Inc_T
then
11477 Set_Etype
(Priv_Dep
, Full_T
);
11481 Formal
: Entity_Id
;
11484 Formal
:= First_Formal
(Priv_Dep
);
11486 while Present
(Formal
) loop
11488 if Etype
(Formal
) = Inc_T
then
11489 Set_Etype
(Formal
, Full_T
);
11492 Next_Formal
(Formal
);
11496 elsif Is_Overloadable
(Priv_Dep
) then
11498 if Is_Tagged_Type
(Full_T
) then
11500 -- Subprogram has an access parameter whose designated type
11501 -- was incomplete. Reexamine declaration now, because it may
11502 -- be a primitive operation of the full type.
11504 Check_Operation_From_Incomplete_Type
(Priv_Dep
, Inc_T
);
11505 Set_Is_Dispatching_Operation
(Priv_Dep
);
11506 Check_Controlling_Formals
(Full_T
, Priv_Dep
);
11509 elsif Ekind
(Priv_Dep
) = E_Subprogram_Body
then
11511 -- Can happen during processing of a body before the completion
11512 -- of a TA type. Ignore, because spec is also on dependent list.
11516 -- Dependent is a subtype
11519 -- We build a new subtype indication using the full view of the
11520 -- incomplete parent. The discriminant constraints have been
11521 -- elaborated already at the point of the subtype declaration.
11523 New_Subt
:= Create_Itype
(E_Void
, N
);
11525 if Has_Discriminants
(Full_T
) then
11526 Disc_Constraint
:= Discriminant_Constraint
(Priv_Dep
);
11528 Disc_Constraint
:= No_Elist
;
11531 Build_Discriminated_Subtype
(Full_T
, New_Subt
, Disc_Constraint
, N
);
11532 Set_Full_View
(Priv_Dep
, New_Subt
);
11535 Next_Elmt
(Inc_Elmt
);
11538 end Process_Incomplete_Dependents
;
11540 --------------------------------
11541 -- Process_Range_Expr_In_Decl --
11542 --------------------------------
11544 procedure Process_Range_Expr_In_Decl
11547 Check_List
: List_Id
:= Empty_List
;
11548 R_Check_Off
: Boolean := False)
11551 R_Checks
: Check_Result
;
11552 Type_Decl
: Node_Id
;
11553 Def_Id
: Entity_Id
;
11556 Analyze_And_Resolve
(R
, Base_Type
(T
));
11558 if Nkind
(R
) = N_Range
then
11559 Lo
:= Low_Bound
(R
);
11560 Hi
:= High_Bound
(R
);
11562 -- If there were errors in the declaration, try and patch up some
11563 -- common mistakes in the bounds. The cases handled are literals
11564 -- which are Integer where the expected type is Real and vice versa.
11565 -- These corrections allow the compilation process to proceed further
11566 -- along since some basic assumptions of the format of the bounds
11569 if Etype
(R
) = Any_Type
then
11571 if Nkind
(Lo
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
11573 Make_Real_Literal
(Sloc
(Lo
), UR_From_Uint
(Intval
(Lo
))));
11575 elsif Nkind
(Hi
) = N_Integer_Literal
and then Is_Real_Type
(T
) then
11577 Make_Real_Literal
(Sloc
(Hi
), UR_From_Uint
(Intval
(Hi
))));
11579 elsif Nkind
(Lo
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
11581 Make_Integer_Literal
(Sloc
(Lo
), UR_To_Uint
(Realval
(Lo
))));
11583 elsif Nkind
(Hi
) = N_Real_Literal
and then Is_Integer_Type
(T
) then
11585 Make_Integer_Literal
(Sloc
(Hi
), UR_To_Uint
(Realval
(Hi
))));
11592 -- If the bounds of the range have been mistakenly given as
11593 -- string literals (perhaps in place of character literals),
11594 -- then an error has already been reported, but we rewrite
11595 -- the string literal as a bound of the range's type to
11596 -- avoid blowups in later processing that looks at static
11599 if Nkind
(Lo
) = N_String_Literal
then
11601 Make_Attribute_Reference
(Sloc
(Lo
),
11602 Attribute_Name
=> Name_First
,
11603 Prefix
=> New_Reference_To
(T
, Sloc
(Lo
))));
11604 Analyze_And_Resolve
(Lo
);
11607 if Nkind
(Hi
) = N_String_Literal
then
11609 Make_Attribute_Reference
(Sloc
(Hi
),
11610 Attribute_Name
=> Name_First
,
11611 Prefix
=> New_Reference_To
(T
, Sloc
(Hi
))));
11612 Analyze_And_Resolve
(Hi
);
11615 -- If bounds aren't scalar at this point then exit, avoiding
11616 -- problems with further processing of the range in this procedure.
11618 if not Is_Scalar_Type
(Etype
(Lo
)) then
11622 -- Resolve (actually Sem_Eval) has checked that the bounds are in
11623 -- then range of the base type. Here we check whether the bounds
11624 -- are in the range of the subtype itself. Note that if the bounds
11625 -- represent the null range the Constraint_Error exception should
11628 -- ??? The following code should be cleaned up as follows
11629 -- 1. The Is_Null_Range (Lo, Hi) test should disapper since it
11630 -- is done in the call to Range_Check (R, T); below
11631 -- 2. The use of R_Check_Off should be investigated and possibly
11632 -- removed, this would clean up things a bit.
11634 if Is_Null_Range
(Lo
, Hi
) then
11638 -- We use a flag here instead of suppressing checks on the
11639 -- type because the type we check against isn't necessarily the
11640 -- place where we put the check.
11642 if not R_Check_Off
then
11643 R_Checks
:= Range_Check
(R
, T
);
11644 Type_Decl
:= Parent
(R
);
11646 -- Look up tree to find an appropriate insertion point.
11647 -- This seems really junk code, and very brittle, couldn't
11648 -- we just use an insert actions call of some kind ???
11650 while Present
(Type_Decl
) and then not
11651 (Nkind
(Type_Decl
) = N_Full_Type_Declaration
11653 Nkind
(Type_Decl
) = N_Subtype_Declaration
11655 Nkind
(Type_Decl
) = N_Loop_Statement
11657 Nkind
(Type_Decl
) = N_Task_Type_Declaration
11659 Nkind
(Type_Decl
) = N_Single_Task_Declaration
11661 Nkind
(Type_Decl
) = N_Protected_Type_Declaration
11663 Nkind
(Type_Decl
) = N_Single_Protected_Declaration
)
11665 Type_Decl
:= Parent
(Type_Decl
);
11668 -- Why would Type_Decl not be present??? Without this test,
11669 -- short regression tests fail.
11671 if Present
(Type_Decl
) then
11672 if Nkind
(Type_Decl
) = N_Loop_Statement
then
11674 Indic
: Node_Id
:= Parent
(R
);
11676 while Present
(Indic
) and then not
11677 (Nkind
(Indic
) = N_Subtype_Indication
)
11679 Indic
:= Parent
(Indic
);
11682 if Present
(Indic
) then
11683 Def_Id
:= Etype
(Subtype_Mark
(Indic
));
11685 Insert_Range_Checks
11691 Do_Before
=> True);
11695 Def_Id
:= Defining_Identifier
(Type_Decl
);
11697 if (Ekind
(Def_Id
) = E_Record_Type
11698 and then Depends_On_Discriminant
(R
))
11700 (Ekind
(Def_Id
) = E_Protected_Type
11701 and then Has_Discriminants
(Def_Id
))
11703 Append_Range_Checks
11704 (R_Checks
, Check_List
, Def_Id
, Sloc
(Type_Decl
), R
);
11707 Insert_Range_Checks
11708 (R_Checks
, Type_Decl
, Def_Id
, Sloc
(Type_Decl
), R
);
11717 Get_Index_Bounds
(R
, Lo
, Hi
);
11719 if Expander_Active
then
11720 Force_Evaluation
(Lo
);
11721 Force_Evaluation
(Hi
);
11724 end Process_Range_Expr_In_Decl
;
11726 --------------------------------------
11727 -- Process_Real_Range_Specification --
11728 --------------------------------------
11730 procedure Process_Real_Range_Specification
(Def
: Node_Id
) is
11731 Spec
: constant Node_Id
:= Real_Range_Specification
(Def
);
11734 Err
: Boolean := False;
11736 procedure Analyze_Bound
(N
: Node_Id
);
11737 -- Analyze and check one bound
11739 procedure Analyze_Bound
(N
: Node_Id
) is
11741 Analyze_And_Resolve
(N
, Any_Real
);
11743 if not Is_OK_Static_Expression
(N
) then
11745 ("bound in real type definition is not static", N
);
11751 if Present
(Spec
) then
11752 Lo
:= Low_Bound
(Spec
);
11753 Hi
:= High_Bound
(Spec
);
11754 Analyze_Bound
(Lo
);
11755 Analyze_Bound
(Hi
);
11757 -- If error, clear away junk range specification
11760 Set_Real_Range_Specification
(Def
, Empty
);
11763 end Process_Real_Range_Specification
;
11765 ---------------------
11766 -- Process_Subtype --
11767 ---------------------
11769 function Process_Subtype
11771 Related_Nod
: Node_Id
;
11772 Related_Id
: Entity_Id
:= Empty
;
11773 Suffix
: Character := ' ')
11777 Def_Id
: Entity_Id
;
11778 Full_View_Id
: Entity_Id
;
11779 Subtype_Mark_Id
: Entity_Id
;
11780 N_Dynamic_Ityp
: Node_Id
:= Empty
;
11783 -- Case of constraint present, so that we have an N_Subtype_Indication
11784 -- node (this node is created only if constraints are present).
11786 if Nkind
(S
) = N_Subtype_Indication
then
11787 Find_Type
(Subtype_Mark
(S
));
11789 if Nkind
(Parent
(S
)) /= N_Access_To_Object_Definition
11791 (Nkind
(Parent
(S
)) = N_Subtype_Declaration
11793 Is_Itype
(Defining_Identifier
(Parent
(S
))))
11795 Check_Incomplete
(Subtype_Mark
(S
));
11799 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
11801 if Is_Unchecked_Union
(Subtype_Mark_Id
)
11802 and then Comes_From_Source
(Related_Nod
)
11805 ("cannot create subtype of Unchecked_Union", Related_Nod
);
11808 -- Explicit subtype declaration case
11810 if Nkind
(P
) = N_Subtype_Declaration
then
11811 Def_Id
:= Defining_Identifier
(P
);
11813 -- Explicit derived type definition case
11815 elsif Nkind
(P
) = N_Derived_Type_Definition
then
11816 Def_Id
:= Defining_Identifier
(Parent
(P
));
11818 -- Implicit case, the Def_Id must be created as an implicit type.
11819 -- The one exception arises in the case of concurrent types,
11820 -- array and access types, where other subsidiary implicit types
11821 -- may be created and must appear before the main implicit type.
11822 -- In these cases we leave Def_Id set to Empty as a signal that
11823 -- Create_Itype has not yet been called to create Def_Id.
11826 if Is_Array_Type
(Subtype_Mark_Id
)
11827 or else Is_Concurrent_Type
(Subtype_Mark_Id
)
11828 or else Is_Access_Type
(Subtype_Mark_Id
)
11832 -- For the other cases, we create a new unattached Itype,
11833 -- and set the indication to ensure it gets attached later.
11837 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
11840 N_Dynamic_Ityp
:= Related_Nod
;
11843 -- If the kind of constraint is invalid for this kind of type,
11844 -- then give an error, and then pretend no constraint was given.
11846 if not Is_Valid_Constraint_Kind
11847 (Ekind
(Subtype_Mark_Id
), Nkind
(Constraint
(S
)))
11850 ("incorrect constraint for this kind of type", Constraint
(S
));
11852 Rewrite
(S
, New_Copy_Tree
(Subtype_Mark
(S
)));
11854 -- Make recursive call, having got rid of the bogus constraint
11856 return Process_Subtype
(S
, Related_Nod
, Related_Id
, Suffix
);
11859 -- Remaining processing depends on type
11861 case Ekind
(Subtype_Mark_Id
) is
11863 when Access_Kind
=>
11864 Constrain_Access
(Def_Id
, S
, Related_Nod
);
11867 Constrain_Array
(Def_Id
, S
, Related_Nod
, Related_Id
, Suffix
);
11869 when Decimal_Fixed_Point_Kind
=>
11870 Constrain_Decimal
(Def_Id
, S
);
11872 when Enumeration_Kind
=>
11873 Constrain_Enumeration
(Def_Id
, S
);
11875 when Ordinary_Fixed_Point_Kind
=>
11876 Constrain_Ordinary_Fixed
(Def_Id
, S
);
11879 Constrain_Float
(Def_Id
, S
);
11881 when Integer_Kind
=>
11882 Constrain_Integer
(Def_Id
, S
);
11884 when E_Record_Type |
11887 E_Incomplete_Type
=>
11888 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
11890 when Private_Kind
=>
11891 Constrain_Discriminated_Type
(Def_Id
, S
, Related_Nod
);
11892 Set_Private_Dependents
(Def_Id
, New_Elmt_List
);
11894 -- In case of an invalid constraint prevent further processing
11895 -- since the type constructed is missing expected fields.
11897 if Etype
(Def_Id
) = Any_Type
then
11901 -- If the full view is that of a task with discriminants,
11902 -- we must constrain both the concurrent type and its
11903 -- corresponding record type. Otherwise we will just propagate
11904 -- the constraint to the full view, if available.
11906 if Present
(Full_View
(Subtype_Mark_Id
))
11907 and then Has_Discriminants
(Subtype_Mark_Id
)
11908 and then Is_Concurrent_Type
(Full_View
(Subtype_Mark_Id
))
11911 Create_Itype
(E_Void
, Related_Nod
, Related_Id
, Suffix
);
11913 Set_Entity
(Subtype_Mark
(S
), Full_View
(Subtype_Mark_Id
));
11914 Constrain_Concurrent
(Full_View_Id
, S
,
11915 Related_Nod
, Related_Id
, Suffix
);
11916 Set_Entity
(Subtype_Mark
(S
), Subtype_Mark_Id
);
11917 Set_Full_View
(Def_Id
, Full_View_Id
);
11920 Prepare_Private_Subtype_Completion
(Def_Id
, Related_Nod
);
11923 when Concurrent_Kind
=>
11924 Constrain_Concurrent
(Def_Id
, S
,
11925 Related_Nod
, Related_Id
, Suffix
);
11928 Error_Msg_N
("invalid subtype mark in subtype indication", S
);
11931 -- Size and Convention are always inherited from the base type
11933 Set_Size_Info
(Def_Id
, (Subtype_Mark_Id
));
11934 Set_Convention
(Def_Id
, Convention
(Subtype_Mark_Id
));
11938 -- Case of no constraints present
11942 Check_Incomplete
(S
);
11945 end Process_Subtype
;
11947 -----------------------------
11948 -- Record_Type_Declaration --
11949 -----------------------------
11951 procedure Record_Type_Declaration
(T
: Entity_Id
; N
: Node_Id
) is
11952 Def
: constant Node_Id
:= Type_Definition
(N
);
11953 Range_Checks_Suppressed_Flag
: Boolean := False;
11955 Is_Tagged
: Boolean;
11956 Tag_Comp
: Entity_Id
;
11959 -- The flag Is_Tagged_Type might have already been set by Find_Type_Name
11960 -- if it detected an error for declaration T. This arises in the case of
11961 -- private tagged types where the full view omits the word tagged.
11963 Is_Tagged
:= Tagged_Present
(Def
)
11964 or else (Serious_Errors_Detected
> 0 and then Is_Tagged_Type
(T
));
11966 -- Records constitute a scope for the component declarations within.
11967 -- The scope is created prior to the processing of these declarations.
11968 -- Discriminants are processed first, so that they are visible when
11969 -- processing the other components. The Ekind of the record type itself
11970 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
11972 -- Enter record scope
11976 -- These flags must be initialized before calling Process_Discriminants
11977 -- because this routine makes use of them.
11979 Set_Is_Tagged_Type
(T
, Is_Tagged
);
11980 Set_Is_Limited_Record
(T
, Limited_Present
(Def
));
11982 -- Type is abstract if full declaration carries keyword, or if
11983 -- previous partial view did.
11985 Set_Is_Abstract
(T
, Is_Abstract
(T
) or else Abstract_Present
(Def
));
11987 Set_Ekind
(T
, E_Record_Type
);
11989 Init_Size_Align
(T
);
11991 Set_Girder_Constraint
(T
, No_Elist
);
11993 -- If an incomplete or private type declaration was already given for
11994 -- the type, then this scope already exists, and the discriminants have
11995 -- been declared within. We must verify that the full declaration
11996 -- matches the incomplete one.
11998 Check_Or_Process_Discriminants
(N
, T
);
12000 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
12001 Set_Has_Delayed_Freeze
(T
, True);
12003 -- For tagged types add a manually analyzed component corresponding
12004 -- to the component _tag, the corresponding piece of tree will be
12005 -- expanded as part of the freezing actions if it is not a CPP_Class.
12008 -- Do not add the tag unless we are in expansion mode.
12010 if Expander_Active
then
12011 Tag_Comp
:= Make_Defining_Identifier
(Sloc
(Def
), Name_uTag
);
12012 Enter_Name
(Tag_Comp
);
12014 Set_Is_Tag
(Tag_Comp
);
12015 Set_Ekind
(Tag_Comp
, E_Component
);
12016 Set_Etype
(Tag_Comp
, RTE
(RE_Tag
));
12017 Set_DT_Entry_Count
(Tag_Comp
, No_Uint
);
12018 Set_Original_Record_Component
(Tag_Comp
, Tag_Comp
);
12019 Init_Component_Location
(Tag_Comp
);
12022 Make_Class_Wide_Type
(T
);
12023 Set_Primitive_Operations
(T
, New_Elmt_List
);
12026 -- We must suppress range checks when processing the components
12027 -- of a record in the presence of discriminants, since we don't
12028 -- want spurious checks to be generated during their analysis, but
12029 -- must reset the Suppress_Range_Checks flags after having procesed
12030 -- the record definition.
12032 if Has_Discriminants
(T
) and then not Suppress_Range_Checks
(T
) then
12033 Set_Suppress_Range_Checks
(T
, True);
12034 Range_Checks_Suppressed_Flag
:= True;
12037 Record_Type_Definition
(Def
, T
);
12039 if Range_Checks_Suppressed_Flag
then
12040 Set_Suppress_Range_Checks
(T
, False);
12041 Range_Checks_Suppressed_Flag
:= False;
12044 -- Exit from record scope
12047 end Record_Type_Declaration
;
12049 ----------------------------
12050 -- Record_Type_Definition --
12051 ----------------------------
12053 procedure Record_Type_Definition
(Def
: Node_Id
; T
: Entity_Id
) is
12054 Component
: Entity_Id
;
12055 Ctrl_Components
: Boolean := False;
12056 Final_Storage_Only
: Boolean := not Is_Controlled
(T
);
12059 -- If the component list of a record type is defined by the reserved
12060 -- word null and there is no discriminant part, then the record type has
12061 -- no components and all records of the type are null records (RM 3.7)
12062 -- This procedure is also called to process the extension part of a
12063 -- record extension, in which case the current scope may have inherited
12067 or else No
(Component_List
(Def
))
12068 or else Null_Present
(Component_List
(Def
))
12073 Analyze_Declarations
(Component_Items
(Component_List
(Def
)));
12075 if Present
(Variant_Part
(Component_List
(Def
))) then
12076 Analyze
(Variant_Part
(Component_List
(Def
)));
12080 -- After completing the semantic analysis of the record definition,
12081 -- record components, both new and inherited, are accessible. Set
12082 -- their kind accordingly.
12084 Component
:= First_Entity
(Current_Scope
);
12085 while Present
(Component
) loop
12087 if Ekind
(Component
) = E_Void
then
12088 Set_Ekind
(Component
, E_Component
);
12089 Init_Component_Location
(Component
);
12092 if Has_Task
(Etype
(Component
)) then
12096 if Ekind
(Component
) /= E_Component
then
12099 elsif Has_Controlled_Component
(Etype
(Component
))
12100 or else (Chars
(Component
) /= Name_uParent
12101 and then Is_Controlled
(Etype
(Component
)))
12103 Set_Has_Controlled_Component
(T
, True);
12104 Final_Storage_Only
:= Final_Storage_Only
12105 and then Finalize_Storage_Only
(Etype
(Component
));
12106 Ctrl_Components
:= True;
12109 Next_Entity
(Component
);
12112 -- A type is Finalize_Storage_Only only if all its controlled
12113 -- components are so.
12115 if Ctrl_Components
then
12116 Set_Finalize_Storage_Only
(T
, Final_Storage_Only
);
12119 if Present
(Def
) then
12120 Process_End_Label
(Def
, 'e', T
);
12122 end Record_Type_Definition
;
12124 ------------------------
12125 -- Replace_Components --
12126 ------------------------
12128 procedure Replace_Components
(Typ
: Entity_Id
; Decl
: Node_Id
) is
12129 function Process
(N
: Node_Id
) return Traverse_Result
;
12135 function Process
(N
: Node_Id
) return Traverse_Result
is
12139 if Nkind
(N
) = N_Discriminant_Specification
then
12140 Comp
:= First_Discriminant
(Typ
);
12142 while Present
(Comp
) loop
12143 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
12144 Set_Defining_Identifier
(N
, Comp
);
12148 Next_Discriminant
(Comp
);
12151 elsif Nkind
(N
) = N_Component_Declaration
then
12152 Comp
:= First_Component
(Typ
);
12154 while Present
(Comp
) loop
12155 if Chars
(Comp
) = Chars
(Defining_Identifier
(N
)) then
12156 Set_Defining_Identifier
(N
, Comp
);
12160 Next_Component
(Comp
);
12167 procedure Replace
is new Traverse_Proc
(Process
);
12169 -- Start of processing for Replace_Components
12173 end Replace_Components
;
12175 -------------------------------
12176 -- Set_Completion_Referenced --
12177 -------------------------------
12179 procedure Set_Completion_Referenced
(E
: Entity_Id
) is
12181 -- If in main unit, mark entity that is a completion as referenced,
12182 -- warnings go on the partial view when needed.
12184 if In_Extended_Main_Source_Unit
(E
) then
12185 Set_Referenced
(E
);
12187 end Set_Completion_Referenced
;
12189 ---------------------
12190 -- Set_Fixed_Range --
12191 ---------------------
12193 -- The range for fixed-point types is complicated by the fact that we
12194 -- do not know the exact end points at the time of the declaration. This
12195 -- is true for three reasons:
12197 -- A size clause may affect the fudging of the end-points
12198 -- A small clause may affect the values of the end-points
12199 -- We try to include the end-points if it does not affect the size
12201 -- This means that the actual end-points must be established at the
12202 -- point when the type is frozen. Meanwhile, we first narrow the range
12203 -- as permitted (so that it will fit if necessary in a small specified
12204 -- size), and then build a range subtree with these narrowed bounds.
12206 -- Set_Fixed_Range constructs the range from real literal values, and
12207 -- sets the range as the Scalar_Range of the given fixed-point type
12210 -- The parent of this range is set to point to the entity so that it
12211 -- is properly hooked into the tree (unlike normal Scalar_Range entries
12212 -- for other scalar types, which are just pointers to the range in the
12213 -- original tree, this would otherwise be an orphan).
12215 -- The tree is left unanalyzed. When the type is frozen, the processing
12216 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not
12217 -- analyzed, and uses this as an indication that it should complete
12218 -- work on the range (it will know the final small and size values).
12220 procedure Set_Fixed_Range
12226 S
: constant Node_Id
:=
12228 Low_Bound
=> Make_Real_Literal
(Loc
, Lo
),
12229 High_Bound
=> Make_Real_Literal
(Loc
, Hi
));
12232 Set_Scalar_Range
(E
, S
);
12234 end Set_Fixed_Range
;
12236 --------------------------------------------------------
12237 -- Set_Girder_Constraint_From_Discriminant_Constraint --
12238 --------------------------------------------------------
12240 procedure Set_Girder_Constraint_From_Discriminant_Constraint
12244 -- Make sure set if encountered during
12245 -- Expand_To_Girder_Constraint
12247 Set_Girder_Constraint
(E
, No_Elist
);
12249 -- Give it the right value
12251 if Is_Constrained
(E
) and then Has_Discriminants
(E
) then
12252 Set_Girder_Constraint
(E
,
12253 Expand_To_Girder_Constraint
(E
, Discriminant_Constraint
(E
)));
12256 end Set_Girder_Constraint_From_Discriminant_Constraint
;
12258 ----------------------------------
12259 -- Set_Scalar_Range_For_Subtype --
12260 ----------------------------------
12262 procedure Set_Scalar_Range_For_Subtype
12263 (Def_Id
: Entity_Id
;
12267 Kind
: constant Entity_Kind
:= Ekind
(Def_Id
);
12269 Set_Scalar_Range
(Def_Id
, R
);
12271 -- We need to link the range into the tree before resolving it so
12272 -- that types that are referenced, including importantly the subtype
12273 -- itself, are properly frozen (Freeze_Expression requires that the
12274 -- expression be properly linked into the tree). Of course if it is
12275 -- already linked in, then we do not disturb the current link.
12277 if No
(Parent
(R
)) then
12278 Set_Parent
(R
, Def_Id
);
12281 -- Reset the kind of the subtype during analysis of the range, to
12282 -- catch possible premature use in the bounds themselves.
12284 Set_Ekind
(Def_Id
, E_Void
);
12285 Process_Range_Expr_In_Decl
(R
, Subt
);
12286 Set_Ekind
(Def_Id
, Kind
);
12288 end Set_Scalar_Range_For_Subtype
;
12290 -------------------------------------
12291 -- Signed_Integer_Type_Declaration --
12292 -------------------------------------
12294 procedure Signed_Integer_Type_Declaration
(T
: Entity_Id
; Def
: Node_Id
) is
12295 Implicit_Base
: Entity_Id
;
12296 Base_Typ
: Entity_Id
;
12299 Errs
: Boolean := False;
12303 function Can_Derive_From
(E
: Entity_Id
) return Boolean;
12304 -- Determine whether given bounds allow derivation from specified type
12306 procedure Check_Bound
(Expr
: Node_Id
);
12307 -- Check bound to make sure it is integral and static. If not, post
12308 -- appropriate error message and set Errs flag
12310 function Can_Derive_From
(E
: Entity_Id
) return Boolean is
12311 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(E
));
12312 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(E
));
12315 -- Note we check both bounds against both end values, to deal with
12316 -- strange types like ones with a range of 0 .. -12341234.
12318 return Lo
<= Lo_Val
and then Lo_Val
<= Hi
12320 Lo
<= Hi_Val
and then Hi_Val
<= Hi
;
12321 end Can_Derive_From
;
12323 procedure Check_Bound
(Expr
: Node_Id
) is
12325 -- If a range constraint is used as an integer type definition, each
12326 -- bound of the range must be defined by a static expression of some
12327 -- integer type, but the two bounds need not have the same integer
12328 -- type (Negative bounds are allowed.) (RM 3.5.4)
12330 if not Is_Integer_Type
(Etype
(Expr
)) then
12332 ("integer type definition bounds must be of integer type", Expr
);
12335 elsif not Is_OK_Static_Expression
(Expr
) then
12337 ("non-static expression used for integer type bound", Expr
);
12340 -- The bounds are folded into literals, and we set their type to be
12341 -- universal, to avoid typing difficulties: we cannot set the type
12342 -- of the literal to the new type, because this would be a forward
12343 -- reference for the back end, and if the original type is user-
12344 -- defined this can lead to spurious semantic errors (e.g. 2928-003).
12347 if Is_Entity_Name
(Expr
) then
12348 Fold_Uint
(Expr
, Expr_Value
(Expr
));
12351 Set_Etype
(Expr
, Universal_Integer
);
12355 -- Start of processing for Signed_Integer_Type_Declaration
12358 -- Create an anonymous base type
12361 Create_Itype
(E_Signed_Integer_Type
, Parent
(Def
), T
, 'B');
12363 -- Analyze and check the bounds, they can be of any integer type
12365 Lo
:= Low_Bound
(Def
);
12366 Hi
:= High_Bound
(Def
);
12368 -- Arbitrarily use Integer as the type if either bound had an error
12370 if Hi
= Error
or else Lo
= Error
then
12371 Base_Typ
:= Any_Integer
;
12372 Set_Error_Posted
(T
, True);
12374 -- Here both bounds are OK expressions
12377 Analyze_And_Resolve
(Lo
, Any_Integer
);
12378 Analyze_And_Resolve
(Hi
, Any_Integer
);
12384 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
12385 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
12388 -- Find type to derive from
12390 Lo_Val
:= Expr_Value
(Lo
);
12391 Hi_Val
:= Expr_Value
(Hi
);
12393 if Can_Derive_From
(Standard_Short_Short_Integer
) then
12394 Base_Typ
:= Base_Type
(Standard_Short_Short_Integer
);
12396 elsif Can_Derive_From
(Standard_Short_Integer
) then
12397 Base_Typ
:= Base_Type
(Standard_Short_Integer
);
12399 elsif Can_Derive_From
(Standard_Integer
) then
12400 Base_Typ
:= Base_Type
(Standard_Integer
);
12402 elsif Can_Derive_From
(Standard_Long_Integer
) then
12403 Base_Typ
:= Base_Type
(Standard_Long_Integer
);
12405 elsif Can_Derive_From
(Standard_Long_Long_Integer
) then
12406 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
12409 Base_Typ
:= Base_Type
(Standard_Long_Long_Integer
);
12410 Error_Msg_N
("integer type definition bounds out of range", Def
);
12411 Hi
:= Type_High_Bound
(Standard_Long_Long_Integer
);
12412 Lo
:= Type_Low_Bound
(Standard_Long_Long_Integer
);
12416 -- Complete both implicit base and declared first subtype entities
12418 Set_Etype
(Implicit_Base
, Base_Typ
);
12419 Set_Scalar_Range
(Implicit_Base
, Scalar_Range
(Base_Typ
));
12420 Set_Size_Info
(Implicit_Base
, (Base_Typ
));
12421 Set_RM_Size
(Implicit_Base
, RM_Size
(Base_Typ
));
12422 Set_First_Rep_Item
(Implicit_Base
, First_Rep_Item
(Base_Typ
));
12424 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
12425 Set_Etype
(T
, Implicit_Base
);
12427 Set_Size_Info
(T
, (Implicit_Base
));
12428 Set_First_Rep_Item
(T
, First_Rep_Item
(Implicit_Base
));
12429 Set_Scalar_Range
(T
, Def
);
12430 Set_RM_Size
(T
, UI_From_Int
(Minimum_Size
(T
)));
12431 Set_Is_Constrained
(T
);
12433 end Signed_Integer_Type_Declaration
;