1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Contracts
; use Contracts
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Errout
; use Errout
;
35 with Expander
; use Expander
;
36 with Exp_Aggr
; use Exp_Aggr
;
37 with Exp_Atag
; use Exp_Atag
;
38 with Exp_Ch4
; use Exp_Ch4
;
39 with Exp_Ch6
; use Exp_Ch6
;
40 with Exp_Ch7
; use Exp_Ch7
;
41 with Exp_Ch9
; use Exp_Ch9
;
42 with Exp_Dbug
; use Exp_Dbug
;
43 with Exp_Disp
; use Exp_Disp
;
44 with Exp_Dist
; use Exp_Dist
;
46 with Exp_Smem
; use Exp_Smem
;
47 with Exp_Strm
; use Exp_Strm
;
48 with Exp_Util
; use Exp_Util
;
49 with Freeze
; use Freeze
;
50 with Ghost
; use Ghost
;
52 with Namet
; use Namet
;
53 with Nlists
; use Nlists
;
54 with Nmake
; use Nmake
;
56 with Restrict
; use Restrict
;
57 with Rident
; use Rident
;
58 with Rtsfind
; use Rtsfind
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Attr
; use Sem_Attr
;
62 with Sem_Cat
; use Sem_Cat
;
63 with Sem_Ch3
; use Sem_Ch3
;
64 with Sem_Ch6
; use Sem_Ch6
;
65 with Sem_Ch8
; use Sem_Ch8
;
66 with Sem_Disp
; use Sem_Disp
;
67 with Sem_Eval
; use Sem_Eval
;
68 with Sem_Mech
; use Sem_Mech
;
69 with Sem_Res
; use Sem_Res
;
70 with Sem_SCIL
; use Sem_SCIL
;
71 with Sem_Type
; use Sem_Type
;
72 with Sem_Util
; use Sem_Util
;
73 with Sinfo
; use Sinfo
;
74 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
75 with Sinfo
.Utils
; use Sinfo
.Utils
;
76 with Stand
; use Stand
;
77 with Snames
; use Snames
;
78 with Tbuild
; use Tbuild
;
79 with Ttypes
; use Ttypes
;
80 with Validsw
; use Validsw
;
82 package body Exp_Ch3
is
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
88 procedure Adjust_Discriminants
(Rtype
: Entity_Id
);
89 -- This is used when freezing a record type. It attempts to construct
90 -- more restrictive subtypes for discriminants so that the max size of
91 -- the record can be calculated more accurately. See the body of this
92 -- procedure for details.
94 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
);
95 -- Build initialization procedure for given array type. Nod is a node
96 -- used for attachment of any actions required in its construction.
97 -- It also supplies the source location used for the procedure.
99 function Build_Discriminant_Formals
101 Use_Dl
: Boolean) return List_Id
;
102 -- This function uses the discriminants of a type to build a list of
103 -- formal parameters, used in Build_Init_Procedure among other places.
104 -- If the flag Use_Dl is set, the list is built using the already
105 -- defined discriminals of the type, as is the case for concurrent
106 -- types with discriminants. Otherwise new identifiers are created,
107 -- with the source names of the discriminants.
109 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
);
110 -- For each variant component, builds a function which checks whether
111 -- the component name is consistent with the current discriminants
112 -- and sets the component's Dcheck_Function attribute to refer to it.
113 -- N is the full type declaration node; the discriminant checking
114 -- functions are inserted after this node.
116 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
;
117 -- This function builds a static aggregate that can serve as the initial
118 -- value for an array type whose bounds are static, and whose component
119 -- type is a composite type that has a static equivalent aggregate.
120 -- The equivalent array aggregate is used both for object initialization
121 -- and for component initialization, when used in the following function.
123 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
;
124 -- This function builds a static aggregate that can serve as the initial
125 -- value for a record type whose components are scalar and initialized
126 -- with compile-time values, or arrays with similar initialization or
127 -- defaults. When possible, initialization of an object of the type can
128 -- be achieved by using a copy of the aggregate as an initial value, thus
129 -- removing the implicit call that would otherwise constitute elaboration
132 procedure Build_Record_Init_Proc
(N
: Node_Id
; Rec_Ent
: Entity_Id
);
133 -- Build record initialization procedure. N is the type declaration
134 -- node, and Rec_Ent is the corresponding entity for the record type.
136 procedure Build_Slice_Assignment
(Typ
: Entity_Id
);
137 -- Build assignment procedure for one-dimensional arrays of controlled
138 -- types. Other array and slice assignments are expanded in-line, but
139 -- the code expansion for controlled components (when control actions
140 -- are active) can lead to very large blocks that GCC handles poorly.
142 procedure Build_Untagged_Equality
(Typ
: Entity_Id
);
143 -- AI05-0123: Equality on untagged records composes. This procedure
144 -- builds the equality routine for an untagged record that has components
145 -- of a record type that has user-defined primitive equality operations.
146 -- The resulting operation is a TSS subprogram.
148 procedure Check_Stream_Attributes
(Typ
: Entity_Id
);
149 -- Check that if a limited extension has a parent with user-defined stream
150 -- attributes, and does not itself have user-defined stream-attributes,
151 -- then any limited component of the extension also has the corresponding
152 -- user-defined stream attributes.
154 procedure Clean_Task_Names
156 Proc_Id
: Entity_Id
);
157 -- If an initialization procedure includes calls to generate names
158 -- for task subcomponents, indicate that secondary stack cleanup is
159 -- needed after an initialization. Typ is the component type, and Proc_Id
160 -- the initialization procedure for the enclosing composite type.
162 procedure Copy_Discr_Checking_Funcs
(N
: Node_Id
);
163 -- For a derived untagged type, copy the attributes that were set
164 -- for the components of the parent type onto the components of the
165 -- derived type. No new subprograms are constructed.
166 -- N is the full type declaration node, as for Build_Discr_Checking_Funcs.
168 procedure Expand_Freeze_Array_Type
(N
: Node_Id
);
169 -- Freeze an array type. Deals with building the initialization procedure,
170 -- creating the packed array type for a packed array and also with the
171 -- creation of the controlling procedures for the controlled case. The
172 -- argument N is the N_Freeze_Entity node for the type.
174 procedure Expand_Freeze_Class_Wide_Type
(N
: Node_Id
);
175 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
176 -- of finalizing controlled derivations from the class-wide's root type.
178 procedure Expand_Freeze_Enumeration_Type
(N
: Node_Id
);
179 -- Freeze enumeration type with non-standard representation. Builds the
180 -- array and function needed to convert between enumeration pos and
181 -- enumeration representation values. N is the N_Freeze_Entity node
184 procedure Expand_Freeze_Record_Type
(N
: Node_Id
);
185 -- Freeze record type. Builds all necessary discriminant checking
186 -- and other ancillary functions, and builds dispatch tables where
187 -- needed. The argument N is the N_Freeze_Entity node. This processing
188 -- applies only to E_Record_Type entities, not to class wide types,
189 -- record subtypes, or private types.
191 procedure Expand_Tagged_Root
(T
: Entity_Id
);
192 -- Add a field _Tag at the beginning of the record. This field carries
193 -- the value of the access to the Dispatch table. This procedure is only
194 -- called on root type, the _Tag field being inherited by the descendants.
196 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
);
197 -- Treat user-defined stream operations as renaming_as_body if the
198 -- subprogram they rename is not frozen when the type is frozen.
200 package Initialization_Control
is
202 function Requires_Late_Init
203 (Decl
: Node_Id
; Rec_Type
: Entity_Id
) return Boolean;
204 -- Return True iff the given component declaration requires late
205 -- initialization, as defined by 3.3.1 (8.1/5).
207 function Has_Late_Init_Component
208 (Tagged_Rec_Type
: Entity_Id
) return Boolean;
209 -- Return True iff the given tagged record type has at least one
210 -- component that requires late initialization; this includes
211 -- components of ancestor types.
213 type Initialization_Mode
is
214 (Full_Init
, Full_Init_Except_Tag
, Early_Init_Only
, Late_Init_Only
);
215 -- The initialization routine for a tagged type is passed in a
216 -- formal parameter of this type, indicating what initialization
217 -- is to be performed. This parameter defaults to Full_Init in all
218 -- cases except when the init proc of a type extension (let's call
219 -- that type T2) calls the init proc of its parent (let's call that
220 -- type T1). In that case, one of the other 3 values will
221 -- be passed in. In all three of those cases, the Tag component has
222 -- already been initialized before the call and is therefore not to be
223 -- modified. T2's init proc will either call T1's init proc
224 -- once (with Full_Init_Except_Tag as the parameter value) or twice
225 -- (first with Early_Init_Only, then later with Late_Init_Only),
226 -- depending on the result returned by Has_Late_Init_Component (T1).
227 -- In the latter case, the first call does not initialize any
228 -- components that require late initialization and the second call
229 -- then performs that deferred initialization.
230 -- Strictly speaking, the formal parameter subtype is actually Natural
231 -- but calls will only pass in values corresponding to literals
232 -- of this enumeration type.
234 function Make_Mode_Literal
235 (Loc
: Source_Ptr
; Mode
: Initialization_Mode
) return Node_Id
236 is (Make_Integer_Literal
(Loc
, Initialization_Mode
'Pos (Mode
)));
237 -- Generate an integer literal for a given mode value.
239 function Tag_Init_Condition
241 Init_Control_Formal
: Entity_Id
) return Node_Id
;
242 function Early_Init_Condition
244 Init_Control_Formal
: Entity_Id
) return Node_Id
;
245 function Late_Init_Condition
247 Init_Control_Formal
: Entity_Id
) return Node_Id
;
248 -- These three functions each return a Boolean expression that
249 -- can be used to determine whether a given call to the initialization
250 -- expression for a tagged type should initialize (respectively)
251 -- the Tag component, the non-Tag components that do not require late
252 -- initialization, and the components that do require late
255 end Initialization_Control
;
257 procedure Initialization_Warning
(E
: Entity_Id
);
258 -- If static elaboration of the package is requested, indicate
259 -- when a type does meet the conditions for static initialization. If
260 -- E is a type, it has components that have no static initialization.
261 -- if E is an entity, its initial expression is not compile-time known.
263 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
;
264 -- This function builds the list of formals for an initialization routine.
265 -- The first formal is always _Init with the given type. For task value
266 -- record types and types containing tasks, three additional formals are
267 -- added and Proc_Id is decorated with attribute Has_Master_Entity:
269 -- _Master : Master_Id
270 -- _Chain : in out Activation_Chain
271 -- _Task_Name : String
273 -- The caller must append additional entries for discriminants if required.
275 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean;
276 -- Returns true if the initialization procedure of Typ should be inlined
278 function In_Runtime
(E
: Entity_Id
) return Boolean;
279 -- Check if E is defined in the RTL (in a child of Ada or System). Used
280 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
282 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean;
283 -- Returns true if Stmts is made of null statements only, possibly wrapped
284 -- in a case statement, recursively. This latter pattern may occur for the
285 -- initialization procedure of an unchecked union.
287 function Make_Eq_Body
289 Eq_Name
: Name_Id
) return Node_Id
;
290 -- Build the body of a primitive equality operation for a tagged record
291 -- type, or in Ada 2012 for any record type that has components with a
292 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
294 function Make_Eq_Case
297 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
;
298 -- Building block for variant record equality. Defined to share the code
299 -- between the tagged and untagged case. Given a Component_List node CL,
300 -- it generates an 'if' followed by a 'case' statement that compares all
301 -- components of local temporaries named X and Y (that are declared as
302 -- formals at some upper level). E provides the Sloc to be used for the
305 -- IF E is an unchecked_union, Discrs is the list of formals created for
306 -- the inferred discriminants of one operand. These formals are used in
307 -- the generated case statements for each variant of the unchecked union.
311 L
: List_Id
) return Node_Id
;
312 -- Building block for variant record equality. Defined to share the code
313 -- between the tagged and untagged case. Given the list of components
314 -- (or discriminants) L, it generates a return statement that compares all
315 -- components of local temporaries named X and Y (that are declared as
316 -- formals at some upper level). E provides the Sloc to be used for the
319 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
;
320 -- Search for a renaming of the inequality dispatching primitive of
321 -- this tagged type. If found then build and return the corresponding
322 -- rename-as-body inequality subprogram; otherwise return Empty.
324 procedure Make_Predefined_Primitive_Specs
325 (Tag_Typ
: Entity_Id
;
326 Predef_List
: out List_Id
;
327 Renamed_Eq
: out Entity_Id
);
328 -- Create a list with the specs of the predefined primitive operations.
329 -- For tagged types that are interfaces all these primitives are defined
332 -- The following entries are present for all tagged types, and provide
333 -- the results of the corresponding attribute applied to the object.
334 -- Dispatching is required in general, since the result of the attribute
335 -- will vary with the actual object subtype.
337 -- _size provides result of 'Size attribute
338 -- typSR provides result of 'Read attribute
339 -- typSW provides result of 'Write attribute
340 -- typSI provides result of 'Input attribute
341 -- typSO provides result of 'Output attribute
342 -- typPI provides result of 'Put_Image attribute
344 -- The following entries are additionally present for non-limited tagged
345 -- types, and implement additional dispatching operations for predefined
348 -- _equality implements "=" operator
349 -- _assign implements assignment operation
350 -- typDF implements deep finalization
351 -- typDA implements deep adjust
353 -- The latter two are empty procedures unless the type contains some
354 -- controlled components that require finalization actions (the deep
355 -- in the name refers to the fact that the action applies to components).
357 -- The list of specs is returned in Predef_List
359 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean;
360 -- Returns True if there are representation clauses for type T that are not
361 -- inherited. If the result is false, the init_proc and the discriminant
362 -- checking functions of the parent can be reused by a derived type.
364 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
;
365 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
366 -- null procedures inherited from an interface type that have not been
367 -- overridden. Only one null procedure will be created for a given set of
368 -- inherited null procedures with homographic profiles.
370 function Predef_Spec_Or_Body
375 Ret_Type
: Entity_Id
:= Empty
;
376 For_Body
: Boolean := False) return Node_Id
;
377 -- This function generates the appropriate expansion for a predefined
378 -- primitive operation specified by its name, parameter profile and
379 -- return type (Empty means this is a procedure). If For_Body is false,
380 -- then the returned node is a subprogram declaration. If For_Body is
381 -- true, then the returned node is a empty subprogram body containing
382 -- no declarations and no statements.
384 function Predef_Stream_Attr_Spec
387 Name
: TSS_Name_Type
) return Node_Id
;
388 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
389 -- input and output attribute whose specs are constructed in Exp_Strm.
391 function Predef_Deep_Spec
394 Name
: TSS_Name_Type
;
395 For_Body
: Boolean := False) return Node_Id
;
396 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
397 -- and _deep_finalize
399 function Predefined_Primitive_Bodies
400 (Tag_Typ
: Entity_Id
;
401 Renamed_Eq
: Entity_Id
) return List_Id
;
402 -- Create the bodies of the predefined primitives that are described in
403 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
404 -- the defining unit name of the type's predefined equality as returned
405 -- by Make_Predefined_Primitive_Specs.
407 function Predefined_Primitive_Freeze
(Tag_Typ
: Entity_Id
) return List_Id
;
408 -- Freeze entities of all predefined primitive operations. This is needed
409 -- because the bodies of these operations do not normally do any freezing.
411 --------------------------
412 -- Adjust_Discriminants --
413 --------------------------
415 -- This procedure attempts to define subtypes for discriminants that are
416 -- more restrictive than those declared. Such a replacement is possible if
417 -- we can demonstrate that values outside the restricted range would cause
418 -- constraint errors in any case. The advantage of restricting the
419 -- discriminant types in this way is that the maximum size of the variant
420 -- record can be calculated more conservatively.
422 -- An example of a situation in which we can perform this type of
423 -- restriction is the following:
425 -- subtype B is range 1 .. 10;
426 -- type Q is array (B range <>) of Integer;
428 -- type V (N : Natural) is record
432 -- In this situation, we can restrict the upper bound of N to 10, since
433 -- any larger value would cause a constraint error in any case.
435 -- There are many situations in which such restriction is possible, but
436 -- for now, we just look for cases like the above, where the component
437 -- in question is a one dimensional array whose upper bound is one of
438 -- the record discriminants. Also the component must not be part of
439 -- any variant part, since then the component does not always exist.
441 procedure Adjust_Discriminants
(Rtype
: Entity_Id
) is
442 Loc
: constant Source_Ptr
:= Sloc
(Rtype
);
459 Comp
:= First_Component
(Rtype
);
460 while Present
(Comp
) loop
462 -- If our parent is a variant, quit, we do not look at components
463 -- that are in variant parts, because they may not always exist.
465 P
:= Parent
(Comp
); -- component declaration
466 P
:= Parent
(P
); -- component list
468 exit when Nkind
(Parent
(P
)) = N_Variant
;
470 -- We are looking for a one dimensional array type
472 Ctyp
:= Etype
(Comp
);
474 if not Is_Array_Type
(Ctyp
) or else Number_Dimensions
(Ctyp
) > 1 then
478 -- The lower bound must be constant, and the upper bound is a
479 -- discriminant (which is a discriminant of the current record).
481 Ityp
:= Etype
(First_Index
(Ctyp
));
482 Lo
:= Type_Low_Bound
(Ityp
);
483 Hi
:= Type_High_Bound
(Ityp
);
485 if not Compile_Time_Known_Value
(Lo
)
486 or else Nkind
(Hi
) /= N_Identifier
487 or else No
(Entity
(Hi
))
488 or else Ekind
(Entity
(Hi
)) /= E_Discriminant
493 -- We have an array with appropriate bounds
495 Loval
:= Expr_Value
(Lo
);
496 Discr
:= Entity
(Hi
);
497 Dtyp
:= Etype
(Discr
);
499 -- See if the discriminant has a known upper bound
501 Dhi
:= Type_High_Bound
(Dtyp
);
503 if not Compile_Time_Known_Value
(Dhi
) then
507 Dhiv
:= Expr_Value
(Dhi
);
509 -- See if base type of component array has known upper bound
511 Ahi
:= Type_High_Bound
(Etype
(First_Index
(Base_Type
(Ctyp
))));
513 if not Compile_Time_Known_Value
(Ahi
) then
517 Ahiv
:= Expr_Value
(Ahi
);
519 -- The condition for doing the restriction is that the high bound
520 -- of the discriminant is greater than the low bound of the array,
521 -- and is also greater than the high bound of the base type index.
523 if Dhiv
> Loval
and then Dhiv
> Ahiv
then
525 -- We can reset the upper bound of the discriminant type to
526 -- whichever is larger, the low bound of the component, or
527 -- the high bound of the base type array index.
529 -- We build a subtype that is declared as
531 -- subtype Tnn is discr_type range discr_type'First .. max;
533 -- And insert this declaration into the tree. The type of the
534 -- discriminant is then reset to this more restricted subtype.
536 Tnn
:= Make_Temporary
(Loc
, 'T');
538 Insert_Action
(Declaration_Node
(Rtype
),
539 Make_Subtype_Declaration
(Loc
,
540 Defining_Identifier
=> Tnn
,
541 Subtype_Indication
=>
542 Make_Subtype_Indication
(Loc
,
543 Subtype_Mark
=> New_Occurrence_Of
(Dtyp
, Loc
),
545 Make_Range_Constraint
(Loc
,
549 Make_Attribute_Reference
(Loc
,
550 Attribute_Name
=> Name_First
,
551 Prefix
=> New_Occurrence_Of
(Dtyp
, Loc
)),
553 Make_Integer_Literal
(Loc
,
554 Intval
=> UI_Max
(Loval
, Ahiv
)))))));
556 Set_Etype
(Discr
, Tnn
);
560 Next_Component
(Comp
);
562 end Adjust_Discriminants
;
564 ------------------------------------------
565 -- Build_Access_Subprogram_Wrapper_Body --
566 ------------------------------------------
568 procedure Build_Access_Subprogram_Wrapper_Body
572 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
573 Actuals
: constant List_Id
:= New_List
;
574 Type_Def
: constant Node_Id
:= Type_Definition
(Decl
);
575 Type_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
576 Spec_Node
: constant Node_Id
:=
577 Copy_Subprogram_Spec
(Specification
(New_Decl
));
578 -- This copy creates new identifiers for formals and subprogram.
586 if not Expander_Active
then
590 -- Create List of actuals for indirect call. The last parameter of the
591 -- subprogram declaration is the access value for the indirect call.
593 Act
:= First
(Parameter_Specifications
(Spec_Node
));
595 while Present
(Act
) loop
596 exit when Act
= Last
(Parameter_Specifications
(Spec_Node
));
598 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Act
))));
604 (Last
(Parameter_Specifications
(Specification
(New_Decl
))));
606 if Nkind
(Type_Def
) = N_Access_Procedure_Definition
then
607 Call_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
609 Make_Explicit_Dereference
610 (Loc
, New_Occurrence_Of
(Ptr
, Loc
)),
611 Parameter_Associations
=> Actuals
);
613 Call_Stmt
:= Make_Simple_Return_Statement
(Loc
,
615 Make_Function_Call
(Loc
,
616 Name
=> Make_Explicit_Dereference
617 (Loc
, New_Occurrence_Of
(Ptr
, Loc
)),
618 Parameter_Associations
=> Actuals
));
621 Body_Node
:= Make_Subprogram_Body
(Loc
,
622 Specification
=> Spec_Node
,
623 Declarations
=> New_List
,
624 Handled_Statement_Sequence
=>
625 Make_Handled_Sequence_Of_Statements
(Loc
,
626 Statements
=> New_List
(Call_Stmt
)));
628 -- Place body in list of freeze actions for the type.
630 Append_Freeze_Action
(Type_Id
, Body_Node
);
631 end Build_Access_Subprogram_Wrapper_Body
;
633 ---------------------------
634 -- Build_Array_Init_Proc --
635 ---------------------------
637 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
) is
638 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
639 Comp_Simple_Init
: constant Boolean :=
640 Needs_Simple_Initialization
643 not (Validity_Check_Copies
and Is_Bit_Packed_Array
(A_Type
)));
644 -- True if the component needs simple initialization, based on its type,
645 -- plus the fact that we do not do simple initialization for components
646 -- of bit-packed arrays when validity checks are enabled, because the
647 -- initialization with deliberately out-of-range values would raise
650 Body_Stmts
: List_Id
;
651 Has_Default_Init
: Boolean;
652 Index_List
: List_Id
;
654 Parameters
: List_Id
;
657 function Init_Component
return List_Id
;
658 -- Create one statement to initialize one array component, designated
659 -- by a full set of indexes.
661 function Init_One_Dimension
(N
: Int
) return List_Id
;
662 -- Create loop to initialize one dimension of the array. The single
663 -- statement in the loop body initializes the inner dimensions if any,
664 -- or else the single component. Note that this procedure is called
665 -- recursively, with N being the dimension to be initialized. A call
666 -- with N greater than the number of dimensions simply generates the
667 -- component initialization, terminating the recursion.
673 function Init_Component
return List_Id
is
678 Make_Indexed_Component
(Loc
,
679 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
680 Expressions
=> Index_List
);
682 if Has_Default_Aspect
(A_Type
) then
683 Set_Assignment_OK
(Comp
);
685 Make_Assignment_Statement
(Loc
,
688 Convert_To
(Comp_Type
,
689 Default_Aspect_Component_Value
(First_Subtype
(A_Type
)))));
691 elsif Comp_Simple_Init
then
692 Set_Assignment_OK
(Comp
);
694 Make_Assignment_Statement
(Loc
,
700 Size
=> Component_Size
(A_Type
))));
703 Clean_Task_Names
(Comp_Type
, Proc_Id
);
705 Build_Initialization_Call
709 In_Init_Proc
=> True,
710 Enclos_Type
=> A_Type
);
714 ------------------------
715 -- Init_One_Dimension --
716 ------------------------
718 function Init_One_Dimension
(N
: Int
) return List_Id
is
721 Result_List
: List_Id
;
723 function Possible_DIC_Call
return Node_Id
;
724 -- If the component type has Default_Initial_Conditions and a DIC
725 -- procedure that is not an empty body, then builds a call to the
726 -- DIC procedure and returns it.
728 -----------------------
729 -- Possible_DIC_Call --
730 -----------------------
732 function Possible_DIC_Call
return Node_Id
is
734 -- When the component's type has a Default_Initial_Condition, then
735 -- create a call for the DIC check.
737 if Has_DIC
(Comp_Type
)
738 -- In GNATprove mode, the component DICs are checked by other
739 -- means. They should not be added to the record type DIC
740 -- procedure, so that the procedure can be used to check the
741 -- record type invariants or DICs if any.
743 and then not GNATprove_Mode
745 -- DIC checks for components of controlled types are done later
746 -- (see Exp_Ch7.Make_Deep_Array_Body).
748 and then not Is_Controlled
(Comp_Type
)
750 and then Present
(DIC_Procedure
(Comp_Type
))
752 and then not Has_Null_Body
(DIC_Procedure
(Comp_Type
))
756 Make_Indexed_Component
(Loc
,
757 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
758 Expressions
=> Index_List
),
763 end Possible_DIC_Call
;
765 -- Start of processing for Init_One_Dimension
768 -- If the component does not need initializing, then there is nothing
769 -- to do here, so we return a null body. This occurs when generating
770 -- the dummy Init_Proc needed for Initialize_Scalars processing.
771 -- An exception is if component type has a Default_Initial_Condition,
772 -- in which case we generate a call to the type's DIC procedure.
774 if not Has_Non_Null_Base_Init_Proc
(Comp_Type
)
775 and then not Comp_Simple_Init
776 and then not Has_Task
(Comp_Type
)
777 and then not Has_Default_Aspect
(A_Type
)
778 and then (not Has_DIC
(Comp_Type
)
779 or else N
> Number_Dimensions
(A_Type
))
781 DIC_Call
:= Possible_DIC_Call
;
783 if Present
(DIC_Call
) then
784 return New_List
(DIC_Call
);
786 return New_List
(Make_Null_Statement
(Loc
));
789 -- If all dimensions dealt with, we simply initialize the component
790 -- and append a call to component type's DIC procedure when needed.
792 elsif N
> Number_Dimensions
(A_Type
) then
793 DIC_Call
:= Possible_DIC_Call
;
795 if Present
(DIC_Call
) then
796 Result_List
:= Init_Component
;
797 Append
(DIC_Call
, Result_List
);
801 return Init_Component
;
804 -- Here we generate the required loop
808 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
810 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
813 Make_Implicit_Loop_Statement
(Nod
,
816 Make_Iteration_Scheme
(Loc
,
817 Loop_Parameter_Specification
=>
818 Make_Loop_Parameter_Specification
(Loc
,
819 Defining_Identifier
=> Index
,
820 Discrete_Subtype_Definition
=>
821 Make_Attribute_Reference
(Loc
,
823 Make_Identifier
(Loc
, Name_uInit
),
824 Attribute_Name
=> Name_Range
,
825 Expressions
=> New_List
(
826 Make_Integer_Literal
(Loc
, N
))))),
827 Statements
=> Init_One_Dimension
(N
+ 1)));
829 end Init_One_Dimension
;
831 -- Start of processing for Build_Array_Init_Proc
834 -- The init proc is created when analyzing the freeze node for the type,
835 -- but it properly belongs with the array type declaration. However, if
836 -- the freeze node is for a subtype of a type declared in another unit
837 -- it seems preferable to use the freeze node as the source location of
838 -- the init proc. In any case this is preferable for gcov usage, and
839 -- the Sloc is not otherwise used by the compiler.
841 if In_Open_Scopes
(Scope
(A_Type
)) then
842 Loc
:= Sloc
(A_Type
);
847 -- Nothing to generate in the following cases:
849 -- 1. Initialization is suppressed for the type
850 -- 2. An initialization already exists for the base type
852 if Initialization_Suppressed
(A_Type
)
853 or else Present
(Base_Init_Proc
(A_Type
))
858 Index_List
:= New_List
;
860 -- We need an initialization procedure if any of the following is true:
862 -- 1. The component type has an initialization procedure
863 -- 2. The component type needs simple initialization
864 -- 3. Tasks are present
865 -- 4. The type is marked as a public entity
866 -- 5. The array type has a Default_Component_Value aspect
867 -- 6. The array component type has a Default_Initialization_Condition
869 -- The reason for the public entity test is to deal properly with the
870 -- Initialize_Scalars pragma. This pragma can be set in the client and
871 -- not in the declaring package, this means the client will make a call
872 -- to the initialization procedure (because one of conditions 1-3 must
873 -- apply in this case), and we must generate a procedure (even if it is
874 -- null) to satisfy the call in this case.
876 -- Exception: do not build an array init_proc for a type whose root
877 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
878 -- is no place to put the code, and in any case we handle initialization
879 -- of such types (in the Initialize_Scalars case, that's the only time
880 -- the issue arises) in a special manner anyway which does not need an
883 Has_Default_Init
:= Has_Non_Null_Base_Init_Proc
(Comp_Type
)
884 or else Comp_Simple_Init
885 or else Has_Task
(Comp_Type
)
886 or else Has_Default_Aspect
(A_Type
)
887 or else Has_DIC
(Comp_Type
);
890 or else (not Restriction_Active
(No_Initialize_Scalars
)
891 and then Is_Public
(A_Type
)
892 and then not Is_Standard_String_Type
(A_Type
))
895 Make_Defining_Identifier
(Loc
,
896 Chars
=> Make_Init_Proc_Name
(A_Type
));
898 -- If No_Default_Initialization restriction is active, then we don't
899 -- want to build an init_proc, but we need to mark that an init_proc
900 -- would be needed if this restriction was not active (so that we can
901 -- detect attempts to call it), so set a dummy init_proc in place.
902 -- This is only done though when actual default initialization is
903 -- needed (and not done when only Is_Public is True), since otherwise
904 -- objects such as arrays of scalars could be wrongly flagged as
905 -- violating the restriction.
907 if Restriction_Active
(No_Default_Initialization
) then
908 if Has_Default_Init
then
909 Set_Init_Proc
(A_Type
, Proc_Id
);
915 Body_Stmts
:= Init_One_Dimension
(1);
916 Parameters
:= Init_Formals
(A_Type
, Proc_Id
);
919 Make_Subprogram_Body
(Loc
,
921 Make_Procedure_Specification
(Loc
,
922 Defining_Unit_Name
=> Proc_Id
,
923 Parameter_Specifications
=> Parameters
),
924 Declarations
=> New_List
,
925 Handled_Statement_Sequence
=>
926 Make_Handled_Sequence_Of_Statements
(Loc
,
927 Statements
=> Body_Stmts
)));
929 Mutate_Ekind
(Proc_Id
, E_Procedure
);
930 Set_Is_Public
(Proc_Id
, Is_Public
(A_Type
));
931 Set_Is_Internal
(Proc_Id
);
932 Set_Has_Completion
(Proc_Id
);
934 if not Debug_Generated_Code
then
935 Set_Debug_Info_Off
(Proc_Id
);
938 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
939 -- component type itself (see also Build_Record_Init_Proc).
941 Set_Is_Inlined
(Proc_Id
, Inline_Init_Proc
(Comp_Type
));
943 -- Associate Init_Proc with type, and determine if the procedure
944 -- is null (happens because of the Initialize_Scalars pragma case,
945 -- where we have to generate a null procedure in case it is called
946 -- by a client with Initialize_Scalars set). Such procedures have
947 -- to be generated, but do not have to be called, so we mark them
948 -- as null to suppress the call. Kill also warnings for the _Init
949 -- out parameter, which is left entirely uninitialized.
951 Set_Init_Proc
(A_Type
, Proc_Id
);
953 if Is_Null_Statement_List
(Body_Stmts
) then
954 Set_Is_Null_Init_Proc
(Proc_Id
);
955 Set_Warnings_Off
(Defining_Identifier
(First
(Parameters
)));
958 -- Try to build a static aggregate to statically initialize
959 -- objects of the type. This can only be done for constrained
960 -- one-dimensional arrays with static bounds.
962 Set_Static_Initialization
964 Build_Equivalent_Array_Aggregate
(First_Subtype
(A_Type
)));
967 end Build_Array_Init_Proc
;
969 --------------------------------
970 -- Build_Discr_Checking_Funcs --
971 --------------------------------
973 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
) is
976 Enclosing_Func_Id
: Entity_Id
;
981 function Build_Case_Statement
982 (Case_Id
: Entity_Id
;
983 Variant
: Node_Id
) return Node_Id
;
984 -- Build a case statement containing only two alternatives. The first
985 -- alternative corresponds to the discrete choices given on the variant
986 -- that contains the components that we are generating the checks
987 -- for. If the discriminant is one of these return False. The second
988 -- alternative is an OTHERS choice that returns True indicating the
989 -- discriminant did not match.
991 function Build_Dcheck_Function
992 (Case_Id
: Entity_Id
;
993 Variant
: Node_Id
) return Entity_Id
;
994 -- Build the discriminant checking function for a given variant
996 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
);
997 -- Builds the discriminant checking function for each variant of the
998 -- given variant part of the record type.
1000 --------------------------
1001 -- Build_Case_Statement --
1002 --------------------------
1004 function Build_Case_Statement
1005 (Case_Id
: Entity_Id
;
1006 Variant
: Node_Id
) return Node_Id
1008 Alt_List
: constant List_Id
:= New_List
;
1009 Actuals_List
: List_Id
;
1010 Case_Node
: Node_Id
;
1011 Case_Alt_Node
: Node_Id
;
1013 Choice_List
: List_Id
;
1015 Return_Node
: Node_Id
;
1018 Case_Node
:= New_Node
(N_Case_Statement
, Loc
);
1019 Set_End_Span
(Case_Node
, Uint_0
);
1021 -- Replace the discriminant which controls the variant with the name
1022 -- of the formal of the checking function.
1024 Set_Expression
(Case_Node
, Make_Identifier
(Loc
, Chars
(Case_Id
)));
1026 Choice
:= First
(Discrete_Choices
(Variant
));
1028 if Nkind
(Choice
) = N_Others_Choice
then
1029 Choice_List
:= New_Copy_List
(Others_Discrete_Choices
(Choice
));
1031 Choice_List
:= New_Copy_List
(Discrete_Choices
(Variant
));
1034 if not Is_Empty_List
(Choice_List
) then
1035 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
1036 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
1038 -- In case this is a nested variant, we need to return the result
1039 -- of the discriminant checking function for the immediately
1040 -- enclosing variant.
1042 if Present
(Enclosing_Func_Id
) then
1043 Actuals_List
:= New_List
;
1045 D
:= First_Discriminant
(Rec_Id
);
1046 while Present
(D
) loop
1047 Append
(Make_Identifier
(Loc
, Chars
(D
)), Actuals_List
);
1048 Next_Discriminant
(D
);
1052 Make_Simple_Return_Statement
(Loc
,
1054 Make_Function_Call
(Loc
,
1056 New_Occurrence_Of
(Enclosing_Func_Id
, Loc
),
1057 Parameter_Associations
=>
1062 Make_Simple_Return_Statement
(Loc
,
1064 New_Occurrence_Of
(Standard_False
, Loc
));
1067 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
1068 Append
(Case_Alt_Node
, Alt_List
);
1071 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
1072 Choice_List
:= New_List
(New_Node
(N_Others_Choice
, Loc
));
1073 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
1076 Make_Simple_Return_Statement
(Loc
,
1078 New_Occurrence_Of
(Standard_True
, Loc
));
1080 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
1081 Append
(Case_Alt_Node
, Alt_List
);
1083 Set_Alternatives
(Case_Node
, Alt_List
);
1085 end Build_Case_Statement
;
1087 ---------------------------
1088 -- Build_Dcheck_Function --
1089 ---------------------------
1091 function Build_Dcheck_Function
1092 (Case_Id
: Entity_Id
;
1093 Variant
: Node_Id
) return Entity_Id
1095 Body_Node
: Node_Id
;
1096 Func_Id
: Entity_Id
;
1097 Parameter_List
: List_Id
;
1098 Spec_Node
: Node_Id
;
1101 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
1102 Sequence
:= Sequence
+ 1;
1105 Make_Defining_Identifier
(Loc
,
1106 Chars
=> New_External_Name
(Chars
(Rec_Id
), 'D', Sequence
));
1107 Set_Is_Discriminant_Check_Function
(Func_Id
);
1109 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
1110 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
1112 Parameter_List
:= Build_Discriminant_Formals
(Rec_Id
, False);
1114 Set_Parameter_Specifications
(Spec_Node
, Parameter_List
);
1115 Set_Result_Definition
(Spec_Node
,
1116 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1117 Set_Specification
(Body_Node
, Spec_Node
);
1118 Set_Declarations
(Body_Node
, New_List
);
1120 Set_Handled_Statement_Sequence
(Body_Node
,
1121 Make_Handled_Sequence_Of_Statements
(Loc
,
1122 Statements
=> New_List
(
1123 Build_Case_Statement
(Case_Id
, Variant
))));
1125 Mutate_Ekind
(Func_Id
, E_Function
);
1126 Set_Mechanism
(Func_Id
, Default_Mechanism
);
1127 Set_Is_Inlined
(Func_Id
, True);
1128 Set_Is_Pure
(Func_Id
, True);
1129 Set_Is_Public
(Func_Id
, Is_Public
(Rec_Id
));
1130 Set_Is_Internal
(Func_Id
, True);
1132 if not Debug_Generated_Code
then
1133 Set_Debug_Info_Off
(Func_Id
);
1136 Analyze
(Body_Node
);
1138 Append_Freeze_Action
(Rec_Id
, Body_Node
);
1139 Set_Dcheck_Function
(Variant
, Func_Id
);
1141 end Build_Dcheck_Function
;
1143 ----------------------------
1144 -- Build_Dcheck_Functions --
1145 ----------------------------
1147 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
) is
1148 Component_List_Node
: Node_Id
;
1150 Discr_Name
: Entity_Id
;
1151 Func_Id
: Entity_Id
;
1153 Saved_Enclosing_Func_Id
: Entity_Id
;
1156 -- Build the discriminant-checking function for each variant, and
1157 -- label all components of that variant with the function's name.
1158 -- We only Generate a discriminant-checking function when the
1159 -- variant is not empty, to prevent the creation of dead code.
1161 Discr_Name
:= Entity
(Name
(Variant_Part_Node
));
1162 Variant
:= First_Non_Pragma
(Variants
(Variant_Part_Node
));
1164 while Present
(Variant
) loop
1165 Component_List_Node
:= Component_List
(Variant
);
1167 if not Null_Present
(Component_List_Node
) then
1168 Func_Id
:= Build_Dcheck_Function
(Discr_Name
, Variant
);
1171 First_Non_Pragma
(Component_Items
(Component_List_Node
));
1172 while Present
(Decl
) loop
1173 Set_Discriminant_Checking_Func
1174 (Defining_Identifier
(Decl
), Func_Id
);
1175 Next_Non_Pragma
(Decl
);
1178 if Present
(Variant_Part
(Component_List_Node
)) then
1179 Saved_Enclosing_Func_Id
:= Enclosing_Func_Id
;
1180 Enclosing_Func_Id
:= Func_Id
;
1181 Build_Dcheck_Functions
(Variant_Part
(Component_List_Node
));
1182 Enclosing_Func_Id
:= Saved_Enclosing_Func_Id
;
1186 Next_Non_Pragma
(Variant
);
1188 end Build_Dcheck_Functions
;
1190 -- Start of processing for Build_Discr_Checking_Funcs
1193 -- Only build if not done already
1195 if not Discr_Check_Funcs_Built
(N
) then
1196 Type_Def
:= Type_Definition
(N
);
1198 if Nkind
(Type_Def
) = N_Record_Definition
then
1199 if No
(Component_List
(Type_Def
)) then -- null record.
1202 V
:= Variant_Part
(Component_List
(Type_Def
));
1205 else pragma Assert
(Nkind
(Type_Def
) = N_Derived_Type_Definition
);
1206 if No
(Component_List
(Record_Extension_Part
(Type_Def
))) then
1210 (Component_List
(Record_Extension_Part
(Type_Def
)));
1214 Rec_Id
:= Defining_Identifier
(N
);
1216 if Present
(V
) and then not Is_Unchecked_Union
(Rec_Id
) then
1218 Enclosing_Func_Id
:= Empty
;
1219 Build_Dcheck_Functions
(V
);
1222 Set_Discr_Check_Funcs_Built
(N
);
1224 end Build_Discr_Checking_Funcs
;
1226 ----------------------------------------
1227 -- Build_Or_Copy_Discr_Checking_Funcs --
1228 ----------------------------------------
1230 procedure Build_Or_Copy_Discr_Checking_Funcs
(N
: Node_Id
) is
1231 Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
1233 if Is_Unchecked_Union
(Typ
) or else not Has_Discriminants
(Typ
) then
1235 elsif not Is_Derived_Type
(Typ
)
1236 or else Has_New_Non_Standard_Rep
(Typ
)
1237 or else Is_Tagged_Type
(Typ
)
1239 Build_Discr_Checking_Funcs
(N
);
1241 Copy_Discr_Checking_Funcs
(N
);
1243 end Build_Or_Copy_Discr_Checking_Funcs
;
1245 --------------------------------
1246 -- Build_Discriminant_Formals --
1247 --------------------------------
1249 function Build_Discriminant_Formals
1250 (Rec_Id
: Entity_Id
;
1251 Use_Dl
: Boolean) return List_Id
1253 Loc
: Source_Ptr
:= Sloc
(Rec_Id
);
1254 Parameter_List
: constant List_Id
:= New_List
;
1257 Formal_Type
: Entity_Id
;
1258 Param_Spec_Node
: Node_Id
;
1261 if Has_Discriminants
(Rec_Id
) then
1262 D
:= First_Discriminant
(Rec_Id
);
1263 while Present
(D
) loop
1267 Formal
:= Discriminal
(D
);
1268 Formal_Type
:= Etype
(Formal
);
1270 Formal
:= Make_Defining_Identifier
(Loc
, Chars
(D
));
1271 Formal_Type
:= Etype
(D
);
1275 Make_Parameter_Specification
(Loc
,
1276 Defining_Identifier
=> Formal
,
1278 New_Occurrence_Of
(Formal_Type
, Loc
));
1279 Append
(Param_Spec_Node
, Parameter_List
);
1280 Next_Discriminant
(D
);
1284 return Parameter_List
;
1285 end Build_Discriminant_Formals
;
1287 --------------------------------------
1288 -- Build_Equivalent_Array_Aggregate --
1289 --------------------------------------
1291 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
is
1292 Loc
: constant Source_Ptr
:= Sloc
(T
);
1293 Comp_Type
: constant Entity_Id
:= Component_Type
(T
);
1294 Index_Type
: constant Entity_Id
:= Etype
(First_Index
(T
));
1295 Proc
: constant Entity_Id
:= Base_Init_Proc
(T
);
1301 if not Is_Constrained
(T
)
1302 or else Number_Dimensions
(T
) > 1
1305 Initialization_Warning
(T
);
1309 Lo
:= Type_Low_Bound
(Index_Type
);
1310 Hi
:= Type_High_Bound
(Index_Type
);
1312 if not Compile_Time_Known_Value
(Lo
)
1313 or else not Compile_Time_Known_Value
(Hi
)
1315 Initialization_Warning
(T
);
1319 if Is_Record_Type
(Comp_Type
)
1320 and then Present
(Base_Init_Proc
(Comp_Type
))
1322 Expr
:= Static_Initialization
(Base_Init_Proc
(Comp_Type
));
1325 Initialization_Warning
(T
);
1330 Initialization_Warning
(T
);
1334 Aggr
:= Make_Aggregate
(Loc
, No_List
, New_List
);
1335 Set_Etype
(Aggr
, T
);
1336 Set_Aggregate_Bounds
(Aggr
,
1338 Low_Bound
=> New_Copy
(Lo
),
1339 High_Bound
=> New_Copy
(Hi
)));
1340 Set_Parent
(Aggr
, Parent
(Proc
));
1342 Append_To
(Component_Associations
(Aggr
),
1343 Make_Component_Association
(Loc
,
1347 Low_Bound
=> New_Copy
(Lo
),
1348 High_Bound
=> New_Copy
(Hi
))),
1349 Expression
=> Expr
));
1351 if Static_Array_Aggregate
(Aggr
) then
1354 Initialization_Warning
(T
);
1357 end Build_Equivalent_Array_Aggregate
;
1359 ---------------------------------------
1360 -- Build_Equivalent_Record_Aggregate --
1361 ---------------------------------------
1363 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
is
1366 Comp_Type
: Entity_Id
;
1369 if not Is_Record_Type
(T
)
1370 or else Has_Discriminants
(T
)
1371 or else Is_Limited_Type
(T
)
1372 or else Has_Non_Standard_Rep
(T
)
1374 Initialization_Warning
(T
);
1378 Comp
:= First_Component
(T
);
1380 -- A null record needs no warning
1386 while Present
(Comp
) loop
1388 -- Array components are acceptable if initialized by a positional
1389 -- aggregate with static components.
1391 if Is_Array_Type
(Etype
(Comp
)) then
1392 Comp_Type
:= Component_Type
(Etype
(Comp
));
1394 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1395 or else No
(Expression
(Parent
(Comp
)))
1396 or else Nkind
(Expression
(Parent
(Comp
))) /= N_Aggregate
1398 Initialization_Warning
(T
);
1401 elsif Is_Scalar_Type
(Component_Type
(Etype
(Comp
)))
1403 (not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1405 not Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
)))
1407 Initialization_Warning
(T
);
1411 not Static_Array_Aggregate
(Expression
(Parent
(Comp
)))
1413 Initialization_Warning
(T
);
1416 -- We need to return empty if the type has predicates because
1417 -- this would otherwise duplicate calls to the predicate
1418 -- function. If the type hasn't been frozen before being
1419 -- referenced in the current record, the extraneous call to
1420 -- the predicate function would be inserted somewhere before
1421 -- the predicate function is elaborated, which would result in
1424 elsif Has_Predicates
(Etype
(Comp
)) then
1428 elsif Is_Scalar_Type
(Etype
(Comp
)) then
1429 Comp_Type
:= Etype
(Comp
);
1431 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1432 or else No
(Expression
(Parent
(Comp
)))
1433 or else not Compile_Time_Known_Value
(Expression
(Parent
(Comp
)))
1434 or else not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1436 Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
))
1438 Initialization_Warning
(T
);
1442 -- For now, other types are excluded
1445 Initialization_Warning
(T
);
1449 Next_Component
(Comp
);
1452 -- All components have static initialization. Build positional aggregate
1453 -- from the given expressions or defaults.
1455 Agg
:= Make_Aggregate
(Sloc
(T
), New_List
, New_List
);
1456 Set_Parent
(Agg
, Parent
(T
));
1458 Comp
:= First_Component
(T
);
1459 while Present
(Comp
) loop
1461 (New_Copy_Tree
(Expression
(Parent
(Comp
))), Expressions
(Agg
));
1462 Next_Component
(Comp
);
1465 Analyze_And_Resolve
(Agg
, T
);
1467 end Build_Equivalent_Record_Aggregate
;
1469 ----------------------------
1470 -- Init_Proc_Level_Formal --
1471 ----------------------------
1473 function Init_Proc_Level_Formal
(Proc
: Entity_Id
) return Entity_Id
is
1476 -- Move through the formals of the initialization procedure Proc to find
1477 -- the extra accessibility level parameter associated with the object
1478 -- being initialized.
1480 Form
:= First_Formal
(Proc
);
1481 while Present
(Form
) loop
1482 if Chars
(Form
) = Name_uInit_Level
then
1489 -- No formal was found, return Empty
1492 end Init_Proc_Level_Formal
;
1494 -------------------------------
1495 -- Build_Initialization_Call --
1496 -------------------------------
1498 -- References to a discriminant inside the record type declaration can
1499 -- appear either in the subtype_indication to constrain a record or an
1500 -- array, or as part of a larger expression given for the initial value
1501 -- of a component. In both of these cases N appears in the record
1502 -- initialization procedure and needs to be replaced by the formal
1503 -- parameter of the initialization procedure which corresponds to that
1506 -- In the example below, references to discriminants D1 and D2 in proc_1
1507 -- are replaced by references to formals with the same name
1510 -- A similar replacement is done for calls to any record initialization
1511 -- procedure for any components that are themselves of a record type.
1513 -- type R (D1, D2 : Integer) is record
1514 -- X : Integer := F * D1;
1515 -- Y : Integer := F * D2;
1518 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1522 -- Out_2.X := F * D1;
1523 -- Out_2.Y := F * D2;
1526 function Build_Initialization_Call
1530 In_Init_Proc
: Boolean := False;
1531 Enclos_Type
: Entity_Id
:= Empty
;
1532 Discr_Map
: Elist_Id
:= New_Elmt_List
;
1533 With_Default_Init
: Boolean := False;
1534 Constructor_Ref
: Node_Id
:= Empty
;
1535 Init_Control_Actual
: Entity_Id
:= Empty
) return List_Id
1537 Res
: constant List_Id
:= New_List
;
1539 Full_Type
: Entity_Id
;
1541 procedure Check_Predicated_Discriminant
1544 -- Discriminants whose subtypes have predicates are checked in two
1546 -- a) When an object is default-initialized and assertions are enabled
1547 -- we check that the value of the discriminant obeys the predicate.
1549 -- b) In all cases, if the discriminant controls a variant and the
1550 -- variant has no others_choice, Constraint_Error must be raised if
1551 -- the predicate is violated, because there is no variant covered
1552 -- by the illegal discriminant value.
1554 -----------------------------------
1555 -- Check_Predicated_Discriminant --
1556 -----------------------------------
1558 procedure Check_Predicated_Discriminant
1562 Typ
: constant Entity_Id
:= Etype
(Discr
);
1564 procedure Check_Missing_Others
(V
: Node_Id
);
1565 -- Check that a given variant and its nested variants have an others
1566 -- choice, and generate a constraint error raise when it does not.
1568 --------------------------
1569 -- Check_Missing_Others --
1570 --------------------------
1572 procedure Check_Missing_Others
(V
: Node_Id
) is
1578 Last_Var
:= Last_Non_Pragma
(Variants
(V
));
1579 Choice
:= First
(Discrete_Choices
(Last_Var
));
1581 -- An others_choice is added during expansion for gcc use, but
1582 -- does not cover the illegality.
1584 if Entity
(Name
(V
)) = Discr
then
1586 and then (Nkind
(Choice
) /= N_Others_Choice
1587 or else not Comes_From_Source
(Choice
))
1589 Check_Expression_Against_Static_Predicate
(Val
, Typ
);
1591 if not Is_Static_Expression
(Val
) then
1593 Make_Raise_Constraint_Error
(Loc
,
1596 Right_Opnd
=> Make_Predicate_Call
(Typ
, Val
)),
1597 Reason
=> CE_Invalid_Data
));
1602 -- Check whether some nested variant is ruled by the predicated
1605 Alt
:= First
(Variants
(V
));
1606 while Present
(Alt
) loop
1607 if Nkind
(Alt
) = N_Variant
1608 and then Present
(Variant_Part
(Component_List
(Alt
)))
1610 Check_Missing_Others
1611 (Variant_Part
(Component_List
(Alt
)));
1616 end Check_Missing_Others
;
1622 -- Start of processing for Check_Predicated_Discriminant
1625 if Ekind
(Base_Type
(Full_Type
)) = E_Record_Type
then
1626 Def
:= Type_Definition
(Parent
(Base_Type
(Full_Type
)));
1631 if Policy_In_Effect
(Name_Assert
) = Name_Check
1632 and then not Predicates_Ignored
(Etype
(Discr
))
1634 Prepend_To
(Res
, Make_Predicate_Check
(Typ
, Val
));
1637 -- If discriminant controls a variant, verify that predicate is
1638 -- obeyed or else an Others_Choice is present.
1640 if Nkind
(Def
) = N_Record_Definition
1641 and then Present
(Variant_Part
(Component_List
(Def
)))
1642 and then Policy_In_Effect
(Name_Assert
) = Name_Ignore
1644 Check_Missing_Others
(Variant_Part
(Component_List
(Def
)));
1646 end Check_Predicated_Discriminant
;
1655 First_Arg
: Node_Id
;
1656 Full_Init_Type
: Entity_Id
;
1657 Init_Call
: Node_Id
;
1658 Init_Type
: Entity_Id
;
1661 -- Start of processing for Build_Initialization_Call
1664 pragma Assert
(Constructor_Ref
= Empty
1665 or else Is_CPP_Constructor_Call
(Constructor_Ref
));
1667 if No
(Constructor_Ref
) then
1668 Proc
:= Base_Init_Proc
(Typ
);
1670 Proc
:= Base_Init_Proc
(Typ
, Entity
(Name
(Constructor_Ref
)));
1673 pragma Assert
(Present
(Proc
));
1674 Init_Type
:= Etype
(First_Formal
(Proc
));
1675 Full_Init_Type
:= Underlying_Type
(Init_Type
);
1677 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1678 -- is active (in which case we make the call anyway, since in the
1679 -- actual compiled client it may be non null).
1681 if Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
then
1684 -- Nothing to do for an array of controlled components that have only
1685 -- the inherited Initialize primitive. This is a useful optimization
1688 elsif Is_Trivial_Subprogram
(Proc
)
1689 and then Is_Array_Type
(Full_Init_Type
)
1691 return New_List
(Make_Null_Statement
(Loc
));
1694 -- Use the [underlying] full view when dealing with a private type. This
1695 -- may require several steps depending on derivations.
1699 if Is_Private_Type
(Full_Type
) then
1700 if Present
(Full_View
(Full_Type
)) then
1701 Full_Type
:= Full_View
(Full_Type
);
1703 elsif Present
(Underlying_Full_View
(Full_Type
)) then
1704 Full_Type
:= Underlying_Full_View
(Full_Type
);
1706 -- When a private type acts as a generic actual and lacks a full
1707 -- view, use the base type.
1709 elsif Is_Generic_Actual_Type
(Full_Type
) then
1710 Full_Type
:= Base_Type
(Full_Type
);
1712 elsif Ekind
(Full_Type
) = E_Private_Subtype
1713 and then (not Has_Discriminants
(Full_Type
)
1714 or else No
(Discriminant_Constraint
(Full_Type
)))
1716 Full_Type
:= Etype
(Full_Type
);
1718 -- The loop has recovered the [underlying] full view, stop the
1725 -- The type is not private, nothing to do
1732 -- If Typ is derived, the procedure is the initialization procedure for
1733 -- the root type. Wrap the argument in an conversion to make it type
1734 -- honest. Actually it isn't quite type honest, because there can be
1735 -- conflicts of views in the private type case. That is why we set
1736 -- Conversion_OK in the conversion node.
1738 if (Is_Record_Type
(Typ
)
1739 or else Is_Array_Type
(Typ
)
1740 or else Is_Private_Type
(Typ
))
1741 and then Init_Type
/= Base_Type
(Typ
)
1743 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
1744 Set_Etype
(First_Arg
, Init_Type
);
1747 First_Arg
:= Id_Ref
;
1750 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
1752 -- In the tasks case, add _Master as the value of the _Master parameter
1753 -- and _Chain as the value of the _Chain parameter. At the outer level,
1754 -- these will be variables holding the corresponding values obtained
1755 -- from GNARL. At inner levels, they will be the parameters passed down
1756 -- through the outer routines.
1758 if Has_Task
(Full_Type
) then
1759 if Restriction_Active
(No_Task_Hierarchy
) then
1760 Append_To
(Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
1762 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1765 -- Add _Chain (not done for sequential elaboration policy, see
1766 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1768 if Partition_Elaboration_Policy
/= 'S' then
1769 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1772 -- Ada 2005 (AI-287): In case of default initialized components
1773 -- with tasks, we generate a null string actual parameter.
1774 -- This is just a workaround that must be improved later???
1776 if With_Default_Init
then
1778 Make_String_Literal
(Loc
,
1783 Build_Task_Image_Decls
(Loc
, Id_Ref
, Enclos_Type
, In_Init_Proc
);
1784 Decl
:= Last
(Decls
);
1787 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
1788 Append_List
(Decls
, Res
);
1796 -- Handle the optionally generated formal *_skip_null_excluding_checks
1798 -- Look at the associated node for the object we are referencing and
1799 -- verify that we are expanding a call to an Init_Proc for an internally
1800 -- generated object declaration before passing True and skipping the
1803 if Needs_Conditional_Null_Excluding_Check
(Full_Init_Type
)
1804 and then Nkind
(Id_Ref
) in N_Has_Entity
1805 and then (Comes_From_Source
(Id_Ref
)
1806 or else (Present
(Associated_Node
(Id_Ref
))
1807 and then Comes_From_Source
1808 (Associated_Node
(Id_Ref
))))
1810 Append_To
(Args
, New_Occurrence_Of
(Standard_True
, Loc
));
1813 -- Add discriminant values if discriminants are present
1815 if Has_Discriminants
(Full_Init_Type
) then
1816 Discr
:= First_Discriminant
(Full_Init_Type
);
1817 while Present
(Discr
) loop
1819 -- If this is a discriminated concurrent type, the init_proc
1820 -- for the corresponding record is being called. Use that type
1821 -- directly to find the discriminant value, to handle properly
1822 -- intervening renamed discriminants.
1825 T
: Entity_Id
:= Full_Type
;
1828 if Is_Protected_Type
(T
) then
1829 T
:= Corresponding_Record_Type
(T
);
1833 Get_Discriminant_Value
(
1836 Discriminant_Constraint
(Full_Type
));
1839 -- If the target has access discriminants, and is constrained by
1840 -- an access to the enclosing construct, i.e. a current instance,
1841 -- replace the reference to the type by a reference to the object.
1843 if Nkind
(Arg
) = N_Attribute_Reference
1844 and then Is_Access_Type
(Etype
(Arg
))
1845 and then Is_Entity_Name
(Prefix
(Arg
))
1846 and then Is_Type
(Entity
(Prefix
(Arg
)))
1849 Make_Attribute_Reference
(Loc
,
1850 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
1851 Attribute_Name
=> Name_Unrestricted_Access
);
1853 elsif In_Init_Proc
then
1855 -- Replace any possible references to the discriminant in the
1856 -- call to the record initialization procedure with references
1857 -- to the appropriate formal parameter.
1859 if Nkind
(Arg
) = N_Identifier
1860 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1862 Arg
:= New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
);
1864 -- Otherwise make a copy of the default expression. Note that
1865 -- we use the current Sloc for this, because we do not want the
1866 -- call to appear to be at the declaration point. Within the
1867 -- expression, replace discriminants with their discriminals.
1871 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
1875 if Is_Constrained
(Full_Type
) then
1876 Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
1878 -- The constraints come from the discriminant default exps,
1879 -- they must be reevaluated, so we use New_Copy_Tree but we
1880 -- ensure the proper Sloc (for any embedded calls).
1881 -- In addition, if a predicate check is needed on the value
1882 -- of the discriminant, insert it ahead of the call.
1884 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
1887 if Has_Predicates
(Etype
(Discr
)) then
1888 Check_Predicated_Discriminant
(Arg
, Discr
);
1892 -- Ada 2005 (AI-287): In case of default initialized components,
1893 -- if the component is constrained with a discriminant of the
1894 -- enclosing type, we need to generate the corresponding selected
1895 -- component node to access the discriminant value. In other cases
1896 -- this is not required, either because we are inside the init
1897 -- proc and we use the corresponding formal, or else because the
1898 -- component is constrained by an expression.
1900 if With_Default_Init
1901 and then Nkind
(Id_Ref
) = N_Selected_Component
1902 and then Nkind
(Arg
) = N_Identifier
1903 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1906 Make_Selected_Component
(Loc
,
1907 Prefix
=> New_Copy_Tree
(Prefix
(Id_Ref
)),
1908 Selector_Name
=> Arg
));
1910 Append_To
(Args
, Arg
);
1913 Next_Discriminant
(Discr
);
1917 -- If this is a call to initialize the parent component of a derived
1918 -- tagged type, indicate that the tag should not be set in the parent.
1919 -- This is done via the actual parameter value for the Init_Control
1920 -- formal parameter, which is also used to deal with late initialization
1923 -- We pass in Full_Init_Except_Tag unless the caller tells us to do
1924 -- otherwise (by passing in a nonempty Init_Control_Actual parameter).
1926 if Is_Tagged_Type
(Full_Init_Type
)
1927 and then not Is_CPP_Class
(Full_Init_Type
)
1928 and then Nkind
(Id_Ref
) = N_Selected_Component
1929 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
1932 use Initialization_Control
;
1935 (if Present
(Init_Control_Actual
)
1936 then Init_Control_Actual
1937 else Make_Mode_Literal
(Loc
, Full_Init_Except_Tag
)));
1939 elsif Present
(Constructor_Ref
) then
1940 Append_List_To
(Args
,
1941 New_Copy_List
(Parameter_Associations
(Constructor_Ref
)));
1944 -- Pass the extra accessibility level parameter associated with the
1945 -- level of the object being initialized when required.
1947 if Is_Entity_Name
(Id_Ref
)
1948 and then Present
(Init_Proc_Level_Formal
(Proc
))
1951 Make_Parameter_Association
(Loc
,
1953 Make_Identifier
(Loc
, Name_uInit_Level
),
1954 Explicit_Actual_Parameter
=>
1955 Accessibility_Level
(Id_Ref
, Dynamic_Level
)));
1959 Make_Procedure_Call_Statement
(Loc
,
1960 Name
=> New_Occurrence_Of
(Proc
, Loc
),
1961 Parameter_Associations
=> Args
));
1963 if Needs_Finalization
(Typ
)
1964 and then Nkind
(Id_Ref
) = N_Selected_Component
1966 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
1969 (Obj_Ref
=> New_Copy_Tree
(First_Arg
),
1972 -- Guard against a missing [Deep_]Initialize when the type was not
1975 if Present
(Init_Call
) then
1976 Append_To
(Res
, Init_Call
);
1984 when RE_Not_Available
=>
1986 end Build_Initialization_Call
;
1988 ----------------------------
1989 -- Build_Record_Init_Proc --
1990 ----------------------------
1992 procedure Build_Record_Init_Proc
(N
: Node_Id
; Rec_Ent
: Entity_Id
) is
1993 Decls
: constant List_Id
:= New_List
;
1994 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
1995 Loc
: constant Source_Ptr
:= Sloc
(Rec_Ent
);
1997 Proc_Id
: Entity_Id
;
1998 Rec_Type
: Entity_Id
;
2000 Init_Control_Formal
: Entity_Id
:= Empty
; -- set in Build_Init_Statements
2001 Has_Late_Init_Comp
: Boolean := False; -- set in Build_Init_Statements
2003 function Build_Assignment
2005 Default
: Node_Id
) return List_Id
;
2006 -- Build an assignment statement that assigns the default expression to
2007 -- its corresponding record component if defined. The left-hand side of
2008 -- the assignment is marked Assignment_OK so that initialization of
2009 -- limited private records works correctly. This routine may also build
2010 -- an adjustment call if the component is controlled.
2012 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
2013 -- If the record has discriminants, add assignment statements to
2014 -- Statement_List to initialize the discriminant values from the
2015 -- arguments of the initialization procedure.
2017 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
2018 -- Build a list representing a sequence of statements which initialize
2019 -- components of the given component list. This may involve building
2020 -- case statements for the variant parts. Append any locally declared
2021 -- objects on list Decls.
2023 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
;
2024 -- Given an untagged type-derivation that declares discriminants, e.g.
2026 -- type R (R1, R2 : Integer) is record ... end record;
2027 -- type D (D1 : Integer) is new R (1, D1);
2029 -- we make the _init_proc of D be
2031 -- procedure _init_proc (X : D; D1 : Integer) is
2033 -- _init_proc (R (X), 1, D1);
2036 -- This function builds the call statement in this _init_proc.
2038 procedure Build_CPP_Init_Procedure
;
2039 -- Build the tree corresponding to the procedure specification and body
2040 -- of the IC procedure that initializes the C++ part of the dispatch
2041 -- table of an Ada tagged type that is a derivation of a CPP type.
2042 -- Install it as the CPP_Init TSS.
2044 procedure Build_Init_Procedure
;
2045 -- Build the tree corresponding to the procedure specification and body
2046 -- of the initialization procedure and install it as the _init TSS.
2048 procedure Build_Offset_To_Top_Functions
;
2049 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
2050 -- and body of Offset_To_Top, a function used in conjuction with types
2051 -- having secondary dispatch tables.
2053 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
2054 -- Add range checks to components of discriminated records. S is a
2055 -- subtype indication of a record component. Check_List is a list
2056 -- to which the check actions are appended.
2058 function Component_Needs_Simple_Initialization
2059 (T
: Entity_Id
) return Boolean;
2060 -- Determine if a component needs simple initialization, given its type
2061 -- T. This routine is the same as Needs_Simple_Initialization except for
2062 -- components of type Tag and Interface_Tag. These two access types do
2063 -- not require initialization since they are explicitly initialized by
2066 function Parent_Subtype_Renaming_Discrims
return Boolean;
2067 -- Returns True for base types N that rename discriminants, else False
2069 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
2070 -- Determine whether a record initialization procedure needs to be
2071 -- generated for the given record type.
2073 ----------------------
2074 -- Build_Assignment --
2075 ----------------------
2077 function Build_Assignment
2079 Default
: Node_Id
) return List_Id
2081 Default_Loc
: constant Source_Ptr
:= Sloc
(Default
);
2082 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
2085 Exp
: Node_Id
:= Default
;
2086 Kind
: Node_Kind
:= Nkind
(Default
);
2092 Make_Selected_Component
(Default_Loc
,
2093 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2094 Selector_Name
=> New_Occurrence_Of
(Id
, Default_Loc
));
2095 Set_Assignment_OK
(Lhs
);
2097 -- Take a copy of Exp to ensure that later copies of this component
2098 -- declaration in derived types see the original tree, not a node
2099 -- rewritten during expansion of the init_proc. If the copy contains
2100 -- itypes, the scope of the new itypes is the init_proc being built.
2103 Map
: Elist_Id
:= No_Elist
;
2105 if Has_Late_Init_Comp
then
2106 -- Map the type to the _Init parameter in order to
2107 -- handle "current instance" references.
2109 Map
:= New_Elmt_List
2111 Elmt2
=> Defining_Identifier
(First
2112 (Parameter_Specifications
2113 (Parent
(Proc_Id
)))));
2115 -- If the type has an incomplete view, a current instance
2116 -- may have an incomplete type. In that case, it must also be
2117 -- replaced by the formal of the Init_Proc.
2119 if Nkind
(Parent
(Rec_Type
)) = N_Full_Type_Declaration
2120 and then Present
(Incomplete_View
(Parent
(Rec_Type
)))
2123 N
=> Incomplete_View
(Parent
(Rec_Type
)),
2126 N
=> Defining_Identifier
2128 (Parameter_Specifications
2129 (Parent
(Proc_Id
)))),
2134 Exp
:= New_Copy_Tree
(Exp
, New_Scope
=> Proc_Id
, Map
=> Map
);
2138 Make_Assignment_Statement
(Loc
,
2140 Expression
=> Exp
));
2142 Set_No_Ctrl_Actions
(First
(Res
));
2144 -- Adjust the tag if tagged (because of possible view conversions).
2145 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2146 -- tags are represented implicitly in objects, and when the record is
2147 -- initialized with a raise expression.
2149 if Is_Tagged_Type
(Typ
)
2150 and then Tagged_Type_Expansion
2151 and then Nkind
(Exp
) /= N_Raise_Expression
2152 and then (Nkind
(Exp
) /= N_Qualified_Expression
2153 or else Nkind
(Expression
(Exp
)) /= N_Raise_Expression
)
2156 Make_Assignment_Statement
(Default_Loc
,
2158 Make_Selected_Component
(Default_Loc
,
2160 New_Copy_Tree
(Lhs
, New_Scope
=> Proc_Id
),
2163 (First_Tag_Component
(Typ
), Default_Loc
)),
2166 Unchecked_Convert_To
(RTE
(RE_Tag
),
2168 (Node
(First_Elmt
(Access_Disp_Table
(Underlying_Type
2173 -- Adjust the component if controlled except if it is an aggregate
2174 -- that will be expanded inline.
2176 if Kind
= N_Qualified_Expression
then
2177 Kind
:= Nkind
(Expression
(Default
));
2180 if Needs_Finalization
(Typ
)
2181 and then Kind
not in N_Aggregate | N_Extension_Aggregate
2182 and then not Is_Build_In_Place_Function_Call
(Exp
)
2186 (Obj_Ref
=> New_Copy_Tree
(Lhs
),
2189 -- Guard against a missing [Deep_]Adjust when the component type
2190 -- was not properly frozen.
2192 if Present
(Adj_Call
) then
2193 Append_To
(Res
, Adj_Call
);
2197 -- If a component type has a predicate, add check to the component
2198 -- assignment. Discriminants are handled at the point of the call,
2199 -- which provides for a better error message.
2201 if Comes_From_Source
(Exp
)
2202 and then Predicate_Enabled
(Typ
)
2204 Append
(Make_Predicate_Check
(Typ
, Exp
), Res
);
2210 when RE_Not_Available
=>
2212 end Build_Assignment
;
2214 ------------------------------------
2215 -- Build_Discriminant_Assignments --
2216 ------------------------------------
2218 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
2219 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
2224 if Has_Discriminants
(Rec_Type
)
2225 and then not Is_Unchecked_Union
(Rec_Type
)
2227 D
:= First_Discriminant
(Rec_Type
);
2228 while Present
(D
) loop
2230 -- Don't generate the assignment for discriminants in derived
2231 -- tagged types if the discriminant is a renaming of some
2232 -- ancestor discriminant. This initialization will be done
2233 -- when initializing the _parent field of the derived record.
2236 and then Present
(Corresponding_Discriminant
(D
))
2242 Append_List_To
(Statement_List
,
2243 Build_Assignment
(D
,
2244 New_Occurrence_Of
(Discriminal
(D
), D_Loc
)));
2247 Next_Discriminant
(D
);
2250 end Build_Discriminant_Assignments
;
2252 --------------------------
2253 -- Build_Init_Call_Thru --
2254 --------------------------
2256 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
is
2257 Parent_Proc
: constant Entity_Id
:=
2258 Base_Init_Proc
(Etype
(Rec_Type
));
2260 Parent_Type
: constant Entity_Id
:=
2261 Etype
(First_Formal
(Parent_Proc
));
2263 Uparent_Type
: constant Entity_Id
:=
2264 Underlying_Type
(Parent_Type
);
2266 First_Discr_Param
: Node_Id
;
2270 First_Arg
: Node_Id
;
2271 Parent_Discr
: Entity_Id
;
2275 -- First argument (_Init) is the object to be initialized.
2276 -- ??? not sure where to get a reasonable Loc for First_Arg
2279 OK_Convert_To
(Parent_Type
,
2281 (Defining_Identifier
(First
(Parameters
)), Loc
));
2283 Set_Etype
(First_Arg
, Parent_Type
);
2285 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
2287 -- In the tasks case,
2288 -- add _Master as the value of the _Master parameter
2289 -- add _Chain as the value of the _Chain parameter.
2290 -- add _Task_Name as the value of the _Task_Name parameter.
2291 -- At the outer level, these will be variables holding the
2292 -- corresponding values obtained from GNARL or the expander.
2294 -- At inner levels, they will be the parameters passed down through
2295 -- the outer routines.
2297 First_Discr_Param
:= Next
(First
(Parameters
));
2299 if Has_Task
(Rec_Type
) then
2300 if Restriction_Active
(No_Task_Hierarchy
) then
2302 (Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
2304 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
2307 -- Add _Chain (not done for sequential elaboration policy, see
2308 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2310 if Partition_Elaboration_Policy
/= 'S' then
2311 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2314 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
2315 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
2318 -- Append discriminant values
2320 if Has_Discriminants
(Uparent_Type
) then
2321 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
2323 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
2324 while Present
(Parent_Discr
) loop
2326 -- Get the initial value for this discriminant
2327 -- ??? needs to be cleaned up to use parent_Discr_Constr
2331 Discr
: Entity_Id
:=
2332 First_Stored_Discriminant
(Uparent_Type
);
2334 Discr_Value
: Elmt_Id
:=
2335 First_Elmt
(Stored_Constraint
(Rec_Type
));
2338 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
2339 Next_Stored_Discriminant
(Discr
);
2340 Next_Elmt
(Discr_Value
);
2343 Arg
:= Node
(Discr_Value
);
2346 -- Append it to the list
2348 if Nkind
(Arg
) = N_Identifier
2349 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2352 New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
));
2354 -- Case of access discriminants. We replace the reference
2355 -- to the type by a reference to the actual object.
2357 -- Is above comment right??? Use of New_Copy below seems mighty
2361 Append_To
(Args
, New_Copy
(Arg
));
2364 Next_Discriminant
(Parent_Discr
);
2370 Make_Procedure_Call_Statement
(Loc
,
2372 New_Occurrence_Of
(Parent_Proc
, Loc
),
2373 Parameter_Associations
=> Args
));
2376 end Build_Init_Call_Thru
;
2378 -----------------------------------
2379 -- Build_Offset_To_Top_Functions --
2380 -----------------------------------
2382 procedure Build_Offset_To_Top_Functions
is
2384 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
);
2386 -- function Fxx (O : Address) return Storage_Offset is
2387 -- type Acc is access all <Typ>;
2389 -- return Acc!(O).Iface_Comp'Position;
2392 ----------------------------------
2393 -- Build_Offset_To_Top_Function --
2394 ----------------------------------
2396 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
) is
2397 Body_Node
: Node_Id
;
2398 Func_Id
: Entity_Id
;
2399 Spec_Node
: Node_Id
;
2400 Acc_Type
: Entity_Id
;
2403 Func_Id
:= Make_Temporary
(Loc
, 'F');
2404 Set_DT_Offset_To_Top_Func
(Iface_Comp
, Func_Id
);
2407 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2409 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
2410 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
2411 Set_Parameter_Specifications
(Spec_Node
, New_List
(
2412 Make_Parameter_Specification
(Loc
,
2413 Defining_Identifier
=>
2414 Make_Defining_Identifier
(Loc
, Name_uO
),
2417 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))));
2418 Set_Result_Definition
(Spec_Node
,
2419 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
));
2422 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2424 -- return -O.Iface_Comp'Position;
2427 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2428 Set_Specification
(Body_Node
, Spec_Node
);
2430 Acc_Type
:= Make_Temporary
(Loc
, 'T');
2431 Set_Declarations
(Body_Node
, New_List
(
2432 Make_Full_Type_Declaration
(Loc
,
2433 Defining_Identifier
=> Acc_Type
,
2435 Make_Access_To_Object_Definition
(Loc
,
2436 All_Present
=> True,
2437 Null_Exclusion_Present
=> False,
2438 Constant_Present
=> False,
2439 Subtype_Indication
=>
2440 New_Occurrence_Of
(Rec_Type
, Loc
)))));
2442 Set_Handled_Statement_Sequence
(Body_Node
,
2443 Make_Handled_Sequence_Of_Statements
(Loc
,
2444 Statements
=> New_List
(
2445 Make_Simple_Return_Statement
(Loc
,
2448 Make_Attribute_Reference
(Loc
,
2450 Make_Selected_Component
(Loc
,
2452 Make_Explicit_Dereference
(Loc
,
2453 Unchecked_Convert_To
(Acc_Type
,
2454 Make_Identifier
(Loc
, Name_uO
))),
2456 New_Occurrence_Of
(Iface_Comp
, Loc
)),
2457 Attribute_Name
=> Name_Position
))))));
2459 Mutate_Ekind
(Func_Id
, E_Function
);
2460 Set_Mechanism
(Func_Id
, Default_Mechanism
);
2461 Set_Is_Internal
(Func_Id
, True);
2463 if not Debug_Generated_Code
then
2464 Set_Debug_Info_Off
(Func_Id
);
2467 Analyze
(Body_Node
);
2469 Append_Freeze_Action
(Rec_Type
, Body_Node
);
2470 end Build_Offset_To_Top_Function
;
2474 Iface_Comp
: Node_Id
;
2475 Iface_Comp_Elmt
: Elmt_Id
;
2476 Ifaces_Comp_List
: Elist_Id
;
2478 -- Start of processing for Build_Offset_To_Top_Functions
2481 -- Offset_To_Top_Functions are built only for derivations of types
2482 -- with discriminants that cover interface types.
2483 -- Nothing is needed either in case of virtual targets, since
2484 -- interfaces are handled directly by the target.
2486 if not Is_Tagged_Type
(Rec_Type
)
2487 or else Etype
(Rec_Type
) = Rec_Type
2488 or else not Has_Discriminants
(Etype
(Rec_Type
))
2489 or else not Tagged_Type_Expansion
2494 Collect_Interface_Components
(Rec_Type
, Ifaces_Comp_List
);
2496 -- For each interface type with secondary dispatch table we generate
2497 -- the Offset_To_Top_Functions (required to displace the pointer in
2498 -- interface conversions)
2500 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
2501 while Present
(Iface_Comp_Elmt
) loop
2502 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
2503 pragma Assert
(Is_Interface
(Related_Type
(Iface_Comp
)));
2505 -- If the interface is a parent of Rec_Type it shares the primary
2506 -- dispatch table and hence there is no need to build the function
2508 if not Is_Ancestor
(Related_Type
(Iface_Comp
), Rec_Type
,
2509 Use_Full_View
=> True)
2511 Build_Offset_To_Top_Function
(Iface_Comp
);
2514 Next_Elmt
(Iface_Comp_Elmt
);
2516 end Build_Offset_To_Top_Functions
;
2518 ------------------------------
2519 -- Build_CPP_Init_Procedure --
2520 ------------------------------
2522 procedure Build_CPP_Init_Procedure
is
2523 Body_Node
: Node_Id
;
2524 Body_Stmts
: List_Id
;
2525 Flag_Id
: Entity_Id
;
2526 Handled_Stmt_Node
: Node_Id
;
2527 Init_Tags_List
: List_Id
;
2528 Proc_Id
: Entity_Id
;
2529 Proc_Spec_Node
: Node_Id
;
2532 -- Check cases requiring no IC routine
2534 if not Is_CPP_Class
(Root_Type
(Rec_Type
))
2535 or else Is_CPP_Class
(Rec_Type
)
2536 or else CPP_Num_Prims
(Rec_Type
) = 0
2537 or else not Tagged_Type_Expansion
2538 or else No_Run_Time_Mode
2545 -- Flag : Boolean := False;
2547 -- procedure Typ_IC is
2550 -- Copy C++ dispatch table slots from parent
2551 -- Update C++ slots of overridden primitives
2555 Flag_Id
:= Make_Temporary
(Loc
, 'F');
2557 Append_Freeze_Action
(Rec_Type
,
2558 Make_Object_Declaration
(Loc
,
2559 Defining_Identifier
=> Flag_Id
,
2560 Object_Definition
=>
2561 New_Occurrence_Of
(Standard_Boolean
, Loc
),
2563 New_Occurrence_Of
(Standard_True
, Loc
)));
2565 Body_Stmts
:= New_List
;
2566 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2568 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
2571 Make_Defining_Identifier
(Loc
,
2572 Chars
=> Make_TSS_Name
(Rec_Type
, TSS_CPP_Init_Proc
));
2574 Mutate_Ekind
(Proc_Id
, E_Procedure
);
2575 Set_Is_Internal
(Proc_Id
);
2577 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
2579 Set_Parameter_Specifications
(Proc_Spec_Node
, New_List
);
2580 Set_Specification
(Body_Node
, Proc_Spec_Node
);
2581 Set_Declarations
(Body_Node
, New_List
);
2583 Init_Tags_List
:= Build_Inherit_CPP_Prims
(Rec_Type
);
2585 Append_To
(Init_Tags_List
,
2586 Make_Assignment_Statement
(Loc
,
2588 New_Occurrence_Of
(Flag_Id
, Loc
),
2590 New_Occurrence_Of
(Standard_False
, Loc
)));
2592 Append_To
(Body_Stmts
,
2593 Make_If_Statement
(Loc
,
2594 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2595 Then_Statements
=> Init_Tags_List
));
2597 Handled_Stmt_Node
:=
2598 New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
2599 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
2600 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
2601 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
2603 if not Debug_Generated_Code
then
2604 Set_Debug_Info_Off
(Proc_Id
);
2607 -- Associate CPP_Init_Proc with type
2609 Set_Init_Proc
(Rec_Type
, Proc_Id
);
2610 end Build_CPP_Init_Procedure
;
2612 --------------------------
2613 -- Build_Init_Procedure --
2614 --------------------------
2616 procedure Build_Init_Procedure
is
2617 Body_Stmts
: List_Id
;
2618 Body_Node
: Node_Id
;
2619 Handled_Stmt_Node
: Node_Id
;
2620 Init_Tags_List
: List_Id
;
2621 Parameters
: List_Id
;
2622 Proc_Spec_Node
: Node_Id
;
2623 Record_Extension_Node
: Node_Id
;
2625 use Initialization_Control
;
2627 Body_Stmts
:= New_List
;
2628 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2629 Mutate_Ekind
(Proc_Id
, E_Procedure
);
2631 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
2632 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
2634 Parameters
:= Init_Formals
(Rec_Type
, Proc_Id
);
2635 Append_List_To
(Parameters
,
2636 Build_Discriminant_Formals
(Rec_Type
, True));
2638 -- For tagged types, we add a parameter to indicate what
2639 -- portion of the object's initialization is to be performed.
2640 -- This is used for two purposes:
2641 -- 1) When a type extension's initialization procedure calls
2642 -- the initialization procedure of the parent type, we do
2643 -- not want the parent to initialize the Tag component;
2644 -- it has been set already.
2645 -- 2) If an ancestor type has at least one component that requires
2646 -- late initialization, then we need to be able to initialize
2647 -- those components separately after initializing any other
2650 if Is_Tagged_Type
(Rec_Type
) then
2651 Init_Control_Formal
:= Make_Temporary
(Loc
, 'P');
2653 Append_To
(Parameters
,
2654 Make_Parameter_Specification
(Loc
,
2655 Defining_Identifier
=> Init_Control_Formal
,
2657 New_Occurrence_Of
(Standard_Natural
, Loc
),
2658 Expression
=> Make_Mode_Literal
(Loc
, Full_Init
)));
2661 -- Create an extra accessibility parameter to capture the level of
2662 -- the object being initialized when its type is a limited record.
2664 if Is_Limited_Record
(Rec_Type
) then
2665 Append_To
(Parameters
,
2666 Make_Parameter_Specification
(Loc
,
2667 Defining_Identifier
=> Make_Defining_Identifier
2668 (Loc
, Name_uInit_Level
),
2670 New_Occurrence_Of
(Standard_Natural
, Loc
),
2672 Make_Integer_Literal
2673 (Loc
, Scope_Depth
(Standard_Standard
))));
2676 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
2677 Set_Specification
(Body_Node
, Proc_Spec_Node
);
2678 Set_Declarations
(Body_Node
, Decls
);
2680 -- N is a Derived_Type_Definition that renames the parameters of the
2681 -- ancestor type. We initialize it by expanding our discriminants and
2682 -- call the ancestor _init_proc with a type-converted object.
2684 if Parent_Subtype_Renaming_Discrims
then
2685 Append_List_To
(Body_Stmts
, Build_Init_Call_Thru
(Parameters
));
2687 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
2688 Build_Discriminant_Assignments
(Body_Stmts
);
2690 if not Null_Present
(Type_Definition
(N
)) then
2691 Append_List_To
(Body_Stmts
,
2692 Build_Init_Statements
(Component_List
(Type_Definition
(N
))));
2695 -- N is a Derived_Type_Definition with a possible non-empty
2696 -- extension. The initialization of a type extension consists in the
2697 -- initialization of the components in the extension.
2700 Build_Discriminant_Assignments
(Body_Stmts
);
2702 Record_Extension_Node
:=
2703 Record_Extension_Part
(Type_Definition
(N
));
2705 if not Null_Present
(Record_Extension_Node
) then
2707 Stmts
: constant List_Id
:=
2708 Build_Init_Statements
(
2709 Component_List
(Record_Extension_Node
));
2712 -- The parent field must be initialized first because the
2713 -- offset of the new discriminants may depend on it. This is
2714 -- not needed if the parent is an interface type because in
2715 -- such case the initialization of the _parent field was not
2718 if not Is_Interface
(Etype
(Rec_Ent
)) then
2720 Parent_IP
: constant Name_Id
:=
2721 Make_Init_Proc_Name
(Etype
(Rec_Ent
));
2722 Stmt
: Node_Id
:= First
(Stmts
);
2723 IP_Call
: Node_Id
:= Empty
;
2725 -- Look for a call to the parent IP associated with
2726 -- the record extension.
2727 -- The call will be inside not one but two
2728 -- if-statements (with the same condition). Testing
2729 -- the same Early_Init condition twice might seem
2730 -- redundant. However, as soon as we exit this loop,
2731 -- we are going to hoist the inner if-statement out
2732 -- of the outer one; the "redundant" test was built
2733 -- in anticipation of this hoisting.
2735 while Present
(Stmt
) loop
2736 if Nkind
(Stmt
) = N_If_Statement
then
2738 Then_Stmt1
: Node_Id
:=
2739 First
(Then_Statements
(Stmt
));
2740 Then_Stmt2
: Node_Id
;
2742 while Present
(Then_Stmt1
) loop
2743 if Nkind
(Then_Stmt1
) = N_If_Statement
then
2745 First
(Then_Statements
(Then_Stmt1
));
2747 if Nkind
(Then_Stmt2
) =
2748 N_Procedure_Call_Statement
2749 and then Chars
(Name
(Then_Stmt2
)) =
2752 -- IP_Call is a call wrapped in an
2754 IP_Call
:= Then_Stmt1
;
2766 -- If found then move it to the beginning of the
2767 -- statements of this IP routine
2769 if Present
(IP_Call
) then
2771 Prepend_List_To
(Body_Stmts
, New_List
(IP_Call
));
2776 Append_List_To
(Body_Stmts
, Stmts
);
2781 -- Add here the assignment to instantiate the Tag
2783 -- The assignment corresponds to the code:
2785 -- _Init._Tag := Typ'Tag;
2787 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2788 -- tags are represented implicitly in objects. It is also suppressed
2789 -- in case of CPP_Class types because in this case the tag is
2790 -- initialized in the C++ side.
2792 if Is_Tagged_Type
(Rec_Type
)
2793 and then Tagged_Type_Expansion
2794 and then not No_Run_Time_Mode
2796 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2797 -- the actual object and invoke the IP of the parent (in this
2798 -- order). The tag must be initialized before the call to the IP
2799 -- of the parent and the assignments to other components because
2800 -- the initial value of the components may depend on the tag (eg.
2801 -- through a dispatching operation on an access to the current
2802 -- type). The tag assignment is not done when initializing the
2803 -- parent component of a type extension, because in that case the
2804 -- tag is set in the extension.
2806 if not Is_CPP_Class
(Root_Type
(Rec_Type
)) then
2808 -- Initialize the primary tag component
2810 Init_Tags_List
:= New_List
(
2811 Make_Assignment_Statement
(Loc
,
2813 Make_Selected_Component
(Loc
,
2814 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2817 (First_Tag_Component
(Rec_Type
), Loc
)),
2821 (First_Elmt
(Access_Disp_Table
(Rec_Type
))), Loc
)));
2823 -- Ada 2005 (AI-251): Initialize the secondary tags components
2824 -- located at fixed positions (tags whose position depends on
2825 -- variable size components are initialized later ---see below)
2827 if Ada_Version
>= Ada_2005
2828 and then not Is_Interface
(Rec_Type
)
2829 and then Has_Interfaces
(Rec_Type
)
2832 Elab_Sec_DT_Stmts_List
: constant List_Id
:= New_List
;
2833 Elab_List
: List_Id
:= New_List
;
2838 Target
=> Make_Identifier
(Loc
, Name_uInit
),
2839 Init_Tags_List
=> Init_Tags_List
,
2840 Stmts_List
=> Elab_Sec_DT_Stmts_List
,
2841 Fixed_Comps
=> True,
2842 Variable_Comps
=> False);
2844 Elab_List
:= New_List
(
2845 Make_If_Statement
(Loc
,
2847 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
2848 Then_Statements
=> Init_Tags_List
));
2850 if Elab_Flag_Needed
(Rec_Type
) then
2851 Append_To
(Elab_Sec_DT_Stmts_List
,
2852 Make_Assignment_Statement
(Loc
,
2855 (Access_Disp_Table_Elab_Flag
(Rec_Type
),
2858 New_Occurrence_Of
(Standard_False
, Loc
)));
2860 Append_To
(Elab_List
,
2861 Make_If_Statement
(Loc
,
2864 (Access_Disp_Table_Elab_Flag
(Rec_Type
), Loc
),
2865 Then_Statements
=> Elab_Sec_DT_Stmts_List
));
2868 Prepend_List_To
(Body_Stmts
, Elab_List
);
2871 Prepend_To
(Body_Stmts
,
2872 Make_If_Statement
(Loc
,
2874 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
2875 Then_Statements
=> Init_Tags_List
));
2878 -- Case 2: CPP type. The imported C++ constructor takes care of
2879 -- tags initialization. No action needed here because the IP
2880 -- is built by Set_CPP_Constructors; in this case the IP is a
2881 -- wrapper that invokes the C++ constructor and copies the C++
2882 -- tags locally. Done to inherit the C++ slots in Ada derivations
2885 elsif Is_CPP_Class
(Rec_Type
) then
2886 pragma Assert
(False);
2889 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2890 -- type derivations. Derivations of imported C++ classes add a
2891 -- complication, because we cannot inhibit tag setting in the
2892 -- constructor for the parent. Hence we initialize the tag after
2893 -- the call to the parent IP (that is, in reverse order compared
2894 -- with pure Ada hierarchies ---see comment on case 1).
2897 -- Initialize the primary tag
2899 Init_Tags_List
:= New_List
(
2900 Make_Assignment_Statement
(Loc
,
2902 Make_Selected_Component
(Loc
,
2903 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2906 (First_Tag_Component
(Rec_Type
), Loc
)),
2910 (First_Elmt
(Access_Disp_Table
(Rec_Type
))), Loc
)));
2912 -- Ada 2005 (AI-251): Initialize the secondary tags components
2913 -- located at fixed positions (tags whose position depends on
2914 -- variable size components are initialized later ---see below)
2916 if Ada_Version
>= Ada_2005
2917 and then not Is_Interface
(Rec_Type
)
2918 and then Has_Interfaces
(Rec_Type
)
2922 Target
=> Make_Identifier
(Loc
, Name_uInit
),
2923 Init_Tags_List
=> Init_Tags_List
,
2924 Stmts_List
=> Init_Tags_List
,
2925 Fixed_Comps
=> True,
2926 Variable_Comps
=> False);
2929 -- Initialize the tag component after invocation of parent IP.
2932 -- parent_IP(_init.parent); // Invokes the C++ constructor
2933 -- [ typIC; ] // Inherit C++ slots from parent
2940 -- Search for the call to the IP of the parent. We assume
2941 -- that the first init_proc call is for the parent.
2942 -- It is wrapped in an "if Early_Init_Condition"
2945 Ins_Nod
:= First
(Body_Stmts
);
2946 while Present
(Next
(Ins_Nod
))
2948 (Nkind
(Ins_Nod
) /= N_If_Statement
2949 or else (Nkind
(First
(Then_Statements
(Ins_Nod
)))
2950 /= N_Procedure_Call_Statement
)
2951 or else not Is_Init_Proc
2952 (Name
(First
(Then_Statements
2958 -- The IC routine copies the inherited slots of the C+ part
2959 -- of the dispatch table from the parent and updates the
2960 -- overridden C++ slots.
2962 if CPP_Num_Prims
(Rec_Type
) > 0 then
2964 Init_DT
: Entity_Id
;
2968 Init_DT
:= CPP_Init_Proc
(Rec_Type
);
2969 pragma Assert
(Present
(Init_DT
));
2972 Make_Procedure_Call_Statement
(Loc
,
2973 New_Occurrence_Of
(Init_DT
, Loc
));
2974 Insert_After
(Ins_Nod
, New_Nod
);
2976 -- Update location of init tag statements
2982 Insert_List_After
(Ins_Nod
, Init_Tags_List
);
2986 -- Ada 2005 (AI-251): Initialize the secondary tag components
2987 -- located at variable positions. We delay the generation of this
2988 -- code until here because the value of the attribute 'Position
2989 -- applied to variable size components of the parent type that
2990 -- depend on discriminants is only safely read at runtime after
2991 -- the parent components have been initialized.
2993 if Ada_Version
>= Ada_2005
2994 and then not Is_Interface
(Rec_Type
)
2995 and then Has_Interfaces
(Rec_Type
)
2996 and then Has_Discriminants
(Etype
(Rec_Type
))
2997 and then Is_Variable_Size_Record
(Etype
(Rec_Type
))
2999 Init_Tags_List
:= New_List
;
3003 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3004 Init_Tags_List
=> Init_Tags_List
,
3005 Stmts_List
=> Init_Tags_List
,
3006 Fixed_Comps
=> False,
3007 Variable_Comps
=> True);
3009 Append_List_To
(Body_Stmts
, Init_Tags_List
);
3013 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
3014 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
3017 -- Deep_Finalize (_init, C1, ..., CN);
3021 and then Needs_Finalization
(Rec_Type
)
3022 and then not Is_Abstract_Type
(Rec_Type
)
3023 and then not Restriction_Active
(No_Exception_Propagation
)
3030 -- Create a local version of Deep_Finalize which has indication
3031 -- of partial initialization state.
3034 Make_Defining_Identifier
(Loc
,
3035 Chars
=> New_External_Name
(Name_uFinalizer
));
3037 Append_To
(Decls
, Make_Local_Deep_Finalize
(Rec_Type
, DF_Id
));
3040 Make_Procedure_Call_Statement
(Loc
,
3041 Name
=> New_Occurrence_Of
(DF_Id
, Loc
),
3042 Parameter_Associations
=> New_List
(
3043 Make_Identifier
(Loc
, Name_uInit
),
3044 New_Occurrence_Of
(Standard_False
, Loc
)));
3046 -- Do not emit warnings related to the elaboration order when a
3047 -- controlled object is declared before the body of Finalize is
3050 if Legacy_Elaboration_Checks
then
3051 Set_No_Elaboration_Check
(DF_Call
);
3054 Set_Exception_Handlers
(Handled_Stmt_Node
, New_List
(
3055 Make_Exception_Handler
(Loc
,
3056 Exception_Choices
=> New_List
(
3057 Make_Others_Choice
(Loc
)),
3058 Statements
=> New_List
(
3060 Make_Raise_Statement
(Loc
)))));
3063 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
3066 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
3068 if not Debug_Generated_Code
then
3069 Set_Debug_Info_Off
(Proc_Id
);
3072 -- Associate Init_Proc with type, and determine if the procedure
3073 -- is null (happens because of the Initialize_Scalars pragma case,
3074 -- where we have to generate a null procedure in case it is called
3075 -- by a client with Initialize_Scalars set). Such procedures have
3076 -- to be generated, but do not have to be called, so we mark them
3077 -- as null to suppress the call. Kill also warnings for the _Init
3078 -- out parameter, which is left entirely uninitialized.
3080 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3082 if Is_Null_Statement_List
(Body_Stmts
) then
3083 Set_Is_Null_Init_Proc
(Proc_Id
);
3084 Set_Warnings_Off
(Defining_Identifier
(First
(Parameters
)));
3086 end Build_Init_Procedure
;
3088 ---------------------------
3089 -- Build_Init_Statements --
3090 ---------------------------
3092 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
3093 Checks
: constant List_Id
:= New_List
;
3094 Actions
: List_Id
:= No_List
;
3095 Counter_Id
: Entity_Id
:= Empty
;
3096 Comp_Loc
: Source_Ptr
;
3099 Parent_Stmts
: List_Id
;
3100 Parent_Id
: Entity_Id
:= Empty
;
3101 Stmts
, Late_Stmts
: List_Id
:= Empty_List
;
3104 procedure Increment_Counter
3105 (Loc
: Source_Ptr
; Late
: Boolean := False);
3106 -- Generate an "increment by one" statement for the current counter
3107 -- and append it to the appropriate statement list.
3109 procedure Make_Counter
(Loc
: Source_Ptr
);
3110 -- Create a new counter for the current component list. The routine
3111 -- creates a new defining Id, adds an object declaration and sets
3112 -- the Id generator for the next variant.
3114 -----------------------
3115 -- Increment_Counter --
3116 -----------------------
3118 procedure Increment_Counter
3119 (Loc
: Source_Ptr
; Late
: Boolean := False) is
3122 -- Counter := Counter + 1;
3124 Append_To
((if Late
then Late_Stmts
else Stmts
),
3125 Make_Assignment_Statement
(Loc
,
3126 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3129 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3130 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
3131 end Increment_Counter
;
3137 procedure Make_Counter
(Loc
: Source_Ptr
) is
3139 -- Increment the Id generator
3141 Counter
:= Counter
+ 1;
3143 -- Create the entity and declaration
3146 Make_Defining_Identifier
(Loc
,
3147 Chars
=> New_External_Name
('C', Counter
));
3150 -- Cnn : Integer := 0;
3153 Make_Object_Declaration
(Loc
,
3154 Defining_Identifier
=> Counter_Id
,
3155 Object_Definition
=>
3156 New_Occurrence_Of
(Standard_Integer
, Loc
),
3158 Make_Integer_Literal
(Loc
, 0)));
3161 -- Start of processing for Build_Init_Statements
3164 if Null_Present
(Comp_List
) then
3165 return New_List
(Make_Null_Statement
(Loc
));
3168 Parent_Stmts
:= New_List
;
3171 -- Loop through visible declarations of task types and protected
3172 -- types moving any expanded code from the spec to the body of the
3175 if Is_Concurrent_Record_Type
(Rec_Type
) then
3177 Decl
: constant Node_Id
:=
3178 Parent
(Corresponding_Concurrent_Type
(Rec_Type
));
3184 if Is_Task_Record_Type
(Rec_Type
) then
3185 Def
:= Task_Definition
(Decl
);
3187 Def
:= Protected_Definition
(Decl
);
3190 if Present
(Def
) then
3191 N1
:= First
(Visible_Declarations
(Def
));
3192 while Present
(N1
) loop
3196 if Nkind
(N2
) in N_Statement_Other_Than_Procedure_Call
3197 or else Nkind
(N2
) in N_Raise_xxx_Error
3198 or else Nkind
(N2
) = N_Procedure_Call_Statement
3201 New_Copy_Tree
(N2
, New_Scope
=> Proc_Id
));
3202 Rewrite
(N2
, Make_Null_Statement
(Sloc
(N2
)));
3210 -- Loop through components, skipping pragmas, in 2 steps. The first
3211 -- step deals with regular components. The second step deals with
3212 -- components that require late initialization.
3214 -- First pass : regular components
3216 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
3217 while Present
(Decl
) loop
3218 Comp_Loc
:= Sloc
(Decl
);
3220 (Subtype_Indication
(Component_Definition
(Decl
)), Checks
);
3222 Id
:= Defining_Identifier
(Decl
);
3225 -- Leave any processing of component requiring late initialization
3226 -- for the second pass.
3228 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
) then
3229 if not Has_Late_Init_Comp
then
3230 Late_Stmts
:= New_List
;
3232 Has_Late_Init_Comp
:= True;
3234 -- Regular component cases
3237 -- In the context of the init proc, references to discriminants
3238 -- resolve to denote the discriminals: this is where we can
3239 -- freeze discriminant dependent component subtypes.
3241 if not Is_Frozen
(Typ
) then
3242 Append_List_To
(Stmts
, Freeze_Entity
(Typ
, N
));
3245 -- Explicit initialization
3247 if Present
(Expression
(Decl
)) then
3248 if Is_CPP_Constructor_Call
(Expression
(Decl
)) then
3250 Build_Initialization_Call
3253 Make_Selected_Component
(Comp_Loc
,
3255 Make_Identifier
(Comp_Loc
, Name_uInit
),
3257 New_Occurrence_Of
(Id
, Comp_Loc
)),
3259 In_Init_Proc
=> True,
3260 Enclos_Type
=> Rec_Type
,
3261 Discr_Map
=> Discr_Map
,
3262 Constructor_Ref
=> Expression
(Decl
));
3264 Actions
:= Build_Assignment
(Id
, Expression
(Decl
));
3267 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3268 -- components are filled in with the corresponding rep-item
3269 -- expression of the concurrent type (if any).
3271 elsif Ekind
(Scope
(Id
)) = E_Record_Type
3272 and then Present
(Corresponding_Concurrent_Type
(Scope
(Id
)))
3273 and then Chars
(Id
) in Name_uCPU
3274 | Name_uDispatching_Domain
3276 | Name_uSecondary_Stack_Size
3281 pragma Warnings
(Off
, Nam
);
3285 if Chars
(Id
) = Name_uCPU
then
3288 elsif Chars
(Id
) = Name_uDispatching_Domain
then
3289 Nam
:= Name_Dispatching_Domain
;
3291 elsif Chars
(Id
) = Name_uPriority
then
3292 Nam
:= Name_Priority
;
3294 elsif Chars
(Id
) = Name_uSecondary_Stack_Size
then
3295 Nam
:= Name_Secondary_Stack_Size
;
3298 -- Get the Rep Item (aspect specification, attribute
3299 -- definition clause or pragma) of the corresponding
3304 (Corresponding_Concurrent_Type
(Scope
(Id
)),
3306 Check_Parents
=> False);
3308 if Present
(Ritem
) then
3312 if Nkind
(Ritem
) = N_Pragma
then
3315 (First
(Pragma_Argument_Associations
(Ritem
)));
3317 -- Conversion for Priority expression
3319 if Nam
= Name_Priority
then
3320 if Pragma_Name
(Ritem
) = Name_Priority
3321 and then not GNAT_Mode
3323 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3326 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3330 -- Aspect/Attribute definition clause case
3333 Exp
:= Expression
(Ritem
);
3335 -- Conversion for Priority expression
3337 if Nam
= Name_Priority
then
3338 if Chars
(Ritem
) = Name_Priority
3339 and then not GNAT_Mode
3341 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3344 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3349 -- Conversion for Dispatching_Domain value
3351 if Nam
= Name_Dispatching_Domain
then
3353 Unchecked_Convert_To
3354 (RTE
(RE_Dispatching_Domain_Access
), Exp
);
3356 -- Conversion for Secondary_Stack_Size value
3358 elsif Nam
= Name_Secondary_Stack_Size
then
3359 Exp
:= Convert_To
(RTE
(RE_Size_Type
), Exp
);
3362 Actions
:= Build_Assignment
(Id
, Exp
);
3364 -- Nothing needed if no Rep Item
3371 -- Composite component with its own Init_Proc
3373 elsif not Is_Interface
(Typ
)
3374 and then Has_Non_Null_Base_Init_Proc
(Typ
)
3377 use Initialization_Control
;
3378 Init_Control_Actual
: Node_Id
:= Empty
;
3379 Is_Parent
: constant Boolean := Chars
(Id
) = Name_uParent
;
3380 Init_Call_Stmts
: List_Id
;
3382 if Is_Parent
and then Has_Late_Init_Component
(Etype
(Id
))
3384 Init_Control_Actual
:=
3385 Make_Mode_Literal
(Comp_Loc
, Early_Init_Only
);
3386 -- Parent_Id used later in second call to parent's
3387 -- init proc to initialize late-init components.
3392 Build_Initialization_Call
3394 Make_Selected_Component
(Comp_Loc
,
3396 Make_Identifier
(Comp_Loc
, Name_uInit
),
3397 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
3399 In_Init_Proc
=> True,
3400 Enclos_Type
=> Rec_Type
,
3401 Discr_Map
=> Discr_Map
,
3402 Init_Control_Actual
=> Init_Control_Actual
);
3405 -- This is tricky. At first it looks like
3406 -- we are going to end up with nested
3407 -- if-statements with the same condition:
3408 -- if Early_Init_Condition then
3409 -- if Early_Init_Condition then
3410 -- Parent_TypeIP (...);
3413 -- But later we will hoist the inner if-statement
3414 -- out of the outer one; we do this because the
3415 -- init-proc call for the _Parent component of a type
3416 -- extension has to precede any other initialization.
3418 New_List
(Make_If_Statement
(Loc
,
3420 Early_Init_Condition
(Loc
, Init_Control_Formal
),
3421 Then_Statements
=> Init_Call_Stmts
));
3423 Actions
:= Init_Call_Stmts
;
3427 Clean_Task_Names
(Typ
, Proc_Id
);
3429 -- Simple initialization. If the Esize is not yet set, we pass
3430 -- Uint_0 as expected by Get_Simple_Init_Val.
3432 elsif Component_Needs_Simple_Initialization
(Typ
) then
3441 (if Known_Esize
(Id
) then Esize
(Id
)
3444 -- Nothing needed for this case
3450 -- When the component's type has a Default_Initial_Condition,
3451 -- and the component is default initialized, then check the
3455 and then No
(Expression
(Decl
))
3456 and then Present
(DIC_Procedure
(Typ
))
3457 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
3459 -- The DICs of ancestors are checked as part of the type's
3462 and then Chars
(Id
) /= Name_uParent
3464 -- In GNATprove mode, the component DICs are checked by other
3465 -- means. They should not be added to the record type DIC
3466 -- procedure, so that the procedure can be used to check the
3467 -- record type invariants or DICs if any.
3469 and then not GNATprove_Mode
3471 Append_New_To
(Actions
,
3474 Make_Selected_Component
(Comp_Loc
,
3476 Make_Identifier
(Comp_Loc
, Name_uInit
),
3478 New_Occurrence_Of
(Id
, Comp_Loc
)),
3482 if Present
(Checks
) then
3483 if Chars
(Id
) = Name_uParent
then
3484 Append_List_To
(Parent_Stmts
, Checks
);
3486 Append_List_To
(Stmts
, Checks
);
3490 if Present
(Actions
) then
3491 if Chars
(Id
) = Name_uParent
then
3492 Append_List_To
(Parent_Stmts
, Actions
);
3494 Append_List_To
(Stmts
, Actions
);
3496 -- Preserve initialization state in the current counter
3498 if Needs_Finalization
(Typ
) then
3499 if No
(Counter_Id
) then
3500 Make_Counter
(Comp_Loc
);
3503 Increment_Counter
(Comp_Loc
);
3509 Next_Non_Pragma
(Decl
);
3512 -- The parent field must be initialized first because variable
3513 -- size components of the parent affect the location of all the
3516 Prepend_List_To
(Stmts
, Parent_Stmts
);
3518 -- Set up tasks and protected object support. This needs to be done
3519 -- before any component with a per-object access discriminant
3520 -- constraint, or any variant part (which may contain such
3521 -- components) is initialized, because the initialization of these
3522 -- components may reference the enclosing concurrent object.
3524 -- For a task record type, add the task create call and calls to bind
3525 -- any interrupt (signal) entries.
3527 if Is_Task_Record_Type
(Rec_Type
) then
3529 -- In the case of the restricted run time the ATCB has already
3530 -- been preallocated.
3532 if Restricted_Profile
then
3534 Make_Assignment_Statement
(Loc
,
3536 Make_Selected_Component
(Loc
,
3537 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
3538 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3540 Make_Attribute_Reference
(Loc
,
3542 Make_Selected_Component
(Loc
,
3543 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
3544 Selector_Name
=> Make_Identifier
(Loc
, Name_uATCB
)),
3545 Attribute_Name
=> Name_Unchecked_Access
)));
3548 Append_To
(Stmts
, Make_Task_Create_Call
(Rec_Type
));
3551 Task_Type
: constant Entity_Id
:=
3552 Corresponding_Concurrent_Type
(Rec_Type
);
3553 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
3554 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
3555 Decl_Loc
: Source_Ptr
;
3560 if Present
(Task_Def
) then
3561 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
3562 while Present
(Vis_Decl
) loop
3563 Decl_Loc
:= Sloc
(Vis_Decl
);
3565 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
3566 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
3569 Ent
:= Entity
(Name
(Vis_Decl
));
3571 if Ekind
(Ent
) = E_Entry
then
3573 Make_Procedure_Call_Statement
(Decl_Loc
,
3575 New_Occurrence_Of
(RTE
(
3576 RE_Bind_Interrupt_To_Entry
), Decl_Loc
),
3577 Parameter_Associations
=> New_List
(
3578 Make_Selected_Component
(Decl_Loc
,
3580 Make_Identifier
(Decl_Loc
, Name_uInit
),
3583 (Decl_Loc
, Name_uTask_Id
)),
3584 Entry_Index_Expression
3585 (Decl_Loc
, Ent
, Empty
, Task_Type
),
3586 Expression
(Vis_Decl
))));
3596 -- For a protected type, add statements generated by
3597 -- Make_Initialize_Protection.
3599 elsif Is_Protected_Record_Type
(Rec_Type
) then
3600 Append_List_To
(Stmts
,
3601 Make_Initialize_Protection
(Rec_Type
));
3604 -- Second pass: components that require late initialization
3606 if Present
(Parent_Id
) then
3608 Parent_Loc
: constant Source_Ptr
:= Sloc
(Parent
(Parent_Id
));
3609 use Initialization_Control
;
3611 -- We are building the init proc for a type extension.
3612 -- Call the parent type's init proc a second time, this
3613 -- time to initialize the parent's components that require
3614 -- late initialization.
3616 Append_List_To
(Late_Stmts
,
3617 Build_Initialization_Call
3620 Make_Selected_Component
(Parent_Loc
,
3621 Prefix
=> Make_Identifier
3622 (Parent_Loc
, Name_uInit
),
3623 Selector_Name
=> New_Occurrence_Of
(Parent_Id
,
3625 Typ
=> Etype
(Parent_Id
),
3626 In_Init_Proc
=> True,
3627 Enclos_Type
=> Rec_Type
,
3628 Discr_Map
=> Discr_Map
,
3629 Init_Control_Actual
=> Make_Mode_Literal
3630 (Parent_Loc
, Late_Init_Only
)));
3634 if Has_Late_Init_Comp
then
3635 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
3636 while Present
(Decl
) loop
3637 Comp_Loc
:= Sloc
(Decl
);
3638 Id
:= Defining_Identifier
(Decl
);
3641 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
)
3643 if Present
(Expression
(Decl
)) then
3644 Append_List_To
(Late_Stmts
,
3645 Build_Assignment
(Id
, Expression
(Decl
)));
3647 elsif Has_Non_Null_Base_Init_Proc
(Typ
) then
3648 Append_List_To
(Late_Stmts
,
3649 Build_Initialization_Call
(Comp_Loc
,
3650 Make_Selected_Component
(Comp_Loc
,
3652 Make_Identifier
(Comp_Loc
, Name_uInit
),
3653 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
3655 In_Init_Proc
=> True,
3656 Enclos_Type
=> Rec_Type
,
3657 Discr_Map
=> Discr_Map
));
3659 Clean_Task_Names
(Typ
, Proc_Id
);
3661 -- Preserve initialization state in the current counter
3663 if Needs_Finalization
(Typ
) then
3664 if No
(Counter_Id
) then
3665 Make_Counter
(Comp_Loc
);
3668 Increment_Counter
(Comp_Loc
, Late
=> True);
3670 elsif Component_Needs_Simple_Initialization
(Typ
) then
3671 Append_List_To
(Late_Stmts
,
3678 Size
=> Esize
(Id
))));
3682 Next_Non_Pragma
(Decl
);
3686 -- Process the variant part (incorrectly ignoring late
3687 -- initialization requirements for components therein).
3689 if Present
(Variant_Part
(Comp_List
)) then
3691 Variant_Alts
: constant List_Id
:= New_List
;
3692 Var_Loc
: Source_Ptr
:= No_Location
;
3697 First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
3698 while Present
(Variant
) loop
3699 Var_Loc
:= Sloc
(Variant
);
3700 Append_To
(Variant_Alts
,
3701 Make_Case_Statement_Alternative
(Var_Loc
,
3703 New_Copy_List
(Discrete_Choices
(Variant
)),
3705 Build_Init_Statements
(Component_List
(Variant
))));
3706 Next_Non_Pragma
(Variant
);
3709 -- The expression of the case statement which is a reference
3710 -- to one of the discriminants is replaced by the appropriate
3711 -- formal parameter of the initialization procedure.
3714 Make_Case_Statement
(Var_Loc
,
3716 New_Occurrence_Of
(Discriminal
(
3717 Entity
(Name
(Variant_Part
(Comp_List
)))), Var_Loc
),
3718 Alternatives
=> Variant_Alts
));
3722 if No
(Init_Control_Formal
) then
3723 Append_List_To
(Stmts
, Late_Stmts
);
3725 -- If no initializations were generated for component declarations
3726 -- and included in Stmts, then append a null statement to Stmts
3727 -- to make it a valid Ada tree.
3729 if Is_Empty_List
(Stmts
) then
3730 Append
(Make_Null_Statement
(Loc
), Stmts
);
3736 use Initialization_Control
;
3738 If_Early
: constant Node_Id
:=
3739 (if Is_Empty_List
(Stmts
) then
3740 Make_Null_Statement
(Loc
)
3742 Make_If_Statement
(Loc
,
3744 Early_Init_Condition
(Loc
, Init_Control_Formal
),
3745 Then_Statements
=> Stmts
));
3746 If_Late
: constant Node_Id
:=
3747 (if Is_Empty_List
(Late_Stmts
) then
3748 Make_Null_Statement
(Loc
)
3750 Make_If_Statement
(Loc
,
3752 Late_Init_Condition
(Loc
, Init_Control_Formal
),
3753 Then_Statements
=> Late_Stmts
));
3755 return New_List
(If_Early
, If_Late
);
3759 when RE_Not_Available
=>
3761 end Build_Init_Statements
;
3763 -------------------------
3764 -- Build_Record_Checks --
3765 -------------------------
3767 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
3768 Subtype_Mark_Id
: Entity_Id
;
3770 procedure Constrain_Array
3772 Check_List
: List_Id
);
3773 -- Apply a list of index constraints to an unconstrained array type.
3774 -- The first parameter is the entity for the resulting subtype.
3775 -- Check_List is a list to which the check actions are appended.
3777 ---------------------
3778 -- Constrain_Array --
3779 ---------------------
3781 procedure Constrain_Array
3783 Check_List
: List_Id
)
3785 C
: constant Node_Id
:= Constraint
(SI
);
3786 Number_Of_Constraints
: Nat
:= 0;
3790 procedure Constrain_Index
3793 Check_List
: List_Id
);
3794 -- Process an index constraint in a constrained array declaration.
3795 -- The constraint can be either a subtype name or a range with or
3796 -- without an explicit subtype mark. Index is the corresponding
3797 -- index of the unconstrained array. S is the range expression.
3798 -- Check_List is a list to which the check actions are appended.
3800 ---------------------
3801 -- Constrain_Index --
3802 ---------------------
3804 procedure Constrain_Index
3807 Check_List
: List_Id
)
3809 T
: constant Entity_Id
:= Etype
(Index
);
3812 if Nkind
(S
) = N_Range
then
3813 Process_Range_Expr_In_Decl
(S
, T
, Check_List
=> Check_List
);
3815 end Constrain_Index
;
3817 -- Start of processing for Constrain_Array
3820 T
:= Entity
(Subtype_Mark
(SI
));
3822 if Is_Access_Type
(T
) then
3823 T
:= Designated_Type
(T
);
3826 S
:= First
(Constraints
(C
));
3827 while Present
(S
) loop
3828 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
3832 -- In either case, the index constraint must provide a discrete
3833 -- range for each index of the array type and the type of each
3834 -- discrete range must be the same as that of the corresponding
3835 -- index. (RM 3.6.1)
3837 S
:= First
(Constraints
(C
));
3838 Index
:= First_Index
(T
);
3841 -- Apply constraints to each index type
3843 for J
in 1 .. Number_Of_Constraints
loop
3844 Constrain_Index
(Index
, S
, Check_List
);
3848 end Constrain_Array
;
3850 -- Start of processing for Build_Record_Checks
3853 if Nkind
(S
) = N_Subtype_Indication
then
3854 Find_Type
(Subtype_Mark
(S
));
3855 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
3857 -- Remaining processing depends on type
3859 case Ekind
(Subtype_Mark_Id
) is
3861 Constrain_Array
(S
, Check_List
);
3867 end Build_Record_Checks
;
3869 -------------------------------------------
3870 -- Component_Needs_Simple_Initialization --
3871 -------------------------------------------
3873 function Component_Needs_Simple_Initialization
3874 (T
: Entity_Id
) return Boolean
3878 Needs_Simple_Initialization
(T
)
3879 and then not Is_RTE
(T
, RE_Tag
)
3881 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3883 and then not Is_RTE
(T
, RE_Interface_Tag
);
3884 end Component_Needs_Simple_Initialization
;
3886 --------------------------------------
3887 -- Parent_Subtype_Renaming_Discrims --
3888 --------------------------------------
3890 function Parent_Subtype_Renaming_Discrims
return Boolean is
3895 if Base_Type
(Rec_Ent
) /= Rec_Ent
then
3899 if Etype
(Rec_Ent
) = Rec_Ent
3900 or else not Has_Discriminants
(Rec_Ent
)
3901 or else Is_Constrained
(Rec_Ent
)
3902 or else Is_Tagged_Type
(Rec_Ent
)
3907 -- If there are no explicit stored discriminants we have inherited
3908 -- the root type discriminants so far, so no renamings occurred.
3910 if First_Discriminant
(Rec_Ent
) =
3911 First_Stored_Discriminant
(Rec_Ent
)
3916 -- Check if we have done some trivial renaming of the parent
3917 -- discriminants, i.e. something like
3919 -- type DT (X1, X2: int) is new PT (X1, X2);
3921 De
:= First_Discriminant
(Rec_Ent
);
3922 Dp
:= First_Discriminant
(Etype
(Rec_Ent
));
3923 while Present
(De
) loop
3924 pragma Assert
(Present
(Dp
));
3926 if Corresponding_Discriminant
(De
) /= Dp
then
3930 Next_Discriminant
(De
);
3931 Next_Discriminant
(Dp
);
3934 return Present
(Dp
);
3935 end Parent_Subtype_Renaming_Discrims
;
3937 ------------------------
3938 -- Requires_Init_Proc --
3939 ------------------------
3941 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
3942 Comp_Decl
: Node_Id
;
3947 -- Definitely do not need one if specifically suppressed
3949 if Initialization_Suppressed
(Rec_Id
) then
3953 -- If it is a type derived from a type with unknown discriminants,
3954 -- we cannot build an initialization procedure for it.
3956 if Has_Unknown_Discriminants
(Rec_Id
)
3957 or else Has_Unknown_Discriminants
(Etype
(Rec_Id
))
3962 -- Otherwise we need to generate an initialization procedure if
3963 -- Is_CPP_Class is False and at least one of the following applies:
3965 -- 1. Discriminants are present, since they need to be initialized
3966 -- with the appropriate discriminant constraint expressions.
3967 -- However, the discriminant of an unchecked union does not
3968 -- count, since the discriminant is not present.
3970 -- 2. The type is a tagged type, since the implicit Tag component
3971 -- needs to be initialized with a pointer to the dispatch table.
3973 -- 3. The type contains tasks
3975 -- 4. One or more components has an initial value
3977 -- 5. One or more components is for a type which itself requires
3978 -- an initialization procedure.
3980 -- 6. One or more components is a type that requires simple
3981 -- initialization (see Needs_Simple_Initialization), except
3982 -- that types Tag and Interface_Tag are excluded, since fields
3983 -- of these types are initialized by other means.
3985 -- 7. The type is the record type built for a task type (since at
3986 -- the very least, Create_Task must be called)
3988 -- 8. The type is the record type built for a protected type (since
3989 -- at least Initialize_Protection must be called)
3991 -- 9. The type is marked as a public entity. The reason we add this
3992 -- case (even if none of the above apply) is to properly handle
3993 -- Initialize_Scalars. If a package is compiled without an IS
3994 -- pragma, and the client is compiled with an IS pragma, then
3995 -- the client will think an initialization procedure is present
3996 -- and call it, when in fact no such procedure is required, but
3997 -- since the call is generated, there had better be a routine
3998 -- at the other end of the call, even if it does nothing).
4000 -- Note: the reason we exclude the CPP_Class case is because in this
4001 -- case the initialization is performed by the C++ constructors, and
4002 -- the IP is built by Set_CPP_Constructors.
4004 if Is_CPP_Class
(Rec_Id
) then
4007 elsif Is_Interface
(Rec_Id
) then
4010 elsif (Has_Discriminants
(Rec_Id
)
4011 and then not Is_Unchecked_Union
(Rec_Id
))
4012 or else Is_Tagged_Type
(Rec_Id
)
4013 or else Is_Concurrent_Record_Type
(Rec_Id
)
4014 or else Has_Task
(Rec_Id
)
4019 Id
:= First_Component
(Rec_Id
);
4020 while Present
(Id
) loop
4021 Comp_Decl
:= Parent
(Id
);
4024 if Present
(Expression
(Comp_Decl
))
4025 or else Has_Non_Null_Base_Init_Proc
(Typ
)
4026 or else Component_Needs_Simple_Initialization
(Typ
)
4031 Next_Component
(Id
);
4034 -- As explained above, a record initialization procedure is needed
4035 -- for public types in case Initialize_Scalars applies to a client.
4036 -- However, such a procedure is not needed in the case where either
4037 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
4038 -- applies. No_Initialize_Scalars excludes the possibility of using
4039 -- Initialize_Scalars in any partition, and No_Default_Initialization
4040 -- implies that no initialization should ever be done for objects of
4041 -- the type, so is incompatible with Initialize_Scalars.
4043 if not Restriction_Active
(No_Initialize_Scalars
)
4044 and then not Restriction_Active
(No_Default_Initialization
)
4045 and then Is_Public
(Rec_Id
)
4051 end Requires_Init_Proc
;
4053 -- Start of processing for Build_Record_Init_Proc
4056 Rec_Type
:= Defining_Identifier
(N
);
4058 -- This may be full declaration of a private type, in which case
4059 -- the visible entity is a record, and the private entity has been
4060 -- exchanged with it in the private part of the current package.
4061 -- The initialization procedure is built for the record type, which
4062 -- is retrievable from the private entity.
4064 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
4065 Rec_Type
:= Underlying_Type
(Rec_Type
);
4068 -- If we have a variant record with restriction No_Implicit_Conditionals
4069 -- in effect, then we skip building the procedure. This is safe because
4070 -- if we can see the restriction, so can any caller, calls to initialize
4071 -- such records are not allowed for variant records if this restriction
4074 if Has_Variant_Part
(Rec_Type
)
4075 and then Restriction_Active
(No_Implicit_Conditionals
)
4080 -- If there are discriminants, build the discriminant map to replace
4081 -- discriminants by their discriminals in complex bound expressions.
4082 -- These only arise for the corresponding records of synchronized types.
4084 if Is_Concurrent_Record_Type
(Rec_Type
)
4085 and then Has_Discriminants
(Rec_Type
)
4090 Disc
:= First_Discriminant
(Rec_Type
);
4091 while Present
(Disc
) loop
4092 Append_Elmt
(Disc
, Discr_Map
);
4093 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
4094 Next_Discriminant
(Disc
);
4099 -- Derived types that have no type extension can use the initialization
4100 -- procedure of their parent and do not need a procedure of their own.
4101 -- This is only correct if there are no representation clauses for the
4102 -- type or its parent, and if the parent has in fact been frozen so
4103 -- that its initialization procedure exists.
4105 if Is_Derived_Type
(Rec_Type
)
4106 and then not Is_Tagged_Type
(Rec_Type
)
4107 and then not Is_Unchecked_Union
(Rec_Type
)
4108 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
4109 and then not Parent_Subtype_Renaming_Discrims
4110 and then Present
(Base_Init_Proc
(Etype
(Rec_Type
)))
4112 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
4114 -- Otherwise if we need an initialization procedure, then build one,
4115 -- mark it as public and inlinable and as having a completion.
4117 elsif Requires_Init_Proc
(Rec_Type
)
4118 or else Is_Unchecked_Union
(Rec_Type
)
4121 Make_Defining_Identifier
(Loc
,
4122 Chars
=> Make_Init_Proc_Name
(Rec_Type
));
4124 -- If No_Default_Initialization restriction is active, then we don't
4125 -- want to build an init_proc, but we need to mark that an init_proc
4126 -- would be needed if this restriction was not active (so that we can
4127 -- detect attempts to call it), so set a dummy init_proc in place.
4129 if Restriction_Active
(No_Default_Initialization
) then
4130 Set_Init_Proc
(Rec_Type
, Proc_Id
);
4134 Build_Offset_To_Top_Functions
;
4135 Build_CPP_Init_Procedure
;
4136 Build_Init_Procedure
;
4138 Set_Is_Public
(Proc_Id
, Is_Public
(Rec_Ent
));
4139 Set_Is_Internal
(Proc_Id
);
4140 Set_Has_Completion
(Proc_Id
);
4142 if not Debug_Generated_Code
then
4143 Set_Debug_Info_Off
(Proc_Id
);
4146 Set_Is_Inlined
(Proc_Id
, Inline_Init_Proc
(Rec_Type
));
4148 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4149 -- needed and may generate early references to non frozen types
4150 -- since we expand aggregate much more systematically.
4152 if Modify_Tree_For_C
then
4157 Agg
: constant Node_Id
:=
4158 Build_Equivalent_Record_Aggregate
(Rec_Type
);
4160 procedure Collect_Itypes
(Comp
: Node_Id
);
4161 -- Generate references to itypes in the aggregate, because
4162 -- the first use of the aggregate may be in a nested scope.
4164 --------------------
4165 -- Collect_Itypes --
4166 --------------------
4168 procedure Collect_Itypes
(Comp
: Node_Id
) is
4171 Typ
: constant Entity_Id
:= Etype
(Comp
);
4174 if Is_Array_Type
(Typ
) and then Is_Itype
(Typ
) then
4175 Ref
:= Make_Itype_Reference
(Loc
);
4176 Set_Itype
(Ref
, Typ
);
4177 Append_Freeze_Action
(Rec_Type
, Ref
);
4179 Ref
:= Make_Itype_Reference
(Loc
);
4180 Set_Itype
(Ref
, Etype
(First_Index
(Typ
)));
4181 Append_Freeze_Action
(Rec_Type
, Ref
);
4183 -- Recurse on nested arrays
4185 Sub_Aggr
:= First
(Expressions
(Comp
));
4186 while Present
(Sub_Aggr
) loop
4187 Collect_Itypes
(Sub_Aggr
);
4194 -- If there is a static initialization aggregate for the type,
4195 -- generate itype references for the types of its (sub)components,
4196 -- to prevent out-of-scope errors in the resulting tree.
4197 -- The aggregate may have been rewritten as a Raise node, in which
4198 -- case there are no relevant itypes.
4200 if Present
(Agg
) and then Nkind
(Agg
) = N_Aggregate
then
4201 Set_Static_Initialization
(Proc_Id
, Agg
);
4206 Comp
:= First
(Component_Associations
(Agg
));
4207 while Present
(Comp
) loop
4208 Collect_Itypes
(Expression
(Comp
));
4215 end Build_Record_Init_Proc
;
4217 ----------------------------
4218 -- Build_Slice_Assignment --
4219 ----------------------------
4221 -- Generates the following subprogram:
4223 -- procedure array_typeSA
4224 -- (Source, Target : Array_Type,
4225 -- Left_Lo, Left_Hi : Index;
4226 -- Right_Lo, Right_Hi : Index;
4233 -- if Left_Hi < Left_Lo then
4246 -- Target (Li1) := Source (Ri1);
4249 -- exit when Li1 = Left_Lo;
4250 -- Li1 := Index'pred (Li1);
4251 -- Ri1 := Index'pred (Ri1);
4253 -- exit when Li1 = Left_Hi;
4254 -- Li1 := Index'succ (Li1);
4255 -- Ri1 := Index'succ (Ri1);
4258 -- end array_typeSA;
4260 procedure Build_Slice_Assignment
(Typ
: Entity_Id
) is
4261 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4262 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
4264 Larray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4265 Rarray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4266 Left_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4267 Left_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4268 Right_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4269 Right_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4270 Rev
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
4271 -- Formal parameters of procedure
4273 Proc_Name
: constant Entity_Id
:=
4274 Make_Defining_Identifier
(Loc
,
4275 Chars
=> Make_TSS_Name
(Typ
, TSS_Slice_Assign
));
4277 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4278 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4279 -- Subscripts for left and right sides
4286 -- Build declarations for indexes
4291 Make_Object_Declaration
(Loc
,
4292 Defining_Identifier
=> Lnn
,
4293 Object_Definition
=>
4294 New_Occurrence_Of
(Index
, Loc
)));
4297 Make_Object_Declaration
(Loc
,
4298 Defining_Identifier
=> Rnn
,
4299 Object_Definition
=>
4300 New_Occurrence_Of
(Index
, Loc
)));
4304 -- Build test for empty slice case
4307 Make_If_Statement
(Loc
,
4310 Left_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
),
4311 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
)),
4312 Then_Statements
=> New_List
(Make_Simple_Return_Statement
(Loc
))));
4314 -- Build initializations for indexes
4317 F_Init
: constant List_Id
:= New_List
;
4318 B_Init
: constant List_Id
:= New_List
;
4322 Make_Assignment_Statement
(Loc
,
4323 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4324 Expression
=> New_Occurrence_Of
(Left_Lo
, Loc
)));
4327 Make_Assignment_Statement
(Loc
,
4328 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4329 Expression
=> New_Occurrence_Of
(Right_Lo
, Loc
)));
4332 Make_Assignment_Statement
(Loc
,
4333 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4334 Expression
=> New_Occurrence_Of
(Left_Hi
, Loc
)));
4337 Make_Assignment_Statement
(Loc
,
4338 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4339 Expression
=> New_Occurrence_Of
(Right_Hi
, Loc
)));
4342 Make_If_Statement
(Loc
,
4343 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4344 Then_Statements
=> B_Init
,
4345 Else_Statements
=> F_Init
));
4348 -- Now construct the assignment statement
4351 Make_Loop_Statement
(Loc
,
4352 Statements
=> New_List
(
4353 Make_Assignment_Statement
(Loc
,
4355 Make_Indexed_Component
(Loc
,
4356 Prefix
=> New_Occurrence_Of
(Larray
, Loc
),
4357 Expressions
=> New_List
(New_Occurrence_Of
(Lnn
, Loc
))),
4359 Make_Indexed_Component
(Loc
,
4360 Prefix
=> New_Occurrence_Of
(Rarray
, Loc
),
4361 Expressions
=> New_List
(New_Occurrence_Of
(Rnn
, Loc
))))),
4362 End_Label
=> Empty
);
4364 -- Build the exit condition and increment/decrement statements
4367 F_Ass
: constant List_Id
:= New_List
;
4368 B_Ass
: constant List_Id
:= New_List
;
4372 Make_Exit_Statement
(Loc
,
4375 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4376 Right_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
))));
4379 Make_Assignment_Statement
(Loc
,
4380 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4382 Make_Attribute_Reference
(Loc
,
4384 New_Occurrence_Of
(Index
, Loc
),
4385 Attribute_Name
=> Name_Succ
,
4386 Expressions
=> New_List
(
4387 New_Occurrence_Of
(Lnn
, Loc
)))));
4390 Make_Assignment_Statement
(Loc
,
4391 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4393 Make_Attribute_Reference
(Loc
,
4395 New_Occurrence_Of
(Index
, Loc
),
4396 Attribute_Name
=> Name_Succ
,
4397 Expressions
=> New_List
(
4398 New_Occurrence_Of
(Rnn
, Loc
)))));
4401 Make_Exit_Statement
(Loc
,
4404 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4405 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
))));
4408 Make_Assignment_Statement
(Loc
,
4409 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4411 Make_Attribute_Reference
(Loc
,
4413 New_Occurrence_Of
(Index
, Loc
),
4414 Attribute_Name
=> Name_Pred
,
4415 Expressions
=> New_List
(
4416 New_Occurrence_Of
(Lnn
, Loc
)))));
4419 Make_Assignment_Statement
(Loc
,
4420 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4422 Make_Attribute_Reference
(Loc
,
4424 New_Occurrence_Of
(Index
, Loc
),
4425 Attribute_Name
=> Name_Pred
,
4426 Expressions
=> New_List
(
4427 New_Occurrence_Of
(Rnn
, Loc
)))));
4429 Append_To
(Statements
(Loops
),
4430 Make_If_Statement
(Loc
,
4431 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4432 Then_Statements
=> B_Ass
,
4433 Else_Statements
=> F_Ass
));
4436 Append_To
(Stats
, Loops
);
4443 Formals
:= New_List
(
4444 Make_Parameter_Specification
(Loc
,
4445 Defining_Identifier
=> Larray
,
4446 Out_Present
=> True,
4448 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4450 Make_Parameter_Specification
(Loc
,
4451 Defining_Identifier
=> Rarray
,
4453 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4455 Make_Parameter_Specification
(Loc
,
4456 Defining_Identifier
=> Left_Lo
,
4458 New_Occurrence_Of
(Index
, Loc
)),
4460 Make_Parameter_Specification
(Loc
,
4461 Defining_Identifier
=> Left_Hi
,
4463 New_Occurrence_Of
(Index
, Loc
)),
4465 Make_Parameter_Specification
(Loc
,
4466 Defining_Identifier
=> Right_Lo
,
4468 New_Occurrence_Of
(Index
, Loc
)),
4470 Make_Parameter_Specification
(Loc
,
4471 Defining_Identifier
=> Right_Hi
,
4473 New_Occurrence_Of
(Index
, Loc
)));
4476 Make_Parameter_Specification
(Loc
,
4477 Defining_Identifier
=> Rev
,
4479 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4482 Make_Procedure_Specification
(Loc
,
4483 Defining_Unit_Name
=> Proc_Name
,
4484 Parameter_Specifications
=> Formals
);
4487 Make_Subprogram_Body
(Loc
,
4488 Specification
=> Spec
,
4489 Declarations
=> Decls
,
4490 Handled_Statement_Sequence
=>
4491 Make_Handled_Sequence_Of_Statements
(Loc
,
4492 Statements
=> Stats
)));
4495 Set_TSS
(Typ
, Proc_Name
);
4496 Set_Is_Pure
(Proc_Name
);
4497 end Build_Slice_Assignment
;
4499 -----------------------------
4500 -- Build_Untagged_Equality --
4501 -----------------------------
4503 procedure Build_Untagged_Equality
(Typ
: Entity_Id
) is
4510 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
;
4511 -- Check whether the type T has a user-defined primitive equality. If so
4512 -- return it, else return Empty. If true for a component of Typ, we have
4513 -- to build the primitive equality for it.
4515 ---------------------
4516 -- User_Defined_Eq --
4517 ---------------------
4519 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
is
4520 Op
: constant Entity_Id
:= TSS
(T
, TSS_Composite_Equality
);
4523 if Present
(Op
) then
4526 return Get_User_Defined_Equality
(T
);
4528 end User_Defined_Eq
;
4530 -- Start of processing for Build_Untagged_Equality
4533 -- If a record component has a primitive equality operation, we must
4534 -- build the corresponding one for the current type.
4537 Comp
:= First_Component
(Typ
);
4538 while Present
(Comp
) loop
4539 if Is_Record_Type
(Etype
(Comp
))
4540 and then Present
(User_Defined_Eq
(Etype
(Comp
)))
4546 Next_Component
(Comp
);
4549 -- If there is a user-defined equality for the type, we do not create
4550 -- the implicit one.
4552 Eq_Op
:= Get_User_Defined_Equality
(Typ
);
4553 if Present
(Eq_Op
) then
4554 if Comes_From_Source
(Eq_Op
) then
4561 -- If the type is derived, inherit the operation, if present, from the
4562 -- parent type. It may have been declared after the type derivation. If
4563 -- the parent type itself is derived, it may have inherited an operation
4564 -- that has itself been overridden, so update its alias and related
4565 -- flags. Ditto for inequality.
4567 if No
(Eq_Op
) and then Is_Derived_Type
(Typ
) then
4568 Eq_Op
:= Get_User_Defined_Equality
(Etype
(Typ
));
4569 if Present
(Eq_Op
) then
4570 Copy_TSS
(Eq_Op
, Typ
);
4574 Op
: constant Entity_Id
:= User_Defined_Eq
(Typ
);
4575 NE_Op
: constant Entity_Id
:= Next_Entity
(Eq_Op
);
4578 if Present
(Op
) then
4579 Set_Alias
(Op
, Eq_Op
);
4580 Set_Is_Abstract_Subprogram
4581 (Op
, Is_Abstract_Subprogram
(Eq_Op
));
4583 if Chars
(Next_Entity
(Op
)) = Name_Op_Ne
then
4584 Set_Is_Abstract_Subprogram
4585 (Next_Entity
(Op
), Is_Abstract_Subprogram
(NE_Op
));
4592 -- If not inherited and not user-defined, build body as for a type with
4593 -- components of record type (i.e. a type for which "=" composes when
4594 -- used as a component in an outer composite type).
4598 Make_Eq_Body
(Typ
, Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
4599 Op
:= Defining_Entity
(Decl
);
4603 if Is_Library_Level_Entity
(Typ
) then
4607 end Build_Untagged_Equality
;
4609 -----------------------------------
4610 -- Build_Variant_Record_Equality --
4611 -----------------------------------
4615 -- function <<Body_Id>> (Left, Right : T) return Boolean is
4616 -- [ X : T renames Left; ]
4617 -- [ Y : T renames Right; ]
4618 -- -- The above renamings are generated only if the parameters of
4619 -- -- this built function (which are passed by the caller) are not
4620 -- -- named 'X' and 'Y'; these names are required to reuse several
4621 -- -- expander routines when generating this body.
4624 -- -- Compare discriminants
4626 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4630 -- -- Compare components
4632 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4636 -- -- Compare variant part
4640 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4645 -- if X.Cn /= Y.Cn or else ... then
4653 function Build_Variant_Record_Equality
4655 Body_Id
: Entity_Id
;
4656 Param_Specs
: List_Id
) return Node_Id
4658 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4659 Def
: constant Node_Id
:= Parent
(Typ
);
4660 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
4661 Left
: constant Entity_Id
:= Defining_Identifier
(First
(Param_Specs
));
4662 Right
: constant Entity_Id
:=
4663 Defining_Identifier
(Next
(First
(Param_Specs
)));
4664 Decls
: constant List_Id
:= New_List
;
4665 Stmts
: constant List_Id
:= New_List
;
4667 Subp_Body
: Node_Id
;
4670 pragma Assert
(not Is_Tagged_Type
(Typ
));
4672 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
4673 -- the name of the formals must be X and Y; otherwise we generate two
4674 -- renaming declarations for such purpose.
4676 if Chars
(Left
) /= Name_X
then
4678 Make_Object_Renaming_Declaration
(Loc
,
4679 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
4680 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4681 Name
=> Make_Identifier
(Loc
, Chars
(Left
))));
4684 if Chars
(Right
) /= Name_Y
then
4686 Make_Object_Renaming_Declaration
(Loc
,
4687 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
4688 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4689 Name
=> Make_Identifier
(Loc
, Chars
(Right
))));
4692 -- Unchecked_Unions require additional machinery to support equality.
4693 -- Two extra parameters (A and B) are added to the equality function
4694 -- parameter list for each discriminant of the type, in order to
4695 -- capture the inferred values of the discriminants in equality calls.
4696 -- The names of the parameters match the names of the corresponding
4697 -- discriminant, with an added suffix.
4699 if Is_Unchecked_Union
(Typ
) then
4704 Discr_Type
: Entity_Id
;
4705 New_Discrs
: Elist_Id
;
4708 New_Discrs
:= New_Elmt_List
;
4710 Discr
:= First_Discriminant
(Typ
);
4711 while Present
(Discr
) loop
4712 Discr_Type
:= Etype
(Discr
);
4715 Make_Defining_Identifier
(Loc
,
4716 Chars
=> New_External_Name
(Chars
(Discr
), 'A'));
4719 Make_Defining_Identifier
(Loc
,
4720 Chars
=> New_External_Name
(Chars
(Discr
), 'B'));
4722 -- Add new parameters to the parameter list
4724 Append_To
(Param_Specs
,
4725 Make_Parameter_Specification
(Loc
,
4726 Defining_Identifier
=> A
,
4728 New_Occurrence_Of
(Discr_Type
, Loc
)));
4730 Append_To
(Param_Specs
,
4731 Make_Parameter_Specification
(Loc
,
4732 Defining_Identifier
=> B
,
4734 New_Occurrence_Of
(Discr_Type
, Loc
)));
4736 Append_Elmt
(A
, New_Discrs
);
4738 -- Generate the following code to compare each of the inferred
4746 Make_If_Statement
(Loc
,
4749 Left_Opnd
=> New_Occurrence_Of
(A
, Loc
),
4750 Right_Opnd
=> New_Occurrence_Of
(B
, Loc
)),
4751 Then_Statements
=> New_List
(
4752 Make_Simple_Return_Statement
(Loc
,
4754 New_Occurrence_Of
(Standard_False
, Loc
)))));
4755 Next_Discriminant
(Discr
);
4758 -- Generate component-by-component comparison. Note that we must
4759 -- propagate the inferred discriminants formals to act as the case
4760 -- statement switch. Their value is added when an equality call on
4761 -- unchecked unions is expanded.
4763 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
, New_Discrs
));
4766 -- Normal case (not unchecked union)
4770 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
4771 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
4775 Make_Simple_Return_Statement
(Loc
,
4776 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
4779 Make_Subprogram_Body
(Loc
,
4781 Make_Function_Specification
(Loc
,
4782 Defining_Unit_Name
=> Body_Id
,
4783 Parameter_Specifications
=> Param_Specs
,
4784 Result_Definition
=>
4785 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
4786 Declarations
=> Decls
,
4787 Handled_Statement_Sequence
=>
4788 Make_Handled_Sequence_Of_Statements
(Loc
,
4789 Statements
=> Stmts
));
4792 end Build_Variant_Record_Equality
;
4794 -----------------------------
4795 -- Check_Stream_Attributes --
4796 -----------------------------
4798 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
4800 Par_Read
: constant Boolean :=
4801 Stream_Attribute_Available
(Typ
, TSS_Stream_Read
)
4802 and then not Has_Specified_Stream_Read
(Typ
);
4803 Par_Write
: constant Boolean :=
4804 Stream_Attribute_Available
(Typ
, TSS_Stream_Write
)
4805 and then not Has_Specified_Stream_Write
(Typ
);
4807 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
);
4808 -- Check that Comp has a user-specified Nam stream attribute
4814 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
) is
4816 -- Move this check to sem???
4818 if not Stream_Attribute_Available
(Etype
(Comp
), TSS_Nam
) then
4819 Error_Msg_Name_1
:= Nam
;
4821 ("|component& in limited extension must have% attribute", Comp
);
4825 -- Start of processing for Check_Stream_Attributes
4828 if Par_Read
or else Par_Write
then
4829 Comp
:= First_Component
(Typ
);
4830 while Present
(Comp
) loop
4831 if Comes_From_Source
(Comp
)
4832 and then Original_Record_Component
(Comp
) = Comp
4833 and then Is_Limited_Type
(Etype
(Comp
))
4836 Check_Attr
(Name_Read
, TSS_Stream_Read
);
4840 Check_Attr
(Name_Write
, TSS_Stream_Write
);
4844 Next_Component
(Comp
);
4847 end Check_Stream_Attributes
;
4849 ----------------------
4850 -- Clean_Task_Names --
4851 ----------------------
4853 procedure Clean_Task_Names
4855 Proc_Id
: Entity_Id
)
4859 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
4860 and then not Global_Discard_Names
4861 and then Tagged_Type_Expansion
4863 Set_Uses_Sec_Stack
(Proc_Id
);
4865 end Clean_Task_Names
;
4867 -------------------------------
4868 -- Copy_Discr_Checking_Funcs --
4869 -------------------------------
4871 procedure Copy_Discr_Checking_Funcs
(N
: Node_Id
) is
4872 Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
4873 Comp
: Entity_Id
:= First_Component
(Typ
);
4874 Old_Comp
: Entity_Id
:= First_Component
4875 (Base_Type
(Underlying_Type
(Etype
(Typ
))));
4877 while Present
(Comp
) loop
4878 if Chars
(Comp
) = Chars
(Old_Comp
) then
4879 Set_Discriminant_Checking_Func
4880 (Comp
, Discriminant_Checking_Func
(Old_Comp
));
4883 Next_Component
(Old_Comp
);
4884 Next_Component
(Comp
);
4886 end Copy_Discr_Checking_Funcs
;
4888 ------------------------------
4889 -- Expand_Freeze_Array_Type --
4890 ------------------------------
4892 procedure Expand_Freeze_Array_Type
(N
: Node_Id
) is
4893 Typ
: constant Entity_Id
:= Entity
(N
);
4894 Base
: constant Entity_Id
:= Base_Type
(Typ
);
4895 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4898 if not Is_Bit_Packed_Array
(Typ
) then
4900 -- If the component contains tasks, so does the array type. This may
4901 -- not be indicated in the array type because the component may have
4902 -- been a private type at the point of definition. Same if component
4903 -- type is controlled or contains protected objects.
4905 Propagate_Concurrent_Flags
(Base
, Comp_Typ
);
4906 Set_Has_Controlled_Component
4907 (Base
, Has_Controlled_Component
(Comp_Typ
)
4908 or else Is_Controlled
(Comp_Typ
));
4910 if No
(Init_Proc
(Base
)) then
4912 -- If this is an anonymous array created for a declaration with
4913 -- an initial value, its init_proc will never be called. The
4914 -- initial value itself may have been expanded into assignments,
4915 -- in which case the object declaration is carries the
4916 -- No_Initialization flag.
4919 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
4920 N_Object_Declaration
4922 (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
4923 or else No_Initialization
(Associated_Node_For_Itype
(Base
)))
4927 -- We do not need an init proc for string or wide [wide] string,
4928 -- since the only time these need initialization in normalize or
4929 -- initialize scalars mode, and these types are treated specially
4930 -- and do not need initialization procedures.
4932 elsif Is_Standard_String_Type
(Base
) then
4935 -- Otherwise we have to build an init proc for the subtype
4938 Build_Array_Init_Proc
(Base
, N
);
4942 if Typ
= Base
and then Has_Controlled_Component
(Base
) then
4943 Build_Controlling_Procs
(Base
);
4945 if not Is_Limited_Type
(Comp_Typ
)
4946 and then Number_Dimensions
(Typ
) = 1
4948 Build_Slice_Assignment
(Typ
);
4952 -- For packed case, default initialization, except if the component type
4953 -- is itself a packed structure with an initialization procedure, or
4954 -- initialize/normalize scalars active, and we have a base type, or the
4955 -- type is public, because in that case a client might specify
4956 -- Normalize_Scalars and there better be a public Init_Proc for it.
4958 elsif (Present
(Init_Proc
(Component_Type
(Base
)))
4959 and then No
(Base_Init_Proc
(Base
)))
4960 or else (Init_Or_Norm_Scalars
and then Base
= Typ
)
4961 or else Is_Public
(Typ
)
4963 Build_Array_Init_Proc
(Base
, N
);
4965 end Expand_Freeze_Array_Type
;
4967 -----------------------------------
4968 -- Expand_Freeze_Class_Wide_Type --
4969 -----------------------------------
4971 procedure Expand_Freeze_Class_Wide_Type
(N
: Node_Id
) is
4972 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean;
4973 -- Given a type, determine whether it is derived from a C or C++ root
4975 ---------------------
4976 -- Is_C_Derivation --
4977 ---------------------
4979 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean is
4986 or else Convention
(T
) = Convention_C
4987 or else Convention
(T
) = Convention_CPP
4992 exit when T
= Etype
(T
);
4998 end Is_C_Derivation
;
5002 Typ
: constant Entity_Id
:= Entity
(N
);
5003 Root
: constant Entity_Id
:= Root_Type
(Typ
);
5005 -- Start of processing for Expand_Freeze_Class_Wide_Type
5008 -- Certain run-time configurations and targets do not provide support
5009 -- for controlled types.
5011 if Restriction_Active
(No_Finalization
) then
5014 -- Do not create TSS routine Finalize_Address when dispatching calls are
5015 -- disabled since the core of the routine is a dispatching call.
5017 elsif Restriction_Active
(No_Dispatching_Calls
) then
5020 -- Do not create TSS routine Finalize_Address for concurrent class-wide
5021 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
5022 -- non-Ada side will handle their destruction.
5024 elsif Is_Concurrent_Type
(Root
)
5025 or else Is_C_Derivation
(Root
)
5026 or else Convention
(Typ
) = Convention_CPP
5030 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
5031 -- mode since the routine contains an Unchecked_Conversion.
5033 elsif CodePeer_Mode
then
5037 -- Create the body of TSS primitive Finalize_Address. This automatically
5038 -- sets the TSS entry for the class-wide type.
5040 Make_Finalize_Address_Body
(Typ
);
5041 end Expand_Freeze_Class_Wide_Type
;
5043 ------------------------------------
5044 -- Expand_Freeze_Enumeration_Type --
5045 ------------------------------------
5047 procedure Expand_Freeze_Enumeration_Type
(N
: Node_Id
) is
5048 Typ
: constant Entity_Id
:= Entity
(N
);
5049 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5054 Is_Contiguous
: Boolean;
5055 Index_Typ
: Entity_Id
;
5063 pragma Warnings
(Off
, Func
);
5066 -- Various optimizations possible if given representation is contiguous
5068 Is_Contiguous
:= True;
5070 Ent
:= First_Literal
(Typ
);
5071 Last_Repval
:= Enumeration_Rep
(Ent
);
5075 while Present
(Ent
) loop
5076 if Enumeration_Rep
(Ent
) - Last_Repval
/= 1 then
5077 Is_Contiguous
:= False;
5079 Last_Repval
:= Enumeration_Rep
(Ent
);
5086 if Is_Contiguous
then
5087 Set_Has_Contiguous_Rep
(Typ
);
5089 -- Now build a subtype declaration
5091 -- subtype typI is new Natural range 0 .. num - 1
5094 Make_Defining_Identifier
(Loc
,
5095 Chars
=> New_External_Name
(Chars
(Typ
), 'I'));
5097 Append_Freeze_Action
(Typ
,
5098 Make_Subtype_Declaration
(Loc
,
5099 Defining_Identifier
=> Index_Typ
,
5100 Subtype_Indication
=>
5101 Make_Subtype_Indication
(Loc
,
5103 New_Occurrence_Of
(Standard_Natural
, Loc
),
5105 Make_Range_Constraint
(Loc
,
5109 Make_Integer_Literal
(Loc
, 0),
5111 Make_Integer_Literal
(Loc
, Num
- 1))))));
5113 Set_Enum_Pos_To_Rep
(Typ
, Index_Typ
);
5116 -- Build list of literal references
5119 Ent
:= First_Literal
(Typ
);
5120 while Present
(Ent
) loop
5121 Append_To
(Lst
, New_Occurrence_Of
(Ent
, Sloc
(Ent
)));
5125 -- Now build an array declaration
5127 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5128 -- (v, v, v, v, v, ....)
5131 Make_Defining_Identifier
(Loc
,
5132 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
5134 Append_Freeze_Action
(Typ
,
5135 Make_Object_Declaration
(Loc
,
5136 Defining_Identifier
=> Arr
,
5137 Constant_Present
=> True,
5139 Object_Definition
=>
5140 Make_Constrained_Array_Definition
(Loc
,
5141 Discrete_Subtype_Definitions
=> New_List
(
5142 Make_Subtype_Indication
(Loc
,
5144 New_Occurrence_Of
(Standard_Natural
, Loc
),
5146 Make_Range_Constraint
(Loc
,
5150 Make_Integer_Literal
(Loc
, 0),
5152 Make_Integer_Literal
(Loc
, Num
- 1))))),
5154 Component_Definition
=>
5155 Make_Component_Definition
(Loc
,
5156 Aliased_Present
=> False,
5157 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))),
5160 Make_Aggregate
(Loc
,
5161 Expressions
=> Lst
)));
5163 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
5166 -- Now we build the function that converts representation values to
5167 -- position values. This function has the form:
5169 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5172 -- when enum-lit'Enum_Rep => return posval;
5173 -- when enum-lit'Enum_Rep => return posval;
5176 -- [raise Constraint_Error when F "invalid data"]
5181 -- Note: the F parameter determines whether the others case (no valid
5182 -- representation) raises Constraint_Error or returns a unique value
5183 -- of minus one. The latter case is used, e.g. in 'Valid code.
5185 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5186 -- the code generator making inappropriate assumptions about the range
5187 -- of the values in the case where the value is invalid. ityp is a
5188 -- signed or unsigned integer type of appropriate width.
5190 -- Note: if exceptions are not supported, then we suppress the raise
5191 -- and return -1 unconditionally (this is an erroneous program in any
5192 -- case and there is no obligation to raise Constraint_Error here). We
5193 -- also do this if pragma Restrictions (No_Exceptions) is active.
5195 -- Is this right??? What about No_Exception_Propagation???
5197 -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly
5198 -- because it might have been inherited from the parent type.
5200 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
5201 Set_Is_Unsigned_Type
(Typ
, False);
5204 Ityp
:= Integer_Type_For
(Esize
(Typ
), Is_Unsigned_Type
(Typ
));
5206 -- The body of the function is a case statement. First collect case
5207 -- alternatives, or optimize the contiguous case.
5211 -- If representation is contiguous, Pos is computed by subtracting
5212 -- the representation of the first literal.
5214 if Is_Contiguous
then
5215 Ent
:= First_Literal
(Typ
);
5217 if Enumeration_Rep
(Ent
) = Last_Repval
then
5219 -- Another special case: for a single literal, Pos is zero
5221 Pos_Expr
:= Make_Integer_Literal
(Loc
, Uint_0
);
5225 Convert_To
(Standard_Integer
,
5226 Make_Op_Subtract
(Loc
,
5228 Unchecked_Convert_To
5229 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5231 Make_Integer_Literal
(Loc
,
5232 Intval
=> Enumeration_Rep
(First_Literal
(Typ
)))));
5236 Make_Case_Statement_Alternative
(Loc
,
5237 Discrete_Choices
=> New_List
(
5238 Make_Range
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5240 Make_Integer_Literal
(Loc
,
5241 Intval
=> Enumeration_Rep
(Ent
)),
5243 Make_Integer_Literal
(Loc
, Intval
=> Last_Repval
))),
5245 Statements
=> New_List
(
5246 Make_Simple_Return_Statement
(Loc
,
5247 Expression
=> Pos_Expr
))));
5250 Ent
:= First_Literal
(Typ
);
5251 while Present
(Ent
) loop
5253 Make_Case_Statement_Alternative
(Loc
,
5254 Discrete_Choices
=> New_List
(
5255 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5256 Intval
=> Enumeration_Rep
(Ent
))),
5258 Statements
=> New_List
(
5259 Make_Simple_Return_Statement
(Loc
,
5261 Make_Integer_Literal
(Loc
,
5262 Intval
=> Enumeration_Pos
(Ent
))))));
5268 -- In normal mode, add the others clause with the test.
5269 -- If Predicates_Ignored is True, validity checks do not apply to
5272 if not No_Exception_Handlers_Set
5273 and then not Predicates_Ignored
(Typ
)
5276 Make_Case_Statement_Alternative
(Loc
,
5277 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5278 Statements
=> New_List
(
5279 Make_Raise_Constraint_Error
(Loc
,
5280 Condition
=> Make_Identifier
(Loc
, Name_uF
),
5281 Reason
=> CE_Invalid_Data
),
5282 Make_Simple_Return_Statement
(Loc
,
5283 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5285 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5286 -- active then return -1 (we cannot usefully raise Constraint_Error in
5287 -- this case). See description above for further details.
5291 Make_Case_Statement_Alternative
(Loc
,
5292 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5293 Statements
=> New_List
(
5294 Make_Simple_Return_Statement
(Loc
,
5295 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5298 -- Now we can build the function body
5301 Make_Defining_Identifier
(Loc
, Make_TSS_Name
(Typ
, TSS_Rep_To_Pos
));
5304 Make_Subprogram_Body
(Loc
,
5306 Make_Function_Specification
(Loc
,
5307 Defining_Unit_Name
=> Fent
,
5308 Parameter_Specifications
=> New_List
(
5309 Make_Parameter_Specification
(Loc
,
5310 Defining_Identifier
=>
5311 Make_Defining_Identifier
(Loc
, Name_uA
),
5312 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
5313 Make_Parameter_Specification
(Loc
,
5314 Defining_Identifier
=>
5315 Make_Defining_Identifier
(Loc
, Name_uF
),
5317 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
5319 Result_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
5321 Declarations
=> Empty_List
,
5323 Handled_Statement_Sequence
=>
5324 Make_Handled_Sequence_Of_Statements
(Loc
,
5325 Statements
=> New_List
(
5326 Make_Case_Statement
(Loc
,
5328 Unchecked_Convert_To
5329 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5330 Alternatives
=> Lst
))));
5332 Set_TSS
(Typ
, Fent
);
5334 -- Set Pure flag (it will be reset if the current context is not Pure).
5335 -- We also pretend there was a pragma Pure_Function so that for purposes
5336 -- of optimization and constant-folding, we will consider the function
5337 -- Pure even if we are not in a Pure context).
5340 Set_Has_Pragma_Pure_Function
(Fent
);
5342 -- Unless we are in -gnatD mode, where we are debugging generated code,
5343 -- this is an internal entity for which we don't need debug info.
5345 if not Debug_Generated_Code
then
5346 Set_Debug_Info_Off
(Fent
);
5349 Set_Is_Inlined
(Fent
);
5352 when RE_Not_Available
=>
5354 end Expand_Freeze_Enumeration_Type
;
5356 -------------------------------
5357 -- Expand_Freeze_Record_Type --
5358 -------------------------------
5360 procedure Expand_Freeze_Record_Type
(N
: Node_Id
) is
5362 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
);
5363 -- Create internal subprograms of Typ primitives that have class-wide
5364 -- preconditions or postconditions; they are invoked by the caller to
5365 -- evaluate the conditions.
5367 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
5368 -- Create An Equality function for the untagged variant record Typ and
5369 -- attach it to the TSS list.
5371 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
);
5372 -- Register dispatch-table wrappers in the dispatch table of Typ
5374 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
);
5375 -- Check extra formals of dispatching primitives of tagged type Typ.
5376 -- Used in pragma Debug.
5378 ---------------------------------------
5379 -- Build_Class_Condition_Subprograms --
5380 ---------------------------------------
5382 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
) is
5383 Prim_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
5384 Prim_Elmt
: Elmt_Id
:= First_Elmt
(Prim_List
);
5388 while Present
(Prim_Elmt
) loop
5389 Prim
:= Node
(Prim_Elmt
);
5391 -- Primitive with class-wide preconditions
5393 if Comes_From_Source
(Prim
)
5394 and then Has_Significant_Contract
(Prim
)
5396 (Present
(Class_Preconditions
(Prim
))
5397 or else Present
(Ignored_Class_Preconditions
(Prim
)))
5399 if Expander_Active
then
5400 Make_Class_Precondition_Subps
(Prim
);
5403 -- Wrapper of a primitive that has or inherits class-wide
5406 elsif Is_Primitive_Wrapper
(Prim
)
5408 (Present
(Nearest_Class_Condition_Subprogram
5410 Kind
=> Class_Precondition
))
5412 Present
(Nearest_Class_Condition_Subprogram
5414 Kind
=> Ignored_Class_Precondition
)))
5416 if Expander_Active
then
5417 Make_Class_Precondition_Subps
(Prim
);
5421 Next_Elmt
(Prim_Elmt
);
5423 end Build_Class_Condition_Subprograms
;
5425 -----------------------------------
5426 -- Build_Variant_Record_Equality --
5427 -----------------------------------
5429 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
5430 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5431 F
: constant Entity_Id
:=
5432 Make_Defining_Identifier
(Loc
,
5433 Chars
=> Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
5435 -- For a variant record with restriction No_Implicit_Conditionals
5436 -- in effect we skip building the procedure. This is safe because
5437 -- if we can see the restriction, so can any caller, and calls to
5438 -- equality test routines are not allowed for variant records if
5439 -- this restriction is active.
5441 if Restriction_Active
(No_Implicit_Conditionals
) then
5445 -- Derived Unchecked_Union types no longer inherit the equality
5446 -- function of their parent.
5448 if Is_Derived_Type
(Typ
)
5449 and then not Is_Unchecked_Union
(Typ
)
5450 and then not Has_New_Non_Standard_Rep
(Typ
)
5453 Parent_Eq
: constant Entity_Id
:=
5454 TSS
(Root_Type
(Typ
), TSS_Composite_Equality
);
5456 if Present
(Parent_Eq
) then
5457 Copy_TSS
(Parent_Eq
, Typ
);
5464 Build_Variant_Record_Equality
5467 Param_Specs
=> New_List
(
5468 Make_Parameter_Specification
(Loc
,
5469 Defining_Identifier
=>
5470 Make_Defining_Identifier
(Loc
, Name_X
),
5471 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
5473 Make_Parameter_Specification
(Loc
,
5474 Defining_Identifier
=>
5475 Make_Defining_Identifier
(Loc
, Name_Y
),
5476 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))));
5481 if not Debug_Generated_Code
then
5482 Set_Debug_Info_Off
(F
);
5484 end Build_Variant_Record_Equality
;
5486 --------------------------------------
5487 -- Register_Dispatch_Table_Wrappers --
5488 --------------------------------------
5490 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
) is
5491 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
5495 while Present
(Elmt
) loop
5496 Subp
:= Node
(Elmt
);
5498 if Is_Dispatch_Table_Wrapper
(Subp
) then
5499 Append_Freeze_Actions
(Typ
,
5500 Register_Primitive
(Sloc
(Subp
), Subp
));
5505 end Register_Dispatch_Table_Wrappers
;
5507 ----------------------------------------
5508 -- Validate_Tagged_Type_Extra_Formals --
5509 ----------------------------------------
5511 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
) is
5512 Ovr_Subp
: Entity_Id
;
5517 pragma Assert
(not Is_Class_Wide_Type
(Typ
));
5519 -- No check required if expansion is not active since we never
5520 -- generate extra formals in such case.
5522 if not Expander_Active
then
5526 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5527 while Present
(Elmt
) loop
5528 Subp
:= Node
(Elmt
);
5530 -- Extra formals of a dispatching primitive must match:
5532 -- 1) The extra formals of its covered interface primitive
5534 if Present
(Interface_Alias
(Subp
)) then
5536 (Extra_Formals_Match_OK
5537 (E
=> Interface_Alias
(Subp
),
5538 Ref_E
=> Alias
(Subp
)));
5541 -- 2) The extra formals of its renamed primitive
5543 if Present
(Alias
(Subp
)) then
5545 (Extra_Formals_Match_OK
5547 Ref_E
=> Ultimate_Alias
(Subp
)));
5550 -- 3) The extra formals of its overridden primitive
5552 if Present
(Overridden_Operation
(Subp
)) then
5553 Ovr_Subp
:= Overridden_Operation
(Subp
);
5555 -- Handle controlling function wrapper
5557 if Is_Wrapper
(Subp
)
5558 and then Ultimate_Alias
(Ovr_Subp
) = Subp
5560 if Present
(Overridden_Operation
(Ovr_Subp
)) then
5562 (Extra_Formals_Match_OK
5564 Ref_E
=> Overridden_Operation
(Ovr_Subp
)));
5569 (Extra_Formals_Match_OK
5571 Ref_E
=> Ovr_Subp
));
5577 end Validate_Tagged_Type_Extra_Formals
;
5581 Typ
: constant Node_Id
:= Entity
(N
);
5582 Typ_Decl
: constant Node_Id
:= Parent
(Typ
);
5585 Comp_Typ
: Entity_Id
;
5586 Predef_List
: List_Id
;
5588 Wrapper_Decl_List
: List_Id
;
5589 Wrapper_Body_List
: List_Id
:= No_List
;
5591 Renamed_Eq
: Node_Id
:= Empty
;
5592 -- Defining unit name for the predefined equality function in the case
5593 -- where the type has a primitive operation that is a renaming of
5594 -- predefined equality (but only if there is also an overriding
5595 -- user-defined equality function). Used to pass this entity from
5596 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
5598 -- Start of processing for Expand_Freeze_Record_Type
5601 -- Build discriminant checking functions if not a derived type (for
5602 -- derived types that are not tagged types, always use the discriminant
5603 -- checking functions of the parent type). However, for untagged types
5604 -- the derivation may have taken place before the parent was frozen, so
5605 -- we copy explicitly the discriminant checking functions from the
5606 -- parent into the components of the derived type.
5608 Build_Or_Copy_Discr_Checking_Funcs
(Typ_Decl
);
5610 if Is_Derived_Type
(Typ
)
5611 and then Is_Limited_Type
(Typ
)
5612 and then Is_Tagged_Type
(Typ
)
5614 Check_Stream_Attributes
(Typ
);
5617 -- Update task, protected, and controlled component flags, because some
5618 -- of the component types may have been private at the point of the
5619 -- record declaration. Detect anonymous access-to-controlled components.
5621 Comp
:= First_Component
(Typ
);
5622 while Present
(Comp
) loop
5623 Comp_Typ
:= Etype
(Comp
);
5625 Propagate_Concurrent_Flags
(Typ
, Comp_Typ
);
5627 -- Do not set Has_Controlled_Component on a class-wide equivalent
5628 -- type. See Make_CW_Equivalent_Type.
5630 if not Is_Class_Wide_Equivalent_Type
(Typ
)
5632 (Has_Controlled_Component
(Comp_Typ
)
5633 or else (Chars
(Comp
) /= Name_uParent
5634 and then Is_Controlled
(Comp_Typ
)))
5636 Set_Has_Controlled_Component
(Typ
);
5639 Next_Component
(Comp
);
5642 -- Handle constructors of untagged CPP_Class types
5644 if not Is_Tagged_Type
(Typ
) and then Is_CPP_Class
(Typ
) then
5645 Set_CPP_Constructors
(Typ
);
5648 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5649 -- for regular tagged types as well as for Ada types deriving from a C++
5650 -- Class, but not for tagged types directly corresponding to C++ classes
5651 -- In the later case we assume that it is created in the C++ side and we
5654 if Is_Tagged_Type
(Typ
) then
5656 -- Add the _Tag component
5658 if Underlying_Type
(Etype
(Typ
)) = Typ
then
5659 Expand_Tagged_Root
(Typ
);
5662 if Is_CPP_Class
(Typ
) then
5663 Set_All_DT_Position
(Typ
);
5665 -- Create the tag entities with a minimum decoration
5667 if Tagged_Type_Expansion
then
5668 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
5671 Set_CPP_Constructors
(Typ
);
5674 if not Building_Static_DT
(Typ
) then
5676 -- Usually inherited primitives are not delayed but the first
5677 -- Ada extension of a CPP_Class is an exception since the
5678 -- address of the inherited subprogram has to be inserted in
5679 -- the new Ada Dispatch Table and this is a freezing action.
5681 -- Similarly, if this is an inherited operation whose parent is
5682 -- not frozen yet, it is not in the DT of the parent, and we
5683 -- generate an explicit freeze node for the inherited operation
5684 -- so it is properly inserted in the DT of the current type.
5691 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5692 while Present
(Elmt
) loop
5693 Subp
:= Node
(Elmt
);
5695 if Present
(Alias
(Subp
)) then
5696 if Is_CPP_Class
(Etype
(Typ
)) then
5697 Set_Has_Delayed_Freeze
(Subp
);
5699 elsif Has_Delayed_Freeze
(Alias
(Subp
))
5700 and then not Is_Frozen
(Alias
(Subp
))
5702 Set_Is_Frozen
(Subp
, False);
5703 Set_Has_Delayed_Freeze
(Subp
);
5712 -- Unfreeze momentarily the type to add the predefined primitives
5713 -- operations. The reason we unfreeze is so that these predefined
5714 -- operations will indeed end up as primitive operations (which
5715 -- must be before the freeze point).
5717 Set_Is_Frozen
(Typ
, False);
5719 -- Do not add the spec of predefined primitives in case of
5720 -- CPP tagged type derivations that have convention CPP.
5722 if Is_CPP_Class
(Root_Type
(Typ
))
5723 and then Convention
(Typ
) = Convention_CPP
5727 -- Do not add the spec of the predefined primitives if we are
5728 -- compiling under restriction No_Dispatching_Calls.
5730 elsif not Restriction_Active
(No_Dispatching_Calls
) then
5731 Make_Predefined_Primitive_Specs
(Typ
, Predef_List
, Renamed_Eq
);
5732 Insert_List_Before_And_Analyze
(N
, Predef_List
);
5735 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5736 -- wrapper functions for each nonoverridden inherited function
5737 -- with a controlling result of the type. The wrapper for such
5738 -- a function returns an extension aggregate that invokes the
5741 if Ada_Version
>= Ada_2005
5742 and then not Is_Abstract_Type
(Typ
)
5743 and then Is_Null_Extension
(Typ
)
5745 Make_Controlling_Function_Wrappers
5746 (Typ
, Wrapper_Decl_List
, Wrapper_Body_List
);
5747 Insert_List_Before_And_Analyze
(N
, Wrapper_Decl_List
);
5750 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5751 -- null procedure declarations for each set of homographic null
5752 -- procedures that are inherited from interface types but not
5753 -- overridden. This is done to ensure that the dispatch table
5754 -- entry associated with such null primitives are properly filled.
5756 if Ada_Version
>= Ada_2005
5757 and then Etype
(Typ
) /= Typ
5758 and then not Is_Abstract_Type
(Typ
)
5759 and then Has_Interfaces
(Typ
)
5761 Insert_Actions
(N
, Make_Null_Procedure_Specs
(Typ
));
5764 Set_Is_Frozen
(Typ
);
5766 if not Is_Derived_Type
(Typ
)
5767 or else Is_Tagged_Type
(Etype
(Typ
))
5769 Set_All_DT_Position
(Typ
);
5771 -- If this is a type derived from an untagged private type whose
5772 -- full view is tagged, the type is marked tagged for layout
5773 -- reasons, but it has no dispatch table.
5775 elsif Is_Derived_Type
(Typ
)
5776 and then Is_Private_Type
(Etype
(Typ
))
5777 and then not Is_Tagged_Type
(Etype
(Typ
))
5782 -- Create and decorate the tags. Suppress their creation when
5783 -- not Tagged_Type_Expansion because the dispatching mechanism is
5784 -- handled internally by the virtual target.
5786 if Tagged_Type_Expansion
then
5787 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
5789 -- Generate dispatch table of locally defined tagged type.
5790 -- Dispatch tables of library level tagged types are built
5791 -- later (see Build_Static_Dispatch_Tables).
5793 if not Building_Static_DT
(Typ
) then
5794 Append_Freeze_Actions
(Typ
, Make_DT
(Typ
));
5796 -- Register dispatch table wrappers in the dispatch table.
5797 -- It could not be done when these wrappers were built
5798 -- because, at that stage, the dispatch table was not
5801 Register_Dispatch_Table_Wrappers
(Typ
);
5805 -- If the type has unknown discriminants, propagate dispatching
5806 -- information to its underlying record view, which does not get
5807 -- its own dispatch table.
5809 if Is_Derived_Type
(Typ
)
5810 and then Has_Unknown_Discriminants
(Typ
)
5811 and then Present
(Underlying_Record_View
(Typ
))
5814 Rep
: constant Entity_Id
:= Underlying_Record_View
(Typ
);
5816 Set_Access_Disp_Table
5817 (Rep
, Access_Disp_Table
(Typ
));
5818 Set_Dispatch_Table_Wrappers
5819 (Rep
, Dispatch_Table_Wrappers
(Typ
));
5820 Set_Direct_Primitive_Operations
5821 (Rep
, Direct_Primitive_Operations
(Typ
));
5825 -- Make sure that the primitives Initialize, Adjust and Finalize
5826 -- are Frozen before other TSS subprograms. We don't want them
5829 if Is_Controlled
(Typ
) then
5830 if not Is_Limited_Type
(Typ
) then
5831 Append_Freeze_Actions
(Typ
,
5832 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Adjust
), Typ
));
5835 Append_Freeze_Actions
(Typ
,
5836 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Initialize
), Typ
));
5838 Append_Freeze_Actions
(Typ
,
5839 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Finalize
), Typ
));
5842 -- Freeze rest of primitive operations. There is no need to handle
5843 -- the predefined primitives if we are compiling under restriction
5844 -- No_Dispatching_Calls.
5846 if not Restriction_Active
(No_Dispatching_Calls
) then
5847 Append_Freeze_Actions
(Typ
, Predefined_Primitive_Freeze
(Typ
));
5851 -- In the untagged case, ever since Ada 83 an equality function must
5852 -- be provided for variant records that are not unchecked unions.
5853 -- In Ada 2012 the equality function composes, and thus must be built
5854 -- explicitly just as for tagged records.
5856 elsif Has_Discriminants
(Typ
)
5857 and then not Is_Limited_Type
(Typ
)
5860 Comps
: constant Node_Id
:=
5861 Component_List
(Type_Definition
(Typ_Decl
));
5864 and then Present
(Variant_Part
(Comps
))
5866 Build_Variant_Record_Equality
(Typ
);
5870 -- Otherwise create primitive equality operation (AI05-0123)
5872 -- This is done unconditionally to ensure that tools can be linked
5873 -- properly with user programs compiled with older language versions.
5874 -- In addition, this is needed because "=" composes for bounded strings
5875 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5877 elsif Comes_From_Source
(Typ
)
5878 and then Convention
(Typ
) = Convention_Ada
5879 and then not Is_Limited_Type
(Typ
)
5881 Build_Untagged_Equality
(Typ
);
5884 -- Before building the record initialization procedure, if we are
5885 -- dealing with a concurrent record value type, then we must go through
5886 -- the discriminants, exchanging discriminals between the concurrent
5887 -- type and the concurrent record value type. See the section "Handling
5888 -- of Discriminants" in the Einfo spec for details.
5890 if Is_Concurrent_Record_Type
(Typ
)
5891 and then Has_Discriminants
(Typ
)
5894 Ctyp
: constant Entity_Id
:=
5895 Corresponding_Concurrent_Type
(Typ
);
5896 Conc_Discr
: Entity_Id
;
5897 Rec_Discr
: Entity_Id
;
5901 Conc_Discr
:= First_Discriminant
(Ctyp
);
5902 Rec_Discr
:= First_Discriminant
(Typ
);
5903 while Present
(Conc_Discr
) loop
5904 Temp
:= Discriminal
(Conc_Discr
);
5905 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
5906 Set_Discriminal
(Rec_Discr
, Temp
);
5908 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
5909 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
5911 Next_Discriminant
(Conc_Discr
);
5912 Next_Discriminant
(Rec_Discr
);
5917 if Has_Controlled_Component
(Typ
) then
5918 Build_Controlling_Procs
(Typ
);
5921 Adjust_Discriminants
(Typ
);
5923 -- Do not need init for interfaces on virtual targets since they're
5926 if Tagged_Type_Expansion
or else not Is_Interface
(Typ
) then
5927 Build_Record_Init_Proc
(Typ_Decl
, Typ
);
5930 -- For tagged type that are not interfaces, build bodies of primitive
5931 -- operations. Note: do this after building the record initialization
5932 -- procedure, since the primitive operations may need the initialization
5933 -- routine. There is no need to add predefined primitives of interfaces
5934 -- because all their predefined primitives are abstract.
5936 if Is_Tagged_Type
(Typ
) and then not Is_Interface
(Typ
) then
5938 -- Do not add the body of predefined primitives in case of CPP tagged
5939 -- type derivations that have convention CPP.
5941 if Is_CPP_Class
(Root_Type
(Typ
))
5942 and then Convention
(Typ
) = Convention_CPP
5946 -- Do not add the body of the predefined primitives if we are
5947 -- compiling under restriction No_Dispatching_Calls or if we are
5948 -- compiling a CPP tagged type.
5950 elsif not Restriction_Active
(No_Dispatching_Calls
) then
5952 -- Create the body of TSS primitive Finalize_Address. This must
5953 -- be done before the bodies of all predefined primitives are
5954 -- created. If Typ is limited, Stream_Input and Stream_Read may
5955 -- produce build-in-place allocations and for those the expander
5956 -- needs Finalize_Address.
5958 Make_Finalize_Address_Body
(Typ
);
5959 Predef_List
:= Predefined_Primitive_Bodies
(Typ
, Renamed_Eq
);
5960 Append_Freeze_Actions
(Typ
, Predef_List
);
5963 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5964 -- inherited functions, then add their bodies to the freeze actions.
5966 Append_Freeze_Actions
(Typ
, Wrapper_Body_List
);
5969 -- Create extra formals for the primitive operations of the type.
5970 -- This must be done before analyzing the body of the initialization
5971 -- procedure, because a self-referential type might call one of these
5972 -- primitives in the body of the init_proc itself.
5974 -- This is not needed:
5975 -- 1) If expansion is disabled, because extra formals are only added
5976 -- when we are generating code.
5978 -- 2) For types with foreign convention since primitives with foreign
5979 -- convention don't have extra formals and AI95-117 requires that
5980 -- all primitives of a tagged type inherit the convention.
5983 and then Is_Tagged_Type
(Typ
)
5984 and then not Has_Foreign_Convention
(Typ
)
5991 -- Add extra formals to primitive operations
5993 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5994 while Present
(Elmt
) loop
5995 Create_Extra_Formals
(Node
(Elmt
));
5999 -- Add extra formals to renamings of primitive operations. The
6000 -- addition of extra formals is done in two steps to minimize
6001 -- the compile time required for this action; the evaluation of
6002 -- Find_Dispatching_Type() and Contains() is only done here for
6003 -- renamings that are not primitive operations.
6005 E
:= First_Entity
(Scope
(Typ
));
6006 while Present
(E
) loop
6007 if Is_Dispatching_Operation
(E
)
6008 and then Present
(Alias
(E
))
6009 and then Find_Dispatching_Type
(E
) = Typ
6010 and then not Contains
(Primitive_Operations
(Typ
), E
)
6012 Create_Extra_Formals
(E
);
6018 pragma Debug
(Validate_Tagged_Type_Extra_Formals
(Typ
));
6022 -- Build internal subprograms of primitives with class-wide
6023 -- pre/postconditions.
6025 if Is_Tagged_Type
(Typ
) then
6026 Build_Class_Condition_Subprograms
(Typ
);
6028 end Expand_Freeze_Record_Type
;
6030 ------------------------------------
6031 -- Expand_N_Full_Type_Declaration --
6032 ------------------------------------
6034 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
6035 procedure Build_Master
(Ptr_Typ
: Entity_Id
);
6036 -- Create the master associated with Ptr_Typ
6042 procedure Build_Master
(Ptr_Typ
: Entity_Id
) is
6043 Desig_Typ
: Entity_Id
:= Designated_Type
(Ptr_Typ
);
6046 -- If the designated type is an incomplete view coming from a
6047 -- limited-with'ed package, we need to use the nonlimited view in
6048 -- case it has tasks.
6050 if Is_Incomplete_Type
(Desig_Typ
)
6051 and then Present
(Non_Limited_View
(Desig_Typ
))
6053 Desig_Typ
:= Non_Limited_View
(Desig_Typ
);
6056 -- Anonymous access types are created for the components of the
6057 -- record parameter for an entry declaration. No master is created
6060 if Has_Task
(Desig_Typ
) then
6061 Build_Master_Entity
(Ptr_Typ
);
6062 Build_Master_Renaming
(Ptr_Typ
);
6064 -- Create a class-wide master because a Master_Id must be generated
6065 -- for access-to-limited-class-wide types whose root may be extended
6066 -- with task components.
6068 -- Note: This code covers access-to-limited-interfaces because they
6069 -- can be used to reference tasks implementing them.
6071 -- Suppress the master creation for access types created for entry
6072 -- formal parameters (parameter block component types). Seems like
6073 -- suppression should be more general for compiler-generated types,
6074 -- but testing Comes_From_Source may be too general in this case
6075 -- (affects some test output)???
6077 elsif not Is_Param_Block_Component_Type
(Ptr_Typ
)
6078 and then Is_Limited_Class_Wide_Type
(Desig_Typ
)
6080 Build_Class_Wide_Master
(Ptr_Typ
);
6084 -- Local declarations
6086 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6087 B_Id
: constant Entity_Id
:= Base_Type
(Def_Id
);
6091 -- Start of processing for Expand_N_Full_Type_Declaration
6094 if Is_Access_Type
(Def_Id
) then
6095 Build_Master
(Def_Id
);
6097 if Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
6098 Expand_Access_Protected_Subprogram_Type
(N
);
6101 -- Array of anonymous access-to-task pointers
6103 elsif Ada_Version
>= Ada_2005
6104 and then Is_Array_Type
(Def_Id
)
6105 and then Is_Access_Type
(Component_Type
(Def_Id
))
6106 and then Ekind
(Component_Type
(Def_Id
)) = E_Anonymous_Access_Type
6108 Build_Master
(Component_Type
(Def_Id
));
6110 elsif Has_Task
(Def_Id
) then
6111 Expand_Previous_Access_Type
(Def_Id
);
6113 -- Check the components of a record type or array of records for
6114 -- anonymous access-to-task pointers.
6116 elsif Ada_Version
>= Ada_2005
6117 and then (Is_Record_Type
(Def_Id
)
6119 (Is_Array_Type
(Def_Id
)
6120 and then Is_Record_Type
(Component_Type
(Def_Id
))))
6125 M_Id
: Entity_Id
:= Empty
;
6129 if Is_Array_Type
(Def_Id
) then
6130 Comp
:= First_Entity
(Component_Type
(Def_Id
));
6132 Comp
:= First_Entity
(Def_Id
);
6135 -- Examine all components looking for anonymous access-to-task
6139 while Present
(Comp
) loop
6140 Typ
:= Etype
(Comp
);
6142 if Ekind
(Typ
) = E_Anonymous_Access_Type
6143 and then Might_Have_Tasks
6144 (Available_View
(Designated_Type
(Typ
)))
6145 and then No
(Master_Id
(Typ
))
6147 -- Ensure that the record or array type have a _master
6150 Build_Master_Entity
(Def_Id
);
6151 Build_Master_Renaming
(Typ
);
6152 M_Id
:= Master_Id
(Typ
);
6156 -- Reuse the same master to service any additional types
6159 pragma Assert
(Present
(M_Id
));
6160 Set_Master_Id
(Typ
, M_Id
);
6169 Par_Id
:= Etype
(B_Id
);
6171 -- The parent type is private then we need to inherit any TSS operations
6172 -- from the full view.
6174 if Is_Private_Type
(Par_Id
)
6175 and then Present
(Full_View
(Par_Id
))
6177 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
6180 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
6181 and then not Is_Tagged_Type
(Def_Id
)
6182 and then Present
(Freeze_Node
(Par_Id
))
6183 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
6185 Ensure_Freeze_Node
(B_Id
);
6186 FN
:= Freeze_Node
(B_Id
);
6188 if No
(TSS_Elist
(FN
)) then
6189 Set_TSS_Elist
(FN
, New_Elmt_List
);
6193 T_E
: constant Elist_Id
:= TSS_Elist
(FN
);
6197 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
6198 while Present
(Elmt
) loop
6199 if Chars
(Node
(Elmt
)) /= Name_uInit
then
6200 Append_Elmt
(Node
(Elmt
), T_E
);
6206 -- If the derived type itself is private with a full view, then
6207 -- associate the full view with the inherited TSS_Elist as well.
6209 if Is_Private_Type
(B_Id
)
6210 and then Present
(Full_View
(B_Id
))
6212 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
6214 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
6218 end Expand_N_Full_Type_Declaration
;
6220 ---------------------------------
6221 -- Expand_N_Object_Declaration --
6222 ---------------------------------
6224 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
6225 Loc
: constant Source_Ptr
:= Sloc
(N
);
6226 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6227 Expr
: constant Node_Id
:= Expression
(N
);
6228 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
6229 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
6230 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
6231 Next_N
: constant Node_Id
:= Next
(N
);
6233 Special_Ret_Obj
: constant Boolean := Is_Special_Return_Object
(Def_Id
);
6234 -- If this is a special return object, it will be allocated differently
6235 -- and ultimately rewritten as a renaming, so initialization activities
6236 -- need to be deferred until after that is done.
6238 Func_Id
: constant Entity_Id
:=
6239 (if Special_Ret_Obj
then Return_Applies_To
(Scope
(Def_Id
)) else Empty
);
6240 -- The function if this is a special return object, otherwise Empty
6242 function Build_Equivalent_Aggregate
return Boolean;
6243 -- If the object has a constrained discriminated type and no initial
6244 -- value, it may be possible to build an equivalent aggregate instead,
6245 -- and prevent an actual call to the initialization procedure.
6247 function Build_Heap_Or_Pool_Allocator
6248 (Temp_Id
: Entity_Id
;
6249 Temp_Typ
: Entity_Id
;
6250 Ret_Typ
: Entity_Id
;
6251 Alloc_Expr
: Node_Id
) return Node_Id
;
6252 -- Create the statements necessary to allocate a return object on the
6253 -- heap or user-defined storage pool. The object may need finalization
6254 -- actions depending on the return type.
6256 -- * Controlled case
6258 -- if BIPfinalizationmaster = null then
6259 -- Temp_Id := <Alloc_Expr>;
6262 -- type Ptr_Typ is access Ret_Typ;
6263 -- for Ptr_Typ'Storage_Pool use
6264 -- Base_Pool (BIPfinalizationmaster.all).all;
6268 -- procedure Allocate (...) is
6270 -- System.Storage_Pools.Subpools.Allocate_Any (...);
6273 -- Local := <Alloc_Expr>;
6274 -- Temp_Id := Temp_Typ (Local);
6278 -- * Non-controlled case
6280 -- Temp_Id := <Alloc_Expr>;
6282 -- Temp_Id is the temporary which is used to reference the internally
6283 -- created object in all allocation forms. Temp_Typ is the type of the
6284 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
6285 -- type of Func_Id. Alloc_Expr is the actual allocator.
6287 procedure Count_Default_Sized_Task_Stacks
6289 Pri_Stacks
: out Int
;
6290 Sec_Stacks
: out Int
);
6291 -- Count the number of default-sized primary and secondary task stacks
6292 -- required for task objects contained within type Typ. If the number of
6293 -- task objects contained within the type is not known at compile time
6294 -- the procedure will return the stack counts of zero.
6296 procedure Default_Initialize_Object
(After
: Node_Id
);
6297 -- Generate all default initialization actions for object Def_Id. Any
6298 -- new code is inserted after node After.
6300 procedure Initialize_Return_Object
6301 (Tag_Assign
: Node_Id
;
6304 Init_Stmt
: Node_Id
;
6306 -- Generate all initialization actions for return object Def_Id. Any
6307 -- new code is inserted after node After.
6309 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
;
6310 -- Make an allocator for a return object initialized with Expr
6312 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean;
6313 -- Return True if N denotes an entity with OK_To_Rename set
6315 --------------------------------
6316 -- Build_Equivalent_Aggregate --
6317 --------------------------------
6319 function Build_Equivalent_Aggregate
return Boolean is
6323 Full_Type
: Entity_Id
;
6328 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
6329 Full_Type
:= Full_View
(Typ
);
6332 -- Only perform this transformation if Elaboration_Code is forbidden
6333 -- or undesirable, and if this is a global entity of a constrained
6336 -- If Initialize_Scalars might be active this transformation cannot
6337 -- be performed either, because it will lead to different semantics
6338 -- or because elaboration code will in fact be created.
6340 if Ekind
(Full_Type
) /= E_Record_Subtype
6341 or else not Has_Discriminants
(Full_Type
)
6342 or else not Is_Constrained
(Full_Type
)
6343 or else Is_Controlled
(Full_Type
)
6344 or else Is_Limited_Type
(Full_Type
)
6345 or else not Restriction_Active
(No_Initialize_Scalars
)
6350 if Ekind
(Current_Scope
) = E_Package
6352 (Restriction_Active
(No_Elaboration_Code
)
6353 or else Is_Preelaborated
(Current_Scope
))
6355 -- Building a static aggregate is possible if the discriminants
6356 -- have static values and the other components have static
6357 -- defaults or none.
6359 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Type
));
6360 while Present
(Discr
) loop
6361 if not Is_OK_Static_Expression
(Node
(Discr
)) then
6368 -- Check that initialized components are OK, and that non-
6369 -- initialized components do not require a call to their own
6370 -- initialization procedure.
6372 Comp
:= First_Component
(Full_Type
);
6373 while Present
(Comp
) loop
6374 if Present
(Expression
(Parent
(Comp
)))
6376 not Is_OK_Static_Expression
(Expression
(Parent
(Comp
)))
6380 elsif Has_Non_Null_Base_Init_Proc
(Etype
(Comp
)) then
6385 Next_Component
(Comp
);
6388 -- Everything is static, assemble the aggregate, discriminant
6392 Make_Aggregate
(Loc
,
6393 Expressions
=> New_List
,
6394 Component_Associations
=> New_List
);
6396 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Type
));
6397 while Present
(Discr
) loop
6398 Append_To
(Expressions
(Aggr
), New_Copy
(Node
(Discr
)));
6402 -- Now collect values of initialized components
6404 Comp
:= First_Component
(Full_Type
);
6405 while Present
(Comp
) loop
6406 if Present
(Expression
(Parent
(Comp
))) then
6407 Append_To
(Component_Associations
(Aggr
),
6408 Make_Component_Association
(Loc
,
6409 Choices
=> New_List
(New_Occurrence_Of
(Comp
, Loc
)),
6410 Expression
=> New_Copy_Tree
6411 (Expression
(Parent
(Comp
)))));
6414 Next_Component
(Comp
);
6417 -- Finally, box-initialize remaining components
6419 Append_To
(Component_Associations
(Aggr
),
6420 Make_Component_Association
(Loc
,
6421 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
6422 Expression
=> Empty
));
6423 Set_Box_Present
(Last
(Component_Associations
(Aggr
)));
6424 Set_Expression
(N
, Aggr
);
6426 if Typ
/= Full_Type
then
6427 Analyze_And_Resolve
(Aggr
, Full_View
(Base_Type
(Full_Type
)));
6428 Rewrite
(Aggr
, Unchecked_Convert_To
(Typ
, Aggr
));
6429 Analyze_And_Resolve
(Aggr
, Typ
);
6431 Analyze_And_Resolve
(Aggr
, Full_Type
);
6439 end Build_Equivalent_Aggregate
;
6441 ----------------------------------
6442 -- Build_Heap_Or_Pool_Allocator --
6443 ----------------------------------
6445 function Build_Heap_Or_Pool_Allocator
6446 (Temp_Id
: Entity_Id
;
6447 Temp_Typ
: Entity_Id
;
6448 Ret_Typ
: Entity_Id
;
6449 Alloc_Expr
: Node_Id
) return Node_Id
6452 pragma Assert
(Is_Build_In_Place_Function
(Func_Id
));
6454 -- Processing for objects that require finalization actions
6456 if Needs_Finalization
(Ret_Typ
) then
6458 Decls
: constant List_Id
:= New_List
;
6459 Fin_Mas_Id
: constant Entity_Id
:=
6460 Build_In_Place_Formal
(Func_Id
, BIP_Finalization_Master
);
6461 Orig_Expr
: constant Node_Id
:= New_Copy_Tree
(Alloc_Expr
);
6462 Stmts
: constant List_Id
:= New_List
;
6463 Local_Id
: Entity_Id
;
6464 Pool_Id
: Entity_Id
;
6465 Ptr_Typ
: Entity_Id
;
6469 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
6471 Pool_Id
:= Make_Temporary
(Loc
, 'P');
6474 Make_Object_Renaming_Declaration
(Loc
,
6475 Defining_Identifier
=> Pool_Id
,
6477 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
6479 Make_Explicit_Dereference
(Loc
,
6481 Make_Function_Call
(Loc
,
6483 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
6484 Parameter_Associations
=> New_List
(
6485 Make_Explicit_Dereference
(Loc
,
6487 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
6489 -- Create an access type which uses the storage pool of the
6490 -- caller's master. This additional type is necessary because
6491 -- the finalization master cannot be associated with the type
6492 -- of the temporary. Otherwise the secondary stack allocation
6496 -- type Ptr_Typ is access Ret_Typ;
6498 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
6501 Make_Full_Type_Declaration
(Loc
,
6502 Defining_Identifier
=> Ptr_Typ
,
6504 Make_Access_To_Object_Definition
(Loc
,
6505 Subtype_Indication
=>
6506 New_Occurrence_Of
(Ret_Typ
, Loc
))));
6508 -- Perform minor decoration in order to set the master and the
6509 -- storage pool attributes.
6511 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
6512 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
6513 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
6515 -- Create the temporary, generate:
6516 -- Local_Id : Ptr_Typ;
6518 Local_Id
:= Make_Temporary
(Loc
, 'T');
6521 Make_Object_Declaration
(Loc
,
6522 Defining_Identifier
=> Local_Id
,
6523 Object_Definition
=>
6524 New_Occurrence_Of
(Ptr_Typ
, Loc
)));
6526 -- Allocate the object, generate:
6527 -- Local_Id := <Alloc_Expr>;
6530 Make_Assignment_Statement
(Loc
,
6531 Name
=> New_Occurrence_Of
(Local_Id
, Loc
),
6532 Expression
=> Alloc_Expr
));
6535 -- Temp_Id := Temp_Typ (Local_Id);
6538 Make_Assignment_Statement
(Loc
,
6539 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6541 Unchecked_Convert_To
(Temp_Typ
,
6542 New_Occurrence_Of
(Local_Id
, Loc
))));
6544 -- Wrap the allocation in a block. This is further conditioned
6545 -- by checking the caller finalization master at runtime. A
6546 -- null value indicates a non-existent master, most likely due
6547 -- to a Finalize_Storage_Only allocation.
6550 -- if BIPfinalizationmaster = null then
6551 -- Temp_Id := <Orig_Expr>;
6561 Make_If_Statement
(Loc
,
6564 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
6565 Right_Opnd
=> Make_Null
(Loc
)),
6567 Then_Statements
=> New_List
(
6568 Make_Assignment_Statement
(Loc
,
6569 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6570 Expression
=> Orig_Expr
)),
6572 Else_Statements
=> New_List
(
6573 Make_Block_Statement
(Loc
,
6574 Declarations
=> Decls
,
6575 Handled_Statement_Sequence
=>
6576 Make_Handled_Sequence_Of_Statements
(Loc
,
6577 Statements
=> Stmts
))));
6580 -- For all other cases, generate:
6581 -- Temp_Id := <Alloc_Expr>;
6585 Make_Assignment_Statement
(Loc
,
6586 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6587 Expression
=> Alloc_Expr
);
6589 end Build_Heap_Or_Pool_Allocator
;
6591 -------------------------------------
6592 -- Count_Default_Sized_Task_Stacks --
6593 -------------------------------------
6595 procedure Count_Default_Sized_Task_Stacks
6597 Pri_Stacks
: out Int
;
6598 Sec_Stacks
: out Int
)
6600 Component
: Entity_Id
;
6603 -- To calculate the number of default-sized task stacks required for
6604 -- an object of Typ, a depth-first recursive traversal of the AST
6605 -- from the Typ entity node is undertaken. Only type nodes containing
6606 -- task objects are visited.
6611 if not Has_Task
(Typ
) then
6619 -- A task type is found marking the bottom of the descent. If
6620 -- the type has no representation aspect for the corresponding
6621 -- stack then that stack is using the default size.
6623 if Present
(Get_Rep_Item
(Typ
, Name_Storage_Size
)) then
6629 if Present
(Get_Rep_Item
(Typ
, Name_Secondary_Stack_Size
)) then
6635 when E_Array_Subtype
6638 -- First find the number of default stacks contained within an
6641 Count_Default_Sized_Task_Stacks
6642 (Component_Type
(Typ
),
6646 -- Then multiply the result by the size of the array
6649 Quantity
: constant Int
:= Number_Of_Elements_In_Array
(Typ
);
6650 -- Number_Of_Elements_In_Array is non-trival, consequently
6651 -- its result is captured as an optimization.
6654 Pri_Stacks
:= Pri_Stacks
* Quantity
;
6655 Sec_Stacks
:= Sec_Stacks
* Quantity
;
6658 when E_Protected_Subtype
6663 Component
:= First_Component_Or_Discriminant
(Typ
);
6665 -- Recursively descend each component of the composite type
6666 -- looking for tasks, but only if the component is marked as
6669 while Present
(Component
) loop
6670 if Has_Task
(Etype
(Component
)) then
6676 Count_Default_Sized_Task_Stacks
6677 (Etype
(Component
), P
, S
);
6678 Pri_Stacks
:= Pri_Stacks
+ P
;
6679 Sec_Stacks
:= Sec_Stacks
+ S
;
6683 Next_Component_Or_Discriminant
(Component
);
6686 when E_Limited_Private_Subtype
6687 | E_Limited_Private_Type
6688 | E_Record_Subtype_With_Private
6689 | E_Record_Type_With_Private
6691 -- Switch to the full view of the private type to continue
6694 Count_Default_Sized_Task_Stacks
6695 (Full_View
(Typ
), Pri_Stacks
, Sec_Stacks
);
6697 -- Other types should not contain tasks
6700 raise Program_Error
;
6702 end Count_Default_Sized_Task_Stacks
;
6704 -------------------------------
6705 -- Default_Initialize_Object --
6706 -------------------------------
6708 procedure Default_Initialize_Object
(After
: Node_Id
) is
6709 function New_Object_Reference
return Node_Id
;
6710 -- Return a new reference to Def_Id with attributes Assignment_OK and
6711 -- Must_Not_Freeze already set.
6713 function Simple_Initialization_OK
6714 (Init_Typ
: Entity_Id
) return Boolean;
6715 -- Determine whether object declaration N with entity Def_Id needs
6716 -- simple initialization, assuming that it is of type Init_Typ.
6718 --------------------------
6719 -- New_Object_Reference --
6720 --------------------------
6722 function New_Object_Reference
return Node_Id
is
6723 Obj_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
6726 -- The call to the type init proc or [Deep_]Finalize must not
6727 -- freeze the related object as the call is internally generated.
6728 -- This way legal rep clauses that apply to the object will not be
6729 -- flagged. Note that the initialization call may be removed if
6730 -- pragma Import is encountered or moved to the freeze actions of
6731 -- the object because of an address clause.
6733 Set_Assignment_OK
(Obj_Ref
);
6734 Set_Must_Not_Freeze
(Obj_Ref
);
6737 end New_Object_Reference
;
6739 ------------------------------
6740 -- Simple_Initialization_OK --
6741 ------------------------------
6743 function Simple_Initialization_OK
6744 (Init_Typ
: Entity_Id
) return Boolean
6747 -- Do not consider the object declaration if it comes with an
6748 -- initialization expression, or is internal in which case it
6749 -- will be assigned later.
6752 not Is_Internal
(Def_Id
)
6753 and then not Has_Init_Expression
(N
)
6754 and then Needs_Simple_Initialization
6758 and then No
(Following_Address_Clause
(N
)));
6759 end Simple_Initialization_OK
;
6763 Exceptions_OK
: constant Boolean :=
6764 not Restriction_Active
(No_Exception_Propagation
);
6766 Aggr_Init
: Node_Id
;
6767 Comp_Init
: List_Id
:= No_List
;
6768 Fin_Block
: Node_Id
;
6770 Init_Stmts
: List_Id
:= No_List
;
6771 Obj_Init
: Node_Id
:= Empty
;
6774 -- Start of processing for Default_Initialize_Object
6777 -- Default initialization is suppressed for objects that are already
6778 -- known to be imported (i.e. whose declaration specifies the Import
6779 -- aspect). Note that for objects with a pragma Import, we generate
6780 -- initialization here, and then remove it downstream when processing
6781 -- the pragma. It is also suppressed for variables for which a pragma
6782 -- Suppress_Initialization has been explicitly given
6784 if Is_Imported
(Def_Id
) or else Suppress_Initialization
(Def_Id
) then
6787 -- Nothing to do if the object being initialized is of a task type
6788 -- and restriction No_Tasking is in effect, because this is a direct
6789 -- violation of the restriction.
6791 elsif Is_Task_Type
(Base_Typ
)
6792 and then Restriction_Active
(No_Tasking
)
6797 -- The expansion performed by this routine is as follows:
6801 -- Type_Init_Proc (Obj);
6804 -- [Deep_]Initialize (Obj);
6808 -- [Deep_]Finalize (Obj, Self => False);
6812 -- Abort_Undefer_Direct;
6815 -- Initialize the components of the object
6817 if Has_Non_Null_Base_Init_Proc
(Typ
)
6818 and then not No_Initialization
(N
)
6819 and then not Initialization_Suppressed
(Typ
)
6821 -- Do not initialize the components if No_Default_Initialization
6822 -- applies as the actual restriction check will occur later when
6823 -- the object is frozen as it is not known yet whether the object
6824 -- is imported or not.
6826 if not Restriction_Active
(No_Default_Initialization
) then
6828 -- If the values of the components are compile-time known, use
6829 -- their prebuilt aggregate form directly.
6831 Aggr_Init
:= Static_Initialization
(Base_Init_Proc
(Typ
));
6833 if Present
(Aggr_Init
) then
6835 New_Copy_Tree
(Aggr_Init
, New_Scope
=> Current_Scope
));
6837 -- If type has discriminants, try to build an equivalent
6838 -- aggregate using discriminant values from the declaration.
6839 -- This is a useful optimization, in particular if restriction
6840 -- No_Elaboration_Code is active.
6842 elsif Build_Equivalent_Aggregate
then
6845 -- Optimize the default initialization of an array object when
6846 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
6847 -- Construct an in-place initialization aggregate which may be
6848 -- convert into a fast memset by the backend.
6850 elsif Init_Or_Norm_Scalars
6851 and then Is_Array_Type
(Typ
)
6853 -- The array must lack atomic components because they are
6854 -- treated as non-static, and as a result the backend will
6855 -- not initialize the memory in one go.
6857 and then not Has_Atomic_Components
(Typ
)
6859 -- The array must not be packed because the invalid values
6860 -- in System.Scalar_Values are multiples of Storage_Unit.
6862 and then not Is_Packed
(Typ
)
6864 -- The array must have static non-empty ranges, otherwise
6865 -- the backend cannot initialize the memory in one go.
6867 and then Has_Static_Non_Empty_Array_Bounds
(Typ
)
6869 -- The optimization is only relevant for arrays of scalar
6872 and then Is_Scalar_Type
(Component_Type
(Typ
))
6874 -- Similar to regular array initialization using a type
6875 -- init proc, predicate checks are not performed because the
6876 -- initialization values are intentionally invalid, and may
6877 -- violate the predicate.
6879 and then not Has_Predicates
(Component_Type
(Typ
))
6881 -- The component type must have a single initialization value
6883 and then Simple_Initialization_OK
(Component_Type
(Typ
))
6885 Set_No_Initialization
(N
, False);
6890 Size
=> (if Known_Esize
(Def_Id
) then Esize
(Def_Id
)
6894 (Expression
(N
), Typ
, Suppress
=> All_Checks
);
6896 -- Otherwise invoke the type init proc, generate:
6897 -- Type_Init_Proc (Obj);
6900 Obj_Ref
:= New_Object_Reference
;
6902 if Comes_From_Source
(Def_Id
) then
6903 Initialization_Warning
(Obj_Ref
);
6906 Comp_Init
:= Build_Initialization_Call
(Loc
, Obj_Ref
, Typ
);
6910 -- Provide a default value if the object needs simple initialization
6912 elsif Simple_Initialization_OK
(Typ
) then
6913 Set_No_Initialization
(N
, False);
6919 (if Known_Esize
(Def_Id
) then Esize
(Def_Id
) else Uint_0
)));
6921 Analyze_And_Resolve
(Expression
(N
), Typ
);
6924 -- Initialize the object, generate:
6925 -- [Deep_]Initialize (Obj);
6927 if Needs_Finalization
(Typ
) and then not No_Initialization
(N
) then
6930 (Obj_Ref
=> New_Object_Reference
,
6934 -- Build a special finalization block when both the object and its
6935 -- controlled components are to be initialized. The block finalizes
6936 -- the components if the object initialization fails. Generate:
6947 if Has_Controlled_Component
(Typ
)
6948 and then Present
(Comp_Init
)
6949 and then Present
(Obj_Init
)
6950 and then Exceptions_OK
6952 Init_Stmts
:= Comp_Init
;
6956 (Obj_Ref
=> New_Object_Reference
,
6960 if Present
(Fin_Call
) then
6962 -- Do not emit warnings related to the elaboration order when a
6963 -- controlled object is declared before the body of Finalize is
6966 if Legacy_Elaboration_Checks
then
6967 Set_No_Elaboration_Check
(Fin_Call
);
6971 Make_Block_Statement
(Loc
,
6972 Declarations
=> No_List
,
6974 Handled_Statement_Sequence
=>
6975 Make_Handled_Sequence_Of_Statements
(Loc
,
6976 Statements
=> New_List
(Obj_Init
),
6978 Exception_Handlers
=> New_List
(
6979 Make_Exception_Handler
(Loc
,
6980 Exception_Choices
=> New_List
(
6981 Make_Others_Choice
(Loc
)),
6983 Statements
=> New_List
(
6985 Make_Raise_Statement
(Loc
))))));
6987 -- Signal the ABE mechanism that the block carries out
6988 -- initialization actions.
6990 Set_Is_Initialization_Block
(Fin_Block
);
6992 Append_To
(Init_Stmts
, Fin_Block
);
6995 -- Otherwise finalization is not required, the initialization calls
6996 -- are passed to the abort block building circuitry, generate:
6998 -- Type_Init_Proc (Obj);
6999 -- [Deep_]Initialize (Obj);
7002 if Present
(Comp_Init
) then
7003 Init_Stmts
:= Comp_Init
;
7006 if Present
(Obj_Init
) then
7007 if No
(Init_Stmts
) then
7008 Init_Stmts
:= New_List
;
7011 Append_To
(Init_Stmts
, Obj_Init
);
7015 -- Build an abort block to protect the initialization calls
7018 and then Present
(Comp_Init
)
7019 and then Present
(Obj_Init
)
7024 Prepend_To
(Init_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7026 -- When exceptions are propagated, abort deferral must take place
7027 -- in the presence of initialization or finalization exceptions.
7034 -- Abort_Undefer_Direct;
7037 if Exceptions_OK
then
7038 Init_Stmts
:= New_List
(
7039 Build_Abort_Undefer_Block
(Loc
,
7040 Stmts
=> Init_Stmts
,
7043 -- Otherwise exceptions are not propagated. Generate:
7050 Append_To
(Init_Stmts
,
7051 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7055 -- Insert the whole initialization sequence into the tree. If the
7056 -- object has a delayed freeze, as will be the case when it has
7057 -- aspect specifications, the initialization sequence is part of
7058 -- the freeze actions.
7060 if Present
(Init_Stmts
) then
7061 if Has_Delayed_Freeze
(Def_Id
) then
7062 Append_Freeze_Actions
(Def_Id
, Init_Stmts
);
7064 Insert_Actions_After
(After
, Init_Stmts
);
7067 end Default_Initialize_Object
;
7069 ------------------------------
7070 -- Initialize_Return_Object --
7071 ------------------------------
7073 procedure Initialize_Return_Object
7074 (Tag_Assign
: Node_Id
;
7077 Init_Stmt
: Node_Id
;
7081 if Present
(Tag_Assign
) then
7082 Insert_Action_After
(After
, Tag_Assign
);
7085 if Present
(Adj_Call
) then
7086 Insert_Action_After
(After
, Adj_Call
);
7090 Default_Initialize_Object
(After
);
7092 elsif Is_Delayed_Aggregate
(Expr
)
7093 and then not No_Initialization
(N
)
7095 Convert_Aggr_In_Object_Decl
(N
);
7097 elsif Present
(Init_Stmt
) then
7098 Insert_Action_After
(After
, Init_Stmt
);
7099 Set_Expression
(N
, Empty
);
7101 end Initialize_Return_Object
;
7103 -------------------------------
7104 -- Make_Allocator_For_Return --
7105 -------------------------------
7107 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
is
7111 -- If the return object's declaration includes an expression and the
7112 -- declaration isn't marked as No_Initialization, then we generate an
7113 -- allocator with a qualified expression. Although this is necessary
7114 -- only in the case where the result type is an interface (or class-
7115 -- wide interface), we do it in all cases for the sake of consistency
7116 -- instead of subsequently generating a separate assignment.
7119 and then not Is_Delayed_Aggregate
(Expr
)
7120 and then not No_Initialization
(N
)
7122 -- Ada 2005 (AI95-344): If the result type is class-wide, insert
7123 -- a check that the level of the return expression's underlying
7124 -- type is not deeper than the level of the master enclosing the
7127 -- AI12-043: The check is made immediately after the return object
7130 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
7131 Apply_CW_Accessibility_Check
(Expr
, Func_Id
);
7134 -- We always use the type of the expression for the qualified
7135 -- expression, rather than the return object's type. We cannot
7136 -- always use the return object's type because the expression
7137 -- might be of a specific type and the result object mignt not.
7140 Make_Allocator
(Loc
,
7142 Make_Qualified_Expression
(Loc
,
7144 New_Occurrence_Of
(Etype
(Expr
), Loc
),
7145 Expression
=> New_Copy_Tree
(Expr
)));
7149 Make_Allocator
(Loc
,
7150 Expression
=> New_Occurrence_Of
(Typ
, Loc
));
7152 -- If the return object requires default initialization, then it
7153 -- will happen later following the elaboration of the renaming.
7154 -- If we don't turn it off here, then the object will be default
7155 -- initialized twice.
7157 Set_No_Initialization
(Alloc
);
7160 -- Set the flag indicating that the allocator is made for a special
7161 -- return object. This is used to bypass various legality checks as
7162 -- well as to make sure that the result is not adjusted twice.
7164 Set_For_Special_Return_Object
(Alloc
);
7167 end Make_Allocator_For_Return
;
7169 ----------------------
7170 -- OK_To_Rename_Ref --
7171 ----------------------
7173 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean is
7175 return Is_Entity_Name
(N
)
7176 and then Ekind
(Entity
(N
)) = E_Variable
7177 and then OK_To_Rename
(Entity
(N
));
7178 end OK_To_Rename_Ref
;
7182 Adj_Call
: Node_Id
:= Empty
;
7183 Expr_Q
: Node_Id
:= Empty
;
7184 Tag_Assign
: Node_Id
:= Empty
;
7186 Init_After
: Node_Id
:= N
;
7187 -- Node after which the initialization actions are to be inserted. This
7188 -- is normally N, except for the case of a shared passive variable, in
7189 -- which case the init proc call must be inserted only after the bodies
7190 -- of the shared variable procedures have been seen.
7192 Rewrite_As_Renaming
: Boolean := False;
7193 -- Whether to turn the declaration into a renaming at the end
7195 -- Start of processing for Expand_N_Object_Declaration
7198 -- Don't do anything for deferred constants. All proper actions will be
7199 -- expanded during the full declaration.
7201 if No
(Expr
) and Constant_Present
(N
) then
7205 -- The type of the object cannot be abstract. This is diagnosed at the
7206 -- point the object is frozen, which happens after the declaration is
7207 -- fully expanded, so simply return now.
7209 if Is_Abstract_Type
(Typ
) then
7213 -- No action needed for the internal imported dummy object added by
7214 -- Make_DT to compute the offset of the components that reference
7215 -- secondary dispatch tables; required to avoid never-ending loop
7216 -- processing this internal object declaration.
7218 if Tagged_Type_Expansion
7219 and then Is_Internal
(Def_Id
)
7220 and then Is_Imported
(Def_Id
)
7221 and then Related_Type
(Def_Id
) = Implementation_Base_Type
(Typ
)
7226 -- Make shared memory routines for shared passive variable
7228 if Is_Shared_Passive
(Def_Id
) then
7229 Init_After
:= Make_Shared_Var_Procs
(N
);
7232 -- If tasks are being declared, make sure we have an activation chain
7233 -- defined for the tasks (has no effect if we already have one), and
7234 -- also that a Master variable is established (and that the appropriate
7235 -- enclosing construct is established as a task master).
7237 if Has_Task
(Typ
) or else Might_Have_Tasks
(Typ
) then
7238 Build_Activation_Chain_Entity
(N
);
7240 if Has_Task
(Typ
) then
7241 Build_Master_Entity
(Def_Id
);
7243 -- Handle objects initialized with BIP function calls
7245 elsif Present
(Expr
) then
7246 Expr_Q
:= Unqualify
(Expr
);
7248 if Is_Build_In_Place_Function_Call
(Expr_Q
)
7249 or else Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
))
7250 or else (Nkind
(Expr_Q
) = N_Reference
7252 Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
)))
7254 Build_Master_Entity
(Def_Id
);
7259 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
7260 -- restrictions are active then default-sized secondary stacks are
7261 -- generated by the binder and allocated by SS_Init. To provide the
7262 -- binder the number of stacks to generate, the number of default-sized
7263 -- stacks required for task objects contained within the object
7264 -- declaration N is calculated here as it is at this point where
7265 -- unconstrained types become constrained. The result is stored in the
7266 -- enclosing unit's Unit_Record.
7268 -- Note if N is an array object declaration that has an initialization
7269 -- expression, a second object declaration for the initialization
7270 -- expression is created by the compiler. To prevent double counting
7271 -- of the stacks in this scenario, the stacks of the first array are
7274 if Might_Have_Tasks
(Typ
)
7275 and then not Restriction_Active
(No_Secondary_Stack
)
7276 and then (Restriction_Active
(No_Implicit_Heap_Allocations
)
7277 or else Restriction_Active
(No_Implicit_Task_Allocations
))
7278 and then not (Ekind
(Typ
) in E_Array_Type | E_Array_Subtype
7279 and then (Has_Init_Expression
(N
)))
7282 PS_Count
, SS_Count
: Int
:= 0;
7284 Count_Default_Sized_Task_Stacks
(Typ
, PS_Count
, SS_Count
);
7285 Increment_Primary_Stack_Count
(PS_Count
);
7286 Increment_Sec_Stack_Count
(SS_Count
);
7290 -- Default initialization required, and no expression present
7293 -- If we have a type with a variant part, the initialization proc
7294 -- will contain implicit tests of the discriminant values, which
7295 -- counts as a violation of the restriction No_Implicit_Conditionals.
7297 if Has_Variant_Part
(Typ
) then
7302 Check_Restriction
(Msg
, No_Implicit_Conditionals
, Obj_Def
);
7306 ("\initialization of variant record tests discriminants",
7313 -- For the default initialization case, if we have a private type
7314 -- with invariants, and invariant checks are enabled, then insert an
7315 -- invariant check after the object declaration. Note that it is OK
7316 -- to clobber the object with an invalid value since if the exception
7317 -- is raised, then the object will go out of scope. In the case where
7318 -- an array object is initialized with an aggregate, the expression
7319 -- is removed. Check flag Has_Init_Expression to avoid generating a
7320 -- junk invariant check and flag No_Initialization to avoid checking
7321 -- an uninitialized object such as a compiler temporary used for an
7324 if Has_Invariants
(Base_Typ
)
7325 and then Present
(Invariant_Procedure
(Base_Typ
))
7326 and then not Has_Init_Expression
(N
)
7327 and then not No_Initialization
(N
)
7329 -- If entity has an address clause or aspect, make invariant
7330 -- call into a freeze action for the explicit freeze node for
7331 -- object. Otherwise insert invariant check after declaration.
7333 if Present
(Following_Address_Clause
(N
))
7334 or else Has_Aspect
(Def_Id
, Aspect_Address
)
7336 Ensure_Freeze_Node
(Def_Id
);
7337 Set_Has_Delayed_Freeze
(Def_Id
);
7338 Set_Is_Frozen
(Def_Id
, False);
7340 if not Partial_View_Has_Unknown_Discr
(Typ
) then
7341 Append_Freeze_Action
(Def_Id
,
7342 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7345 elsif not Partial_View_Has_Unknown_Discr
(Typ
) then
7347 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7351 if not Special_Ret_Obj
then
7352 Default_Initialize_Object
(Init_After
);
7355 -- Generate attribute for Persistent_BSS if needed
7357 if Persistent_BSS_Mode
7358 and then Comes_From_Source
(N
)
7359 and then Is_Potentially_Persistent_Type
(Typ
)
7360 and then not Has_Init_Expression
(N
)
7361 and then Is_Library_Level_Entity
(Def_Id
)
7367 Make_Linker_Section_Pragma
7368 (Def_Id
, Sloc
(N
), ".persistent.bss");
7369 Insert_After
(N
, Prag
);
7374 -- If access type, then we know it is null if not initialized
7376 if Is_Access_Type
(Typ
) then
7377 Set_Is_Known_Null
(Def_Id
);
7380 -- Explicit initialization present
7383 -- Obtain actual expression from qualified expression
7385 Expr_Q
:= Unqualify
(Expr
);
7387 -- When we have the appropriate type of aggregate in the expression
7388 -- (it has been determined during analysis of the aggregate by
7389 -- setting the delay flag), let's perform in place assignment and
7390 -- thus avoid creating a temporary.
7392 if Is_Delayed_Aggregate
(Expr_Q
) then
7394 -- An aggregate that must be built in place is not resolved and
7395 -- expanded until the enclosing construct is expanded. This will
7396 -- happen when the aggregate is limited and the declared object
7397 -- has a following address clause; it happens also when generating
7398 -- C code for an aggregate that has an alignment or address clause
7399 -- (see Analyze_Object_Declaration). Resolution is done without
7400 -- expansion because it will take place when the declaration
7401 -- itself is expanded.
7403 if (Is_Limited_Type
(Typ
) or else Modify_Tree_For_C
)
7404 and then not Analyzed
(Expr
)
7406 Expander_Mode_Save_And_Set
(False);
7407 Resolve
(Expr
, Typ
);
7408 Expander_Mode_Restore
;
7411 if not Special_Ret_Obj
then
7412 Convert_Aggr_In_Object_Decl
(N
);
7415 -- Ada 2005 (AI-318-02): If the initialization expression is a call
7416 -- to a build-in-place function, then access to the declared object
7417 -- must be passed to the function. Currently we limit such functions
7418 -- to those with constrained limited result subtypes, but eventually
7419 -- plan to expand the allowed forms of functions that are treated as
7422 elsif Is_Build_In_Place_Function_Call
(Expr_Q
) then
7423 Make_Build_In_Place_Call_In_Object_Declaration
(N
, Expr_Q
);
7425 -- The previous call expands the expression initializing the
7426 -- built-in-place object into further code that will be analyzed
7427 -- later. No further expansion needed here.
7431 -- This is the same as the previous 'elsif', except that the call has
7432 -- been transformed by other expansion activities into something like
7433 -- F(...)'Reference.
7435 elsif Nkind
(Expr_Q
) = N_Reference
7436 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7437 and then not Is_Expanded_Build_In_Place_Call
7438 (Unqual_Conv
(Prefix
(Expr_Q
)))
7440 Make_Build_In_Place_Call_In_Anonymous_Context
(Prefix
(Expr_Q
));
7442 -- The previous call expands the expression initializing the
7443 -- built-in-place object into further code that will be analyzed
7444 -- later. No further expansion needed here.
7448 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7449 -- expressions containing a build-in-place function call whose
7450 -- returned object covers interface types, and Expr_Q has calls to
7451 -- Ada.Tags.Displace to displace the pointer to the returned build-
7452 -- in-place object to reference the secondary dispatch table of a
7453 -- covered interface type.
7455 elsif Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
)) then
7456 Make_Build_In_Place_Iface_Call_In_Object_Declaration
(N
, Expr_Q
);
7458 -- The previous call expands the expression initializing the
7459 -- built-in-place object into further code that will be analyzed
7460 -- later. No further expansion needed here.
7464 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7465 -- class-wide interface object to ensure that we copy the full
7466 -- object, unless we are targetting a VM where interfaces are handled
7467 -- by VM itself. Note that if the root type of Typ is an ancestor of
7468 -- Expr's type, both types share the same dispatch table and there is
7469 -- no need to displace the pointer.
7471 elsif Is_Interface
(Typ
)
7473 -- Avoid never-ending recursion because if Equivalent_Type is set
7474 -- then we've done it already and must not do it again.
7477 (Nkind
(Obj_Def
) = N_Identifier
7478 and then Present
(Equivalent_Type
(Entity
(Obj_Def
))))
7480 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7482 -- If the object is a special return object, then bypass special
7483 -- treatment of class-wide interface initialization below. In this
7484 -- case, the expansion of the return statement will take care of
7485 -- creating the object (via allocator) and initializing it.
7487 if Special_Ret_Obj
then
7489 -- If the type needs finalization and is not inherently
7490 -- limited, then the target is adjusted after the copy
7491 -- and attached to the finalization list.
7493 if Needs_Finalization
(Typ
)
7494 and then not Is_Limited_View
(Typ
)
7498 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
7502 elsif Tagged_Type_Expansion
then
7504 Iface
: constant Entity_Id
:= Root_Type
(Typ
);
7506 Expr_Typ
: Entity_Id
;
7509 Ptr_Obj_Decl
: Node_Id
;
7510 Ptr_Obj_Id
: Entity_Id
;
7514 -- If the original node of the expression was a conversion
7515 -- to this specific class-wide interface type then restore
7516 -- the original node because we must copy the object before
7517 -- displacing the pointer to reference the secondary tag
7518 -- component. This code must be kept synchronized with the
7519 -- expansion done by routine Expand_Interface_Conversion
7521 if not Comes_From_Source
(Expr
)
7522 and then Nkind
(Expr
) = N_Explicit_Dereference
7523 and then Nkind
(Original_Node
(Expr
)) = N_Type_Conversion
7524 and then Etype
(Original_Node
(Expr
)) = Typ
7526 Rewrite
(Expr
, Original_Node
(Expression
(N
)));
7529 -- Avoid expansion of redundant interface conversion
7531 if Is_Interface
(Etype
(Expr
))
7532 and then Nkind
(Expr
) = N_Type_Conversion
7533 and then Etype
(Expr
) = Typ
7535 Expr_Q
:= Expression
(Expr
);
7540 Obj_Id
:= Make_Temporary
(Loc
, 'D', Expr_Q
);
7541 Expr_Typ
:= Base_Type
(Etype
(Expr_Q
));
7543 if Is_Class_Wide_Type
(Expr_Typ
) then
7544 Expr_Typ
:= Root_Type
(Expr_Typ
);
7548 -- CW : I'Class := Obj;
7550 -- Tmp : Typ := Obj;
7551 -- type Ityp is not null access I'Class;
7552 -- Rnn : constant Ityp := Ityp (Tmp.I_Tag'Address);
7553 -- CW : I'Class renames Rnn.all;
7555 if Comes_From_Source
(Expr_Q
)
7556 and then Is_Entity_Name
(Expr_Q
)
7557 and then not Is_Interface
(Expr_Typ
)
7558 and then Interface_Present_In_Ancestor
(Expr_Typ
, Typ
)
7559 and then (Expr_Typ
= Etype
(Expr_Typ
)
7561 Is_Variable_Size_Record
(Etype
(Expr_Typ
)))
7566 Make_Object_Declaration
(Loc
,
7567 Defining_Identifier
=> Obj_Id
,
7568 Object_Definition
=>
7569 New_Occurrence_Of
(Expr_Typ
, Loc
),
7570 Expression
=> Relocate_Node
(Expr_Q
)));
7572 -- Statically reference the tag associated with the
7576 Make_Selected_Component
(Loc
,
7577 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7580 (Find_Interface_Tag
(Expr_Typ
, Iface
), Loc
));
7583 -- IW : I'Class := Obj;
7585 -- type Equiv_Record is record ... end record;
7586 -- implicit subtype CW is <Class_Wide_Subtype>;
7587 -- Tmp : CW := CW!(Obj);
7588 -- type Ityp is not null access I'Class;
7589 -- Rnn : constant Ityp :=
7590 -- Ityp!(Displace (Tmp'Address, I'Tag));
7591 -- IW : I'Class renames Rnn.all;
7594 -- Generate the equivalent record type and update the
7595 -- subtype indication to reference it.
7597 Expand_Subtype_From_Expr
7600 Subtype_Indic
=> Obj_Def
,
7603 if not Is_Interface
(Etype
(Expr_Q
)) then
7604 New_Expr
:= Relocate_Node
(Expr_Q
);
7606 -- For interface types we use 'Address which displaces
7607 -- the pointer to the base of the object (if required)
7611 Unchecked_Convert_To
(Etype
(Obj_Def
),
7612 Make_Explicit_Dereference
(Loc
,
7613 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7614 Make_Attribute_Reference
(Loc
,
7615 Prefix
=> Relocate_Node
(Expr_Q
),
7616 Attribute_Name
=> Name_Address
))));
7621 if not Is_Limited_Record
(Expr_Typ
) then
7623 Make_Object_Declaration
(Loc
,
7624 Defining_Identifier
=> Obj_Id
,
7625 Object_Definition
=>
7626 New_Occurrence_Of
(Etype
(Obj_Def
), Loc
),
7627 Expression
=> New_Expr
));
7629 -- Rename limited type object since they cannot be copied
7630 -- This case occurs when the initialization expression
7631 -- has been previously expanded into a temporary object.
7635 Make_Object_Renaming_Declaration
(Loc
,
7636 Defining_Identifier
=> Obj_Id
,
7638 New_Occurrence_Of
(Etype
(Obj_Def
), Loc
),
7640 Unchecked_Convert_To
7641 (Etype
(Obj_Def
), New_Expr
)));
7644 -- Dynamically reference the tag associated with the
7648 Make_Function_Call
(Loc
,
7649 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
7650 Parameter_Associations
=> New_List
(
7651 Make_Attribute_Reference
(Loc
,
7652 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7653 Attribute_Name
=> Name_Address
),
7655 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
7659 -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
7660 -- to do the final conversion, but we insert an intermediate
7661 -- temporary before the dereference so that we can process
7662 -- the expansion as part of the analysis of the declaration
7663 -- of this temporary, and then rewrite manually the original
7664 -- object as the simple renaming of this dereference.
7666 Tag_Comp
:= Convert_Tag_To_Interface
(Typ
, Tag_Comp
);
7667 pragma Assert
(Nkind
(Tag_Comp
) = N_Explicit_Dereference
7669 Nkind
(Prefix
(Tag_Comp
)) = N_Unchecked_Type_Conversion
);
7671 Ptr_Obj_Id
:= Make_Temporary
(Loc
, 'R');
7674 Make_Object_Declaration
(Loc
,
7675 Defining_Identifier
=> Ptr_Obj_Id
,
7676 Constant_Present
=> True,
7677 Object_Definition
=>
7679 (Entity
(Subtype_Mark
(Prefix
(Tag_Comp
))), Loc
),
7680 Expression
=> Prefix
(Tag_Comp
));
7682 Insert_Action
(N
, Ptr_Obj_Decl
, Suppress
=> All_Checks
);
7684 Set_Prefix
(Tag_Comp
, New_Occurrence_Of
(Ptr_Obj_Id
, Loc
));
7686 Set_Etype
(Expr_Q
, Typ
);
7688 Rewrite_As_Renaming
:= True;
7695 -- Common case of explicit object initialization
7698 -- In most cases, we must check that the initial value meets any
7699 -- constraint imposed by the declared type. However, there is one
7700 -- very important exception to this rule. If the entity has an
7701 -- unconstrained nominal subtype, then it acquired its constraints
7702 -- from the expression in the first place, and not only does this
7703 -- mean that the constraint check is not needed, but an attempt to
7704 -- perform the constraint check can cause order of elaboration
7707 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
7709 -- If this is an allocator for an aggregate that has been
7710 -- allocated in place, delay checks until assignments are
7711 -- made, because the discriminants are not initialized.
7713 if Nkind
(Expr
) = N_Allocator
7714 and then No_Initialization
(Expr
)
7718 -- Otherwise apply a constraint check now if no prev error
7720 elsif Nkind
(Expr
) /= N_Error
then
7721 Apply_Constraint_Check
(Expr
, Typ
);
7723 -- Deal with possible range check
7725 if Do_Range_Check
(Expr
) then
7727 -- If assignment checks are suppressed, turn off flag
7729 if Suppress_Assignment_Checks
(N
) then
7730 Set_Do_Range_Check
(Expr
, False);
7732 -- Otherwise generate the range check
7735 Generate_Range_Check
7736 (Expr
, Typ
, CE_Range_Check_Failed
);
7742 -- For tagged types, when an init value is given, the tag has to
7743 -- be re-initialized separately in order to avoid the propagation
7744 -- of a wrong tag coming from a view conversion unless the type
7745 -- is class wide (in this case the tag comes from the init value).
7746 -- Suppress the tag assignment when not Tagged_Type_Expansion
7747 -- because tags are represented implicitly in objects. Ditto for
7748 -- types that are CPP_CLASS, and for initializations that are
7749 -- aggregates, because they have to have the right tag.
7751 -- The re-assignment of the tag has to be done even if the object
7752 -- is a constant. The assignment must be analyzed after the
7753 -- declaration. If an address clause follows, this is handled as
7754 -- part of the freeze actions for the object, otherwise insert
7755 -- tag assignment here.
7757 Tag_Assign
:= Make_Tag_Assignment
(N
);
7759 if Present
(Tag_Assign
) then
7760 if Present
(Following_Address_Clause
(N
)) then
7761 Ensure_Freeze_Node
(Def_Id
);
7762 elsif not Special_Ret_Obj
then
7763 Insert_Action_After
(Init_After
, Tag_Assign
);
7766 -- Handle C++ constructor calls. Note that we do not check that
7767 -- Typ is a tagged type since the equivalent Ada type of a C++
7768 -- class that has no virtual methods is an untagged limited
7771 elsif Is_CPP_Constructor_Call
(Expr
) then
7773 Id_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
7776 -- The call to the initialization procedure does NOT freeze
7777 -- the object being initialized.
7779 Set_Must_Not_Freeze
(Id_Ref
);
7780 Set_Assignment_OK
(Id_Ref
);
7782 Insert_Actions_After
(Init_After
,
7783 Build_Initialization_Call
(Loc
, Id_Ref
, Typ
,
7784 Constructor_Ref
=> Expr
));
7786 -- We remove here the original call to the constructor
7787 -- to avoid its management in the backend
7789 Set_Expression
(N
, Empty
);
7793 -- Handle initialization of limited tagged types
7795 elsif Is_Tagged_Type
(Typ
)
7796 and then Is_Class_Wide_Type
(Typ
)
7797 and then Is_Limited_Record
(Typ
)
7798 and then not Is_Limited_Interface
(Typ
)
7800 -- Given that the type is limited we cannot perform a copy. If
7801 -- Expr_Q is the reference to a variable we mark the variable
7802 -- as OK_To_Rename to expand this declaration into a renaming
7803 -- declaration (see below).
7805 if Is_Entity_Name
(Expr_Q
) then
7806 Set_OK_To_Rename
(Entity
(Expr_Q
));
7808 -- If we cannot convert the expression into a renaming we must
7809 -- consider it an internal error because the backend does not
7810 -- have support to handle it. But avoid crashing on a raise
7811 -- expression or conditional expression.
7813 elsif Nkind
(Original_Node
(Expr_Q
)) not in
7814 N_Raise_Expression | N_If_Expression | N_Case_Expression
7816 raise Program_Error
;
7819 -- For discrete types, set the Is_Known_Valid flag if the
7820 -- initializing value is known to be valid. Only do this for
7821 -- source assignments, since otherwise we can end up turning
7822 -- on the known valid flag prematurely from inserted code.
7824 elsif Comes_From_Source
(N
)
7825 and then Is_Discrete_Type
(Typ
)
7826 and then Expr_Known_Valid
(Expr
)
7827 and then Safe_To_Capture_Value
(N
, Def_Id
)
7829 Set_Is_Known_Valid
(Def_Id
);
7831 -- For access types, set the Is_Known_Non_Null flag if the
7832 -- initializing value is known to be non-null. We can also
7833 -- set Can_Never_Be_Null if this is a constant.
7835 elsif Is_Access_Type
(Typ
) and then Known_Non_Null
(Expr
) then
7836 Set_Is_Known_Non_Null
(Def_Id
, True);
7838 if Constant_Present
(N
) then
7839 Set_Can_Never_Be_Null
(Def_Id
);
7843 -- If validity checking on copies, validate initial expression.
7844 -- But skip this if declaration is for a generic type, since it
7845 -- makes no sense to validate generic types. Not clear if this
7846 -- can happen for legal programs, but it definitely can arise
7847 -- from previous instantiation errors.
7849 if Validity_Checks_On
7850 and then Comes_From_Source
(N
)
7851 and then Validity_Check_Copies
7852 and then not Is_Generic_Type
(Typ
)
7854 Ensure_Valid
(Expr
);
7856 if Safe_To_Capture_Value
(N
, Def_Id
) then
7857 Set_Is_Known_Valid
(Def_Id
);
7861 -- Now determine whether we will use a renaming
7863 Rewrite_As_Renaming
:=
7865 -- The declaration cannot be rewritten if it has got constraints
7866 -- in other words the nominal subtype must be unconstrained.
7868 Is_Entity_Name
(Original_Node
(Obj_Def
))
7870 -- The aliased case has to be excluded because the expression
7871 -- will not be aliased in the general case.
7873 and then not Aliased_Present
(N
)
7875 -- If the object declaration originally appears in the form
7877 -- Obj : Typ := Func (...);
7879 -- and has been rewritten as the dereference of a reference
7880 -- to the function result built either on the primary or the
7881 -- secondary stack, then the declaration can be rewritten as
7882 -- the renaming of this dereference:
7884 -- type Ann is access all Typ;
7885 -- Rnn : constant Axx := Func (...)'reference;
7886 -- Obj : Typ renames Rnn.all;
7888 -- This avoids an extra copy and, in the case where Typ needs
7889 -- finalization, a pair of Adjust/Finalize calls (see below).
7891 -- However, in the case of a special return object, we need to
7892 -- make sure that the object Rnn is properly recognized by the
7893 -- Is_Related_To_Func_Return predicate; otherwise, if it is of
7894 -- a type that needs finalization, Requires_Cleanup_Actions
7895 -- would return true because of this and Build_Finalizer would
7896 -- finalize it prematurely (see Expand_Simple_Function_Return
7897 -- for the same test in the case of a simple return).
7899 -- Moreover, in the case of a special return object, we also
7900 -- need to make sure that the two functions return on the same
7901 -- stack, otherwise we would create a dangling reference.
7904 ((not Is_Library_Level_Entity
(Def_Id
)
7905 and then Is_Captured_Function_Call
(Expr_Q
)
7907 (not Special_Ret_Obj
7909 (Is_Related_To_Func_Return
(Entity
(Prefix
(Expr_Q
)))
7910 and then Needs_Secondary_Stack
(Etype
(Expr_Q
)) =
7911 Needs_Secondary_Stack
(Etype
(Func_Id
)))))
7913 -- If the initializing expression is a variable with the
7914 -- flag OK_To_Rename set, then transform:
7916 -- Obj : Typ := Expr;
7920 -- Obj : Typ renames Expr;
7922 or else (OK_To_Rename_Ref
(Expr_Q
)
7923 and then not Special_Ret_Obj
)
7925 -- Likewise if it is a slice of such a variable
7927 or else (Nkind
(Expr_Q
) = N_Slice
7928 and then OK_To_Rename_Ref
(Prefix
(Expr_Q
))
7929 and then not Special_Ret_Obj
));
7931 -- If the type needs finalization and is not inherently limited,
7932 -- then the target is adjusted after the copy and attached to the
7933 -- finalization list. However, no adjustment is needed in the case
7934 -- where the object has been initialized by a call to a function
7935 -- returning on the primary stack (see Expand_Ctrl_Function_Call)
7936 -- since no copy occurred, given that the type is by-reference.
7937 -- Similarly, no adjustment is needed if we are going to rewrite
7938 -- the object declaration into a renaming declaration.
7940 if Needs_Finalization
(Typ
)
7941 and then not Is_Limited_View
(Typ
)
7942 and then Nkind
(Expr_Q
) /= N_Function_Call
7943 and then not Rewrite_As_Renaming
7947 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
7950 if Present
(Adj_Call
) and then not Special_Ret_Obj
then
7951 Insert_Action_After
(Init_After
, Adj_Call
);
7956 -- Cases where the back end cannot handle the initialization
7957 -- directly. In such cases, we expand an assignment that will
7958 -- be appropriately handled by Expand_N_Assignment_Statement.
7960 -- The exclusion of the unconstrained case is wrong, but for now it
7961 -- is too much trouble ???
7963 if (Is_Possibly_Unaligned_Slice
(Expr
)
7964 or else (Is_Possibly_Unaligned_Object
(Expr
)
7965 and then not Represented_As_Scalar
(Etype
(Expr
))))
7966 and then not (Is_Array_Type
(Etype
(Expr
))
7967 and then not Is_Constrained
(Etype
(Expr
)))
7970 Stat
: constant Node_Id
:=
7971 Make_Assignment_Statement
(Loc
,
7972 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
7973 Expression
=> Relocate_Node
(Expr
));
7975 Set_Assignment_OK
(Name
(Stat
));
7976 Set_No_Ctrl_Actions
(Stat
);
7977 Insert_Action_After
(Init_After
, Stat
);
7978 Set_Expression
(N
, Empty
);
7979 Set_No_Initialization
(N
);
7984 if Nkind
(Obj_Def
) = N_Access_Definition
7985 and then not Is_Local_Anonymous_Access
(Typ
)
7987 -- An Ada 2012 stand-alone object of an anonymous access type
7990 Loc
: constant Source_Ptr
:= Sloc
(N
);
7992 Level
: constant Entity_Id
:=
7993 Make_Defining_Identifier
(Sloc
(N
),
7995 New_External_Name
(Chars
(Def_Id
), Suffix
=> "L"));
7997 Level_Decl
: Node_Id
;
7998 Level_Expr
: Node_Id
;
8001 Mutate_Ekind
(Level
, Ekind
(Def_Id
));
8002 Set_Etype
(Level
, Standard_Natural
);
8003 Set_Scope
(Level
, Scope
(Def_Id
));
8005 -- Set accessibility level of null
8009 Make_Integer_Literal
8010 (Loc
, Scope_Depth
(Standard_Standard
));
8012 -- When the expression of the object is a function which returns
8013 -- an anonymous access type the master of the call is the object
8014 -- being initialized instead of the type.
8016 elsif Nkind
(Expr
) = N_Function_Call
8017 and then Ekind
(Etype
(Name
(Expr
))) = E_Anonymous_Access_Type
8019 Level_Expr
:= Accessibility_Level
8020 (Def_Id
, Object_Decl_Level
);
8025 Level_Expr
:= Accessibility_Level
(Expr
, Dynamic_Level
);
8029 Make_Object_Declaration
(Loc
,
8030 Defining_Identifier
=> Level
,
8031 Object_Definition
=>
8032 New_Occurrence_Of
(Standard_Natural
, Loc
),
8033 Expression
=> Level_Expr
,
8034 Constant_Present
=> Constant_Present
(N
),
8035 Has_Init_Expression
=> True);
8037 Insert_Action_After
(Init_After
, Level_Decl
);
8039 Set_Extra_Accessibility
(Def_Id
, Level
);
8043 -- If the object is default initialized and its type is subject to
8044 -- pragma Default_Initial_Condition, add a runtime check to verify
8045 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
8047 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
8049 -- Note that the check is generated for source objects only
8051 if Comes_From_Source
(Def_Id
)
8052 and then Has_DIC
(Typ
)
8053 and then Present
(DIC_Procedure
(Typ
))
8054 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
8055 and then not Has_Init_Expression
(N
)
8057 and then not Is_Imported
(Def_Id
)
8060 DIC_Call
: constant Node_Id
:=
8062 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Typ
);
8064 if Present
(Next_N
) then
8065 Insert_Before_And_Analyze
(Next_N
, DIC_Call
);
8067 -- The object declaration is the last node in a declarative or a
8071 Append_To
(List_Containing
(N
), DIC_Call
);
8077 -- If this is the return object of a build-in-place function, locate the
8078 -- implicit BIPaccess parameter designating the caller-supplied return
8079 -- object and convert the declaration to a renaming of a dereference of
8080 -- this parameter. If the declaration includes an expression, add an
8081 -- assignment statement to ensure the return object gets initialized.
8083 -- Result : T [:= <expression>];
8087 -- Result : T renames BIPaccess.all;
8088 -- [Result := <expression>;]
8090 -- in the constrained case, or to
8092 -- type Txx is access all ...;
8093 -- Rxx : Txx := null;
8095 -- if BIPalloc = 1 then
8096 -- Rxx := BIPaccess;
8097 -- Rxx.all := <expression>;
8098 -- elsif BIPalloc = 2 then
8099 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8100 -- system__secondary_stack__ss_pool][procedure_to_call =
8101 -- system__secondary_stack__ss_allocate];
8102 -- elsif BIPalloc = 3 then
8103 -- Rxx := new <expression-type>'(<expression>)
8104 -- elsif BIPalloc = 4 then
8105 -- Pxx : system__storage_pools__root_storage_pool renames
8106 -- BIPstoragepool.all;
8107 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8108 -- Pxx][procedure_to_call =
8109 -- system__storage_pools__allocate_any];
8111 -- [program_error "build in place mismatch"]
8114 -- Result : T renames Rxx.all;
8116 -- in the unconstrained case.
8118 if Is_Build_In_Place_Return_Object
(Def_Id
) then
8120 Init_Stmt
: Node_Id
;
8121 Obj_Acc_Formal
: Entity_Id
;
8124 -- Retrieve the implicit access parameter passed by the caller
8127 Build_In_Place_Formal
(Func_Id
, BIP_Object_Access
);
8129 -- If the return object's declaration includes an expression
8130 -- and the declaration isn't marked as No_Initialization, then
8131 -- we need to generate an assignment to the object and insert
8132 -- it after the declaration before rewriting it as a renaming
8133 -- (otherwise we'll lose the initialization). The case where
8134 -- the result type is an interface (or class-wide interface)
8135 -- is also excluded because the context of the function call
8136 -- must be unconstrained, so the initialization will always
8137 -- be done as part of an allocator evaluation (storage pool
8138 -- or secondary stack), never to a constrained target object
8139 -- passed in by the caller. Besides the assignment being
8140 -- unneeded in this case, it avoids problems with trying to
8141 -- generate a dispatching assignment when the return expression
8142 -- is a nonlimited descendant of a limited interface (the
8143 -- interface has no assignment operation).
8146 and then not Is_Delayed_Aggregate
(Expr_Q
)
8147 and then not No_Initialization
(N
)
8148 and then not Is_Interface
(Typ
)
8150 if Is_Class_Wide_Type
(Typ
)
8151 and then not Is_Class_Wide_Type
(Etype
(Expr_Q
))
8154 Make_Assignment_Statement
(Loc
,
8155 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8157 Make_Type_Conversion
(Loc
,
8159 New_Occurrence_Of
(Typ
, Loc
),
8160 Expression
=> New_Copy_Tree
(Expr_Q
)));
8164 Make_Assignment_Statement
(Loc
,
8165 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8166 Expression
=> New_Copy_Tree
(Expr_Q
));
8169 Set_Assignment_OK
(Name
(Init_Stmt
));
8170 Set_No_Ctrl_Actions
(Init_Stmt
);
8176 -- When the function's subtype is unconstrained, a run-time
8177 -- test may be needed to decide the form of allocation to use
8178 -- for the return object. The function has an implicit formal
8179 -- parameter indicating this. If the BIP_Alloc_Form formal has
8180 -- the value one, then the caller has passed access to an
8181 -- existing object for use as the return object. If the value
8182 -- is two, then the return object must be allocated on the
8183 -- secondary stack. If the value is three, then the return
8184 -- object must be allocated on the heap. Otherwise, the object
8185 -- must be allocated in a storage pool. We generate an if
8186 -- statement to test the BIP_Alloc_Form formal and initialize
8187 -- a local access value appropriately.
8189 if Needs_BIP_Alloc_Form
(Func_Id
) then
8191 Desig_Typ
: constant Entity_Id
:=
8192 (if Ekind
(Typ
) = E_Array_Subtype
8193 then Etype
(Func_Id
) else Typ
);
8194 -- Ensure that the we use a fat pointer when allocating
8195 -- an unconstrained array on the heap. In this case the
8196 -- result object's type is a constrained array type even
8197 -- though the function's type is unconstrained.
8199 Obj_Alloc_Formal
: constant Entity_Id
:=
8200 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
8201 Pool_Id
: constant Entity_Id
:=
8202 Make_Temporary
(Loc
, 'P');
8204 Acc_Typ
: Entity_Id
;
8205 Alloc_Obj_Decl
: Node_Id
;
8206 Alloc_Obj_Id
: Entity_Id
;
8207 Alloc_Stmt
: Node_Id
;
8208 Guard_Except
: Node_Id
;
8209 Heap_Allocator
: Node_Id
;
8210 Pool_Allocator
: Node_Id
;
8211 Pool_Decl
: Node_Id
;
8212 Ptr_Typ_Decl
: Node_Id
;
8213 SS_Allocator
: Node_Id
;
8216 -- Create an access type designating the function's
8219 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8222 Make_Full_Type_Declaration
(Loc
,
8223 Defining_Identifier
=> Acc_Typ
,
8225 Make_Access_To_Object_Definition
(Loc
,
8226 All_Present
=> True,
8227 Subtype_Indication
=>
8228 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8230 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8232 -- Create an access object that will be initialized to an
8233 -- access value denoting the return object, either coming
8234 -- from an implicit access value passed in by the caller
8235 -- or from the result of an allocator.
8237 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8240 Make_Object_Declaration
(Loc
,
8241 Defining_Identifier
=> Alloc_Obj_Id
,
8242 Object_Definition
=>
8243 New_Occurrence_Of
(Acc_Typ
, Loc
));
8245 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8247 -- First create the Heap_Allocator
8249 Heap_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8251 -- The Pool_Allocator is just like the Heap_Allocator,
8252 -- except we set Storage_Pool and Procedure_To_Call so
8253 -- it will use the user-defined storage pool.
8255 Pool_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8257 -- Do not generate the renaming of the build-in-place
8258 -- pool parameter on ZFP because the parameter is not
8259 -- created in the first place.
8261 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
8263 Make_Object_Renaming_Declaration
(Loc
,
8264 Defining_Identifier
=> Pool_Id
,
8267 (RTE
(RE_Root_Storage_Pool
), Loc
),
8269 Make_Explicit_Dereference
(Loc
,
8271 (Build_In_Place_Formal
8272 (Func_Id
, BIP_Storage_Pool
), Loc
)));
8273 Set_Storage_Pool
(Pool_Allocator
, Pool_Id
);
8274 Set_Procedure_To_Call
8275 (Pool_Allocator
, RTE
(RE_Allocate_Any
));
8277 Pool_Decl
:= Make_Null_Statement
(Loc
);
8280 -- If the No_Allocators restriction is active, then only
8281 -- an allocator for secondary stack allocation is needed.
8282 -- It's OK for such allocators to have Comes_From_Source
8283 -- set to False, because gigi knows not to flag them as
8284 -- being a violation of No_Implicit_Heap_Allocations.
8286 if Restriction_Active
(No_Allocators
) then
8287 SS_Allocator
:= Heap_Allocator
;
8288 Heap_Allocator
:= Make_Null
(Loc
);
8289 Pool_Allocator
:= Make_Null
(Loc
);
8291 -- Otherwise the heap and pool allocators may be needed,
8292 -- so we make another allocator for secondary stack
8296 SS_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8298 -- The heap and pool allocators are marked as
8299 -- Comes_From_Source since they correspond to an
8300 -- explicit user-written allocator (that is, it will
8301 -- only be executed on behalf of callers that call the
8302 -- function as initialization for such an allocator).
8303 -- Prevents errors when No_Implicit_Heap_Allocations
8306 Set_Comes_From_Source
(Heap_Allocator
, True);
8307 Set_Comes_From_Source
(Pool_Allocator
, True);
8310 -- The allocator is returned on the secondary stack
8312 Check_Restriction
(No_Secondary_Stack
, N
);
8313 Set_Storage_Pool
(SS_Allocator
, RTE
(RE_SS_Pool
));
8314 Set_Procedure_To_Call
8315 (SS_Allocator
, RTE
(RE_SS_Allocate
));
8317 -- The allocator is returned on the secondary stack,
8318 -- so indicate that the function return, as well as
8319 -- all blocks that encloses the allocator, must not
8320 -- release it. The flags must be set now because
8321 -- the decision to use the secondary stack is done
8322 -- very late in the course of expanding the return
8323 -- statement, past the point where these flags are
8326 Set_Uses_Sec_Stack
(Func_Id
);
8327 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8328 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8330 -- Guard against poor expansion on the caller side by
8331 -- using a raise statement to catch out-of-range values
8332 -- of formal parameter BIP_Alloc_Form.
8334 if Exceptions_OK
then
8336 Make_Raise_Program_Error
(Loc
,
8337 Reason
=> PE_Build_In_Place_Mismatch
);
8339 Guard_Except
:= Make_Null_Statement
(Loc
);
8342 -- Create an if statement to test the BIP_Alloc_Form
8343 -- formal and initialize the access object to either the
8344 -- BIP_Object_Access formal (BIP_Alloc_Form =
8345 -- Caller_Allocation), the result of allocating the
8346 -- object in the secondary stack (BIP_Alloc_Form =
8347 -- Secondary_Stack), or else an allocator to create the
8348 -- return object in the heap or user-defined pool
8349 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
8351 -- ??? An unchecked type conversion must be made in the
8352 -- case of assigning the access object formal to the
8353 -- local access object, because a normal conversion would
8354 -- be illegal in some cases (such as converting access-
8355 -- to-unconstrained to access-to-constrained), but the
8356 -- the unchecked conversion will presumably fail to work
8357 -- right in just such cases. It's not clear at all how to
8361 Make_If_Statement
(Loc
,
8365 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8367 Make_Integer_Literal
(Loc
,
8368 UI_From_Int
(BIP_Allocation_Form
'Pos
8369 (Caller_Allocation
)))),
8371 Then_Statements
=> New_List
(
8372 Make_Assignment_Statement
(Loc
,
8374 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8376 Unchecked_Convert_To
8378 New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)))),
8380 Elsif_Parts
=> New_List
(
8381 Make_Elsif_Part
(Loc
,
8385 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8387 Make_Integer_Literal
(Loc
,
8388 UI_From_Int
(BIP_Allocation_Form
'Pos
8389 (Secondary_Stack
)))),
8391 Then_Statements
=> New_List
(
8392 Make_Assignment_Statement
(Loc
,
8394 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8395 Expression
=> SS_Allocator
))),
8397 Make_Elsif_Part
(Loc
,
8401 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8403 Make_Integer_Literal
(Loc
,
8404 UI_From_Int
(BIP_Allocation_Form
'Pos
8407 Then_Statements
=> New_List
(
8408 Build_Heap_Or_Pool_Allocator
8409 (Temp_Id
=> Alloc_Obj_Id
,
8410 Temp_Typ
=> Acc_Typ
,
8411 Ret_Typ
=> Desig_Typ
,
8412 Alloc_Expr
=> Heap_Allocator
))),
8414 -- ??? If all is well, we can put the following
8415 -- 'elsif' in the 'else', but this is a useful
8416 -- self-check in case caller and callee don't agree
8417 -- on whether BIPAlloc and so on should be passed.
8419 Make_Elsif_Part
(Loc
,
8423 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8425 Make_Integer_Literal
(Loc
,
8426 UI_From_Int
(BIP_Allocation_Form
'Pos
8427 (User_Storage_Pool
)))),
8429 Then_Statements
=> New_List
(
8431 Build_Heap_Or_Pool_Allocator
8432 (Temp_Id
=> Alloc_Obj_Id
,
8433 Temp_Typ
=> Acc_Typ
,
8434 Ret_Typ
=> Desig_Typ
,
8435 Alloc_Expr
=> Pool_Allocator
)))),
8437 -- Raise Program_Error if it's none of the above;
8438 -- this is a compiler bug.
8440 Else_Statements
=> New_List
(Guard_Except
));
8442 -- If a separate initialization assignment was created
8443 -- earlier, append that following the assignment of the
8444 -- implicit access formal to the access object, to ensure
8445 -- that the return object is initialized in that case. In
8446 -- this situation, the target of the assignment must be
8447 -- rewritten to denote a dereference of the access to the
8448 -- return object passed in by the caller.
8450 if Present
(Init_Stmt
) then
8451 Set_Name
(Init_Stmt
,
8452 Make_Explicit_Dereference
(Loc
,
8453 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
)));
8454 Set_Assignment_OK
(Name
(Init_Stmt
));
8456 Append_To
(Then_Statements
(Alloc_Stmt
), Init_Stmt
);
8460 Insert_Action
(N
, Alloc_Stmt
, Suppress
=> All_Checks
);
8462 -- From now on, the type of the return object is the
8465 if Desig_Typ
/= Typ
then
8466 Set_Etype
(Def_Id
, Desig_Typ
);
8467 Set_Actual_Subtype
(Def_Id
, Typ
);
8470 -- Remember the local access object for use in the
8471 -- dereference of the renaming created below.
8473 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8476 -- When the function's type is unconstrained and a run-time test
8477 -- is not needed, we nevertheless need to build the return using
8478 -- the return object's type.
8480 elsif not Is_Constrained
(Underlying_Type
(Etype
(Func_Id
))) then
8482 Acc_Typ
: Entity_Id
;
8483 Alloc_Obj_Decl
: Node_Id
;
8484 Alloc_Obj_Id
: Entity_Id
;
8485 Ptr_Typ_Decl
: Node_Id
;
8488 -- Create an access type designating the function's
8491 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8494 Make_Full_Type_Declaration
(Loc
,
8495 Defining_Identifier
=> Acc_Typ
,
8497 Make_Access_To_Object_Definition
(Loc
,
8498 All_Present
=> True,
8499 Subtype_Indication
=>
8500 New_Occurrence_Of
(Typ
, Loc
)));
8502 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8504 -- Create an access object initialized to the conversion
8505 -- of the implicit access value passed in by the caller.
8507 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8509 -- See the ??? comment a few lines above about the use of
8510 -- an unchecked conversion here.
8513 Make_Object_Declaration
(Loc
,
8514 Defining_Identifier
=> Alloc_Obj_Id
,
8515 Constant_Present
=> True,
8516 Object_Definition
=>
8517 New_Occurrence_Of
(Acc_Typ
, Loc
),
8519 Unchecked_Convert_To
8520 (Acc_Typ
, New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)));
8522 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8524 -- Remember the local access object for use in the
8525 -- dereference of the renaming created below.
8527 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8531 -- Initialize the object now that it has got its final subtype,
8532 -- but before rewriting it as a renaming.
8534 Initialize_Return_Object
8535 (Tag_Assign
, Adj_Call
, Expr_Q
, Init_Stmt
, Init_After
);
8537 -- Replace the return object declaration with a renaming of a
8538 -- dereference of the access value designating the return object.
8541 Make_Explicit_Dereference
(Loc
,
8542 Prefix
=> New_Occurrence_Of
(Obj_Acc_Formal
, Loc
));
8543 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8545 Rewrite_As_Renaming
:= True;
8548 -- If we can rename the initialization expression, we need to make sure
8549 -- that we use the proper type in the case of a return object that lives
8550 -- on the secondary stack (see other cases below for a similar handling)
8551 -- and that the tag is assigned in the case of any return object.
8553 elsif Rewrite_As_Renaming
then
8554 if Special_Ret_Obj
then
8556 Desig_Typ
: constant Entity_Id
:=
8557 (if Ekind
(Typ
) = E_Array_Subtype
8558 then Etype
(Func_Id
) else Typ
);
8561 -- From now on, the type of the return object is the
8564 if Desig_Typ
/= Typ
then
8565 Set_Etype
(Def_Id
, Desig_Typ
);
8566 Set_Actual_Subtype
(Def_Id
, Typ
);
8569 if Present
(Tag_Assign
) then
8570 Insert_Action_After
(Init_After
, Tag_Assign
);
8573 -- Ada 2005 (AI95-344): If the result type is class-wide,
8574 -- insert a check that the level of the return expression's
8575 -- underlying type is not deeper than the level of the master
8576 -- enclosing the function.
8578 -- AI12-043: The check is made immediately after the return
8579 -- object is created.
8581 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
8582 Apply_CW_Accessibility_Check
(Expr_Q
, Func_Id
);
8587 -- If this is the return object of a function returning on the secondary
8588 -- stack, convert the declaration to a renaming of the dereference of ah
8589 -- allocator for the secondary stack.
8591 -- Result : T [:= <expression>];
8595 -- type Txx is access all ...;
8596 -- Rxx : constant Txx :=
8597 -- new <expression-type>['(<expression>)][storage_pool =
8598 -- system__secondary_stack__ss_pool][procedure_to_call =
8599 -- system__secondary_stack__ss_allocate];
8601 -- Result : T renames Rxx.all;
8603 elsif Is_Secondary_Stack_Return_Object
(Def_Id
) then
8605 Desig_Typ
: constant Entity_Id
:=
8606 (if Ekind
(Typ
) = E_Array_Subtype
8607 then Etype
(Func_Id
) else Typ
);
8608 -- Ensure that the we use a fat pointer when allocating
8609 -- an unconstrained array on the heap. In this case the
8610 -- result object's type is a constrained array type even
8611 -- though the function's type is unconstrained.
8613 Acc_Typ
: Entity_Id
;
8614 Alloc_Obj_Decl
: Node_Id
;
8615 Alloc_Obj_Id
: Entity_Id
;
8616 Ptr_Type_Decl
: Node_Id
;
8619 -- Create an access type designating the function's
8622 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8625 Make_Full_Type_Declaration
(Loc
,
8626 Defining_Identifier
=> Acc_Typ
,
8628 Make_Access_To_Object_Definition
(Loc
,
8629 All_Present
=> True,
8630 Subtype_Indication
=>
8631 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8633 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
8635 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
8637 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8640 Make_Object_Declaration
(Loc
,
8641 Defining_Identifier
=> Alloc_Obj_Id
,
8642 Constant_Present
=> True,
8643 Object_Definition
=>
8644 New_Occurrence_Of
(Acc_Typ
, Loc
),
8645 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
8647 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8649 Set_Uses_Sec_Stack
(Func_Id
);
8650 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8651 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8653 -- From now on, the type of the return object is the
8656 if Desig_Typ
/= Typ
then
8657 Set_Etype
(Def_Id
, Desig_Typ
);
8658 Set_Actual_Subtype
(Def_Id
, Typ
);
8661 -- Initialize the object now that it has got its final subtype,
8662 -- but before rewriting it as a renaming.
8664 Initialize_Return_Object
8665 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
8667 -- Replace the return object declaration with a renaming of a
8668 -- dereference of the access value designating the return object.
8671 Make_Explicit_Dereference
(Loc
,
8672 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
8673 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8675 Rewrite_As_Renaming
:= True;
8678 -- If this is the return object of a function returning a by-reference
8679 -- type, convert the declaration to a renaming of the dereference of ah
8680 -- allocator for the return stack.
8682 -- Result : T [:= <expression>];
8686 -- type Txx is access all ...;
8687 -- Rxx : constant Txx :=
8688 -- new <expression-type>['(<expression>)][storage_pool =
8689 -- system__return_stack__rs_pool][procedure_to_call =
8690 -- system__return_stack__rs_allocate];
8692 -- Result : T renames Rxx.all;
8694 elsif Back_End_Return_Slot
8695 and then Is_By_Reference_Return_Object
(Def_Id
)
8698 Acc_Typ
: Entity_Id
;
8699 Alloc_Obj_Decl
: Node_Id
;
8700 Alloc_Obj_Id
: Entity_Id
;
8701 Ptr_Type_Decl
: Node_Id
;
8704 -- Create an access type designating the function's
8707 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8710 Make_Full_Type_Declaration
(Loc
,
8711 Defining_Identifier
=> Acc_Typ
,
8713 Make_Access_To_Object_Definition
(Loc
,
8714 All_Present
=> True,
8715 Subtype_Indication
=>
8716 New_Occurrence_Of
(Typ
, Loc
)));
8718 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
8720 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_RS_Pool
));
8722 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8725 Make_Object_Declaration
(Loc
,
8726 Defining_Identifier
=> Alloc_Obj_Id
,
8727 Constant_Present
=> True,
8728 Object_Definition
=>
8729 New_Occurrence_Of
(Acc_Typ
, Loc
),
8730 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
8732 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8734 -- Initialize the object now that it has got its final subtype,
8735 -- but before rewriting it as a renaming.
8737 Initialize_Return_Object
8738 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
8740 -- Replace the return object declaration with a renaming of a
8741 -- dereference of the access value designating the return object.
8744 Make_Explicit_Dereference
(Loc
,
8745 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
8746 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8748 Rewrite_As_Renaming
:= True;
8752 -- Final transformation - turn the object declaration into a renaming
8753 -- if appropriate. If this is the completion of a deferred constant
8754 -- declaration, then this transformation generates what would be
8755 -- illegal code if written by hand, but that's OK.
8757 if Rewrite_As_Renaming
then
8759 Make_Object_Renaming_Declaration
(Loc
,
8760 Defining_Identifier
=> Def_Id
,
8761 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Def_Id
), Loc
),
8764 -- We do not analyze this renaming declaration, because all its
8765 -- components have already been analyzed, and if we were to go
8766 -- ahead and analyze it, we would in effect be trying to generate
8767 -- another declaration of X, which won't do.
8769 Set_Renamed_Object
(Def_Id
, Expr_Q
);
8772 -- We do need to deal with debug issues for this renaming
8774 -- First, if entity comes from source, then mark it as needing
8775 -- debug information, even though it is defined by a generated
8776 -- renaming that does not come from source.
8778 Set_Debug_Info_Defining_Id
(N
);
8780 -- Now call the routine to generate debug info for the renaming
8782 Insert_Action
(N
, Debug_Renaming_Declaration
(N
));
8785 -- Exception on library entity not available
8788 when RE_Not_Available
=>
8790 end Expand_N_Object_Declaration
;
8792 ---------------------------------
8793 -- Expand_N_Subtype_Indication --
8794 ---------------------------------
8796 -- Add a check on the range of the subtype and deal with validity checking
8798 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
8799 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
8800 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
8803 if Nkind
(Constraint
(N
)) = N_Range_Constraint
then
8804 Validity_Check_Range
(Range_Expression
(Constraint
(N
)));
8807 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
8809 if Nkind
(Parent
(N
)) in N_Constrained_Array_Definition | N_Slice
8810 and then Nkind
(Parent
(Parent
(N
))) not in
8811 N_Full_Type_Declaration | N_Object_Declaration
8813 Apply_Range_Check
(Ran
, Typ
);
8815 end Expand_N_Subtype_Indication
;
8817 ---------------------------
8818 -- Expand_N_Variant_Part --
8819 ---------------------------
8821 -- Note: this procedure no longer has any effect. It used to be that we
8822 -- would replace the choices in the last variant by a when others, and
8823 -- also expanded static predicates in variant choices here, but both of
8824 -- those activities were being done too early, since we can't check the
8825 -- choices until the statically predicated subtypes are frozen, which can
8826 -- happen as late as the free point of the record, and we can't change the
8827 -- last choice to an others before checking the choices, which is now done
8828 -- at the freeze point of the record.
8830 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
8833 end Expand_N_Variant_Part
;
8835 ---------------------------------
8836 -- Expand_Previous_Access_Type --
8837 ---------------------------------
8839 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
8840 Ptr_Typ
: Entity_Id
;
8843 -- Find all access types in the current scope whose designated type is
8844 -- Def_Id and build master renamings for them.
8846 Ptr_Typ
:= First_Entity
(Current_Scope
);
8847 while Present
(Ptr_Typ
) loop
8848 if Is_Access_Type
(Ptr_Typ
)
8849 and then Designated_Type
(Ptr_Typ
) = Def_Id
8850 and then No
(Master_Id
(Ptr_Typ
))
8852 -- Ensure that the designated type has a master
8854 Build_Master_Entity
(Def_Id
);
8856 -- Private and incomplete types complicate the insertion of master
8857 -- renamings because the access type may precede the full view of
8858 -- the designated type. For this reason, the master renamings are
8859 -- inserted relative to the designated type.
8861 Build_Master_Renaming
(Ptr_Typ
, Ins_Nod
=> Parent
(Def_Id
));
8864 Next_Entity
(Ptr_Typ
);
8866 end Expand_Previous_Access_Type
;
8868 -----------------------------
8869 -- Expand_Record_Extension --
8870 -----------------------------
8872 -- Add a field _parent at the beginning of the record extension. This is
8873 -- used to implement inheritance. Here are some examples of expansion:
8875 -- 1. no discriminants
8876 -- type T2 is new T1 with null record;
8878 -- type T2 is new T1 with record
8882 -- 2. renamed discriminants
8883 -- type T2 (B, C : Int) is new T1 (A => B) with record
8884 -- _Parent : T1 (A => B);
8888 -- 3. inherited discriminants
8889 -- type T2 is new T1 with record -- discriminant A inherited
8890 -- _Parent : T1 (A);
8894 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
8895 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8896 Loc
: constant Source_Ptr
:= Sloc
(Def
);
8897 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
8898 Par_Subtype
: Entity_Id
;
8899 Comp_List
: Node_Id
;
8900 Comp_Decl
: Node_Id
;
8903 List_Constr
: constant List_Id
:= New_List
;
8906 -- Expand_Record_Extension is called directly from the semantics, so
8907 -- we must check to see whether expansion is active before proceeding,
8908 -- because this affects the visibility of selected components in bodies
8909 -- of instances. Within a generic we still need to set Parent_Subtype
8910 -- link because the visibility of inherited components will have to be
8911 -- verified in subsequent instances.
8913 if not Expander_Active
then
8914 if Inside_A_Generic
and then Ekind
(T
) = E_Record_Type
then
8915 Set_Parent_Subtype
(T
, Etype
(T
));
8920 -- This may be a derivation of an untagged private type whose full
8921 -- view is tagged, in which case the Derived_Type_Definition has no
8922 -- extension part. Build an empty one now.
8924 if No
(Rec_Ext_Part
) then
8926 Make_Record_Definition
(Loc
,
8928 Component_List
=> Empty
,
8929 Null_Present
=> True);
8931 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
8932 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
8935 Comp_List
:= Component_List
(Rec_Ext_Part
);
8937 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
8939 -- If the derived type inherits its discriminants the type of the
8940 -- _parent field must be constrained by the inherited discriminants
8942 if Has_Discriminants
(T
)
8943 and then Nkind
(Indic
) /= N_Subtype_Indication
8944 and then not Is_Constrained
(Entity
(Indic
))
8946 D
:= First_Discriminant
(T
);
8947 while Present
(D
) loop
8948 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
8949 Next_Discriminant
(D
);
8954 Make_Subtype_Indication
(Loc
,
8955 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Indic
), Loc
),
8957 Make_Index_Or_Discriminant_Constraint
(Loc
,
8958 Constraints
=> List_Constr
)),
8961 -- Otherwise the original subtype_indication is just what is needed
8964 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
8967 Set_Parent_Subtype
(T
, Par_Subtype
);
8970 Make_Component_Declaration
(Loc
,
8971 Defining_Identifier
=> Parent_N
,
8972 Component_Definition
=>
8973 Make_Component_Definition
(Loc
,
8974 Aliased_Present
=> False,
8975 Subtype_Indication
=> New_Occurrence_Of
(Par_Subtype
, Loc
)));
8977 if Null_Present
(Rec_Ext_Part
) then
8978 Set_Component_List
(Rec_Ext_Part
,
8979 Make_Component_List
(Loc
,
8980 Component_Items
=> New_List
(Comp_Decl
),
8981 Variant_Part
=> Empty
,
8982 Null_Present
=> False));
8983 Set_Null_Present
(Rec_Ext_Part
, False);
8985 elsif Null_Present
(Comp_List
)
8986 or else Is_Empty_List
(Component_Items
(Comp_List
))
8988 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
8989 Set_Null_Present
(Comp_List
, False);
8992 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
8995 Analyze
(Comp_Decl
);
8996 end Expand_Record_Extension
;
8998 ------------------------
8999 -- Expand_Tagged_Root --
9000 ------------------------
9002 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
9003 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
9004 Comp_List
: Node_Id
;
9005 Comp_Decl
: Node_Id
;
9006 Sloc_N
: Source_Ptr
;
9009 if Null_Present
(Def
) then
9010 Set_Component_List
(Def
,
9011 Make_Component_List
(Sloc
(Def
),
9012 Component_Items
=> Empty_List
,
9013 Variant_Part
=> Empty
,
9014 Null_Present
=> True));
9017 Comp_List
:= Component_List
(Def
);
9019 if Null_Present
(Comp_List
)
9020 or else Is_Empty_List
(Component_Items
(Comp_List
))
9022 Sloc_N
:= Sloc
(Comp_List
);
9024 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
9028 Make_Component_Declaration
(Sloc_N
,
9029 Defining_Identifier
=> First_Tag_Component
(T
),
9030 Component_Definition
=>
9031 Make_Component_Definition
(Sloc_N
,
9032 Aliased_Present
=> False,
9033 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RE_Tag
), Sloc_N
)));
9035 if Null_Present
(Comp_List
)
9036 or else Is_Empty_List
(Component_Items
(Comp_List
))
9038 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9039 Set_Null_Present
(Comp_List
, False);
9042 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9045 -- We don't Analyze the whole expansion because the tag component has
9046 -- already been analyzed previously. Here we just insure that the tree
9047 -- is coherent with the semantic decoration
9049 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
9052 when RE_Not_Available
=>
9054 end Expand_Tagged_Root
;
9056 ------------------------------
9057 -- Freeze_Stream_Operations --
9058 ------------------------------
9060 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
9061 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
9066 Stream_Op
: Entity_Id
;
9069 -- Primitive operations of tagged types are frozen when the dispatch
9070 -- table is constructed.
9072 if not Comes_From_Source
(Typ
) or else Is_Tagged_Type
(Typ
) then
9076 for J
in Names
'Range loop
9077 Stream_Op
:= TSS
(Typ
, Names
(J
));
9079 if Present
(Stream_Op
)
9080 and then Is_Subprogram
(Stream_Op
)
9081 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
9082 N_Subprogram_Declaration
9083 and then not Is_Frozen
(Stream_Op
)
9085 Append_Freeze_Actions
(Typ
, Freeze_Entity
(Stream_Op
, N
));
9088 end Freeze_Stream_Operations
;
9094 -- Full type declarations are expanded at the point at which the type is
9095 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
9096 -- declarations generated by the freezing (e.g. the procedure generated
9097 -- for initialization) are chained in the Actions field list of the freeze
9098 -- node using Append_Freeze_Actions.
9100 -- WARNING: This routine manages Ghost regions. Return statements must be
9101 -- replaced by gotos which jump to the end of the routine and restore the
9104 function Freeze_Type
(N
: Node_Id
) return Boolean is
9105 procedure Process_RACW_Types
(Typ
: Entity_Id
);
9106 -- Validate and generate stubs for all RACW types associated with type
9109 procedure Process_Pending_Access_Types
(Typ
: Entity_Id
);
9110 -- Associate type Typ's Finalize_Address primitive with the finalization
9111 -- masters of pending access-to-Typ types.
9113 ------------------------
9114 -- Process_RACW_Types --
9115 ------------------------
9117 procedure Process_RACW_Types
(Typ
: Entity_Id
) is
9118 List
: constant Elist_Id
:= Access_Types_To_Process
(N
);
9120 Seen
: Boolean := False;
9123 if Present
(List
) then
9124 E
:= First_Elmt
(List
);
9125 while Present
(E
) loop
9126 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
9127 Validate_RACW_Primitives
(Node
(E
));
9135 -- If there are RACWs designating this type, make stubs now
9138 Remote_Types_Tagged_Full_View_Encountered
(Typ
);
9140 end Process_RACW_Types
;
9142 ----------------------------------
9143 -- Process_Pending_Access_Types --
9144 ----------------------------------
9146 procedure Process_Pending_Access_Types
(Typ
: Entity_Id
) is
9150 -- Finalize_Address is not generated in CodePeer mode because the
9151 -- body contains address arithmetic. This processing is disabled.
9153 if CodePeer_Mode
then
9156 -- Certain itypes are generated for contexts that cannot allocate
9157 -- objects and should not set primitive Finalize_Address.
9159 elsif Is_Itype
(Typ
)
9160 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
9161 N_Explicit_Dereference
9165 -- When an access type is declared after the incomplete view of a
9166 -- Taft-amendment type, the access type is considered pending in
9167 -- case the full view of the Taft-amendment type is controlled. If
9168 -- this is indeed the case, associate the Finalize_Address routine
9169 -- of the full view with the finalization masters of all pending
9170 -- access types. This scenario applies to anonymous access types as
9173 elsif Needs_Finalization
(Typ
)
9174 and then Present
(Pending_Access_Types
(Typ
))
9176 E
:= First_Elmt
(Pending_Access_Types
(Typ
));
9177 while Present
(E
) loop
9180 -- Set_Finalize_Address
9181 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
9183 Append_Freeze_Action
(Typ
,
9184 Make_Set_Finalize_Address_Call
9186 Ptr_Typ
=> Node
(E
)));
9191 end Process_Pending_Access_Types
;
9195 Def_Id
: constant Entity_Id
:= Entity
(N
);
9197 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
9198 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
9199 -- Save the Ghost-related attributes to restore on exit
9201 Result
: Boolean := False;
9203 -- Start of processing for Freeze_Type
9206 -- The type being frozen may be subject to pragma Ghost. Set the mode
9207 -- now to ensure that any nodes generated during freezing are properly
9210 Set_Ghost_Mode
(Def_Id
);
9212 -- Process any remote access-to-class-wide types designating the type
9215 Process_RACW_Types
(Def_Id
);
9217 -- Freeze processing for record types
9219 if Is_Record_Type
(Def_Id
) then
9220 if Ekind
(Def_Id
) = E_Record_Type
then
9221 Expand_Freeze_Record_Type
(N
);
9222 elsif Is_Class_Wide_Type
(Def_Id
) then
9223 Expand_Freeze_Class_Wide_Type
(N
);
9226 -- Freeze processing for array types
9228 elsif Is_Array_Type
(Def_Id
) then
9229 Expand_Freeze_Array_Type
(N
);
9231 -- Freeze processing for access types
9233 -- For pool-specific access types, find out the pool object used for
9234 -- this type, needs actual expansion of it in some cases. Here are the
9235 -- different cases :
9237 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
9238 -- ---> don't use any storage pool
9240 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
9242 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
9244 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9245 -- ---> Storage Pool is the specified one
9247 -- See GNAT Pool packages in the Run-Time for more details
9249 elsif Ekind
(Def_Id
) in E_Access_Type | E_General_Access_Type
then
9251 Loc
: constant Source_Ptr
:= Sloc
(N
);
9252 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
9254 Freeze_Action_Typ
: Entity_Id
;
9255 Pool_Object
: Entity_Id
;
9260 -- Rep Clause "for Def_Id'Storage_Size use 0;"
9261 -- ---> don't use any storage pool
9263 if No_Pool_Assigned
(Def_Id
) then
9268 -- Rep Clause : for Def_Id'Storage_Size use Expr.
9270 -- Def_Id__Pool : Stack_Bounded_Pool
9271 -- (Expr, DT'Size, DT'Alignment);
9273 elsif Has_Storage_Size_Clause
(Def_Id
) then
9279 -- For unconstrained composite types we give a size of zero
9280 -- so that the pool knows that it needs a special algorithm
9281 -- for variable size object allocation.
9283 if Is_Composite_Type
(Desig_Type
)
9284 and then not Is_Constrained
(Desig_Type
)
9286 DT_Size
:= Make_Integer_Literal
(Loc
, 0);
9287 DT_Align
:= Make_Integer_Literal
(Loc
, Maximum_Alignment
);
9291 Make_Attribute_Reference
(Loc
,
9292 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9293 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
9296 Make_Attribute_Reference
(Loc
,
9297 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9298 Attribute_Name
=> Name_Alignment
);
9302 Make_Defining_Identifier
(Loc
,
9303 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
9305 -- We put the code associated with the pools in the entity
9306 -- that has the later freeze node, usually the access type
9307 -- but it can also be the designated_type; because the pool
9308 -- code requires both those types to be frozen
9310 if Is_Frozen
(Desig_Type
)
9311 and then (No
(Freeze_Node
(Desig_Type
))
9312 or else Analyzed
(Freeze_Node
(Desig_Type
)))
9314 Freeze_Action_Typ
:= Def_Id
;
9316 -- A Taft amendment type cannot get the freeze actions
9317 -- since the full view is not there.
9319 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
9320 and then No
(Full_View
(Desig_Type
))
9322 Freeze_Action_Typ
:= Def_Id
;
9325 Freeze_Action_Typ
:= Desig_Type
;
9328 Append_Freeze_Action
(Freeze_Action_Typ
,
9329 Make_Object_Declaration
(Loc
,
9330 Defining_Identifier
=> Pool_Object
,
9331 Object_Definition
=>
9332 Make_Subtype_Indication
(Loc
,
9335 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
9338 Make_Index_Or_Discriminant_Constraint
(Loc
,
9339 Constraints
=> New_List
(
9341 -- First discriminant is the Pool Size
9344 Storage_Size_Variable
(Def_Id
), Loc
),
9346 -- Second discriminant is the element size
9350 -- Third discriminant is the alignment
9355 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
9359 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9360 -- ---> Storage Pool is the specified one
9362 -- When compiling in Ada 2012 mode, ensure that the accessibility
9363 -- level of the subpool access type is not deeper than that of the
9364 -- pool_with_subpools.
9366 elsif Ada_Version
>= Ada_2012
9367 and then Present
(Associated_Storage_Pool
(Def_Id
))
9368 and then RTU_Loaded
(System_Storage_Pools_Subpools
)
9371 Loc
: constant Source_Ptr
:= Sloc
(Def_Id
);
9372 Pool
: constant Entity_Id
:=
9373 Associated_Storage_Pool
(Def_Id
);
9376 -- It is known that the accessibility level of the access
9377 -- type is deeper than that of the pool.
9379 if Type_Access_Level
(Def_Id
)
9380 > Static_Accessibility_Level
(Pool
, Object_Decl_Level
)
9381 and then Is_Class_Wide_Type
(Etype
(Pool
))
9382 and then not Accessibility_Checks_Suppressed
(Def_Id
)
9383 and then not Accessibility_Checks_Suppressed
(Pool
)
9385 -- When the pool is of a class-wide type, it may or may
9386 -- not support subpools depending on the path of
9387 -- derivation. Generate:
9389 -- if Def_Id in RSPWS'Class then
9390 -- raise Program_Error;
9393 Append_Freeze_Action
(Def_Id
,
9394 Make_If_Statement
(Loc
,
9397 Left_Opnd
=> New_Occurrence_Of
(Pool
, Loc
),
9402 (RE_Root_Storage_Pool_With_Subpools
)),
9404 Then_Statements
=> New_List
(
9405 Make_Raise_Program_Error
(Loc
,
9406 Reason
=> PE_Accessibility_Check_Failed
))));
9411 -- For access-to-controlled types (including class-wide types and
9412 -- Taft-amendment types, which potentially have controlled
9413 -- components), expand the list controller object that will store
9414 -- the dynamically allocated objects. Don't do this transformation
9415 -- for expander-generated access types, except do it for types
9416 -- that are the full view of types derived from other private
9417 -- types and for access types used to implement indirect temps.
9418 -- Also suppress the list controller in the case of a designated
9419 -- type with convention Java, since this is used when binding to
9420 -- Java API specs, where there's no equivalent of a finalization
9421 -- list and we don't want to pull in the finalization support if
9424 if not Comes_From_Source
(Def_Id
)
9425 and then not Has_Private_Declaration
(Def_Id
)
9426 and then not Old_Attr_Util
.Indirect_Temps
9427 .Is_Access_Type_For_Indirect_Temp
(Def_Id
)
9431 -- An exception is made for types defined in the run-time because
9432 -- Ada.Tags.Tag itself is such a type and cannot afford this
9433 -- unnecessary overhead that would generates a loop in the
9434 -- expansion scheme. Another exception is if Restrictions
9435 -- (No_Finalization) is active, since then we know nothing is
9438 elsif Restriction_Active
(No_Finalization
)
9439 or else In_Runtime
(Def_Id
)
9443 -- Create a finalization master for an access-to-controlled type
9444 -- or an access-to-incomplete type. It is assumed that the full
9445 -- view will be controlled.
9447 elsif Needs_Finalization
(Desig_Type
)
9448 or else (Is_Incomplete_Type
(Desig_Type
)
9449 and then No
(Full_View
(Desig_Type
)))
9451 Build_Finalization_Master
(Def_Id
);
9453 -- Create a finalization master when the designated type contains
9454 -- a private component. It is assumed that the full view will be
9457 elsif Has_Private_Component
(Desig_Type
) then
9458 Build_Finalization_Master
9460 For_Private
=> True,
9461 Context_Scope
=> Scope
(Def_Id
),
9462 Insertion_Node
=> Declaration_Node
(Desig_Type
));
9466 -- Freeze processing for enumeration types
9468 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
9470 -- We only have something to do if we have a non-standard
9471 -- representation (i.e. at least one literal whose pos value
9472 -- is not the same as its representation)
9474 if Has_Non_Standard_Rep
(Def_Id
) then
9475 Expand_Freeze_Enumeration_Type
(N
);
9478 -- Private types that are completed by a derivation from a private
9479 -- type have an internally generated full view, that needs to be
9480 -- frozen. This must be done explicitly because the two views share
9481 -- the freeze node, and the underlying full view is not visible when
9482 -- the freeze node is analyzed.
9484 elsif Is_Private_Type
(Def_Id
)
9485 and then Is_Derived_Type
(Def_Id
)
9486 and then Present
(Full_View
(Def_Id
))
9487 and then Is_Itype
(Full_View
(Def_Id
))
9488 and then Has_Private_Declaration
(Full_View
(Def_Id
))
9489 and then Freeze_Node
(Full_View
(Def_Id
)) = N
9491 Set_Entity
(N
, Full_View
(Def_Id
));
9492 Result
:= Freeze_Type
(N
);
9493 Set_Entity
(N
, Def_Id
);
9495 -- All other types require no expander action. There are such cases
9496 -- (e.g. task types and protected types). In such cases, the freeze
9497 -- nodes are there for use by Gigi.
9501 -- Complete the initialization of all pending access types' finalization
9502 -- masters now that the designated type has been is frozen and primitive
9503 -- Finalize_Address generated.
9505 Process_Pending_Access_Types
(Def_Id
);
9506 Freeze_Stream_Operations
(N
, Def_Id
);
9508 -- Generate the [spec and] body of the invariant procedure tasked with
9509 -- the runtime verification of all invariants that pertain to the type.
9510 -- This includes invariants on the partial and full view, inherited
9511 -- class-wide invariants from parent types or interfaces, and invariants
9512 -- on array elements or record components. But skip internal types.
9514 if Is_Itype
(Def_Id
) then
9517 elsif Is_Interface
(Def_Id
) then
9519 -- Interfaces are treated as the partial view of a private type in
9520 -- order to achieve uniformity with the general case. As a result, an
9521 -- interface receives only a "partial" invariant procedure which is
9524 if Has_Own_Invariants
(Def_Id
) then
9525 Build_Invariant_Procedure_Body
9527 Partial_Invariant
=> Is_Interface
(Def_Id
));
9530 -- Non-interface types
9532 -- Do not generate invariant procedure within other assertion
9533 -- subprograms, which may involve local declarations of local
9534 -- subtypes to which these checks do not apply.
9537 if Has_Invariants
(Def_Id
) then
9538 if not Predicate_Check_In_Scope
(Def_Id
)
9539 or else (Ekind
(Current_Scope
) = E_Function
9540 and then Is_Predicate_Function
(Current_Scope
))
9544 Build_Invariant_Procedure_Body
(Def_Id
);
9548 -- Generate the [spec and] body of the procedure tasked with the
9549 -- run-time verification of pragma Default_Initial_Condition's
9552 if Has_DIC
(Def_Id
) then
9553 Build_DIC_Procedure_Body
(Def_Id
);
9557 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9562 when RE_Not_Available
=>
9563 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9568 -------------------------
9569 -- Get_Simple_Init_Val --
9570 -------------------------
9572 function Get_Simple_Init_Val
9575 Size
: Uint
:= No_Uint
) return Node_Id
9577 IV_Attribute
: constant Boolean :=
9578 Nkind
(N
) = N_Attribute_Reference
9579 and then Attribute_Name
(N
) = Name_Invalid_Value
;
9581 Loc
: constant Source_Ptr
:= Sloc
(N
);
9583 procedure Extract_Subtype_Bounds
9584 (Lo_Bound
: out Uint
;
9585 Hi_Bound
: out Uint
);
9586 -- Inspect subtype Typ as well its ancestor subtypes and derived types
9587 -- to determine the best known information about the bounds of the type.
9588 -- The output parameters are set as follows:
9590 -- * Lo_Bound - Set to No_Unit when there is no information available,
9591 -- or to the known low bound.
9593 -- * Hi_Bound - Set to No_Unit when there is no information available,
9594 -- or to the known high bound.
9596 function Simple_Init_Array_Type
return Node_Id
;
9597 -- Build an expression to initialize array type Typ
9599 function Simple_Init_Defaulted_Type
return Node_Id
;
9600 -- Build an expression to initialize type Typ which is subject to
9601 -- aspect Default_Value.
9603 function Simple_Init_Initialize_Scalars_Type
9604 (Size_To_Use
: Uint
) return Node_Id
;
9605 -- Build an expression to initialize scalar type Typ which is subject to
9606 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
9608 function Simple_Init_Normalize_Scalars_Type
9609 (Size_To_Use
: Uint
) return Node_Id
;
9610 -- Build an expression to initialize scalar type Typ which is subject to
9611 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
9613 function Simple_Init_Private_Type
return Node_Id
;
9614 -- Build an expression to initialize private type Typ
9616 function Simple_Init_Scalar_Type
return Node_Id
;
9617 -- Build an expression to initialize scalar type Typ
9619 ----------------------------
9620 -- Extract_Subtype_Bounds --
9621 ----------------------------
9623 procedure Extract_Subtype_Bounds
9624 (Lo_Bound
: out Uint
;
9625 Hi_Bound
: out Uint
)
9635 Lo_Bound
:= No_Uint
;
9636 Hi_Bound
:= No_Uint
;
9638 -- Loop to climb ancestor subtypes and derived types
9642 if not Is_Discrete_Type
(ST1
) then
9646 Lo
:= Type_Low_Bound
(ST1
);
9647 Hi
:= Type_High_Bound
(ST1
);
9649 if Compile_Time_Known_Value
(Lo
) then
9650 Lo_Val
:= Expr_Value
(Lo
);
9652 if No
(Lo_Bound
) or else Lo_Bound
< Lo_Val
then
9657 if Compile_Time_Known_Value
(Hi
) then
9658 Hi_Val
:= Expr_Value
(Hi
);
9660 if No
(Hi_Bound
) or else Hi_Bound
> Hi_Val
then
9665 ST2
:= Ancestor_Subtype
(ST1
);
9671 exit when ST1
= ST2
;
9674 end Extract_Subtype_Bounds
;
9676 ----------------------------
9677 -- Simple_Init_Array_Type --
9678 ----------------------------
9680 function Simple_Init_Array_Type
return Node_Id
is
9681 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
9683 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
;
9684 -- Initialize a single array dimension with index constraint Index
9686 --------------------
9687 -- Simple_Init_Dimension --
9688 --------------------
9690 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
is
9692 -- Process the current dimension
9694 if Present
(Index
) then
9696 -- Build a suitable "others" aggregate for the next dimension,
9697 -- or initialize the component itself. Generate:
9702 Make_Aggregate
(Loc
,
9703 Component_Associations
=> New_List
(
9704 Make_Component_Association
(Loc
,
9705 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
9707 Simple_Init_Dimension
(Next_Index
(Index
)))));
9709 -- Otherwise all dimensions have been processed. Initialize the
9710 -- component itself.
9717 Size
=> Esize
(Comp_Typ
));
9719 end Simple_Init_Dimension
;
9721 -- Start of processing for Simple_Init_Array_Type
9724 return Simple_Init_Dimension
(First_Index
(Typ
));
9725 end Simple_Init_Array_Type
;
9727 --------------------------------
9728 -- Simple_Init_Defaulted_Type --
9729 --------------------------------
9731 function Simple_Init_Defaulted_Type
return Node_Id
is
9732 Subtyp
: Entity_Id
:= First_Subtype
(Typ
);
9735 -- When the first subtype is private, retrieve the expression of the
9736 -- Default_Value from the underlying type.
9738 if Is_Private_Type
(Subtyp
) then
9739 Subtyp
:= Full_View
(Subtyp
);
9742 -- Use the Sloc of the context node when constructing the initial
9743 -- value because the expression of Default_Value may come from a
9744 -- different unit. Updating the Sloc will result in accurate error
9752 (Source
=> Default_Aspect_Value
(Subtyp
),
9754 end Simple_Init_Defaulted_Type
;
9756 -----------------------------------------
9757 -- Simple_Init_Initialize_Scalars_Type --
9758 -----------------------------------------
9760 function Simple_Init_Initialize_Scalars_Type
9761 (Size_To_Use
: Uint
) return Node_Id
9763 Float_Typ
: Entity_Id
;
9766 Scal_Typ
: Scalar_Id
;
9769 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
9773 if Is_Floating_Point_Type
(Typ
) then
9774 Float_Typ
:= Root_Type
(Typ
);
9776 if Float_Typ
= Standard_Short_Float
then
9777 Scal_Typ
:= Name_Short_Float
;
9778 elsif Float_Typ
= Standard_Float
then
9779 Scal_Typ
:= Name_Float
;
9780 elsif Float_Typ
= Standard_Long_Float
then
9781 Scal_Typ
:= Name_Long_Float
;
9782 else pragma Assert
(Float_Typ
= Standard_Long_Long_Float
);
9783 Scal_Typ
:= Name_Long_Long_Float
;
9786 -- If zero is invalid, it is a convenient value to use that is for
9787 -- sure an appropriate invalid value in all situations.
9789 elsif Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
9790 return Make_Integer_Literal
(Loc
, 0);
9794 elsif Is_Unsigned_Type
(Typ
) then
9795 if Size_To_Use
<= 8 then
9796 Scal_Typ
:= Name_Unsigned_8
;
9797 elsif Size_To_Use
<= 16 then
9798 Scal_Typ
:= Name_Unsigned_16
;
9799 elsif Size_To_Use
<= 32 then
9800 Scal_Typ
:= Name_Unsigned_32
;
9801 elsif Size_To_Use
<= 64 then
9802 Scal_Typ
:= Name_Unsigned_64
;
9804 Scal_Typ
:= Name_Unsigned_128
;
9810 if Size_To_Use
<= 8 then
9811 Scal_Typ
:= Name_Signed_8
;
9812 elsif Size_To_Use
<= 16 then
9813 Scal_Typ
:= Name_Signed_16
;
9814 elsif Size_To_Use
<= 32 then
9815 Scal_Typ
:= Name_Signed_32
;
9816 elsif Size_To_Use
<= 64 then
9817 Scal_Typ
:= Name_Signed_64
;
9819 Scal_Typ
:= Name_Signed_128
;
9823 -- Use the values specified by pragma Initialize_Scalars or the ones
9824 -- provided by the binder. Higher precedence is given to the pragma.
9826 return Invalid_Scalar_Value
(Loc
, Scal_Typ
);
9827 end Simple_Init_Initialize_Scalars_Type
;
9829 ----------------------------------------
9830 -- Simple_Init_Normalize_Scalars_Type --
9831 ----------------------------------------
9833 function Simple_Init_Normalize_Scalars_Type
9834 (Size_To_Use
: Uint
) return Node_Id
9836 Signed_Size
: constant Uint
:= UI_Min
(Uint_63
, Size_To_Use
- 1);
9843 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
9845 -- If zero is invalid, it is a convenient value to use that is for
9846 -- sure an appropriate invalid value in all situations.
9848 if Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
9849 Expr
:= Make_Integer_Literal
(Loc
, 0);
9851 -- Cases where all one bits is the appropriate invalid value
9853 -- For modular types, all 1 bits is either invalid or valid. If it
9854 -- is valid, then there is nothing that can be done since there are
9855 -- no invalid values (we ruled out zero already).
9857 -- For signed integer types that have no negative values, either
9858 -- there is room for negative values, or there is not. If there
9859 -- is, then all 1-bits may be interpreted as minus one, which is
9860 -- certainly invalid. Alternatively it is treated as the largest
9861 -- positive value, in which case the observation for modular types
9864 -- For float types, all 1-bits is a NaN (not a number), which is
9865 -- certainly an appropriately invalid value.
9867 elsif Is_Enumeration_Type
(Typ
)
9868 or else Is_Floating_Point_Type
(Typ
)
9869 or else Is_Unsigned_Type
(Typ
)
9871 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Size_To_Use
- 1);
9873 -- Resolve as Long_Long_Long_Unsigned, because the largest number
9874 -- we can generate is out of range of universal integer.
9876 Analyze_And_Resolve
(Expr
, Standard_Long_Long_Long_Unsigned
);
9878 -- Case of signed types
9881 -- Normally we like to use the most negative number. The one
9882 -- exception is when this number is in the known subtype range and
9883 -- the largest positive number is not in the known subtype range.
9885 -- For this exceptional case, use largest positive value
9887 if Present
(Lo_Bound
) and then Present
(Hi_Bound
)
9888 and then Lo_Bound
<= (-(2 ** Signed_Size
))
9889 and then Hi_Bound
< 2 ** Signed_Size
9891 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Signed_Size
- 1);
9893 -- Normal case of largest negative value
9896 Expr
:= Make_Integer_Literal
(Loc
, -(2 ** Signed_Size
));
9901 end Simple_Init_Normalize_Scalars_Type
;
9903 ------------------------------
9904 -- Simple_Init_Private_Type --
9905 ------------------------------
9907 function Simple_Init_Private_Type
return Node_Id
is
9908 Under_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
9912 -- The availability of the underlying view must be checked by routine
9913 -- Needs_Simple_Initialization.
9915 pragma Assert
(Present
(Under_Typ
));
9917 Expr
:= Get_Simple_Init_Val
(Under_Typ
, N
, Size
);
9919 -- If the initial value is null or an aggregate, qualify it with the
9920 -- underlying type in order to provide a proper context.
9922 if Nkind
(Expr
) in N_Aggregate | N_Null
then
9924 Make_Qualified_Expression
(Loc
,
9925 Subtype_Mark
=> New_Occurrence_Of
(Under_Typ
, Loc
),
9926 Expression
=> Expr
);
9929 Expr
:= Unchecked_Convert_To
(Typ
, Expr
);
9931 -- Do not truncate the result when scalar types are involved and
9932 -- Initialize/Normalize_Scalars is in effect.
9934 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
9935 and then Is_Scalar_Type
(Under_Typ
)
9937 Set_No_Truncation
(Expr
);
9941 end Simple_Init_Private_Type
;
9943 -----------------------------
9944 -- Simple_Init_Scalar_Type --
9945 -----------------------------
9947 function Simple_Init_Scalar_Type
return Node_Id
is
9952 pragma Assert
(Init_Or_Norm_Scalars
or IV_Attribute
);
9954 -- Determine the size of the object. This is either the size provided
9955 -- by the caller, or the Esize of the scalar type.
9957 if No
(Size
) or else Size
<= Uint_0
then
9958 Size_To_Use
:= UI_Max
(Uint_1
, Esize
(Typ
));
9960 Size_To_Use
:= Size
;
9963 -- The maximum size to use is System_Max_Integer_Size bits. This
9964 -- will create values of type Long_Long_Long_Unsigned and the range
9965 -- must fit this type.
9967 if Present
(Size_To_Use
)
9968 and then Size_To_Use
> System_Max_Integer_Size
9970 Size_To_Use
:= UI_From_Int
(System_Max_Integer_Size
);
9973 if Normalize_Scalars
and then not IV_Attribute
then
9974 Expr
:= Simple_Init_Normalize_Scalars_Type
(Size_To_Use
);
9976 Expr
:= Simple_Init_Initialize_Scalars_Type
(Size_To_Use
);
9979 -- The final expression is obtained by doing an unchecked conversion
9980 -- of this result to the base type of the required subtype. Use the
9981 -- base type to prevent the unchecked conversion from chopping bits,
9982 -- and then we set Kill_Range_Check to preserve the "bad" value.
9984 Expr
:= Unchecked_Convert_To
(Base_Type
(Typ
), Expr
);
9986 -- Ensure that the expression is not truncated since the "bad" bits
9987 -- are desired, and also kill the range checks.
9989 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
9990 Set_Kill_Range_Check
(Expr
);
9991 Set_No_Truncation
(Expr
);
9995 end Simple_Init_Scalar_Type
;
9997 -- Start of processing for Get_Simple_Init_Val
10000 if Is_Private_Type
(Typ
) then
10001 return Simple_Init_Private_Type
;
10003 elsif Is_Scalar_Type
(Typ
) then
10004 if Has_Default_Aspect
(Typ
) then
10005 return Simple_Init_Defaulted_Type
;
10007 return Simple_Init_Scalar_Type
;
10010 -- Array type with Initialize or Normalize_Scalars
10012 elsif Is_Array_Type
(Typ
) then
10013 pragma Assert
(Init_Or_Norm_Scalars
);
10014 return Simple_Init_Array_Type
;
10016 -- Access type is initialized to null
10018 elsif Is_Access_Type
(Typ
) then
10019 return Make_Null
(Loc
);
10021 -- No other possibilities should arise, since we should only be calling
10022 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
10023 -- indicating one of the above cases held.
10026 raise Program_Error
;
10030 when RE_Not_Available
=>
10032 end Get_Simple_Init_Val
;
10034 ------------------------------
10035 -- Has_New_Non_Standard_Rep --
10036 ------------------------------
10038 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
10040 if not Is_Derived_Type
(T
) then
10041 return Has_Non_Standard_Rep
(T
)
10042 or else Has_Non_Standard_Rep
(Root_Type
(T
));
10044 -- If Has_Non_Standard_Rep is not set on the derived type, the
10045 -- representation is fully inherited.
10047 elsif not Has_Non_Standard_Rep
(T
) then
10051 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
10053 -- May need a more precise check here: the First_Rep_Item may be a
10054 -- stream attribute, which does not affect the representation of the
10058 end Has_New_Non_Standard_Rep
;
10060 ----------------------
10061 -- Inline_Init_Proc --
10062 ----------------------
10064 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean is
10066 -- The initialization proc of protected records is not worth inlining.
10067 -- In addition, when compiled for another unit for inlining purposes,
10068 -- it may make reference to entities that have not been elaborated yet.
10069 -- The initialization proc of records that need finalization contains
10070 -- a nested clean-up procedure that makes it impractical to inline as
10071 -- well, except for simple controlled types themselves. And similar
10072 -- considerations apply to task types.
10074 if Is_Concurrent_Type
(Typ
) then
10077 elsif Needs_Finalization
(Typ
) and then not Is_Controlled
(Typ
) then
10080 elsif Has_Task
(Typ
) then
10086 end Inline_Init_Proc
;
10092 function In_Runtime
(E
: Entity_Id
) return Boolean is
10097 while Scope
(S1
) /= Standard_Standard
loop
10101 return Is_RTU
(S1
, System
) or else Is_RTU
(S1
, Ada
);
10104 package body Initialization_Control
is
10106 ------------------------
10107 -- Requires_Late_Init --
10108 ------------------------
10110 function Requires_Late_Init
10112 Rec_Type
: Entity_Id
) return Boolean
10114 References_Current_Instance
: Boolean := False;
10115 Has_Access_Discriminant
: Boolean := False;
10116 Has_Internal_Call
: Boolean := False;
10118 function Find_Access_Discriminant
10119 (N
: Node_Id
) return Traverse_Result
;
10120 -- Look for a name denoting an access discriminant
10122 function Find_Current_Instance
10123 (N
: Node_Id
) return Traverse_Result
;
10124 -- Look for a reference to the current instance of the type
10126 function Find_Internal_Call
10127 (N
: Node_Id
) return Traverse_Result
;
10128 -- Look for an internal protected function call
10130 ------------------------------
10131 -- Find_Access_Discriminant --
10132 ------------------------------
10134 function Find_Access_Discriminant
10135 (N
: Node_Id
) return Traverse_Result
is
10137 if Is_Entity_Name
(N
)
10138 and then Denotes_Discriminant
(N
)
10139 and then Is_Access_Type
(Etype
(N
))
10141 Has_Access_Discriminant
:= True;
10146 end Find_Access_Discriminant
;
10148 ---------------------------
10149 -- Find_Current_Instance --
10150 ---------------------------
10152 function Find_Current_Instance
10153 (N
: Node_Id
) return Traverse_Result
is
10155 if Is_Entity_Name
(N
)
10156 and then Present
(Entity
(N
))
10157 and then Is_Current_Instance
(N
)
10159 References_Current_Instance
:= True;
10164 end Find_Current_Instance
;
10166 ------------------------
10167 -- Find_Internal_Call --
10168 ------------------------
10170 function Find_Internal_Call
(N
: Node_Id
) return Traverse_Result
is
10172 function Call_Scope
(N
: Node_Id
) return Entity_Id
;
10173 -- Return the scope enclosing a given call node N
10179 function Call_Scope
(N
: Node_Id
) return Entity_Id
is
10180 Nam
: constant Node_Id
:= Name
(N
);
10182 if Nkind
(Nam
) = N_Selected_Component
then
10183 return Scope
(Entity
(Prefix
(Nam
)));
10185 return Scope
(Entity
(Nam
));
10190 if Nkind
(N
) = N_Function_Call
10191 and then Call_Scope
(N
)
10192 = Corresponding_Concurrent_Type
(Rec_Type
)
10194 Has_Internal_Call
:= True;
10199 end Find_Internal_Call
;
10201 procedure Search_Access_Discriminant
is new
10202 Traverse_Proc
(Find_Access_Discriminant
);
10204 procedure Search_Current_Instance
is new
10205 Traverse_Proc
(Find_Current_Instance
);
10207 procedure Search_Internal_Call
is new
10208 Traverse_Proc
(Find_Internal_Call
);
10210 -- Start of processing for Requires_Late_Init
10213 -- A component of an object is said to require late initialization
10216 -- it has an access discriminant value constrained by a per-object
10219 if Has_Access_Constraint
(Defining_Identifier
(Decl
))
10220 and then No
(Expression
(Decl
))
10224 elsif Present
(Expression
(Decl
)) then
10226 -- it has an initialization expression that includes a name
10227 -- denoting an access discriminant;
10229 Search_Access_Discriminant
(Expression
(Decl
));
10231 if Has_Access_Discriminant
then
10235 -- or it has an initialization expression that includes a
10236 -- reference to the current instance of the type either by
10239 Search_Current_Instance
(Expression
(Decl
));
10241 if References_Current_Instance
then
10245 -- ...or implicitly as the target object of a call.
10247 if Is_Protected_Record_Type
(Rec_Type
) then
10248 Search_Internal_Call
(Expression
(Decl
));
10250 if Has_Internal_Call
then
10257 end Requires_Late_Init
;
10259 -----------------------------
10260 -- Has_Late_Init_Component --
10261 -----------------------------
10263 function Has_Late_Init_Component
10264 (Tagged_Rec_Type
: Entity_Id
) return Boolean
10266 Comp_Id
: Entity_Id
:=
10267 First_Component
(Implementation_Base_Type
(Tagged_Rec_Type
));
10269 while Present
(Comp_Id
) loop
10270 if Requires_Late_Init
(Decl
=> Parent
(Comp_Id
),
10271 Rec_Type
=> Tagged_Rec_Type
)
10273 return True; -- found a component that requires late init
10275 elsif Chars
(Comp_Id
) = Name_uParent
10276 and then Has_Late_Init_Component
(Etype
(Comp_Id
))
10278 return True; -- an ancestor type has a late init component
10281 Next_Component
(Comp_Id
);
10285 end Has_Late_Init_Component
;
10287 ------------------------
10288 -- Tag_Init_Condition --
10289 ------------------------
10291 function Tag_Init_Condition
10293 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10295 return Make_Op_Eq
(Loc
,
10296 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10297 Make_Mode_Literal
(Loc
, Full_Init
));
10298 end Tag_Init_Condition
;
10300 --------------------------
10301 -- Early_Init_Condition --
10302 --------------------------
10304 function Early_Init_Condition
10306 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10308 return Make_Op_Ne
(Loc
,
10309 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10310 Make_Mode_Literal
(Loc
, Late_Init_Only
));
10311 end Early_Init_Condition
;
10313 -------------------------
10314 -- Late_Init_Condition --
10315 -------------------------
10317 function Late_Init_Condition
10319 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10321 return Make_Op_Ne
(Loc
,
10322 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10323 Make_Mode_Literal
(Loc
, Early_Init_Only
));
10324 end Late_Init_Condition
;
10326 end Initialization_Control
;
10328 ----------------------------
10329 -- Initialization_Warning --
10330 ----------------------------
10332 procedure Initialization_Warning
(E
: Entity_Id
) is
10333 Warning_Needed
: Boolean;
10336 Warning_Needed
:= False;
10338 if Ekind
(Current_Scope
) = E_Package
10339 and then Static_Elaboration_Desired
(Current_Scope
)
10341 if Is_Type
(E
) then
10342 if Is_Record_Type
(E
) then
10343 if Has_Discriminants
(E
)
10344 or else Is_Limited_Type
(E
)
10345 or else Has_Non_Standard_Rep
(E
)
10347 Warning_Needed
:= True;
10350 -- Verify that at least one component has an initialization
10351 -- expression. No need for a warning on a type if all its
10352 -- components have no initialization.
10358 Comp
:= First_Component
(E
);
10359 while Present
(Comp
) loop
10361 (Nkind
(Parent
(Comp
)) = N_Component_Declaration
);
10363 if Present
(Expression
(Parent
(Comp
))) then
10364 Warning_Needed
:= True;
10368 Next_Component
(Comp
);
10373 if Warning_Needed
then
10375 ("objects of the type cannot be initialized statically "
10376 & "by default??", Parent
(E
));
10381 Error_Msg_N
("object cannot be initialized statically??", E
);
10384 end Initialization_Warning
;
10390 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
10392 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10393 Unc_Arr
: constant Boolean :=
10394 Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
);
10395 With_Prot
: constant Boolean :=
10396 Has_Protected
(Typ
)
10397 or else (Is_Record_Type
(Typ
)
10398 and then Is_Protected_Record_Type
(Typ
));
10399 With_Task
: constant Boolean :=
10400 not Global_No_Tasking
10403 or else (Is_Record_Type
(Typ
)
10404 and then Is_Task_Record_Type
(Typ
)));
10408 -- The first parameter is always _Init : [in] out Typ. Note that we need
10409 -- it to be in/out in the case of an unconstrained array, because of the
10410 -- need to have the bounds, and in the case of protected or task record
10411 -- value, because there are default record fields that may be referenced
10412 -- in the generated initialization routine.
10414 Formals
:= New_List
(
10415 Make_Parameter_Specification
(Loc
,
10416 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uInit
),
10417 In_Present
=> Unc_Arr
or else With_Prot
or else With_Task
,
10418 Out_Present
=> True,
10419 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
10421 -- For task record value, or type that contains tasks, add two more
10422 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
10423 -- We also add these parameters for the task record type case.
10426 Append_To
(Formals
,
10427 Make_Parameter_Specification
(Loc
,
10428 Defining_Identifier
=>
10429 Make_Defining_Identifier
(Loc
, Name_uMaster
),
10431 New_Occurrence_Of
(Standard_Integer
, Loc
)));
10433 Set_Has_Master_Entity
(Proc_Id
);
10435 -- Add _Chain (not done for sequential elaboration policy, see
10436 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
10438 if Partition_Elaboration_Policy
/= 'S' then
10439 Append_To
(Formals
,
10440 Make_Parameter_Specification
(Loc
,
10441 Defining_Identifier
=>
10442 Make_Defining_Identifier
(Loc
, Name_uChain
),
10443 In_Present
=> True,
10444 Out_Present
=> True,
10446 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
)));
10449 Append_To
(Formals
,
10450 Make_Parameter_Specification
(Loc
,
10451 Defining_Identifier
=>
10452 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
10453 In_Present
=> True,
10454 Parameter_Type
=> New_Occurrence_Of
(Standard_String
, Loc
)));
10457 -- Due to certain edge cases such as arrays with null-excluding
10458 -- components being built with the secondary stack it becomes necessary
10459 -- to add a formal to the Init_Proc which controls whether we raise
10460 -- Constraint_Errors on generated calls for internal object
10463 if Needs_Conditional_Null_Excluding_Check
(Typ
) then
10464 Append_To
(Formals
,
10465 Make_Parameter_Specification
(Loc
,
10466 Defining_Identifier
=>
10467 Make_Defining_Identifier
(Loc
,
10468 New_External_Name
(Chars
10469 (Component_Type
(Typ
)), "_skip_null_excluding_check")),
10470 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
10471 In_Present
=> True,
10473 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
10479 when RE_Not_Available
=>
10483 -------------------------
10484 -- Init_Secondary_Tags --
10485 -------------------------
10487 procedure Init_Secondary_Tags
10490 Init_Tags_List
: List_Id
;
10491 Stmts_List
: List_Id
;
10492 Fixed_Comps
: Boolean := True;
10493 Variable_Comps
: Boolean := True)
10495 Loc
: constant Source_Ptr
:= Sloc
(Target
);
10497 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
10498 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10500 procedure Initialize_Tag
10503 Tag_Comp
: Entity_Id
;
10504 Iface_Tag
: Node_Id
);
10505 -- Initialize the tag of the secondary dispatch table of Typ associated
10506 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10507 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
10508 -- of Typ CPP tagged type we generate code to inherit the contents of
10509 -- the dispatch table directly from the ancestor.
10511 --------------------
10512 -- Initialize_Tag --
10513 --------------------
10515 procedure Initialize_Tag
10518 Tag_Comp
: Entity_Id
;
10519 Iface_Tag
: Node_Id
)
10521 Comp_Typ
: Entity_Id
;
10522 Offset_To_Top_Comp
: Entity_Id
:= Empty
;
10525 -- Initialize pointer to secondary DT associated with the interface
10527 if not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
10528 Append_To
(Init_Tags_List
,
10529 Make_Assignment_Statement
(Loc
,
10531 Make_Selected_Component
(Loc
,
10532 Prefix
=> New_Copy_Tree
(Target
),
10533 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10535 New_Occurrence_Of
(Iface_Tag
, Loc
)));
10538 Comp_Typ
:= Scope
(Tag_Comp
);
10540 -- Initialize the entries of the table of interfaces. We generate a
10541 -- different call when the parent of the type has variable size
10544 if Comp_Typ
/= Etype
(Comp_Typ
)
10545 and then Is_Variable_Size_Record
(Etype
(Comp_Typ
))
10546 and then Chars
(Tag_Comp
) /= Name_uTag
10548 pragma Assert
(Present
(DT_Offset_To_Top_Func
(Tag_Comp
)));
10550 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
10551 -- configurable run-time environment.
10553 if not RTE_Available
(RE_Set_Dynamic_Offset_To_Top
) then
10555 ("variable size record with interface types", Typ
);
10560 -- Set_Dynamic_Offset_To_Top
10562 -- Prim_T => Typ'Tag,
10563 -- Interface_T => Iface'Tag,
10564 -- Offset_Value => n,
10565 -- Offset_Func => Fn'Unrestricted_Access)
10567 Append_To
(Stmts_List
,
10568 Make_Procedure_Call_Statement
(Loc
,
10570 New_Occurrence_Of
(RTE
(RE_Set_Dynamic_Offset_To_Top
), Loc
),
10571 Parameter_Associations
=> New_List
(
10572 Make_Attribute_Reference
(Loc
,
10573 Prefix
=> New_Copy_Tree
(Target
),
10574 Attribute_Name
=> Name_Address
),
10576 Unchecked_Convert_To
(RTE
(RE_Tag
),
10578 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10580 Unchecked_Convert_To
(RTE
(RE_Tag
),
10582 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
10585 Unchecked_Convert_To
10586 (RTE
(RE_Storage_Offset
),
10587 Make_Op_Minus
(Loc
,
10588 Make_Attribute_Reference
(Loc
,
10590 Make_Selected_Component
(Loc
,
10591 Prefix
=> New_Copy_Tree
(Target
),
10593 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10594 Attribute_Name
=> Name_Position
))),
10596 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Function_Ptr
),
10597 Make_Attribute_Reference
(Loc
,
10598 Prefix
=> New_Occurrence_Of
10599 (DT_Offset_To_Top_Func
(Tag_Comp
), Loc
),
10600 Attribute_Name
=> Name_Unrestricted_Access
)))));
10602 -- In this case the next component stores the value of the offset
10605 Offset_To_Top_Comp
:= Next_Entity
(Tag_Comp
);
10606 pragma Assert
(Present
(Offset_To_Top_Comp
));
10608 Append_To
(Init_Tags_List
,
10609 Make_Assignment_Statement
(Loc
,
10611 Make_Selected_Component
(Loc
,
10612 Prefix
=> New_Copy_Tree
(Target
),
10614 New_Occurrence_Of
(Offset_To_Top_Comp
, Loc
)),
10617 Make_Op_Minus
(Loc
,
10618 Make_Attribute_Reference
(Loc
,
10620 Make_Selected_Component
(Loc
,
10621 Prefix
=> New_Copy_Tree
(Target
),
10622 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10623 Attribute_Name
=> Name_Position
))));
10625 -- Normal case: No discriminants in the parent type
10628 -- Don't need to set any value if the offset-to-top field is
10629 -- statically set or if this interface shares the primary
10632 if not Building_Static_Secondary_DT
(Typ
)
10633 and then not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True)
10635 Append_To
(Stmts_List
,
10636 Build_Set_Static_Offset_To_Top
(Loc
,
10637 Iface_Tag
=> New_Occurrence_Of
(Iface_Tag
, Loc
),
10639 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10640 Make_Op_Minus
(Loc
,
10641 Make_Attribute_Reference
(Loc
,
10643 Make_Selected_Component
(Loc
,
10644 Prefix
=> New_Copy_Tree
(Target
),
10646 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10647 Attribute_Name
=> Name_Position
)))));
10651 -- Register_Interface_Offset
10652 -- (Prim_T => Typ'Tag,
10653 -- Interface_T => Iface'Tag,
10654 -- Is_Constant => True,
10655 -- Offset_Value => n,
10656 -- Offset_Func => null);
10658 if not Building_Static_Secondary_DT
(Typ
)
10659 and then RTE_Available
(RE_Register_Interface_Offset
)
10661 Append_To
(Stmts_List
,
10662 Make_Procedure_Call_Statement
(Loc
,
10665 (RTE
(RE_Register_Interface_Offset
), Loc
),
10666 Parameter_Associations
=> New_List
(
10667 Unchecked_Convert_To
(RTE
(RE_Tag
),
10669 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10671 Unchecked_Convert_To
(RTE
(RE_Tag
),
10673 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))), Loc
)),
10675 New_Occurrence_Of
(Standard_True
, Loc
),
10677 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10678 Make_Op_Minus
(Loc
,
10679 Make_Attribute_Reference
(Loc
,
10681 Make_Selected_Component
(Loc
,
10682 Prefix
=> New_Copy_Tree
(Target
),
10684 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10685 Attribute_Name
=> Name_Position
))),
10687 Make_Null
(Loc
))));
10690 end Initialize_Tag
;
10694 Full_Typ
: Entity_Id
;
10695 Ifaces_List
: Elist_Id
;
10696 Ifaces_Comp_List
: Elist_Id
;
10697 Ifaces_Tag_List
: Elist_Id
;
10698 Iface_Elmt
: Elmt_Id
;
10699 Iface_Comp_Elmt
: Elmt_Id
;
10700 Iface_Tag_Elmt
: Elmt_Id
;
10701 Tag_Comp
: Node_Id
;
10702 In_Variable_Pos
: Boolean;
10704 -- Start of processing for Init_Secondary_Tags
10707 -- Handle private types
10709 if Present
(Full_View
(Typ
)) then
10710 Full_Typ
:= Full_View
(Typ
);
10715 Collect_Interfaces_Info
10716 (Full_Typ
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
10718 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
10719 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
10720 Iface_Tag_Elmt
:= First_Elmt
(Ifaces_Tag_List
);
10721 while Present
(Iface_Elmt
) loop
10722 Tag_Comp
:= Node
(Iface_Comp_Elmt
);
10724 -- Check if parent of record type has variable size components
10726 In_Variable_Pos
:= Scope
(Tag_Comp
) /= Etype
(Scope
(Tag_Comp
))
10727 and then Is_Variable_Size_Record
(Etype
(Scope
(Tag_Comp
)));
10729 -- If we are compiling under the CPP full ABI compatibility mode and
10730 -- the ancestor is a CPP_Pragma tagged type then we generate code to
10731 -- initialize the secondary tag components from tags that reference
10732 -- secondary tables filled with copy of parent slots.
10734 if Is_CPP_Class
(Root_Type
(Full_Typ
)) then
10736 -- Reject interface components located at variable offset in
10737 -- C++ derivations. This is currently unsupported.
10739 if not Fixed_Comps
and then In_Variable_Pos
then
10741 -- Locate the first dynamic component of the record. Done to
10742 -- improve the text of the warning.
10746 Comp_Typ
: Entity_Id
;
10749 Comp
:= First_Entity
(Typ
);
10750 while Present
(Comp
) loop
10751 Comp_Typ
:= Etype
(Comp
);
10753 if Ekind
(Comp
) /= E_Discriminant
10754 and then not Is_Tag
(Comp
)
10757 (Is_Record_Type
(Comp_Typ
)
10759 Is_Variable_Size_Record
(Base_Type
(Comp_Typ
)))
10761 (Is_Array_Type
(Comp_Typ
)
10762 and then Is_Variable_Size_Array
(Comp_Typ
));
10765 Next_Entity
(Comp
);
10768 pragma Assert
(Present
(Comp
));
10770 -- Move this check to sem???
10771 Error_Msg_Node_2
:= Comp
;
10773 ("parent type & with dynamic component & cannot be parent"
10774 & " of 'C'P'P derivation if new interfaces are present",
10775 Typ
, Scope
(Original_Record_Component
(Comp
)));
10778 Sloc
(Scope
(Original_Record_Component
(Comp
)));
10780 ("type derived from 'C'P'P type & defined #",
10781 Typ
, Scope
(Original_Record_Component
(Comp
)));
10783 -- Avoid duplicated warnings
10788 -- Initialize secondary tags
10793 Iface
=> Node
(Iface_Elmt
),
10794 Tag_Comp
=> Tag_Comp
,
10795 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
10798 -- Otherwise generate code to initialize the tag
10801 if (In_Variable_Pos
and then Variable_Comps
)
10802 or else (not In_Variable_Pos
and then Fixed_Comps
)
10806 Iface
=> Node
(Iface_Elmt
),
10807 Tag_Comp
=> Tag_Comp
,
10808 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
10812 Next_Elmt
(Iface_Elmt
);
10813 Next_Elmt
(Iface_Comp_Elmt
);
10814 Next_Elmt
(Iface_Tag_Elmt
);
10816 end Init_Secondary_Tags
;
10818 ----------------------------
10819 -- Is_Null_Statement_List --
10820 ----------------------------
10822 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean is
10826 -- We must skip SCIL nodes because they may have been added to the list
10827 -- by Insert_Actions.
10829 Stmt
:= First_Non_SCIL_Node
(Stmts
);
10830 while Present
(Stmt
) loop
10831 if Nkind
(Stmt
) = N_Case_Statement
then
10835 Alt
:= First
(Alternatives
(Stmt
));
10836 while Present
(Alt
) loop
10837 if not Is_Null_Statement_List
(Statements
(Alt
)) then
10845 elsif Nkind
(Stmt
) /= N_Null_Statement
then
10849 Stmt
:= Next_Non_SCIL_Node
(Stmt
);
10853 end Is_Null_Statement_List
;
10855 ----------------------------------------
10856 -- Make_Controlling_Function_Wrappers --
10857 ----------------------------------------
10859 procedure Make_Controlling_Function_Wrappers
10860 (Tag_Typ
: Entity_Id
;
10861 Decl_List
: out List_Id
;
10862 Body_List
: out List_Id
)
10864 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
10866 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
;
10867 -- Returns a function specification with the same profile as Subp
10869 --------------------------------
10870 -- Make_Wrapper_Specification --
10871 --------------------------------
10873 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
is
10876 Make_Function_Specification
(Loc
,
10877 Defining_Unit_Name
=>
10878 Make_Defining_Identifier
(Loc
,
10879 Chars
=> Chars
(Subp
)),
10880 Parameter_Specifications
=>
10881 Copy_Parameter_List
(Subp
),
10882 Result_Definition
=>
10883 New_Occurrence_Of
(Etype
(Subp
), Loc
));
10884 end Make_Wrapper_Specification
;
10886 Prim_Elmt
: Elmt_Id
;
10888 Actual_List
: List_Id
;
10889 Formal
: Entity_Id
;
10890 Par_Formal
: Entity_Id
;
10891 Ext_Aggr
: Node_Id
;
10892 Formal_Node
: Node_Id
;
10893 Func_Body
: Node_Id
;
10894 Func_Decl
: Node_Id
;
10895 Func_Id
: Entity_Id
;
10897 -- Start of processing for Make_Controlling_Function_Wrappers
10900 Decl_List
:= New_List
;
10901 Body_List
:= New_List
;
10903 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
10904 while Present
(Prim_Elmt
) loop
10905 Subp
:= Node
(Prim_Elmt
);
10907 -- If a primitive function with a controlling result of the type has
10908 -- not been overridden by the user, then we must create a wrapper
10909 -- function here that effectively overrides it and invokes the
10910 -- (non-abstract) parent function. This can only occur for a null
10911 -- extension. Note that functions with anonymous controlling access
10912 -- results don't qualify and must be overridden. We also exclude
10913 -- Input attributes, since each type will have its own version of
10914 -- Input constructed by the expander. The test for Comes_From_Source
10915 -- is needed to distinguish inherited operations from renamings
10916 -- (which also have Alias set). We exclude internal entities with
10917 -- Interface_Alias to avoid generating duplicated wrappers since
10918 -- the primitive which covers the interface is also available in
10919 -- the list of primitive operations.
10921 -- The function may be abstract, or require_Overriding may be set
10922 -- for it, because tests for null extensions may already have reset
10923 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
10924 -- set, functions that need wrappers are recognized by having an
10925 -- alias that returns the parent type.
10927 if Comes_From_Source
(Subp
)
10928 or else No
(Alias
(Subp
))
10929 or else Present
(Interface_Alias
(Subp
))
10930 or else Ekind
(Subp
) /= E_Function
10931 or else not Has_Controlling_Result
(Subp
)
10932 or else Is_Access_Type
(Etype
(Subp
))
10933 or else Is_Abstract_Subprogram
(Alias
(Subp
))
10934 or else Is_TSS
(Subp
, TSS_Stream_Input
)
10938 elsif Is_Abstract_Subprogram
(Subp
)
10939 or else Requires_Overriding
(Subp
)
10941 (Is_Null_Extension
(Etype
(Subp
))
10942 and then Etype
(Alias
(Subp
)) /= Etype
(Subp
))
10944 -- If there is a non-overloadable homonym in the current
10945 -- scope, the implicit declaration remains invisible.
10946 -- We check the current entity with the same name, or its
10947 -- homonym in case the derivation takes place after the
10948 -- hiding object declaration.
10950 if Present
(Current_Entity
(Subp
)) then
10952 Curr
: constant Entity_Id
:= Current_Entity
(Subp
);
10953 Prev
: constant Entity_Id
:= Homonym
(Curr
);
10955 if (Comes_From_Source
(Curr
)
10956 and then Scope
(Curr
) = Current_Scope
10957 and then not Is_Overloadable
(Curr
))
10960 and then Comes_From_Source
(Prev
)
10961 and then Scope
(Prev
) = Current_Scope
10962 and then not Is_Overloadable
(Prev
))
10970 Make_Subprogram_Declaration
(Loc
,
10971 Specification
=> Make_Wrapper_Specification
(Subp
));
10973 Append_To
(Decl_List
, Func_Decl
);
10975 -- Build a wrapper body that calls the parent function. The body
10976 -- contains a single return statement that returns an extension
10977 -- aggregate whose ancestor part is a call to the parent function,
10978 -- passing the formals as actuals (with any controlling arguments
10979 -- converted to the types of the corresponding formals of the
10980 -- parent function, which might be anonymous access types), and
10981 -- having a null extension.
10983 Formal
:= First_Formal
(Subp
);
10984 Par_Formal
:= First_Formal
(Alias
(Subp
));
10986 First
(Parameter_Specifications
(Specification
(Func_Decl
)));
10988 if Present
(Formal
) then
10989 Actual_List
:= New_List
;
10991 while Present
(Formal
) loop
10992 if Is_Controlling_Formal
(Formal
) then
10993 Append_To
(Actual_List
,
10994 Make_Type_Conversion
(Loc
,
10996 New_Occurrence_Of
(Etype
(Par_Formal
), Loc
),
10999 (Defining_Identifier
(Formal_Node
), Loc
)));
11004 (Defining_Identifier
(Formal_Node
), Loc
));
11007 Next_Formal
(Formal
);
11008 Next_Formal
(Par_Formal
);
11009 Next
(Formal_Node
);
11012 Actual_List
:= No_List
;
11016 Make_Extension_Aggregate
(Loc
,
11018 Make_Function_Call
(Loc
,
11020 New_Occurrence_Of
(Alias
(Subp
), Loc
),
11021 Parameter_Associations
=> Actual_List
),
11022 Null_Record_Present
=> True);
11024 -- GNATprove will use expression of an expression function as an
11025 -- implicit postcondition. GNAT will not benefit from expression
11026 -- function (and would struggle if we add an expression function
11027 -- to freezing actions).
11029 if GNATprove_Mode
then
11031 Make_Expression_Function
(Loc
,
11033 Make_Wrapper_Specification
(Subp
),
11034 Expression
=> Ext_Aggr
);
11037 Make_Subprogram_Body
(Loc
,
11039 Make_Wrapper_Specification
(Subp
),
11040 Declarations
=> Empty_List
,
11041 Handled_Statement_Sequence
=>
11042 Make_Handled_Sequence_Of_Statements
(Loc
,
11043 Statements
=> New_List
(
11044 Make_Simple_Return_Statement
(Loc
,
11045 Expression
=> Ext_Aggr
))));
11048 Append_To
(Body_List
, Func_Body
);
11050 -- Replace the inherited function with the wrapper function in the
11051 -- primitive operations list. We add the minimum decoration needed
11052 -- to override interface primitives.
11054 Func_Id
:= Defining_Unit_Name
(Specification
(Func_Decl
));
11056 Mutate_Ekind
(Func_Id
, E_Function
);
11057 Set_Is_Wrapper
(Func_Id
);
11059 -- Corresponding_Spec will be set again to the same value during
11060 -- analysis, but we need this information earlier.
11061 -- Expand_N_Freeze_Entity needs to know whether a subprogram body
11062 -- is a wrapper's body in order to get check suppression right.
11064 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
11066 Override_Dispatching_Operation
(Tag_Typ
, Subp
, New_Op
=> Func_Id
);
11070 Next_Elmt
(Prim_Elmt
);
11072 end Make_Controlling_Function_Wrappers
;
11078 function Make_Eq_Body
11080 Eq_Name
: Name_Id
) return Node_Id
11082 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Typ
));
11084 Def
: constant Node_Id
:= Parent
(Typ
);
11085 Stmts
: constant List_Id
:= New_List
;
11086 Variant_Case
: Boolean := Has_Discriminants
(Typ
);
11087 Comps
: Node_Id
:= Empty
;
11088 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
11092 Predef_Spec_Or_Body
(Loc
,
11095 Profile
=> New_List
(
11096 Make_Parameter_Specification
(Loc
,
11097 Defining_Identifier
=>
11098 Make_Defining_Identifier
(Loc
, Name_X
),
11099 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
11101 Make_Parameter_Specification
(Loc
,
11102 Defining_Identifier
=>
11103 Make_Defining_Identifier
(Loc
, Name_Y
),
11104 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
11106 Ret_Type
=> Standard_Boolean
,
11109 if Variant_Case
then
11110 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
11111 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
11114 if Present
(Typ_Def
) then
11115 Comps
:= Component_List
(Typ_Def
);
11119 Present
(Comps
) and then Present
(Variant_Part
(Comps
));
11122 if Variant_Case
then
11124 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
11125 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
11127 Make_Simple_Return_Statement
(Loc
,
11128 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11132 Make_Simple_Return_Statement
(Loc
,
11134 Expand_Record_Equality
11137 Lhs
=> Make_Identifier
(Loc
, Name_X
),
11138 Rhs
=> Make_Identifier
(Loc
, Name_Y
))));
11141 Set_Handled_Statement_Sequence
11142 (Decl
, Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
11150 -- <Make_Eq_If shared components>
11153 -- when V1 => <Make_Eq_Case> on subcomponents
11155 -- when Vn => <Make_Eq_Case> on subcomponents
11158 function Make_Eq_Case
11161 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
11163 Loc
: constant Source_Ptr
:= Sloc
(E
);
11164 Result
: constant List_Id
:= New_List
;
11166 Alt_List
: List_Id
;
11168 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
;
11169 -- Given the discriminant that controls a given variant of an unchecked
11170 -- union, find the formal of the equality function that carries the
11171 -- inferred value of the discriminant.
11173 function External_Name
(E
: Entity_Id
) return Name_Id
;
11174 -- The value of a given discriminant is conveyed in the corresponding
11175 -- formal parameter of the equality routine. The name of this formal
11176 -- parameter carries a one-character suffix which is removed here.
11178 --------------------------
11179 -- Corresponding_Formal --
11180 --------------------------
11182 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
is
11183 Discr
: constant Entity_Id
:= Entity
(Name
(Variant_Part
(C
)));
11187 Elm
:= First_Elmt
(Discrs
);
11188 while Present
(Elm
) loop
11189 if Chars
(Discr
) = External_Name
(Node
(Elm
)) then
11196 -- A formal of the proper name must be found
11198 raise Program_Error
;
11199 end Corresponding_Formal
;
11201 -------------------
11202 -- External_Name --
11203 -------------------
11205 function External_Name
(E
: Entity_Id
) return Name_Id
is
11207 Get_Name_String
(Chars
(E
));
11208 Name_Len
:= Name_Len
- 1;
11212 -- Start of processing for Make_Eq_Case
11215 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
11217 if No
(Variant_Part
(CL
)) then
11221 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
11223 if No
(Variant
) then
11227 Alt_List
:= New_List
;
11228 while Present
(Variant
) loop
11229 Append_To
(Alt_List
,
11230 Make_Case_Statement_Alternative
(Loc
,
11231 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
11233 Make_Eq_Case
(E
, Component_List
(Variant
), Discrs
)));
11234 Next_Non_Pragma
(Variant
);
11237 -- If we have an Unchecked_Union, use one of the parameters of the
11238 -- enclosing equality routine that captures the discriminant, to use
11239 -- as the expression in the generated case statement.
11241 if Is_Unchecked_Union
(E
) then
11243 Make_Case_Statement
(Loc
,
11245 New_Occurrence_Of
(Corresponding_Formal
(CL
), Loc
),
11246 Alternatives
=> Alt_List
));
11250 Make_Case_Statement
(Loc
,
11252 Make_Selected_Component
(Loc
,
11253 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11254 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
11255 Alternatives
=> Alt_List
));
11276 -- or a null statement if the list L is empty
11278 -- Equality may be user-defined for a given component type, in which case
11279 -- a function call is constructed instead of an operator node. This is an
11280 -- Ada 2012 change in the composability of equality for untagged composite
11283 function Make_Eq_If
11285 L
: List_Id
) return Node_Id
11287 Loc
: constant Source_Ptr
:= Sloc
(E
);
11291 Field_Name
: Name_Id
;
11292 Next_Test
: Node_Id
;
11297 return Make_Null_Statement
(Loc
);
11302 C
:= First_Non_Pragma
(L
);
11303 while Present
(C
) loop
11304 Typ
:= Etype
(Defining_Identifier
(C
));
11305 Field_Name
:= Chars
(Defining_Identifier
(C
));
11307 -- The tags must not be compared: they are not part of the value.
11308 -- Ditto for parent interfaces because their equality operator is
11311 -- Note also that in the following, we use Make_Identifier for
11312 -- the component names. Use of New_Occurrence_Of to identify the
11313 -- components would be incorrect because the wrong entities for
11314 -- discriminants could be picked up in the private type case.
11316 if Field_Name
= Name_uParent
11317 and then Is_Interface
(Typ
)
11321 elsif Field_Name
/= Name_uTag
then
11323 Lhs
: constant Node_Id
:=
11324 Make_Selected_Component
(Loc
,
11325 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11326 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11328 Rhs
: constant Node_Id
:=
11329 Make_Selected_Component
(Loc
,
11330 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
11331 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11335 -- Build equality code with a user-defined operator, if
11336 -- available, and with the predefined "=" otherwise. For
11337 -- compatibility with older Ada versions, we also use the
11338 -- predefined operation if the component-type equality is
11339 -- abstract, rather than raising Program_Error.
11341 if Ada_Version
< Ada_2012
then
11342 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11345 Eq_Call
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
11347 if No
(Eq_Call
) then
11348 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11350 -- If a component has a defined abstract equality, its
11351 -- application raises Program_Error on that component
11352 -- and therefore on the current variant.
11354 elsif Nkind
(Eq_Call
) = N_Raise_Program_Error
then
11355 Set_Etype
(Eq_Call
, Standard_Boolean
);
11356 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11359 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11364 Evolve_Or_Else
(Cond
, Next_Test
);
11367 Next_Non_Pragma
(C
);
11371 return Make_Null_Statement
(Loc
);
11375 Make_Implicit_If_Statement
(E
,
11377 Then_Statements
=> New_List
(
11378 Make_Simple_Return_Statement
(Loc
,
11379 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
11384 -------------------
11385 -- Make_Neq_Body --
11386 -------------------
11388 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
is
11390 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean;
11391 -- Returns true if Prim is a renaming of an unresolved predefined
11392 -- inequality operation.
11394 --------------------------------
11395 -- Is_Predefined_Neq_Renaming --
11396 --------------------------------
11398 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean is
11400 return Chars
(Prim
) /= Name_Op_Ne
11401 and then Present
(Alias
(Prim
))
11402 and then Comes_From_Source
(Prim
)
11403 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11404 and then Chars
(Alias
(Prim
)) = Name_Op_Ne
;
11405 end Is_Predefined_Neq_Renaming
;
11409 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Tag_Typ
));
11411 Eq_Prim
: Entity_Id
;
11412 Left_Op
: Entity_Id
;
11413 Renaming_Prim
: Entity_Id
;
11414 Right_Op
: Entity_Id
;
11415 Target
: Entity_Id
;
11417 -- Start of processing for Make_Neq_Body
11420 -- For a call on a renaming of a dispatching subprogram that is
11421 -- overridden, if the overriding occurred before the renaming, then
11422 -- the body executed is that of the overriding declaration, even if the
11423 -- overriding declaration is not visible at the place of the renaming;
11424 -- otherwise, the inherited or predefined subprogram is called, see
11427 -- Stage 1: Search for a renaming of the inequality primitive and also
11428 -- search for an overriding of the equality primitive located before the
11429 -- renaming declaration.
11437 Renaming_Prim
:= Empty
;
11439 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11440 while Present
(Elmt
) loop
11441 Prim
:= Node
(Elmt
);
11443 if Is_User_Defined_Equality
(Prim
) and then No
(Alias
(Prim
)) then
11444 if No
(Renaming_Prim
) then
11445 pragma Assert
(No
(Eq_Prim
));
11449 elsif Is_Predefined_Neq_Renaming
(Prim
) then
11450 Renaming_Prim
:= Prim
;
11457 -- No further action needed if no renaming was found
11459 if No
(Renaming_Prim
) then
11463 -- Stage 2: Replace the renaming declaration by a subprogram declaration
11464 -- (required to add its body)
11466 Decl
:= Parent
(Parent
(Renaming_Prim
));
11468 Make_Subprogram_Declaration
(Loc
,
11469 Specification
=> Specification
(Decl
)));
11470 Set_Analyzed
(Decl
);
11472 -- Remove the decoration of intrinsic renaming subprogram
11474 Set_Is_Intrinsic_Subprogram
(Renaming_Prim
, False);
11475 Set_Convention
(Renaming_Prim
, Convention_Ada
);
11476 Set_Alias
(Renaming_Prim
, Empty
);
11477 Set_Has_Completion
(Renaming_Prim
, False);
11479 -- Stage 3: Build the corresponding body
11481 Left_Op
:= First_Formal
(Renaming_Prim
);
11482 Right_Op
:= Next_Formal
(Left_Op
);
11485 Predef_Spec_Or_Body
(Loc
,
11486 Tag_Typ
=> Tag_Typ
,
11487 Name
=> Chars
(Renaming_Prim
),
11488 Profile
=> New_List
(
11489 Make_Parameter_Specification
(Loc
,
11490 Defining_Identifier
=>
11491 Make_Defining_Identifier
(Loc
, Chars
(Left_Op
)),
11492 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11494 Make_Parameter_Specification
(Loc
,
11495 Defining_Identifier
=>
11496 Make_Defining_Identifier
(Loc
, Chars
(Right_Op
)),
11497 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11499 Ret_Type
=> Standard_Boolean
,
11502 -- If the overriding of the equality primitive occurred before the
11503 -- renaming, then generate:
11505 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11507 -- return not Oeq (X, Y);
11510 if Present
(Eq_Prim
) then
11513 -- Otherwise build a nested subprogram which performs the predefined
11514 -- evaluation of the equality operator. That is, generate:
11516 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11517 -- function Oeq (X : Y) return Boolean is
11519 -- <<body of default implementation>>
11522 -- return not Oeq (X, Y);
11527 Local_Subp
: Node_Id
;
11529 Local_Subp
:= Make_Eq_Body
(Tag_Typ
, Name_Op_Eq
);
11530 Set_Declarations
(Decl
, New_List
(Local_Subp
));
11531 Target
:= Defining_Entity
(Local_Subp
);
11535 Set_Handled_Statement_Sequence
11537 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
11538 Make_Simple_Return_Statement
(Loc
,
11541 Make_Function_Call
(Loc
,
11542 Name
=> New_Occurrence_Of
(Target
, Loc
),
11543 Parameter_Associations
=> New_List
(
11544 Make_Identifier
(Loc
, Chars
(Left_Op
)),
11545 Make_Identifier
(Loc
, Chars
(Right_Op
)))))))));
11550 -------------------------------
11551 -- Make_Null_Procedure_Specs --
11552 -------------------------------
11554 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
is
11555 Decl_List
: constant List_Id
:= New_List
;
11556 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11557 Formal
: Entity_Id
;
11558 New_Param_Spec
: Node_Id
;
11559 New_Spec
: Node_Id
;
11560 Parent_Subp
: Entity_Id
;
11561 Prim_Elmt
: Elmt_Id
;
11565 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11566 while Present
(Prim_Elmt
) loop
11567 Subp
:= Node
(Prim_Elmt
);
11569 -- If a null procedure inherited from an interface has not been
11570 -- overridden, then we build a null procedure declaration to
11571 -- override the inherited procedure.
11573 Parent_Subp
:= Alias
(Subp
);
11575 if Present
(Parent_Subp
)
11576 and then Is_Null_Interface_Primitive
(Parent_Subp
)
11578 -- The null procedure spec is copied from the inherited procedure,
11579 -- except for the IS NULL (which must be added) and the overriding
11580 -- indicators (which must be removed, if present).
11583 Copy_Subprogram_Spec
(Subprogram_Specification
(Subp
), Loc
);
11585 Set_Null_Present
(New_Spec
, True);
11586 Set_Must_Override
(New_Spec
, False);
11587 Set_Must_Not_Override
(New_Spec
, False);
11589 Formal
:= First_Formal
(Subp
);
11590 New_Param_Spec
:= First
(Parameter_Specifications
(New_Spec
));
11592 while Present
(Formal
) loop
11594 -- For controlling arguments we must change their parameter
11595 -- type to reference the tagged type (instead of the interface
11598 if Is_Controlling_Formal
(Formal
) then
11599 if Nkind
(Parameter_Type
(Parent
(Formal
))) = N_Identifier
11601 Set_Parameter_Type
(New_Param_Spec
,
11602 New_Occurrence_Of
(Tag_Typ
, Loc
));
11605 (Nkind
(Parameter_Type
(Parent
(Formal
))) =
11606 N_Access_Definition
);
11607 Set_Subtype_Mark
(Parameter_Type
(New_Param_Spec
),
11608 New_Occurrence_Of
(Tag_Typ
, Loc
));
11612 Next_Formal
(Formal
);
11613 Next
(New_Param_Spec
);
11616 Append_To
(Decl_List
,
11617 Make_Subprogram_Declaration
(Loc
,
11618 Specification
=> New_Spec
));
11621 Next_Elmt
(Prim_Elmt
);
11625 end Make_Null_Procedure_Specs
;
11627 ---------------------------------------
11628 -- Make_Predefined_Primitive_Eq_Spec --
11629 ---------------------------------------
11631 procedure Make_Predefined_Primitive_Eq_Spec
11632 (Tag_Typ
: Entity_Id
;
11633 Predef_List
: List_Id
;
11634 Renamed_Eq
: out Entity_Id
)
11636 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
11637 -- Returns true if Prim is a renaming of an unresolved predefined
11638 -- equality operation.
11640 -------------------------------
11641 -- Is_Predefined_Eq_Renaming --
11642 -------------------------------
11644 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
11646 return Chars
(Prim
) /= Name_Op_Eq
11647 and then Present
(Alias
(Prim
))
11648 and then Comes_From_Source
(Prim
)
11649 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11650 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
11651 end Is_Predefined_Eq_Renaming
;
11655 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11657 Eq_Name
: Name_Id
:= Name_Op_Eq
;
11658 Eq_Needed
: Boolean := True;
11662 Has_Predef_Eq_Renaming
: Boolean := False;
11663 -- Set to True if Tag_Typ has a primitive that renames the predefined
11664 -- equality operator. Used to implement (RM 8-5-4(8)).
11666 -- Start of processing for Make_Predefined_Primitive_Specs
11669 Renamed_Eq
:= Empty
;
11671 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11672 while Present
(Prim
) loop
11674 -- If a primitive is encountered that renames the predefined equality
11675 -- operator before reaching any explicit equality primitive, then we
11676 -- still need to create a predefined equality function, because calls
11677 -- to it can occur via the renaming. A new name is created for the
11678 -- equality to avoid conflicting with any user-defined equality.
11679 -- (Note that this doesn't account for renamings of equality nested
11680 -- within subpackages???)
11682 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
11683 Has_Predef_Eq_Renaming
:= True;
11684 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
11686 -- User-defined equality
11688 elsif Is_User_Defined_Equality
(Node
(Prim
)) then
11689 if No
(Alias
(Node
(Prim
)))
11690 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
11691 N_Subprogram_Renaming_Declaration
11693 Eq_Needed
:= False;
11696 -- If the parent is not an interface type and has an abstract
11697 -- equality function explicitly defined in the sources, then the
11698 -- inherited equality is abstract as well, and no body can be
11701 elsif not Is_Interface
(Etype
(Tag_Typ
))
11702 and then Present
(Alias
(Node
(Prim
)))
11703 and then Comes_From_Source
(Alias
(Node
(Prim
)))
11704 and then Is_Abstract_Subprogram
(Alias
(Node
(Prim
)))
11706 Eq_Needed
:= False;
11709 -- If the type has an equality function corresponding with a
11710 -- primitive defined in an interface type, the inherited equality
11711 -- is abstract as well, and no body can be created for it.
11713 elsif Present
(Alias
(Node
(Prim
)))
11714 and then Comes_From_Source
(Ultimate_Alias
(Node
(Prim
)))
11717 (Find_Dispatching_Type
(Ultimate_Alias
(Node
(Prim
))))
11719 Eq_Needed
:= False;
11727 -- If a renaming of predefined equality was found but there was no
11728 -- user-defined equality (so Eq_Needed is still true), then set the name
11729 -- back to Name_Op_Eq. But in the case where a user-defined equality was
11730 -- located after such a renaming, then the predefined equality function
11731 -- is still needed, so Eq_Needed must be set back to True.
11733 if Eq_Name
/= Name_Op_Eq
then
11735 Eq_Name
:= Name_Op_Eq
;
11742 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
11743 Tag_Typ
=> Tag_Typ
,
11745 Profile
=> New_List
(
11746 Make_Parameter_Specification
(Loc
,
11747 Defining_Identifier
=>
11748 Make_Defining_Identifier
(Loc
, Name_X
),
11749 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11751 Make_Parameter_Specification
(Loc
,
11752 Defining_Identifier
=>
11753 Make_Defining_Identifier
(Loc
, Name_Y
),
11754 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11755 Ret_Type
=> Standard_Boolean
);
11756 Append_To
(Predef_List
, Eq_Spec
);
11758 if Has_Predef_Eq_Renaming
then
11759 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
11761 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11762 while Present
(Prim
) loop
11764 -- Any renamings of equality that appeared before an overriding
11765 -- equality must be updated to refer to the entity for the
11766 -- predefined equality, otherwise calls via the renaming would
11767 -- get incorrectly resolved to call the user-defined equality
11770 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
11771 Set_Alias
(Node
(Prim
), Renamed_Eq
);
11773 -- Exit upon encountering a user-defined equality
11775 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
11776 and then No
(Alias
(Node
(Prim
)))
11785 end Make_Predefined_Primitive_Eq_Spec
;
11787 -------------------------------------
11788 -- Make_Predefined_Primitive_Specs --
11789 -------------------------------------
11791 procedure Make_Predefined_Primitive_Specs
11792 (Tag_Typ
: Entity_Id
;
11793 Predef_List
: out List_Id
;
11794 Renamed_Eq
: out Entity_Id
)
11796 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11797 Res
: constant List_Id
:= New_List
;
11802 Renamed_Eq
:= Empty
;
11806 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11807 Tag_Typ
=> Tag_Typ
,
11808 Name
=> Name_uSize
,
11809 Profile
=> New_List
(
11810 Make_Parameter_Specification
(Loc
,
11811 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
11812 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11814 Ret_Type
=> Standard_Long_Long_Integer
));
11816 -- Spec of Put_Image
11818 if (not No_Run_Time_Mode
)
11819 and then RTE_Available
(RE_Root_Buffer_Type
)
11821 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
11822 -- (like any tagged type) will be rejected. Given this, avoid
11823 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
11826 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11827 Tag_Typ
=> Tag_Typ
,
11828 Name
=> Make_TSS_Name
(Tag_Typ
, TSS_Put_Image
),
11829 Profile
=> Build_Put_Image_Profile
(Loc
, Tag_Typ
)));
11832 -- Specs for dispatching stream attributes
11835 Stream_Op_TSS_Names
:
11836 constant array (Positive range <>) of TSS_Name_Type
:=
11840 TSS_Stream_Output
);
11843 for Op
in Stream_Op_TSS_Names
'Range loop
11844 if Stream_Operation_OK
(Tag_Typ
, Stream_Op_TSS_Names
(Op
)) then
11846 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
,
11847 Stream_Op_TSS_Names
(Op
)));
11852 -- Spec of "=" is expanded if the type is not limited and if a user
11853 -- defined "=" was not already declared for the non-full view of a
11854 -- private extension.
11856 if not Is_Limited_Type
(Tag_Typ
) then
11857 Make_Predefined_Primitive_Eq_Spec
(Tag_Typ
, Res
, Renamed_Eq
);
11859 -- Spec for dispatching assignment
11861 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11862 Tag_Typ
=> Tag_Typ
,
11863 Name
=> Name_uAssign
,
11864 Profile
=> New_List
(
11865 Make_Parameter_Specification
(Loc
,
11866 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
11867 Out_Present
=> True,
11868 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11870 Make_Parameter_Specification
(Loc
,
11871 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
11872 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)))));
11875 -- Ada 2005: Generate declarations for the following primitive
11876 -- operations for limited interfaces and synchronized types that
11877 -- implement a limited interface.
11879 -- Disp_Asynchronous_Select
11880 -- Disp_Conditional_Select
11881 -- Disp_Get_Prim_Op_Kind
11882 -- Disp_Get_Task_Id
11884 -- Disp_Timed_Select
11886 -- Disable the generation of these bodies if Ravenscar or ZFP is active
11888 if Ada_Version
>= Ada_2005
11889 and then not Restriction_Active
(No_Select_Statements
)
11890 and then RTE_Available
(RE_Select_Specific_Data
)
11892 -- These primitives are defined abstract in interface types
11894 if Is_Interface
(Tag_Typ
)
11895 and then Is_Limited_Record
(Tag_Typ
)
11898 Make_Abstract_Subprogram_Declaration
(Loc
,
11900 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
11903 Make_Abstract_Subprogram_Declaration
(Loc
,
11905 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
11908 Make_Abstract_Subprogram_Declaration
(Loc
,
11910 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
11913 Make_Abstract_Subprogram_Declaration
(Loc
,
11915 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
11918 Make_Abstract_Subprogram_Declaration
(Loc
,
11920 Make_Disp_Requeue_Spec
(Tag_Typ
)));
11923 Make_Abstract_Subprogram_Declaration
(Loc
,
11925 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
11927 -- If ancestor is an interface type, declare non-abstract primitives
11928 -- to override the abstract primitives of the interface type.
11930 -- In VM targets we define these primitives in all root tagged types
11931 -- that are not interface types. Done because in VM targets we don't
11932 -- have secondary dispatch tables and any derivation of Tag_Typ may
11933 -- cover limited interfaces (which always have these primitives since
11934 -- they may be ancestors of synchronized interface types).
11936 elsif (not Is_Interface
(Tag_Typ
)
11937 and then Is_Interface
(Etype
(Tag_Typ
))
11938 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
11940 (Is_Concurrent_Record_Type
(Tag_Typ
)
11941 and then Has_Interfaces
(Tag_Typ
))
11943 (not Tagged_Type_Expansion
11944 and then not Is_Interface
(Tag_Typ
)
11945 and then Tag_Typ
= Root_Type
(Tag_Typ
))
11948 Make_Subprogram_Declaration
(Loc
,
11950 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
11953 Make_Subprogram_Declaration
(Loc
,
11955 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
11958 Make_Subprogram_Declaration
(Loc
,
11960 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
11963 Make_Subprogram_Declaration
(Loc
,
11965 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
11968 Make_Subprogram_Declaration
(Loc
,
11970 Make_Disp_Requeue_Spec
(Tag_Typ
)));
11973 Make_Subprogram_Declaration
(Loc
,
11975 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
11979 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
11980 -- regardless of whether they are controlled or may contain controlled
11983 -- Do not generate the routines if finalization is disabled
11985 if Restriction_Active
(No_Finalization
) then
11989 if not Is_Limited_Type
(Tag_Typ
) then
11990 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
11993 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
11996 Predef_List
:= Res
;
11997 end Make_Predefined_Primitive_Specs
;
11999 -------------------------
12000 -- Make_Tag_Assignment --
12001 -------------------------
12003 function Make_Tag_Assignment
(N
: Node_Id
) return Node_Id
is
12004 Loc
: constant Source_Ptr
:= Sloc
(N
);
12005 Def_If
: constant Entity_Id
:= Defining_Identifier
(N
);
12006 Expr
: constant Node_Id
:= Expression
(N
);
12007 Typ
: constant Entity_Id
:= Etype
(Def_If
);
12008 Full_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
12013 -- This expansion activity is called during analysis
12015 if Is_Tagged_Type
(Typ
)
12016 and then not Is_Class_Wide_Type
(Typ
)
12017 and then not Is_CPP_Class
(Typ
)
12018 and then Tagged_Type_Expansion
12019 and then Nkind
(Expr
) /= N_Aggregate
12020 and then (Nkind
(Expr
) /= N_Qualified_Expression
12021 or else Nkind
(Expression
(Expr
)) /= N_Aggregate
)
12024 Make_Selected_Component
(Loc
,
12025 Prefix
=> New_Occurrence_Of
(Def_If
, Loc
),
12027 New_Occurrence_Of
(First_Tag_Component
(Full_Typ
), Loc
));
12029 Set_Assignment_OK
(New_Ref
);
12032 Make_Assignment_Statement
(Loc
,
12035 Unchecked_Convert_To
(RTE
(RE_Tag
),
12037 (Node
(First_Elmt
(Access_Disp_Table
(Full_Typ
))), Loc
)));
12041 end Make_Tag_Assignment
;
12043 ----------------------
12044 -- Predef_Deep_Spec --
12045 ----------------------
12047 function Predef_Deep_Spec
12049 Tag_Typ
: Entity_Id
;
12050 Name
: TSS_Name_Type
;
12051 For_Body
: Boolean := False) return Node_Id
12056 -- V : in out Tag_Typ
12058 Formals
:= New_List
(
12059 Make_Parameter_Specification
(Loc
,
12060 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
12061 In_Present
=> True,
12062 Out_Present
=> True,
12063 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)));
12065 -- F : Boolean := True
12067 if Name
= TSS_Deep_Adjust
12068 or else Name
= TSS_Deep_Finalize
12070 Append_To
(Formals
,
12071 Make_Parameter_Specification
(Loc
,
12072 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
12073 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12074 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12078 Predef_Spec_Or_Body
(Loc
,
12079 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12080 Tag_Typ
=> Tag_Typ
,
12081 Profile
=> Formals
,
12082 For_Body
=> For_Body
);
12085 when RE_Not_Available
=>
12087 end Predef_Deep_Spec
;
12089 -------------------------
12090 -- Predef_Spec_Or_Body --
12091 -------------------------
12093 function Predef_Spec_Or_Body
12095 Tag_Typ
: Entity_Id
;
12098 Ret_Type
: Entity_Id
:= Empty
;
12099 For_Body
: Boolean := False) return Node_Id
12101 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
12105 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
12107 -- The internal flag is set to mark these declarations because they have
12108 -- specific properties. First, they are primitives even if they are not
12109 -- defined in the type scope (the freezing point is not necessarily in
12110 -- the same scope). Second, the predefined equality can be overridden by
12111 -- a user-defined equality, no body will be generated in this case.
12113 Set_Is_Internal
(Id
);
12115 if not Debug_Generated_Code
then
12116 Set_Debug_Info_Off
(Id
);
12119 if No
(Ret_Type
) then
12121 Make_Procedure_Specification
(Loc
,
12122 Defining_Unit_Name
=> Id
,
12123 Parameter_Specifications
=> Profile
);
12126 Make_Function_Specification
(Loc
,
12127 Defining_Unit_Name
=> Id
,
12128 Parameter_Specifications
=> Profile
,
12129 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
12132 -- Declare an abstract subprogram for primitive subprograms of an
12133 -- interface type (except for "=").
12135 if Is_Interface
(Tag_Typ
) then
12136 if Name
/= Name_Op_Eq
then
12137 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12139 -- The equality function (if any) for an interface type is defined
12140 -- to be nonabstract, so we create an expression function for it that
12141 -- always returns False. Note that the function can never actually be
12142 -- invoked because interface types are abstract, so there aren't any
12143 -- objects of such types (and their equality operation will always
12147 return Make_Expression_Function
12148 (Loc
, Spec
, New_Occurrence_Of
(Standard_False
, Loc
));
12151 -- If body case, return empty subprogram body. Note that this is ill-
12152 -- formed, because there is not even a null statement, and certainly not
12153 -- a return in the function case. The caller is expected to do surgery
12154 -- on the body to add the appropriate stuff.
12156 elsif For_Body
then
12157 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
12159 -- For the case of an Input attribute predefined for an abstract type,
12160 -- generate an abstract specification. This will never be called, but we
12161 -- need the slot allocated in the dispatching table so that attributes
12162 -- typ'Class'Input and typ'Class'Output will work properly.
12164 elsif Is_TSS
(Name
, TSS_Stream_Input
)
12165 and then Is_Abstract_Type
(Tag_Typ
)
12167 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12169 -- Normal spec case, where we return a subprogram declaration
12172 return Make_Subprogram_Declaration
(Loc
, Spec
);
12174 end Predef_Spec_Or_Body
;
12176 -----------------------------
12177 -- Predef_Stream_Attr_Spec --
12178 -----------------------------
12180 function Predef_Stream_Attr_Spec
12182 Tag_Typ
: Entity_Id
;
12183 Name
: TSS_Name_Type
) return Node_Id
12185 Ret_Type
: Entity_Id
;
12188 if Name
= TSS_Stream_Input
then
12189 Ret_Type
:= Tag_Typ
;
12195 Predef_Spec_Or_Body
12197 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12198 Tag_Typ
=> Tag_Typ
,
12199 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
12200 Ret_Type
=> Ret_Type
,
12201 For_Body
=> False);
12202 end Predef_Stream_Attr_Spec
;
12204 ----------------------------------
12205 -- Predefined_Primitive_Eq_Body --
12206 ----------------------------------
12208 procedure Predefined_Primitive_Eq_Body
12209 (Tag_Typ
: Entity_Id
;
12210 Predef_List
: List_Id
;
12211 Renamed_Eq
: Entity_Id
)
12214 Eq_Needed
: Boolean;
12219 -- See if we have a predefined "=" operator
12221 if Present
(Renamed_Eq
) then
12223 Eq_Name
:= Chars
(Renamed_Eq
);
12225 -- If the parent is an interface type then it has defined all the
12226 -- predefined primitives abstract and we need to check if the type
12227 -- has some user defined "=" function which matches the profile of
12228 -- the Ada predefined equality operator to avoid generating it.
12230 elsif Is_Interface
(Etype
(Tag_Typ
)) then
12232 Eq_Name
:= Name_Op_Eq
;
12234 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12235 while Present
(Prim
) loop
12236 if Is_User_Defined_Equality
(Node
(Prim
))
12237 and then not Is_Internal
(Node
(Prim
))
12239 Eq_Needed
:= False;
12240 Eq_Name
:= No_Name
;
12248 Eq_Needed
:= False;
12249 Eq_Name
:= No_Name
;
12251 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12252 while Present
(Prim
) loop
12253 if Is_User_Defined_Equality
(Node
(Prim
))
12254 and then Is_Internal
(Node
(Prim
))
12257 Eq_Name
:= Name_Op_Eq
;
12265 -- If equality is needed, we will have its name
12267 pragma Assert
(Eq_Needed
= Present
(Eq_Name
));
12269 -- Body for equality
12272 Decl
:= Make_Eq_Body
(Tag_Typ
, Eq_Name
);
12273 Append_To
(Predef_List
, Decl
);
12276 -- Body for inequality (if required)
12278 Decl
:= Make_Neq_Body
(Tag_Typ
);
12280 if Present
(Decl
) then
12281 Append_To
(Predef_List
, Decl
);
12283 end Predefined_Primitive_Eq_Body
;
12285 ---------------------------------
12286 -- Predefined_Primitive_Bodies --
12287 ---------------------------------
12289 function Predefined_Primitive_Bodies
12290 (Tag_Typ
: Entity_Id
;
12291 Renamed_Eq
: Entity_Id
) return List_Id
12293 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12294 Res
: constant List_Id
:= New_List
;
12295 Adj_Call
: Node_Id
;
12297 Fin_Call
: Node_Id
;
12300 pragma Warnings
(Off
, Ent
);
12305 pragma Assert
(not Is_Interface
(Tag_Typ
));
12309 Decl
:= Predef_Spec_Or_Body
(Loc
,
12310 Tag_Typ
=> Tag_Typ
,
12311 Name
=> Name_uSize
,
12312 Profile
=> New_List
(
12313 Make_Parameter_Specification
(Loc
,
12314 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12315 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12317 Ret_Type
=> Standard_Long_Long_Integer
,
12320 Set_Handled_Statement_Sequence
(Decl
,
12321 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12322 Make_Simple_Return_Statement
(Loc
,
12324 Make_Attribute_Reference
(Loc
,
12325 Prefix
=> Make_Identifier
(Loc
, Name_X
),
12326 Attribute_Name
=> Name_Size
)))));
12328 Append_To
(Res
, Decl
);
12330 -- Body of Put_Image
12332 if No
(TSS
(Tag_Typ
, TSS_Put_Image
))
12333 and then (not No_Run_Time_Mode
)
12334 and then RTE_Available
(RE_Root_Buffer_Type
)
12336 Build_Record_Put_Image_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12337 Append_To
(Res
, Decl
);
12340 -- Bodies for Dispatching stream IO routines. We need these only for
12341 -- non-limited types (in the limited case there is no dispatching).
12342 -- We also skip them if dispatching or finalization are not available
12343 -- or if stream operations are prohibited by restriction No_Streams or
12344 -- from use of pragma/aspect No_Tagged_Streams.
12346 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Read
)
12347 and then No
(TSS
(Tag_Typ
, TSS_Stream_Read
))
12349 Build_Record_Read_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12350 Append_To
(Res
, Decl
);
12353 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Write
)
12354 and then No
(TSS
(Tag_Typ
, TSS_Stream_Write
))
12356 Build_Record_Write_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12357 Append_To
(Res
, Decl
);
12360 -- Skip body of _Input for the abstract case, since the corresponding
12361 -- spec is abstract (see Predef_Spec_Or_Body).
12363 if not Is_Abstract_Type
(Tag_Typ
)
12364 and then Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Input
)
12365 and then No
(TSS
(Tag_Typ
, TSS_Stream_Input
))
12367 Build_Record_Or_Elementary_Input_Function
12368 (Loc
, Tag_Typ
, Decl
, Ent
);
12369 Append_To
(Res
, Decl
);
12372 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Output
)
12373 and then No
(TSS
(Tag_Typ
, TSS_Stream_Output
))
12375 Build_Record_Or_Elementary_Output_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12376 Append_To
(Res
, Decl
);
12379 -- Ada 2005: Generate bodies for the following primitive operations for
12380 -- limited interfaces and synchronized types that implement a limited
12383 -- disp_asynchronous_select
12384 -- disp_conditional_select
12385 -- disp_get_prim_op_kind
12386 -- disp_get_task_id
12387 -- disp_timed_select
12389 -- The interface versions will have null bodies
12391 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12393 -- In VM targets we define these primitives in all root tagged types
12394 -- that are not interface types. Done because in VM targets we don't
12395 -- have secondary dispatch tables and any derivation of Tag_Typ may
12396 -- cover limited interfaces (which always have these primitives since
12397 -- they may be ancestors of synchronized interface types).
12399 if Ada_Version
>= Ada_2005
12401 ((Is_Interface
(Etype
(Tag_Typ
))
12402 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12404 (Is_Concurrent_Record_Type
(Tag_Typ
)
12405 and then Has_Interfaces
(Tag_Typ
))
12407 (not Tagged_Type_Expansion
12408 and then Tag_Typ
= Root_Type
(Tag_Typ
)))
12409 and then not Restriction_Active
(No_Select_Statements
)
12410 and then RTE_Available
(RE_Select_Specific_Data
)
12412 Append_To
(Res
, Make_Disp_Asynchronous_Select_Body
(Tag_Typ
));
12413 Append_To
(Res
, Make_Disp_Conditional_Select_Body
(Tag_Typ
));
12414 Append_To
(Res
, Make_Disp_Get_Prim_Op_Kind_Body
(Tag_Typ
));
12415 Append_To
(Res
, Make_Disp_Get_Task_Id_Body
(Tag_Typ
));
12416 Append_To
(Res
, Make_Disp_Requeue_Body
(Tag_Typ
));
12417 Append_To
(Res
, Make_Disp_Timed_Select_Body
(Tag_Typ
));
12420 if not Is_Limited_Type
(Tag_Typ
) then
12421 -- Body for equality and inequality
12423 Predefined_Primitive_Eq_Body
(Tag_Typ
, Res
, Renamed_Eq
);
12425 -- Body for dispatching assignment
12428 Predef_Spec_Or_Body
(Loc
,
12429 Tag_Typ
=> Tag_Typ
,
12430 Name
=> Name_uAssign
,
12431 Profile
=> New_List
(
12432 Make_Parameter_Specification
(Loc
,
12433 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12434 Out_Present
=> True,
12435 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12437 Make_Parameter_Specification
(Loc
,
12438 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12439 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12442 Set_Handled_Statement_Sequence
(Decl
,
12443 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12444 Make_Assignment_Statement
(Loc
,
12445 Name
=> Make_Identifier
(Loc
, Name_X
),
12446 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
12448 Append_To
(Res
, Decl
);
12451 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
12452 -- tagged types which do not contain controlled components.
12454 -- Do not generate the routines if finalization is disabled
12456 if Restriction_Active
(No_Finalization
) then
12459 elsif not Has_Controlled_Component
(Tag_Typ
) then
12460 if not Is_Limited_Type
(Tag_Typ
) then
12462 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
12464 if Is_Controlled
(Tag_Typ
) then
12467 Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12471 if No
(Adj_Call
) then
12472 Adj_Call
:= Make_Null_Statement
(Loc
);
12475 Set_Handled_Statement_Sequence
(Decl
,
12476 Make_Handled_Sequence_Of_Statements
(Loc
,
12477 Statements
=> New_List
(Adj_Call
)));
12479 Append_To
(Res
, Decl
);
12483 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
12485 if Is_Controlled
(Tag_Typ
) then
12488 (Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12492 if No
(Fin_Call
) then
12493 Fin_Call
:= Make_Null_Statement
(Loc
);
12496 Set_Handled_Statement_Sequence
(Decl
,
12497 Make_Handled_Sequence_Of_Statements
(Loc
,
12498 Statements
=> New_List
(Fin_Call
)));
12500 Append_To
(Res
, Decl
);
12504 end Predefined_Primitive_Bodies
;
12506 ---------------------------------
12507 -- Predefined_Primitive_Freeze --
12508 ---------------------------------
12510 function Predefined_Primitive_Freeze
12511 (Tag_Typ
: Entity_Id
) return List_Id
12513 Res
: constant List_Id
:= New_List
;
12518 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12519 while Present
(Prim
) loop
12520 if Is_Predefined_Dispatching_Operation
(Node
(Prim
)) then
12521 Frnodes
:= Freeze_Entity
(Node
(Prim
), Tag_Typ
);
12523 if Present
(Frnodes
) then
12524 Append_List_To
(Res
, Frnodes
);
12532 end Predefined_Primitive_Freeze
;
12534 -------------------------
12535 -- Stream_Operation_OK --
12536 -------------------------
12538 function Stream_Operation_OK
12540 Operation
: TSS_Name_Type
) return Boolean
12542 Has_Predefined_Or_Specified_Stream_Attribute
: Boolean := False;
12545 -- Special case of a limited type extension: a default implementation
12546 -- of the stream attributes Read or Write exists if that attribute
12547 -- has been specified or is available for an ancestor type; a default
12548 -- implementation of the attribute Output (resp. Input) exists if the
12549 -- attribute has been specified or Write (resp. Read) is available for
12550 -- an ancestor type. The last condition only applies under Ada 2005.
12552 if Is_Limited_Type
(Typ
) and then Is_Tagged_Type
(Typ
) then
12553 if Operation
= TSS_Stream_Read
then
12554 Has_Predefined_Or_Specified_Stream_Attribute
:=
12555 Has_Specified_Stream_Read
(Typ
);
12557 elsif Operation
= TSS_Stream_Write
then
12558 Has_Predefined_Or_Specified_Stream_Attribute
:=
12559 Has_Specified_Stream_Write
(Typ
);
12561 elsif Operation
= TSS_Stream_Input
then
12562 Has_Predefined_Or_Specified_Stream_Attribute
:=
12563 Has_Specified_Stream_Input
(Typ
)
12565 (Ada_Version
>= Ada_2005
12566 and then Stream_Operation_OK
(Typ
, TSS_Stream_Read
));
12568 elsif Operation
= TSS_Stream_Output
then
12569 Has_Predefined_Or_Specified_Stream_Attribute
:=
12570 Has_Specified_Stream_Output
(Typ
)
12572 (Ada_Version
>= Ada_2005
12573 and then Stream_Operation_OK
(Typ
, TSS_Stream_Write
));
12576 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
12578 if not Has_Predefined_Or_Specified_Stream_Attribute
12579 and then Is_Derived_Type
(Typ
)
12580 and then (Operation
= TSS_Stream_Read
12581 or else Operation
= TSS_Stream_Write
)
12583 Has_Predefined_Or_Specified_Stream_Attribute
:=
12585 (Find_Inherited_TSS
(Base_Type
(Etype
(Typ
)), Operation
));
12589 -- If the type is not limited, or else is limited but the attribute is
12590 -- explicitly specified or is predefined for the type, then return True,
12591 -- unless other conditions prevail, such as restrictions prohibiting
12592 -- streams or dispatching operations. We also return True for limited
12593 -- interfaces, because they may be extended by nonlimited types and
12594 -- permit inheritance in this case (addresses cases where an abstract
12595 -- extension doesn't get 'Input declared, as per comments below, but
12596 -- 'Class'Input must still be allowed). Note that attempts to apply
12597 -- stream attributes to a limited interface or its class-wide type
12598 -- (or limited extensions thereof) will still get properly rejected
12599 -- by Check_Stream_Attribute.
12601 -- We exclude the Input operation from being a predefined subprogram in
12602 -- the case where the associated type is an abstract extension, because
12603 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
12604 -- we don't want an abstract version created because types derived from
12605 -- the abstract type may not even have Input available (for example if
12606 -- derived from a private view of the abstract type that doesn't have
12607 -- a visible Input).
12609 -- Do not generate stream routines for type Finalization_Master because
12610 -- a master may never appear in types and therefore cannot be read or
12614 (not Is_Limited_Type
(Typ
)
12615 or else Is_Interface
(Typ
)
12616 or else Has_Predefined_Or_Specified_Stream_Attribute
)
12618 (Operation
/= TSS_Stream_Input
12619 or else not Is_Abstract_Type
(Typ
)
12620 or else not Is_Derived_Type
(Typ
))
12621 and then not Has_Unknown_Discriminants
(Typ
)
12622 and then not Is_Concurrent_Interface
(Typ
)
12623 and then not Restriction_Active
(No_Streams
)
12624 and then not Restriction_Active
(No_Dispatch
)
12625 and then No
(No_Tagged_Streams_Pragma
(Typ
))
12626 and then not No_Run_Time_Mode
12627 and then RTE_Available
(RE_Tag
)
12628 and then No
(Type_Without_Stream_Operation
(Typ
))
12629 and then RTE_Available
(RE_Root_Stream_Type
)
12630 and then not Is_RTE
(Typ
, RE_Finalization_Master
);
12631 end Stream_Operation_OK
;