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 Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean;
6310 -- If we are not at library level and the object declaration originally
6311 -- appears in the form:
6313 -- Obj : Typ := Func (...);
6315 -- and has been rewritten as the dereference of a captured reference
6316 -- to the function result built either on the primary or the secondary
6317 -- stack, then the declaration can be rewritten as the renaming of this
6320 -- type Ann is access all Typ;
6321 -- Rnn : constant Axx := Func (...)'reference;
6322 -- Obj : Typ renames Rnn.all;
6324 -- This will avoid making an extra copy and, in the case where Typ needs
6325 -- finalization, a pair of calls to the Adjust and Finalize primitives,
6326 -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
6327 -- has components that themselves need finalization.
6329 -- However, in the case of a special return object, we need to make sure
6330 -- that the object Rnn is recognized by the Is_Related_To_Func_Return
6331 -- predicate; otherwise, if it is of a type that needs finalization,
6332 -- then Requires_Cleanup_Actions would return true because of this and
6333 -- Build_Finalizer would finalize it prematurely because of this (see
6334 -- also Expand_Simple_Function_Return for the same test in the case of
6335 -- a simple return).
6337 -- Finally, in the case of a special return object, we also need to make
6338 -- sure that the two functions return on the same stack, otherwise we
6339 -- would create a dangling reference.
6341 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
;
6342 -- Make an allocator for a return object initialized with Expr
6344 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean;
6345 -- Return True if N denotes an entity with OK_To_Rename set
6347 --------------------------------
6348 -- Build_Equivalent_Aggregate --
6349 --------------------------------
6351 function Build_Equivalent_Aggregate
return Boolean is
6355 Full_Type
: Entity_Id
;
6360 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
6361 Full_Type
:= Full_View
(Typ
);
6364 -- Only perform this transformation if Elaboration_Code is forbidden
6365 -- or undesirable, and if this is a global entity of a constrained
6368 -- If Initialize_Scalars might be active this transformation cannot
6369 -- be performed either, because it will lead to different semantics
6370 -- or because elaboration code will in fact be created.
6372 if Ekind
(Full_Type
) /= E_Record_Subtype
6373 or else not Has_Discriminants
(Full_Type
)
6374 or else not Is_Constrained
(Full_Type
)
6375 or else Is_Controlled
(Full_Type
)
6376 or else Is_Limited_Type
(Full_Type
)
6377 or else not Restriction_Active
(No_Initialize_Scalars
)
6382 if Ekind
(Current_Scope
) = E_Package
6384 (Restriction_Active
(No_Elaboration_Code
)
6385 or else Is_Preelaborated
(Current_Scope
))
6387 -- Building a static aggregate is possible if the discriminants
6388 -- have static values and the other components have static
6389 -- defaults or none.
6391 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Type
));
6392 while Present
(Discr
) loop
6393 if not Is_OK_Static_Expression
(Node
(Discr
)) then
6400 -- Check that initialized components are OK, and that non-
6401 -- initialized components do not require a call to their own
6402 -- initialization procedure.
6404 Comp
:= First_Component
(Full_Type
);
6405 while Present
(Comp
) loop
6406 if Present
(Expression
(Parent
(Comp
)))
6408 not Is_OK_Static_Expression
(Expression
(Parent
(Comp
)))
6412 elsif Has_Non_Null_Base_Init_Proc
(Etype
(Comp
)) then
6417 Next_Component
(Comp
);
6420 -- Everything is static, assemble the aggregate, discriminant
6424 Make_Aggregate
(Loc
,
6425 Expressions
=> New_List
,
6426 Component_Associations
=> New_List
);
6428 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Type
));
6429 while Present
(Discr
) loop
6430 Append_To
(Expressions
(Aggr
), New_Copy
(Node
(Discr
)));
6434 -- Now collect values of initialized components
6436 Comp
:= First_Component
(Full_Type
);
6437 while Present
(Comp
) loop
6438 if Present
(Expression
(Parent
(Comp
))) then
6439 Append_To
(Component_Associations
(Aggr
),
6440 Make_Component_Association
(Loc
,
6441 Choices
=> New_List
(New_Occurrence_Of
(Comp
, Loc
)),
6442 Expression
=> New_Copy_Tree
6443 (Expression
(Parent
(Comp
)))));
6446 Next_Component
(Comp
);
6449 -- Finally, box-initialize remaining components
6451 Append_To
(Component_Associations
(Aggr
),
6452 Make_Component_Association
(Loc
,
6453 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
6454 Expression
=> Empty
));
6455 Set_Box_Present
(Last
(Component_Associations
(Aggr
)));
6456 Set_Expression
(N
, Aggr
);
6458 if Typ
/= Full_Type
then
6459 Analyze_And_Resolve
(Aggr
, Full_View
(Base_Type
(Full_Type
)));
6460 Rewrite
(Aggr
, Unchecked_Convert_To
(Typ
, Aggr
));
6461 Analyze_And_Resolve
(Aggr
, Typ
);
6463 Analyze_And_Resolve
(Aggr
, Full_Type
);
6471 end Build_Equivalent_Aggregate
;
6473 ----------------------------------
6474 -- Build_Heap_Or_Pool_Allocator --
6475 ----------------------------------
6477 function Build_Heap_Or_Pool_Allocator
6478 (Temp_Id
: Entity_Id
;
6479 Temp_Typ
: Entity_Id
;
6480 Ret_Typ
: Entity_Id
;
6481 Alloc_Expr
: Node_Id
) return Node_Id
6484 pragma Assert
(Is_Build_In_Place_Function
(Func_Id
));
6486 -- Processing for objects that require finalization actions
6488 if Needs_Finalization
(Ret_Typ
) then
6490 Decls
: constant List_Id
:= New_List
;
6491 Fin_Mas_Id
: constant Entity_Id
:=
6492 Build_In_Place_Formal
(Func_Id
, BIP_Finalization_Master
);
6493 Orig_Expr
: constant Node_Id
:= New_Copy_Tree
(Alloc_Expr
);
6494 Stmts
: constant List_Id
:= New_List
;
6495 Local_Id
: Entity_Id
;
6496 Pool_Id
: Entity_Id
;
6497 Ptr_Typ
: Entity_Id
;
6501 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
6503 Pool_Id
:= Make_Temporary
(Loc
, 'P');
6506 Make_Object_Renaming_Declaration
(Loc
,
6507 Defining_Identifier
=> Pool_Id
,
6509 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
6511 Make_Explicit_Dereference
(Loc
,
6513 Make_Function_Call
(Loc
,
6515 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
6516 Parameter_Associations
=> New_List
(
6517 Make_Explicit_Dereference
(Loc
,
6519 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
6521 -- Create an access type which uses the storage pool of the
6522 -- caller's master. This additional type is necessary because
6523 -- the finalization master cannot be associated with the type
6524 -- of the temporary. Otherwise the secondary stack allocation
6528 -- type Ptr_Typ is access Ret_Typ;
6530 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
6533 Make_Full_Type_Declaration
(Loc
,
6534 Defining_Identifier
=> Ptr_Typ
,
6536 Make_Access_To_Object_Definition
(Loc
,
6537 Subtype_Indication
=>
6538 New_Occurrence_Of
(Ret_Typ
, Loc
))));
6540 -- Perform minor decoration in order to set the master and the
6541 -- storage pool attributes.
6543 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
6544 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
6545 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
6547 -- Create the temporary, generate:
6548 -- Local_Id : Ptr_Typ;
6550 Local_Id
:= Make_Temporary
(Loc
, 'T');
6553 Make_Object_Declaration
(Loc
,
6554 Defining_Identifier
=> Local_Id
,
6555 Object_Definition
=>
6556 New_Occurrence_Of
(Ptr_Typ
, Loc
)));
6558 -- Allocate the object, generate:
6559 -- Local_Id := <Alloc_Expr>;
6562 Make_Assignment_Statement
(Loc
,
6563 Name
=> New_Occurrence_Of
(Local_Id
, Loc
),
6564 Expression
=> Alloc_Expr
));
6567 -- Temp_Id := Temp_Typ (Local_Id);
6570 Make_Assignment_Statement
(Loc
,
6571 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6573 Unchecked_Convert_To
(Temp_Typ
,
6574 New_Occurrence_Of
(Local_Id
, Loc
))));
6576 -- Wrap the allocation in a block. This is further conditioned
6577 -- by checking the caller finalization master at runtime. A
6578 -- null value indicates a non-existent master, most likely due
6579 -- to a Finalize_Storage_Only allocation.
6582 -- if BIPfinalizationmaster = null then
6583 -- Temp_Id := <Orig_Expr>;
6593 Make_If_Statement
(Loc
,
6596 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
6597 Right_Opnd
=> Make_Null
(Loc
)),
6599 Then_Statements
=> New_List
(
6600 Make_Assignment_Statement
(Loc
,
6601 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6602 Expression
=> Orig_Expr
)),
6604 Else_Statements
=> New_List
(
6605 Make_Block_Statement
(Loc
,
6606 Declarations
=> Decls
,
6607 Handled_Statement_Sequence
=>
6608 Make_Handled_Sequence_Of_Statements
(Loc
,
6609 Statements
=> Stmts
))));
6612 -- For all other cases, generate:
6613 -- Temp_Id := <Alloc_Expr>;
6617 Make_Assignment_Statement
(Loc
,
6618 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6619 Expression
=> Alloc_Expr
);
6621 end Build_Heap_Or_Pool_Allocator
;
6623 -------------------------------------
6624 -- Count_Default_Sized_Task_Stacks --
6625 -------------------------------------
6627 procedure Count_Default_Sized_Task_Stacks
6629 Pri_Stacks
: out Int
;
6630 Sec_Stacks
: out Int
)
6632 Component
: Entity_Id
;
6635 -- To calculate the number of default-sized task stacks required for
6636 -- an object of Typ, a depth-first recursive traversal of the AST
6637 -- from the Typ entity node is undertaken. Only type nodes containing
6638 -- task objects are visited.
6643 if not Has_Task
(Typ
) then
6651 -- A task type is found marking the bottom of the descent. If
6652 -- the type has no representation aspect for the corresponding
6653 -- stack then that stack is using the default size.
6655 if Present
(Get_Rep_Item
(Typ
, Name_Storage_Size
)) then
6661 if Present
(Get_Rep_Item
(Typ
, Name_Secondary_Stack_Size
)) then
6667 when E_Array_Subtype
6670 -- First find the number of default stacks contained within an
6673 Count_Default_Sized_Task_Stacks
6674 (Component_Type
(Typ
),
6678 -- Then multiply the result by the size of the array
6681 Quantity
: constant Int
:= Number_Of_Elements_In_Array
(Typ
);
6682 -- Number_Of_Elements_In_Array is non-trival, consequently
6683 -- its result is captured as an optimization.
6686 Pri_Stacks
:= Pri_Stacks
* Quantity
;
6687 Sec_Stacks
:= Sec_Stacks
* Quantity
;
6690 when E_Protected_Subtype
6695 Component
:= First_Component_Or_Discriminant
(Typ
);
6697 -- Recursively descend each component of the composite type
6698 -- looking for tasks, but only if the component is marked as
6701 while Present
(Component
) loop
6702 if Has_Task
(Etype
(Component
)) then
6708 Count_Default_Sized_Task_Stacks
6709 (Etype
(Component
), P
, S
);
6710 Pri_Stacks
:= Pri_Stacks
+ P
;
6711 Sec_Stacks
:= Sec_Stacks
+ S
;
6715 Next_Component_Or_Discriminant
(Component
);
6718 when E_Limited_Private_Subtype
6719 | E_Limited_Private_Type
6720 | E_Record_Subtype_With_Private
6721 | E_Record_Type_With_Private
6723 -- Switch to the full view of the private type to continue
6726 Count_Default_Sized_Task_Stacks
6727 (Full_View
(Typ
), Pri_Stacks
, Sec_Stacks
);
6729 -- Other types should not contain tasks
6732 raise Program_Error
;
6734 end Count_Default_Sized_Task_Stacks
;
6736 -------------------------------
6737 -- Default_Initialize_Object --
6738 -------------------------------
6740 procedure Default_Initialize_Object
(After
: Node_Id
) is
6741 function New_Object_Reference
return Node_Id
;
6742 -- Return a new reference to Def_Id with attributes Assignment_OK and
6743 -- Must_Not_Freeze already set.
6745 function Simple_Initialization_OK
6746 (Init_Typ
: Entity_Id
) return Boolean;
6747 -- Determine whether object declaration N with entity Def_Id needs
6748 -- simple initialization, assuming that it is of type Init_Typ.
6750 --------------------------
6751 -- New_Object_Reference --
6752 --------------------------
6754 function New_Object_Reference
return Node_Id
is
6755 Obj_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
6758 -- The call to the type init proc or [Deep_]Finalize must not
6759 -- freeze the related object as the call is internally generated.
6760 -- This way legal rep clauses that apply to the object will not be
6761 -- flagged. Note that the initialization call may be removed if
6762 -- pragma Import is encountered or moved to the freeze actions of
6763 -- the object because of an address clause.
6765 Set_Assignment_OK
(Obj_Ref
);
6766 Set_Must_Not_Freeze
(Obj_Ref
);
6769 end New_Object_Reference
;
6771 ------------------------------
6772 -- Simple_Initialization_OK --
6773 ------------------------------
6775 function Simple_Initialization_OK
6776 (Init_Typ
: Entity_Id
) return Boolean
6779 -- Do not consider the object declaration if it comes with an
6780 -- initialization expression, or is internal in which case it
6781 -- will be assigned later.
6784 not Is_Internal
(Def_Id
)
6785 and then not Has_Init_Expression
(N
)
6786 and then Needs_Simple_Initialization
6790 and then No
(Following_Address_Clause
(N
)));
6791 end Simple_Initialization_OK
;
6795 Exceptions_OK
: constant Boolean :=
6796 not Restriction_Active
(No_Exception_Propagation
);
6798 Aggr_Init
: Node_Id
;
6799 Comp_Init
: List_Id
:= No_List
;
6800 Fin_Block
: Node_Id
;
6802 Init_Stmts
: List_Id
:= No_List
;
6803 Obj_Init
: Node_Id
:= Empty
;
6806 -- Start of processing for Default_Initialize_Object
6809 -- Default initialization is suppressed for objects that are already
6810 -- known to be imported (i.e. whose declaration specifies the Import
6811 -- aspect). Note that for objects with a pragma Import, we generate
6812 -- initialization here, and then remove it downstream when processing
6813 -- the pragma. It is also suppressed for variables for which a pragma
6814 -- Suppress_Initialization has been explicitly given
6816 if Is_Imported
(Def_Id
) or else Suppress_Initialization
(Def_Id
) then
6819 -- Nothing to do if the object being initialized is of a task type
6820 -- and restriction No_Tasking is in effect, because this is a direct
6821 -- violation of the restriction.
6823 elsif Is_Task_Type
(Base_Typ
)
6824 and then Restriction_Active
(No_Tasking
)
6829 -- The expansion performed by this routine is as follows:
6833 -- Type_Init_Proc (Obj);
6836 -- [Deep_]Initialize (Obj);
6840 -- [Deep_]Finalize (Obj, Self => False);
6844 -- Abort_Undefer_Direct;
6847 -- Initialize the components of the object
6849 if Has_Non_Null_Base_Init_Proc
(Typ
)
6850 and then not No_Initialization
(N
)
6851 and then not Initialization_Suppressed
(Typ
)
6853 -- Do not initialize the components if No_Default_Initialization
6854 -- applies as the actual restriction check will occur later when
6855 -- the object is frozen as it is not known yet whether the object
6856 -- is imported or not.
6858 if not Restriction_Active
(No_Default_Initialization
) then
6860 -- If the values of the components are compile-time known, use
6861 -- their prebuilt aggregate form directly.
6863 Aggr_Init
:= Static_Initialization
(Base_Init_Proc
(Typ
));
6865 if Present
(Aggr_Init
) then
6867 New_Copy_Tree
(Aggr_Init
, New_Scope
=> Current_Scope
));
6869 -- If type has discriminants, try to build an equivalent
6870 -- aggregate using discriminant values from the declaration.
6871 -- This is a useful optimization, in particular if restriction
6872 -- No_Elaboration_Code is active.
6874 elsif Build_Equivalent_Aggregate
then
6877 -- Optimize the default initialization of an array object when
6878 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
6879 -- Construct an in-place initialization aggregate which may be
6880 -- convert into a fast memset by the backend.
6882 elsif Init_Or_Norm_Scalars
6883 and then Is_Array_Type
(Typ
)
6885 -- The array must lack atomic components because they are
6886 -- treated as non-static, and as a result the backend will
6887 -- not initialize the memory in one go.
6889 and then not Has_Atomic_Components
(Typ
)
6891 -- The array must not be packed because the invalid values
6892 -- in System.Scalar_Values are multiples of Storage_Unit.
6894 and then not Is_Packed
(Typ
)
6896 -- The array must have static non-empty ranges, otherwise
6897 -- the backend cannot initialize the memory in one go.
6899 and then Has_Static_Non_Empty_Array_Bounds
(Typ
)
6901 -- The optimization is only relevant for arrays of scalar
6904 and then Is_Scalar_Type
(Component_Type
(Typ
))
6906 -- Similar to regular array initialization using a type
6907 -- init proc, predicate checks are not performed because the
6908 -- initialization values are intentionally invalid, and may
6909 -- violate the predicate.
6911 and then not Has_Predicates
(Component_Type
(Typ
))
6913 -- The component type must have a single initialization value
6915 and then Simple_Initialization_OK
(Component_Type
(Typ
))
6917 Set_No_Initialization
(N
, False);
6922 Size
=> (if Known_Esize
(Def_Id
) then Esize
(Def_Id
)
6926 (Expression
(N
), Typ
, Suppress
=> All_Checks
);
6928 -- Otherwise invoke the type init proc, generate:
6929 -- Type_Init_Proc (Obj);
6932 Obj_Ref
:= New_Object_Reference
;
6934 if Comes_From_Source
(Def_Id
) then
6935 Initialization_Warning
(Obj_Ref
);
6938 Comp_Init
:= Build_Initialization_Call
(Loc
, Obj_Ref
, Typ
);
6942 -- Provide a default value if the object needs simple initialization
6944 elsif Simple_Initialization_OK
(Typ
) then
6945 Set_No_Initialization
(N
, False);
6951 (if Known_Esize
(Def_Id
) then Esize
(Def_Id
) else Uint_0
)));
6953 Analyze_And_Resolve
(Expression
(N
), Typ
);
6956 -- Initialize the object, generate:
6957 -- [Deep_]Initialize (Obj);
6959 if Needs_Finalization
(Typ
) and then not No_Initialization
(N
) then
6962 (Obj_Ref
=> New_Object_Reference
,
6966 -- Build a special finalization block when both the object and its
6967 -- controlled components are to be initialized. The block finalizes
6968 -- the components if the object initialization fails. Generate:
6979 if Has_Controlled_Component
(Typ
)
6980 and then Present
(Comp_Init
)
6981 and then Present
(Obj_Init
)
6982 and then Exceptions_OK
6984 Init_Stmts
:= Comp_Init
;
6988 (Obj_Ref
=> New_Object_Reference
,
6992 if Present
(Fin_Call
) then
6994 -- Do not emit warnings related to the elaboration order when a
6995 -- controlled object is declared before the body of Finalize is
6998 if Legacy_Elaboration_Checks
then
6999 Set_No_Elaboration_Check
(Fin_Call
);
7003 Make_Block_Statement
(Loc
,
7004 Declarations
=> No_List
,
7006 Handled_Statement_Sequence
=>
7007 Make_Handled_Sequence_Of_Statements
(Loc
,
7008 Statements
=> New_List
(Obj_Init
),
7010 Exception_Handlers
=> New_List
(
7011 Make_Exception_Handler
(Loc
,
7012 Exception_Choices
=> New_List
(
7013 Make_Others_Choice
(Loc
)),
7015 Statements
=> New_List
(
7017 Make_Raise_Statement
(Loc
))))));
7019 -- Signal the ABE mechanism that the block carries out
7020 -- initialization actions.
7022 Set_Is_Initialization_Block
(Fin_Block
);
7024 Append_To
(Init_Stmts
, Fin_Block
);
7027 -- Otherwise finalization is not required, the initialization calls
7028 -- are passed to the abort block building circuitry, generate:
7030 -- Type_Init_Proc (Obj);
7031 -- [Deep_]Initialize (Obj);
7034 if Present
(Comp_Init
) then
7035 Init_Stmts
:= Comp_Init
;
7038 if Present
(Obj_Init
) then
7039 if No
(Init_Stmts
) then
7040 Init_Stmts
:= New_List
;
7043 Append_To
(Init_Stmts
, Obj_Init
);
7047 -- Build an abort block to protect the initialization calls
7050 and then Present
(Comp_Init
)
7051 and then Present
(Obj_Init
)
7056 Prepend_To
(Init_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7058 -- When exceptions are propagated, abort deferral must take place
7059 -- in the presence of initialization or finalization exceptions.
7066 -- Abort_Undefer_Direct;
7069 if Exceptions_OK
then
7070 Init_Stmts
:= New_List
(
7071 Build_Abort_Undefer_Block
(Loc
,
7072 Stmts
=> Init_Stmts
,
7075 -- Otherwise exceptions are not propagated. Generate:
7082 Append_To
(Init_Stmts
,
7083 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7087 -- Insert the whole initialization sequence into the tree. If the
7088 -- object has a delayed freeze, as will be the case when it has
7089 -- aspect specifications, the initialization sequence is part of
7090 -- the freeze actions.
7092 if Present
(Init_Stmts
) then
7093 if Has_Delayed_Freeze
(Def_Id
) then
7094 Append_Freeze_Actions
(Def_Id
, Init_Stmts
);
7096 Insert_Actions_After
(After
, Init_Stmts
);
7099 end Default_Initialize_Object
;
7101 ------------------------------
7102 -- Initialize_Return_Object --
7103 ------------------------------
7105 procedure Initialize_Return_Object
7106 (Tag_Assign
: Node_Id
;
7109 Init_Stmt
: Node_Id
;
7113 if Present
(Tag_Assign
) then
7114 Insert_Action_After
(After
, Tag_Assign
);
7117 if Present
(Adj_Call
) then
7118 Insert_Action_After
(After
, Adj_Call
);
7122 Default_Initialize_Object
(After
);
7124 elsif Is_Delayed_Aggregate
(Expr
)
7125 and then not No_Initialization
(N
)
7127 Convert_Aggr_In_Object_Decl
(N
);
7129 elsif Present
(Init_Stmt
) then
7130 Insert_Action_After
(After
, Init_Stmt
);
7131 Set_Expression
(N
, Empty
);
7133 end Initialize_Return_Object
;
7135 --------------------------------
7136 -- Is_Renamable_Function_Call --
7137 --------------------------------
7139 function Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean is
7141 return not Is_Library_Level_Entity
(Def_Id
)
7142 and then Is_Captured_Function_Call
(Expr
)
7143 and then (not Special_Ret_Obj
7145 (Is_Related_To_Func_Return
(Entity
(Prefix
(Expr
)))
7146 and then Needs_Secondary_Stack
(Etype
(Expr
)) =
7147 Needs_Secondary_Stack
(Etype
(Func_Id
))));
7148 end Is_Renamable_Function_Call
;
7150 -------------------------------
7151 -- Make_Allocator_For_Return --
7152 -------------------------------
7154 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
is
7156 Alloc_Expr
: Entity_Id
;
7159 -- If the return object's declaration includes an expression and the
7160 -- declaration isn't marked as No_Initialization, then we generate an
7161 -- allocator with a qualified expression. Although this is necessary
7162 -- only in the case where the result type is an interface (or class-
7163 -- wide interface), we do it in all cases for the sake of consistency
7164 -- instead of subsequently generating a separate assignment.
7167 and then not Is_Delayed_Aggregate
(Expr
)
7168 and then not No_Initialization
(N
)
7170 -- Ada 2005 (AI95-344): If the result type is class-wide, insert
7171 -- a check that the level of the return expression's underlying
7172 -- type is not deeper than the level of the master enclosing the
7175 -- AI12-043: The check is made immediately after the return object
7178 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
7179 Apply_CW_Accessibility_Check
(Expr
, Func_Id
);
7182 Alloc_Expr
:= New_Copy_Tree
(Expr
);
7184 -- In the constrained array case, deal with a potential sliding.
7185 -- In the interface case, put back a conversion that we may have
7186 -- removed earlier in the processing.
7188 if (Ekind
(Typ
) = E_Array_Subtype
7189 or else (Is_Interface
(Typ
)
7190 and then Is_Class_Wide_Type
(Etype
(Alloc_Expr
))))
7191 and then Typ
/= Etype
(Alloc_Expr
)
7193 Alloc_Expr
:= Convert_To
(Typ
, Alloc_Expr
);
7196 -- We always use the type of the expression for the qualified
7197 -- expression, rather than the return object's type. We cannot
7198 -- always use the return object's type because the expression
7199 -- might be of a specific type and the return object mignt not.
7202 Make_Allocator
(Loc
,
7204 Make_Qualified_Expression
(Loc
,
7206 New_Occurrence_Of
(Etype
(Alloc_Expr
), Loc
),
7207 Expression
=> Alloc_Expr
));
7211 Make_Allocator
(Loc
,
7212 Expression
=> New_Occurrence_Of
(Typ
, Loc
));
7214 -- If the return object requires default initialization, then it
7215 -- will happen later following the elaboration of the renaming.
7216 -- If we don't turn it off here, then the object will be default
7217 -- initialized twice.
7219 Set_No_Initialization
(Alloc
);
7222 -- Set the flag indicating that the allocator is made for a special
7223 -- return object. This is used to bypass various legality checks as
7224 -- well as to make sure that the result is not adjusted twice.
7226 Set_For_Special_Return_Object
(Alloc
);
7229 end Make_Allocator_For_Return
;
7231 ----------------------
7232 -- OK_To_Rename_Ref --
7233 ----------------------
7235 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean is
7237 return Is_Entity_Name
(N
)
7238 and then Ekind
(Entity
(N
)) = E_Variable
7239 and then OK_To_Rename
(Entity
(N
));
7240 end OK_To_Rename_Ref
;
7244 Adj_Call
: Node_Id
:= Empty
;
7245 Expr_Q
: Node_Id
:= Empty
;
7246 Tag_Assign
: Node_Id
:= Empty
;
7248 Init_After
: Node_Id
:= N
;
7249 -- Node after which the initialization actions are to be inserted. This
7250 -- is normally N, except for the case of a shared passive variable, in
7251 -- which case the init proc call must be inserted only after the bodies
7252 -- of the shared variable procedures have been seen.
7254 Rewrite_As_Renaming
: Boolean := False;
7255 -- Whether to turn the declaration into a renaming at the end
7257 -- Start of processing for Expand_N_Object_Declaration
7260 -- Don't do anything for deferred constants. All proper actions will be
7261 -- expanded during the full declaration.
7263 if No
(Expr
) and Constant_Present
(N
) then
7267 -- The type of the object cannot be abstract. This is diagnosed at the
7268 -- point the object is frozen, which happens after the declaration is
7269 -- fully expanded, so simply return now.
7271 if Is_Abstract_Type
(Typ
) then
7275 -- No action needed for the internal imported dummy object added by
7276 -- Make_DT to compute the offset of the components that reference
7277 -- secondary dispatch tables; required to avoid never-ending loop
7278 -- processing this internal object declaration.
7280 if Tagged_Type_Expansion
7281 and then Is_Internal
(Def_Id
)
7282 and then Is_Imported
(Def_Id
)
7283 and then Related_Type
(Def_Id
) = Implementation_Base_Type
(Typ
)
7288 -- Make shared memory routines for shared passive variable
7290 if Is_Shared_Passive
(Def_Id
) then
7291 Init_After
:= Make_Shared_Var_Procs
(N
);
7294 -- If tasks are being declared, make sure we have an activation chain
7295 -- defined for the tasks (has no effect if we already have one), and
7296 -- also that a Master variable is established (and that the appropriate
7297 -- enclosing construct is established as a task master).
7299 if Has_Task
(Typ
) or else Might_Have_Tasks
(Typ
) then
7300 Build_Activation_Chain_Entity
(N
);
7302 if Has_Task
(Typ
) then
7303 Build_Master_Entity
(Def_Id
);
7305 -- Handle objects initialized with BIP function calls
7307 elsif Present
(Expr
) then
7308 Expr_Q
:= Unqualify
(Expr
);
7310 if Is_Build_In_Place_Function_Call
(Expr_Q
)
7311 or else Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
))
7312 or else (Nkind
(Expr_Q
) = N_Reference
7314 Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
)))
7316 Build_Master_Entity
(Def_Id
);
7321 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
7322 -- restrictions are active then default-sized secondary stacks are
7323 -- generated by the binder and allocated by SS_Init. To provide the
7324 -- binder the number of stacks to generate, the number of default-sized
7325 -- stacks required for task objects contained within the object
7326 -- declaration N is calculated here as it is at this point where
7327 -- unconstrained types become constrained. The result is stored in the
7328 -- enclosing unit's Unit_Record.
7330 -- Note if N is an array object declaration that has an initialization
7331 -- expression, a second object declaration for the initialization
7332 -- expression is created by the compiler. To prevent double counting
7333 -- of the stacks in this scenario, the stacks of the first array are
7336 if Might_Have_Tasks
(Typ
)
7337 and then not Restriction_Active
(No_Secondary_Stack
)
7338 and then (Restriction_Active
(No_Implicit_Heap_Allocations
)
7339 or else Restriction_Active
(No_Implicit_Task_Allocations
))
7340 and then not (Ekind
(Typ
) in E_Array_Type | E_Array_Subtype
7341 and then (Has_Init_Expression
(N
)))
7344 PS_Count
, SS_Count
: Int
:= 0;
7346 Count_Default_Sized_Task_Stacks
(Typ
, PS_Count
, SS_Count
);
7347 Increment_Primary_Stack_Count
(PS_Count
);
7348 Increment_Sec_Stack_Count
(SS_Count
);
7352 -- Default initialization required, and no expression present
7355 -- If we have a type with a variant part, the initialization proc
7356 -- will contain implicit tests of the discriminant values, which
7357 -- counts as a violation of the restriction No_Implicit_Conditionals.
7359 if Has_Variant_Part
(Typ
) then
7364 Check_Restriction
(Msg
, No_Implicit_Conditionals
, Obj_Def
);
7368 ("\initialization of variant record tests discriminants",
7375 -- For the default initialization case, if we have a private type
7376 -- with invariants, and invariant checks are enabled, then insert an
7377 -- invariant check after the object declaration. Note that it is OK
7378 -- to clobber the object with an invalid value since if the exception
7379 -- is raised, then the object will go out of scope. In the case where
7380 -- an array object is initialized with an aggregate, the expression
7381 -- is removed. Check flag Has_Init_Expression to avoid generating a
7382 -- junk invariant check and flag No_Initialization to avoid checking
7383 -- an uninitialized object such as a compiler temporary used for an
7386 if Has_Invariants
(Base_Typ
)
7387 and then Present
(Invariant_Procedure
(Base_Typ
))
7388 and then not Has_Init_Expression
(N
)
7389 and then not No_Initialization
(N
)
7391 -- If entity has an address clause or aspect, make invariant
7392 -- call into a freeze action for the explicit freeze node for
7393 -- object. Otherwise insert invariant check after declaration.
7395 if Present
(Following_Address_Clause
(N
))
7396 or else Has_Aspect
(Def_Id
, Aspect_Address
)
7398 Ensure_Freeze_Node
(Def_Id
);
7399 Set_Has_Delayed_Freeze
(Def_Id
);
7400 Set_Is_Frozen
(Def_Id
, False);
7402 if not Partial_View_Has_Unknown_Discr
(Typ
) then
7403 Append_Freeze_Action
(Def_Id
,
7404 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7407 elsif not Partial_View_Has_Unknown_Discr
(Typ
) then
7409 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7413 if not Special_Ret_Obj
then
7414 Default_Initialize_Object
(Init_After
);
7417 -- Generate attribute for Persistent_BSS if needed
7419 if Persistent_BSS_Mode
7420 and then Comes_From_Source
(N
)
7421 and then Is_Potentially_Persistent_Type
(Typ
)
7422 and then not Has_Init_Expression
(N
)
7423 and then Is_Library_Level_Entity
(Def_Id
)
7429 Make_Linker_Section_Pragma
7430 (Def_Id
, Sloc
(N
), ".persistent.bss");
7431 Insert_After
(N
, Prag
);
7436 -- If access type, then we know it is null if not initialized
7438 if Is_Access_Type
(Typ
) then
7439 Set_Is_Known_Null
(Def_Id
);
7442 -- Explicit initialization present
7445 -- Obtain actual expression from qualified expression
7447 Expr_Q
:= Unqualify
(Expr
);
7449 -- When we have the appropriate type of aggregate in the expression
7450 -- (it has been determined during analysis of the aggregate by
7451 -- setting the delay flag), let's perform in place assignment and
7452 -- thus avoid creating a temporary.
7454 if Is_Delayed_Aggregate
(Expr_Q
) then
7456 -- An aggregate that must be built in place is not resolved and
7457 -- expanded until the enclosing construct is expanded. This will
7458 -- happen when the aggregate is limited and the declared object
7459 -- has a following address clause; it happens also when generating
7460 -- C code for an aggregate that has an alignment or address clause
7461 -- (see Analyze_Object_Declaration). Resolution is done without
7462 -- expansion because it will take place when the declaration
7463 -- itself is expanded.
7465 if (Is_Limited_Type
(Typ
) or else Modify_Tree_For_C
)
7466 and then not Analyzed
(Expr
)
7468 Expander_Mode_Save_And_Set
(False);
7469 Resolve
(Expr
, Typ
);
7470 Expander_Mode_Restore
;
7473 if not Special_Ret_Obj
then
7474 Convert_Aggr_In_Object_Decl
(N
);
7477 -- Ada 2005 (AI-318-02): If the initialization expression is a call
7478 -- to a build-in-place function, then access to the declared object
7479 -- must be passed to the function. Currently we limit such functions
7480 -- to those with constrained limited result subtypes, but eventually
7481 -- plan to expand the allowed forms of functions that are treated as
7484 elsif Is_Build_In_Place_Function_Call
(Expr_Q
) then
7485 Make_Build_In_Place_Call_In_Object_Declaration
(N
, Expr_Q
);
7487 -- The previous call expands the expression initializing the
7488 -- built-in-place object into further code that will be analyzed
7489 -- later. No further expansion needed here.
7493 -- This is the same as the previous 'elsif', except that the call has
7494 -- been transformed by other expansion activities into something like
7495 -- F(...)'Reference.
7497 elsif Nkind
(Expr_Q
) = N_Reference
7498 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7499 and then not Is_Expanded_Build_In_Place_Call
7500 (Unqual_Conv
(Prefix
(Expr_Q
)))
7502 Make_Build_In_Place_Call_In_Anonymous_Context
(Prefix
(Expr_Q
));
7504 -- The previous call expands the expression initializing the
7505 -- built-in-place object into further code that will be analyzed
7506 -- later. No further expansion needed here.
7510 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7511 -- expressions containing a build-in-place function call whose
7512 -- returned object covers interface types, and Expr_Q has calls to
7513 -- Ada.Tags.Displace to displace the pointer to the returned build-
7514 -- in-place object to reference the secondary dispatch table of a
7515 -- covered interface type.
7517 elsif Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
)) then
7518 Make_Build_In_Place_Iface_Call_In_Object_Declaration
(N
, Expr_Q
);
7520 -- The previous call expands the expression initializing the
7521 -- built-in-place object into further code that will be analyzed
7522 -- later. No further expansion needed here.
7526 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7527 -- class-wide interface object to ensure that we copy the full
7528 -- object, unless we are targetting a VM where interfaces are handled
7529 -- by VM itself. Note that if the root type of Typ is an ancestor of
7530 -- Expr's type, both types share the same dispatch table and there is
7531 -- no need to displace the pointer.
7533 elsif Is_Interface
(Typ
)
7535 -- Avoid never-ending recursion because if Equivalent_Type is set
7536 -- then we've done it already and must not do it again.
7539 (Nkind
(Obj_Def
) = N_Identifier
7540 and then Present
(Equivalent_Type
(Entity
(Obj_Def
))))
7542 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7544 -- If the original node of the expression was a conversion
7545 -- to this specific class-wide interface type then restore
7546 -- the original node because we must copy the object before
7547 -- displacing the pointer to reference the secondary tag
7548 -- component. This code must be kept synchronized with the
7549 -- expansion done by routine Expand_Interface_Conversion
7551 if not Comes_From_Source
(Expr
)
7552 and then Nkind
(Expr
) = N_Explicit_Dereference
7553 and then Nkind
(Original_Node
(Expr
)) = N_Type_Conversion
7554 and then Etype
(Original_Node
(Expr
)) = Typ
7556 Rewrite
(Expr
, Original_Node
(Expression
(N
)));
7559 -- Avoid expansion of redundant interface conversion
7561 if Nkind
(Expr
) = N_Type_Conversion
7562 and then Etype
(Expr
) = Typ
7564 Expr_Q
:= Expression
(Expr
);
7569 -- We may use a renaming if the initialization expression is a
7570 -- captured function call that meets a few conditions.
7572 Rewrite_As_Renaming
:= Is_Renamable_Function_Call
(Expr_Q
);
7574 -- If the object is a special return object, then bypass special
7575 -- treatment of class-wide interface initialization below. In this
7576 -- case, the expansion of the return object will take care of this
7577 -- initialization via the expansion of the allocator.
7579 if Special_Ret_Obj
and then not Rewrite_As_Renaming
then
7581 -- If the type needs finalization and is not inherently
7582 -- limited, then the target is adjusted after the copy
7583 -- and attached to the finalization list.
7585 if Needs_Finalization
(Typ
)
7586 and then not Is_Limited_View
(Typ
)
7590 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
7594 -- Renaming an expression of the object's type is immediate
7596 elsif Rewrite_As_Renaming
7597 and then Base_Type
(Etype
(Expr_Q
)) = Base_Type
(Typ
)
7601 elsif Tagged_Type_Expansion
then
7603 Iface
: constant Entity_Id
:= Root_Type
(Typ
);
7605 Expr_Typ
: Entity_Id
;
7608 Ptr_Obj_Decl
: Node_Id
;
7609 Ptr_Obj_Id
: Entity_Id
;
7613 Expr_Typ
:= Base_Type
(Etype
(Expr_Q
));
7614 if Is_Class_Wide_Type
(Expr_Typ
) then
7615 Expr_Typ
:= Root_Type
(Expr_Typ
);
7618 -- Rename limited objects since they cannot be copied
7620 if Is_Limited_Record
(Expr_Typ
) then
7621 Rewrite_As_Renaming
:= True;
7624 Obj_Id
:= Make_Temporary
(Loc
, 'D', Expr_Q
);
7627 -- IW : I'Class := Expr;
7629 -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
7630 -- type Ityp is not null access I'Class;
7631 -- Rnn : constant Ityp :=
7632 -- Ityp!(Displace (Dnn'Address, I'Tag));
7633 -- IW : I'Class renames Rnn.all;
7635 if Rewrite_As_Renaming
then
7637 Make_Explicit_Dereference
(Loc
,
7638 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7639 Make_Attribute_Reference
(Loc
,
7640 Prefix
=> Relocate_Node
(Expr_Q
),
7641 Attribute_Name
=> Name_Address
)));
7643 -- Suppress junk access checks on RE_Tag_Ptr
7646 Make_Object_Renaming_Declaration
(Loc
,
7647 Defining_Identifier
=> Obj_Id
,
7649 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7651 Suppress
=> Access_Check
);
7653 -- Dynamically reference the tag associated with the
7657 Make_Function_Call
(Loc
,
7658 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
7659 Parameter_Associations
=> New_List
(
7660 Make_Attribute_Reference
(Loc
,
7661 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7662 Attribute_Name
=> Name_Address
),
7664 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
7668 -- IW : I'Class := Expr;
7670 -- Dnn : Typ := Expr;
7671 -- type Ityp is not null access I'Class;
7672 -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
7673 -- IW : I'Class renames Rnn.all;
7675 elsif Has_Tag_Of_Type
(Expr_Q
)
7676 and then Interface_Present_In_Ancestor
(Expr_Typ
, Typ
)
7677 and then (Expr_Typ
= Etype
(Expr_Typ
)
7679 Is_Variable_Size_Record
(Etype
(Expr_Typ
)))
7682 Make_Object_Declaration
(Loc
,
7683 Defining_Identifier
=> Obj_Id
,
7684 Object_Definition
=>
7685 New_Occurrence_Of
(Expr_Typ
, Loc
),
7686 Expression
=> Relocate_Node
(Expr_Q
)));
7688 -- Statically reference the tag associated with the
7692 Make_Selected_Component
(Loc
,
7693 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7696 (Find_Interface_Tag
(Expr_Typ
, Iface
), Loc
));
7699 -- IW : I'Class := Expr;
7701 -- type Equiv_Record is record ... end record;
7702 -- implicit subtype CW is <Class_Wide_Subtype>;
7703 -- Dnn : CW := CW!(Expr);
7704 -- type Ityp is not null access I'Class;
7705 -- Rnn : constant Ityp :=
7706 -- Ityp!(Displace (Dnn'Address, I'Tag));
7707 -- IW : I'Class renames Rnn.all;
7710 -- Generate the equivalent record type and update the
7711 -- subtype indication to reference it.
7713 Expand_Subtype_From_Expr
7716 Subtype_Indic
=> Obj_Def
,
7719 -- For interface types we use 'Address which displaces
7720 -- the pointer to the base of the object (if required).
7722 if Is_Interface
(Etype
(Expr_Q
)) then
7724 Unchecked_Convert_To
(Etype
(Obj_Def
),
7725 Make_Explicit_Dereference
(Loc
,
7726 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7727 Make_Attribute_Reference
(Loc
,
7728 Prefix
=> Relocate_Node
(Expr_Q
),
7729 Attribute_Name
=> Name_Address
))));
7731 -- For other types, no displacement is needed
7734 New_Expr
:= Relocate_Node
(Expr_Q
);
7737 -- Suppress junk access checks on RE_Tag_Ptr
7740 Make_Object_Declaration
(Loc
,
7741 Defining_Identifier
=> Obj_Id
,
7742 Object_Definition
=>
7743 New_Occurrence_Of
(Etype
(Obj_Def
), Loc
),
7744 Expression
=> New_Expr
),
7745 Suppress
=> Access_Check
);
7747 -- Dynamically reference the tag associated with the
7751 Make_Function_Call
(Loc
,
7752 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
7753 Parameter_Associations
=> New_List
(
7754 Make_Attribute_Reference
(Loc
,
7755 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7756 Attribute_Name
=> Name_Address
),
7758 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
7762 -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
7763 -- to do the final conversion, but we insert an intermediate
7764 -- temporary before the dereference so that we can process
7765 -- the expansion as part of the analysis of the declaration
7766 -- of this temporary, and then rewrite manually the original
7767 -- object as the simple renaming of this dereference.
7769 Tag_Comp
:= Convert_Tag_To_Interface
(Typ
, Tag_Comp
);
7770 pragma Assert
(Nkind
(Tag_Comp
) = N_Explicit_Dereference
7772 Nkind
(Prefix
(Tag_Comp
)) = N_Unchecked_Type_Conversion
);
7774 Ptr_Obj_Id
:= Make_Temporary
(Loc
, 'R');
7777 Make_Object_Declaration
(Loc
,
7778 Defining_Identifier
=> Ptr_Obj_Id
,
7779 Constant_Present
=> True,
7780 Object_Definition
=>
7782 (Entity
(Subtype_Mark
(Prefix
(Tag_Comp
))), Loc
),
7783 Expression
=> Prefix
(Tag_Comp
));
7785 Insert_Action
(N
, Ptr_Obj_Decl
, Suppress
=> All_Checks
);
7787 Set_Prefix
(Tag_Comp
, New_Occurrence_Of
(Ptr_Obj_Id
, Loc
));
7789 Set_Etype
(Expr_Q
, Typ
);
7790 Set_Parent
(Expr_Q
, N
);
7792 Rewrite_As_Renaming
:= True;
7799 -- Common case of explicit object initialization
7802 -- Small optimization: if the expression is a function call and
7803 -- the object is stand-alone, not declared at library level and of
7804 -- a class-wide type, then we capture the result of the call into
7805 -- a temporary, with the benefit that, if the result's type does
7806 -- not need finalization, nothing will be finalized and, if it
7807 -- does, the temporary only will be finalized by means of a direct
7808 -- call to the Finalize primitive if the result's type is not a
7809 -- class-wide type; whereas, in both cases, the stand-alone object
7810 -- itself would be finalized by means of a dispatching call to the
7811 -- Deep_Finalize routine.
7813 if Nkind
(Expr_Q
) = N_Function_Call
7814 and then not Special_Ret_Obj
7815 and then not Is_Library_Level_Entity
(Def_Id
)
7816 and then Is_Class_Wide_Type
(Typ
)
7818 Remove_Side_Effects
(Expr_Q
);
7821 -- In most cases, we must check that the initial value meets any
7822 -- constraint imposed by the declared type. However, there is one
7823 -- very important exception to this rule. If the entity has an
7824 -- unconstrained nominal subtype, then it acquired its constraints
7825 -- from the expression in the first place, and not only does this
7826 -- mean that the constraint check is not needed, but an attempt to
7827 -- perform the constraint check can cause order of elaboration
7830 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
7832 -- If this is an allocator for an aggregate that has been
7833 -- allocated in place, delay checks until assignments are
7834 -- made, because the discriminants are not initialized.
7836 if Nkind
(Expr
) = N_Allocator
7837 and then No_Initialization
(Expr
)
7841 -- Otherwise apply a constraint check now if no prev error
7843 elsif Nkind
(Expr
) /= N_Error
then
7844 Apply_Constraint_Check
(Expr
, Typ
);
7846 -- Deal with possible range check
7848 if Do_Range_Check
(Expr
) then
7850 -- If assignment checks are suppressed, turn off flag
7852 if Suppress_Assignment_Checks
(N
) then
7853 Set_Do_Range_Check
(Expr
, False);
7855 -- Otherwise generate the range check
7858 Generate_Range_Check
7859 (Expr
, Typ
, CE_Range_Check_Failed
);
7865 -- For tagged types, when an init value is given, the tag has to
7866 -- be re-initialized separately in order to avoid the propagation
7867 -- of a wrong tag coming from a view conversion unless the type
7868 -- is class wide (in this case the tag comes from the init value).
7869 -- Suppress the tag assignment when not Tagged_Type_Expansion
7870 -- because tags are represented implicitly in objects. Ditto for
7871 -- types that are CPP_CLASS, and for initializations that are
7872 -- aggregates, because they have to have the right tag.
7874 -- The re-assignment of the tag has to be done even if the object
7875 -- is a constant. The assignment must be analyzed after the
7876 -- declaration. If an address clause follows, this is handled as
7877 -- part of the freeze actions for the object, otherwise insert
7878 -- tag assignment here.
7880 Tag_Assign
:= Make_Tag_Assignment
(N
);
7882 if Present
(Tag_Assign
) then
7883 if Present
(Following_Address_Clause
(N
)) then
7884 Ensure_Freeze_Node
(Def_Id
);
7885 elsif not Special_Ret_Obj
then
7886 Insert_Action_After
(Init_After
, Tag_Assign
);
7889 -- Handle C++ constructor calls. Note that we do not check that
7890 -- Typ is a tagged type since the equivalent Ada type of a C++
7891 -- class that has no virtual methods is an untagged limited
7894 elsif Is_CPP_Constructor_Call
(Expr
) then
7896 Id_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
7899 -- The call to the initialization procedure does NOT freeze
7900 -- the object being initialized.
7902 Set_Must_Not_Freeze
(Id_Ref
);
7903 Set_Assignment_OK
(Id_Ref
);
7905 Insert_Actions_After
(Init_After
,
7906 Build_Initialization_Call
(Loc
, Id_Ref
, Typ
,
7907 Constructor_Ref
=> Expr
));
7909 -- We remove here the original call to the constructor
7910 -- to avoid its management in the backend
7912 Set_Expression
(N
, Empty
);
7916 -- Handle initialization of limited tagged types
7918 elsif Is_Tagged_Type
(Typ
)
7919 and then Is_Class_Wide_Type
(Typ
)
7920 and then Is_Limited_Record
(Typ
)
7921 and then not Is_Limited_Interface
(Typ
)
7923 -- Given that the type is limited we cannot perform a copy. If
7924 -- Expr_Q is the reference to a variable we mark the variable
7925 -- as OK_To_Rename to expand this declaration into a renaming
7926 -- declaration (see below).
7928 if Is_Entity_Name
(Expr_Q
) then
7929 Set_OK_To_Rename
(Entity
(Expr_Q
));
7931 -- If we cannot convert the expression into a renaming we must
7932 -- consider it an internal error because the backend does not
7933 -- have support to handle it. But avoid crashing on a raise
7934 -- expression or conditional expression.
7936 elsif Nkind
(Original_Node
(Expr_Q
)) not in
7937 N_Raise_Expression | N_If_Expression | N_Case_Expression
7939 raise Program_Error
;
7942 -- For discrete types, set the Is_Known_Valid flag if the
7943 -- initializing value is known to be valid. Only do this for
7944 -- source assignments, since otherwise we can end up turning
7945 -- on the known valid flag prematurely from inserted code.
7947 elsif Comes_From_Source
(N
)
7948 and then Is_Discrete_Type
(Typ
)
7949 and then Expr_Known_Valid
(Expr
)
7950 and then Safe_To_Capture_Value
(N
, Def_Id
)
7952 Set_Is_Known_Valid
(Def_Id
);
7954 -- For access types, set the Is_Known_Non_Null flag if the
7955 -- initializing value is known to be non-null. We can also
7956 -- set Can_Never_Be_Null if this is a constant.
7958 elsif Is_Access_Type
(Typ
) and then Known_Non_Null
(Expr
) then
7959 Set_Is_Known_Non_Null
(Def_Id
, True);
7961 if Constant_Present
(N
) then
7962 Set_Can_Never_Be_Null
(Def_Id
);
7966 -- If validity checking on copies, validate initial expression.
7967 -- But skip this if declaration is for a generic type, since it
7968 -- makes no sense to validate generic types. Not clear if this
7969 -- can happen for legal programs, but it definitely can arise
7970 -- from previous instantiation errors.
7972 if Validity_Checks_On
7973 and then Comes_From_Source
(N
)
7974 and then Validity_Check_Copies
7975 and then not Is_Generic_Type
(Typ
)
7977 Ensure_Valid
(Expr
);
7979 if Safe_To_Capture_Value
(N
, Def_Id
) then
7980 Set_Is_Known_Valid
(Def_Id
);
7984 -- Now determine whether we will use a renaming
7986 Rewrite_As_Renaming
:=
7988 -- The declaration cannot be rewritten if it has got constraints
7990 Is_Entity_Name
(Original_Node
(Obj_Def
))
7992 -- Nor if it is effectively an unconstrained declaration
7994 and then not (Is_Array_Type
(Typ
)
7995 and then Is_Constr_Subt_For_UN_Aliased
(Typ
))
7997 -- We may use a renaming if the initialization expression is a
7998 -- captured function call that meets a few conditions.
8001 (Is_Renamable_Function_Call
(Expr_Q
)
8003 -- Or else if it is a variable with OK_To_Rename set
8005 or else (OK_To_Rename_Ref
(Expr_Q
)
8006 and then not Special_Ret_Obj
)
8008 -- Or else if it is a slice of such a variable
8010 or else (Nkind
(Expr_Q
) = N_Slice
8011 and then OK_To_Rename_Ref
(Prefix
(Expr_Q
))
8012 and then not Special_Ret_Obj
));
8014 -- If the type needs finalization and is not inherently limited,
8015 -- then the target is adjusted after the copy and attached to the
8016 -- finalization list. However, no adjustment is needed in the case
8017 -- where the object has been initialized by a call to a function
8018 -- returning on the primary stack (see Expand_Ctrl_Function_Call)
8019 -- since no copy occurred, given that the type is by-reference.
8020 -- Similarly, no adjustment is needed if we are going to rewrite
8021 -- the object declaration into a renaming declaration.
8023 if Needs_Finalization
(Typ
)
8024 and then not Is_Limited_View
(Typ
)
8025 and then Nkind
(Expr_Q
) /= N_Function_Call
8026 and then not Rewrite_As_Renaming
8030 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
8033 if Present
(Adj_Call
) and then not Special_Ret_Obj
then
8034 Insert_Action_After
(Init_After
, Adj_Call
);
8039 -- Cases where the back end cannot handle the initialization
8040 -- directly. In such cases, we expand an assignment that will
8041 -- be appropriately handled by Expand_N_Assignment_Statement.
8043 -- The exclusion of the unconstrained case is wrong, but for now it
8044 -- is too much trouble ???
8046 if (Is_Possibly_Unaligned_Slice
(Expr
)
8047 or else (Is_Possibly_Unaligned_Object
(Expr
)
8048 and then not Represented_As_Scalar
(Etype
(Expr
))))
8049 and then not (Is_Array_Type
(Etype
(Expr
))
8050 and then not Is_Constrained
(Etype
(Expr
)))
8053 Stat
: constant Node_Id
:=
8054 Make_Assignment_Statement
(Loc
,
8055 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8056 Expression
=> Relocate_Node
(Expr
));
8058 Set_Assignment_OK
(Name
(Stat
));
8059 Set_No_Ctrl_Actions
(Stat
);
8060 Insert_Action_After
(Init_After
, Stat
);
8061 Set_Expression
(N
, Empty
);
8062 Set_No_Initialization
(N
);
8067 if Nkind
(Obj_Def
) = N_Access_Definition
8068 and then not Is_Local_Anonymous_Access
(Typ
)
8070 -- An Ada 2012 stand-alone object of an anonymous access type
8073 Loc
: constant Source_Ptr
:= Sloc
(N
);
8075 Level
: constant Entity_Id
:=
8076 Make_Defining_Identifier
(Sloc
(N
),
8078 New_External_Name
(Chars
(Def_Id
), Suffix
=> "L"));
8080 Level_Decl
: Node_Id
;
8081 Level_Expr
: Node_Id
;
8084 Mutate_Ekind
(Level
, Ekind
(Def_Id
));
8085 Set_Etype
(Level
, Standard_Natural
);
8086 Set_Scope
(Level
, Scope
(Def_Id
));
8088 -- Set accessibility level of null
8092 Make_Integer_Literal
8093 (Loc
, Scope_Depth
(Standard_Standard
));
8095 -- When the expression of the object is a function which returns
8096 -- an anonymous access type the master of the call is the object
8097 -- being initialized instead of the type.
8099 elsif Nkind
(Expr
) = N_Function_Call
8100 and then Ekind
(Etype
(Name
(Expr
))) = E_Anonymous_Access_Type
8102 Level_Expr
:= Accessibility_Level
8103 (Def_Id
, Object_Decl_Level
);
8108 Level_Expr
:= Accessibility_Level
(Expr
, Dynamic_Level
);
8112 Make_Object_Declaration
(Loc
,
8113 Defining_Identifier
=> Level
,
8114 Object_Definition
=>
8115 New_Occurrence_Of
(Standard_Natural
, Loc
),
8116 Expression
=> Level_Expr
,
8117 Constant_Present
=> Constant_Present
(N
),
8118 Has_Init_Expression
=> True);
8120 Insert_Action_After
(Init_After
, Level_Decl
);
8122 Set_Extra_Accessibility
(Def_Id
, Level
);
8126 -- If the object is default initialized and its type is subject to
8127 -- pragma Default_Initial_Condition, add a runtime check to verify
8128 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
8130 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
8132 -- Note that the check is generated for source objects only
8134 if Comes_From_Source
(Def_Id
)
8135 and then Has_DIC
(Typ
)
8136 and then Present
(DIC_Procedure
(Typ
))
8137 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
8138 and then not Has_Init_Expression
(N
)
8140 and then not Is_Imported
(Def_Id
)
8143 DIC_Call
: constant Node_Id
:=
8145 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Typ
);
8147 if Present
(Next_N
) then
8148 Insert_Before_And_Analyze
(Next_N
, DIC_Call
);
8150 -- The object declaration is the last node in a declarative or a
8154 Append_To
(List_Containing
(N
), DIC_Call
);
8160 -- If this is the return object of a build-in-place function, locate the
8161 -- implicit BIPaccess parameter designating the caller-supplied return
8162 -- object and convert the declaration to a renaming of a dereference of
8163 -- this parameter. If the declaration includes an expression, add an
8164 -- assignment statement to ensure the return object gets initialized.
8166 -- Result : T [:= <expression>];
8170 -- Result : T renames BIPaccess.all;
8171 -- [Result := <expression>;]
8173 -- in the constrained case, or to
8175 -- type Txx is access all ...;
8176 -- Rxx : Txx := null;
8178 -- if BIPalloc = 1 then
8179 -- Rxx := BIPaccess;
8180 -- Rxx.all := <expression>;
8181 -- elsif BIPalloc = 2 then
8182 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8183 -- system__secondary_stack__ss_pool][procedure_to_call =
8184 -- system__secondary_stack__ss_allocate];
8185 -- elsif BIPalloc = 3 then
8186 -- Rxx := new <expression-type>'(<expression>)
8187 -- elsif BIPalloc = 4 then
8188 -- Pxx : system__storage_pools__root_storage_pool renames
8189 -- BIPstoragepool.all;
8190 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8191 -- Pxx][procedure_to_call =
8192 -- system__storage_pools__allocate_any];
8194 -- [program_error "build in place mismatch"]
8197 -- Result : T renames Rxx.all;
8199 -- in the unconstrained case.
8201 if Is_Build_In_Place_Return_Object
(Def_Id
) then
8203 Init_Stmt
: Node_Id
;
8204 Obj_Acc_Formal
: Entity_Id
;
8207 -- Retrieve the implicit access parameter passed by the caller
8210 Build_In_Place_Formal
(Func_Id
, BIP_Object_Access
);
8212 -- If the return object's declaration includes an expression
8213 -- and the declaration isn't marked as No_Initialization, then
8214 -- we need to generate an assignment to the object and insert
8215 -- it after the declaration before rewriting it as a renaming
8216 -- (otherwise we'll lose the initialization). The case where
8217 -- the result type is an interface (or class-wide interface)
8218 -- is also excluded because the context of the function call
8219 -- must be unconstrained, so the initialization will always
8220 -- be done as part of an allocator evaluation (storage pool
8221 -- or secondary stack), never to a constrained target object
8222 -- passed in by the caller. Besides the assignment being
8223 -- unneeded in this case, it avoids problems with trying to
8224 -- generate a dispatching assignment when the return expression
8225 -- is a nonlimited descendant of a limited interface (the
8226 -- interface has no assignment operation).
8229 and then not Is_Delayed_Aggregate
(Expr_Q
)
8230 and then not No_Initialization
(N
)
8231 and then not Is_Interface
(Typ
)
8233 if Is_Class_Wide_Type
(Typ
)
8234 and then not Is_Class_Wide_Type
(Etype
(Expr_Q
))
8237 Make_Assignment_Statement
(Loc
,
8238 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8240 Make_Type_Conversion
(Loc
,
8242 New_Occurrence_Of
(Typ
, Loc
),
8243 Expression
=> New_Copy_Tree
(Expr_Q
)));
8247 Make_Assignment_Statement
(Loc
,
8248 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8249 Expression
=> New_Copy_Tree
(Expr_Q
));
8252 Set_Assignment_OK
(Name
(Init_Stmt
));
8253 Set_No_Ctrl_Actions
(Init_Stmt
);
8259 -- When the function's subtype is unconstrained, a run-time
8260 -- test may be needed to decide the form of allocation to use
8261 -- for the return object. The function has an implicit formal
8262 -- parameter indicating this. If the BIP_Alloc_Form formal has
8263 -- the value one, then the caller has passed access to an
8264 -- existing object for use as the return object. If the value
8265 -- is two, then the return object must be allocated on the
8266 -- secondary stack. If the value is three, then the return
8267 -- object must be allocated on the heap. Otherwise, the object
8268 -- must be allocated in a storage pool. We generate an if
8269 -- statement to test the BIP_Alloc_Form formal and initialize
8270 -- a local access value appropriately.
8272 if Needs_BIP_Alloc_Form
(Func_Id
) then
8274 Desig_Typ
: constant Entity_Id
:=
8275 (if Ekind
(Typ
) = E_Array_Subtype
8276 then Etype
(Func_Id
) else Typ
);
8277 -- Ensure that the we use a fat pointer when allocating
8278 -- an unconstrained array on the heap. In this case the
8279 -- result object's type is a constrained array type even
8280 -- though the function's type is unconstrained.
8282 Obj_Alloc_Formal
: constant Entity_Id
:=
8283 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
8284 Pool_Id
: constant Entity_Id
:=
8285 Make_Temporary
(Loc
, 'P');
8287 Acc_Typ
: Entity_Id
;
8288 Alloc_Obj_Decl
: Node_Id
;
8289 Alloc_Obj_Id
: Entity_Id
;
8290 Alloc_Stmt
: Node_Id
;
8291 Guard_Except
: Node_Id
;
8292 Heap_Allocator
: Node_Id
;
8293 Pool_Allocator
: Node_Id
;
8294 Pool_Decl
: Node_Id
;
8295 Ptr_Typ_Decl
: Node_Id
;
8296 SS_Allocator
: Node_Id
;
8299 -- Create an access type designating the function's
8302 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8305 Make_Full_Type_Declaration
(Loc
,
8306 Defining_Identifier
=> Acc_Typ
,
8308 Make_Access_To_Object_Definition
(Loc
,
8309 All_Present
=> True,
8310 Subtype_Indication
=>
8311 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8313 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8315 -- Create an access object that will be initialized to an
8316 -- access value denoting the return object, either coming
8317 -- from an implicit access value passed in by the caller
8318 -- or from the result of an allocator.
8320 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8323 Make_Object_Declaration
(Loc
,
8324 Defining_Identifier
=> Alloc_Obj_Id
,
8325 Object_Definition
=>
8326 New_Occurrence_Of
(Acc_Typ
, Loc
));
8328 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8330 -- First create the Heap_Allocator
8332 Heap_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8334 -- The Pool_Allocator is just like the Heap_Allocator,
8335 -- except we set Storage_Pool and Procedure_To_Call so
8336 -- it will use the user-defined storage pool.
8338 Pool_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8340 -- Do not generate the renaming of the build-in-place
8341 -- pool parameter on ZFP because the parameter is not
8342 -- created in the first place.
8344 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
8346 Make_Object_Renaming_Declaration
(Loc
,
8347 Defining_Identifier
=> Pool_Id
,
8350 (RTE
(RE_Root_Storage_Pool
), Loc
),
8352 Make_Explicit_Dereference
(Loc
,
8354 (Build_In_Place_Formal
8355 (Func_Id
, BIP_Storage_Pool
), Loc
)));
8356 Set_Storage_Pool
(Pool_Allocator
, Pool_Id
);
8357 Set_Procedure_To_Call
8358 (Pool_Allocator
, RTE
(RE_Allocate_Any
));
8360 Pool_Decl
:= Make_Null_Statement
(Loc
);
8363 -- If the No_Allocators restriction is active, then only
8364 -- an allocator for secondary stack allocation is needed.
8365 -- It's OK for such allocators to have Comes_From_Source
8366 -- set to False, because gigi knows not to flag them as
8367 -- being a violation of No_Implicit_Heap_Allocations.
8369 if Restriction_Active
(No_Allocators
) then
8370 SS_Allocator
:= Heap_Allocator
;
8371 Heap_Allocator
:= Make_Null
(Loc
);
8372 Pool_Allocator
:= Make_Null
(Loc
);
8374 -- Otherwise the heap and pool allocators may be needed,
8375 -- so we make another allocator for secondary stack
8379 SS_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8381 -- The heap and pool allocators are marked as
8382 -- Comes_From_Source since they correspond to an
8383 -- explicit user-written allocator (that is, it will
8384 -- only be executed on behalf of callers that call the
8385 -- function as initialization for such an allocator).
8386 -- Prevents errors when No_Implicit_Heap_Allocations
8389 Set_Comes_From_Source
(Heap_Allocator
, True);
8390 Set_Comes_From_Source
(Pool_Allocator
, True);
8393 -- The allocator is returned on the secondary stack
8395 Check_Restriction
(No_Secondary_Stack
, N
);
8396 Set_Storage_Pool
(SS_Allocator
, RTE
(RE_SS_Pool
));
8397 Set_Procedure_To_Call
8398 (SS_Allocator
, RTE
(RE_SS_Allocate
));
8400 -- The allocator is returned on the secondary stack,
8401 -- so indicate that the function return, as well as
8402 -- all blocks that encloses the allocator, must not
8403 -- release it. The flags must be set now because
8404 -- the decision to use the secondary stack is done
8405 -- very late in the course of expanding the return
8406 -- statement, past the point where these flags are
8409 Set_Uses_Sec_Stack
(Func_Id
);
8410 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8411 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8413 -- Guard against poor expansion on the caller side by
8414 -- using a raise statement to catch out-of-range values
8415 -- of formal parameter BIP_Alloc_Form.
8417 if Exceptions_OK
then
8419 Make_Raise_Program_Error
(Loc
,
8420 Reason
=> PE_Build_In_Place_Mismatch
);
8422 Guard_Except
:= Make_Null_Statement
(Loc
);
8425 -- Create an if statement to test the BIP_Alloc_Form
8426 -- formal and initialize the access object to either the
8427 -- BIP_Object_Access formal (BIP_Alloc_Form =
8428 -- Caller_Allocation), the result of allocating the
8429 -- object in the secondary stack (BIP_Alloc_Form =
8430 -- Secondary_Stack), or else an allocator to create the
8431 -- return object in the heap or user-defined pool
8432 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
8434 -- ??? An unchecked type conversion must be made in the
8435 -- case of assigning the access object formal to the
8436 -- local access object, because a normal conversion would
8437 -- be illegal in some cases (such as converting access-
8438 -- to-unconstrained to access-to-constrained), but the
8439 -- the unchecked conversion will presumably fail to work
8440 -- right in just such cases. It's not clear at all how to
8444 Make_If_Statement
(Loc
,
8448 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8450 Make_Integer_Literal
(Loc
,
8451 UI_From_Int
(BIP_Allocation_Form
'Pos
8452 (Caller_Allocation
)))),
8454 Then_Statements
=> New_List
(
8455 Make_Assignment_Statement
(Loc
,
8457 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8459 Unchecked_Convert_To
8461 New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)))),
8463 Elsif_Parts
=> New_List
(
8464 Make_Elsif_Part
(Loc
,
8468 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8470 Make_Integer_Literal
(Loc
,
8471 UI_From_Int
(BIP_Allocation_Form
'Pos
8472 (Secondary_Stack
)))),
8474 Then_Statements
=> New_List
(
8475 Make_Assignment_Statement
(Loc
,
8477 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8478 Expression
=> SS_Allocator
))),
8480 Make_Elsif_Part
(Loc
,
8484 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8486 Make_Integer_Literal
(Loc
,
8487 UI_From_Int
(BIP_Allocation_Form
'Pos
8490 Then_Statements
=> New_List
(
8491 Build_Heap_Or_Pool_Allocator
8492 (Temp_Id
=> Alloc_Obj_Id
,
8493 Temp_Typ
=> Acc_Typ
,
8494 Ret_Typ
=> Desig_Typ
,
8495 Alloc_Expr
=> Heap_Allocator
))),
8497 -- ??? If all is well, we can put the following
8498 -- 'elsif' in the 'else', but this is a useful
8499 -- self-check in case caller and callee don't agree
8500 -- on whether BIPAlloc and so on should be passed.
8502 Make_Elsif_Part
(Loc
,
8506 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8508 Make_Integer_Literal
(Loc
,
8509 UI_From_Int
(BIP_Allocation_Form
'Pos
8510 (User_Storage_Pool
)))),
8512 Then_Statements
=> New_List
(
8514 Build_Heap_Or_Pool_Allocator
8515 (Temp_Id
=> Alloc_Obj_Id
,
8516 Temp_Typ
=> Acc_Typ
,
8517 Ret_Typ
=> Desig_Typ
,
8518 Alloc_Expr
=> Pool_Allocator
)))),
8520 -- Raise Program_Error if it's none of the above;
8521 -- this is a compiler bug.
8523 Else_Statements
=> New_List
(Guard_Except
));
8525 -- If a separate initialization assignment was created
8526 -- earlier, append that following the assignment of the
8527 -- implicit access formal to the access object, to ensure
8528 -- that the return object is initialized in that case. In
8529 -- this situation, the target of the assignment must be
8530 -- rewritten to denote a dereference of the access to the
8531 -- return object passed in by the caller.
8533 if Present
(Init_Stmt
) then
8534 Set_Name
(Init_Stmt
,
8535 Make_Explicit_Dereference
(Loc
,
8536 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
)));
8537 Set_Assignment_OK
(Name
(Init_Stmt
));
8539 Append_To
(Then_Statements
(Alloc_Stmt
), Init_Stmt
);
8543 Insert_Action
(N
, Alloc_Stmt
, Suppress
=> All_Checks
);
8545 -- From now on, the type of the return object is the
8548 if Desig_Typ
/= Typ
then
8549 Set_Etype
(Def_Id
, Desig_Typ
);
8550 Set_Actual_Subtype
(Def_Id
, Typ
);
8553 -- Remember the local access object for use in the
8554 -- dereference of the renaming created below.
8556 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8559 -- When the function's type is unconstrained and a run-time test
8560 -- is not needed, we nevertheless need to build the return using
8561 -- the return object's type.
8563 elsif not Is_Constrained
(Underlying_Type
(Etype
(Func_Id
))) then
8565 Acc_Typ
: Entity_Id
;
8566 Alloc_Obj_Decl
: Node_Id
;
8567 Alloc_Obj_Id
: Entity_Id
;
8568 Ptr_Typ_Decl
: Node_Id
;
8571 -- Create an access type designating the function's
8574 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8577 Make_Full_Type_Declaration
(Loc
,
8578 Defining_Identifier
=> Acc_Typ
,
8580 Make_Access_To_Object_Definition
(Loc
,
8581 All_Present
=> True,
8582 Subtype_Indication
=>
8583 New_Occurrence_Of
(Typ
, Loc
)));
8585 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8587 -- Create an access object initialized to the conversion
8588 -- of the implicit access value passed in by the caller.
8590 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8592 -- See the ??? comment a few lines above about the use of
8593 -- an unchecked conversion here.
8596 Make_Object_Declaration
(Loc
,
8597 Defining_Identifier
=> Alloc_Obj_Id
,
8598 Constant_Present
=> True,
8599 Object_Definition
=>
8600 New_Occurrence_Of
(Acc_Typ
, Loc
),
8602 Unchecked_Convert_To
8603 (Acc_Typ
, New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)));
8605 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8607 -- Remember the local access object for use in the
8608 -- dereference of the renaming created below.
8610 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8614 -- Initialize the object now that it has got its final subtype,
8615 -- but before rewriting it as a renaming.
8617 Initialize_Return_Object
8618 (Tag_Assign
, Adj_Call
, Expr_Q
, Init_Stmt
, Init_After
);
8620 -- Replace the return object declaration with a renaming of a
8621 -- dereference of the access value designating the return object.
8624 Make_Explicit_Dereference
(Loc
,
8625 Prefix
=> New_Occurrence_Of
(Obj_Acc_Formal
, Loc
));
8626 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8628 Rewrite_As_Renaming
:= True;
8631 -- If we can rename the initialization expression, we need to make sure
8632 -- that we use the proper type in the case of a return object that lives
8633 -- on the secondary stack (see other cases below for a similar handling)
8634 -- and that the tag is assigned in the case of any return object.
8636 elsif Rewrite_As_Renaming
then
8637 if Special_Ret_Obj
then
8639 Desig_Typ
: constant Entity_Id
:=
8640 (if Ekind
(Typ
) = E_Array_Subtype
8641 then Etype
(Func_Id
) else Typ
);
8644 -- From now on, the type of the return object is the
8647 if Desig_Typ
/= Typ
then
8648 Set_Etype
(Def_Id
, Desig_Typ
);
8649 Set_Actual_Subtype
(Def_Id
, Typ
);
8652 if Present
(Tag_Assign
) then
8653 Insert_Action_After
(Init_After
, Tag_Assign
);
8656 -- Ada 2005 (AI95-344): If the result type is class-wide,
8657 -- insert a check that the level of the return expression's
8658 -- underlying type is not deeper than the level of the master
8659 -- enclosing the function.
8661 -- AI12-043: The check is made immediately after the return
8662 -- object is created.
8664 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
8665 Apply_CW_Accessibility_Check
(Expr_Q
, Func_Id
);
8670 -- If this is the return object of a function returning on the secondary
8671 -- stack, convert the declaration to a renaming of the dereference of ah
8672 -- allocator for the secondary stack.
8674 -- Result : T [:= <expression>];
8678 -- type Txx is access all ...;
8679 -- Rxx : constant Txx :=
8680 -- new <expression-type>['(<expression>)][storage_pool =
8681 -- system__secondary_stack__ss_pool][procedure_to_call =
8682 -- system__secondary_stack__ss_allocate];
8684 -- Result : T renames Rxx.all;
8686 elsif Is_Secondary_Stack_Return_Object
(Def_Id
) then
8688 Desig_Typ
: constant Entity_Id
:=
8689 (if Ekind
(Typ
) = E_Array_Subtype
8690 then Etype
(Func_Id
) else Typ
);
8691 -- Ensure that the we use a fat pointer when allocating
8692 -- an unconstrained array on the heap. In this case the
8693 -- result object's type is a constrained array type even
8694 -- though the function's type is unconstrained.
8696 Acc_Typ
: Entity_Id
;
8697 Alloc_Obj_Decl
: Node_Id
;
8698 Alloc_Obj_Id
: Entity_Id
;
8699 Ptr_Type_Decl
: Node_Id
;
8702 -- Create an access type designating the function's
8705 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8708 Make_Full_Type_Declaration
(Loc
,
8709 Defining_Identifier
=> Acc_Typ
,
8711 Make_Access_To_Object_Definition
(Loc
,
8712 All_Present
=> True,
8713 Subtype_Indication
=>
8714 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8716 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
8718 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
8720 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8723 Make_Object_Declaration
(Loc
,
8724 Defining_Identifier
=> Alloc_Obj_Id
,
8725 Constant_Present
=> True,
8726 Object_Definition
=>
8727 New_Occurrence_Of
(Acc_Typ
, Loc
),
8728 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
8730 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8732 Set_Uses_Sec_Stack
(Func_Id
);
8733 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8734 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8736 -- From now on, the type of the return object is the
8739 if Desig_Typ
/= Typ
then
8740 Set_Etype
(Def_Id
, Desig_Typ
);
8741 Set_Actual_Subtype
(Def_Id
, Typ
);
8744 -- Initialize the object now that it has got its final subtype,
8745 -- but before rewriting it as a renaming.
8747 Initialize_Return_Object
8748 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
8750 -- Replace the return object declaration with a renaming of a
8751 -- dereference of the access value designating the return object.
8754 Make_Explicit_Dereference
(Loc
,
8755 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
8756 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8758 Rewrite_As_Renaming
:= True;
8761 -- If this is the return object of a function returning a by-reference
8762 -- type, convert the declaration to a renaming of the dereference of ah
8763 -- allocator for the return stack.
8765 -- Result : T [:= <expression>];
8769 -- type Txx is access all ...;
8770 -- Rxx : constant Txx :=
8771 -- new <expression-type>['(<expression>)][storage_pool =
8772 -- system__return_stack__rs_pool][procedure_to_call =
8773 -- system__return_stack__rs_allocate];
8775 -- Result : T renames Rxx.all;
8777 elsif Back_End_Return_Slot
8778 and then Is_By_Reference_Return_Object
(Def_Id
)
8781 Acc_Typ
: Entity_Id
;
8782 Alloc_Obj_Decl
: Node_Id
;
8783 Alloc_Obj_Id
: Entity_Id
;
8784 Ptr_Type_Decl
: Node_Id
;
8787 -- Create an access type designating the function's
8790 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8793 Make_Full_Type_Declaration
(Loc
,
8794 Defining_Identifier
=> Acc_Typ
,
8796 Make_Access_To_Object_Definition
(Loc
,
8797 All_Present
=> True,
8798 Subtype_Indication
=>
8799 New_Occurrence_Of
(Typ
, Loc
)));
8801 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
8803 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_RS_Pool
));
8805 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8808 Make_Object_Declaration
(Loc
,
8809 Defining_Identifier
=> Alloc_Obj_Id
,
8810 Constant_Present
=> True,
8811 Object_Definition
=>
8812 New_Occurrence_Of
(Acc_Typ
, Loc
),
8813 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
8815 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8817 -- Initialize the object now that it has got its final subtype,
8818 -- but before rewriting it as a renaming.
8820 Initialize_Return_Object
8821 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
8823 -- Replace the return object declaration with a renaming of a
8824 -- dereference of the access value designating the return object.
8827 Make_Explicit_Dereference
(Loc
,
8828 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
8829 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8831 Rewrite_As_Renaming
:= True;
8835 -- Final transformation - turn the object declaration into a renaming
8836 -- if appropriate. If this is the completion of a deferred constant
8837 -- declaration, then this transformation generates what would be
8838 -- illegal code if written by hand, but that's OK.
8840 if Rewrite_As_Renaming
then
8842 Make_Object_Renaming_Declaration
(Loc
,
8843 Defining_Identifier
=> Def_Id
,
8844 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Def_Id
), Loc
),
8847 -- We do not analyze this renaming declaration, because all its
8848 -- components have already been analyzed, and if we were to go
8849 -- ahead and analyze it, we would in effect be trying to generate
8850 -- another declaration of X, which won't do.
8852 Set_Renamed_Object
(Def_Id
, Expr_Q
);
8855 -- We do need to deal with debug issues for this renaming
8857 -- First, if entity comes from source, then mark it as needing
8858 -- debug information, even though it is defined by a generated
8859 -- renaming that does not come from source.
8861 Set_Debug_Info_Defining_Id
(N
);
8863 -- Now call the routine to generate debug info for the renaming
8865 Insert_Action
(N
, Debug_Renaming_Declaration
(N
));
8868 -- Exception on library entity not available
8871 when RE_Not_Available
=>
8873 end Expand_N_Object_Declaration
;
8875 ---------------------------------
8876 -- Expand_N_Subtype_Indication --
8877 ---------------------------------
8879 -- Add a check on the range of the subtype and deal with validity checking
8881 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
8882 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
8883 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
8886 if Nkind
(Constraint
(N
)) = N_Range_Constraint
then
8887 Validity_Check_Range
(Range_Expression
(Constraint
(N
)));
8890 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
8892 if Nkind
(Parent
(N
)) in N_Constrained_Array_Definition | N_Slice
8893 and then Nkind
(Parent
(Parent
(N
))) not in
8894 N_Full_Type_Declaration | N_Object_Declaration
8896 Apply_Range_Check
(Ran
, Typ
);
8898 end Expand_N_Subtype_Indication
;
8900 ---------------------------
8901 -- Expand_N_Variant_Part --
8902 ---------------------------
8904 -- Note: this procedure no longer has any effect. It used to be that we
8905 -- would replace the choices in the last variant by a when others, and
8906 -- also expanded static predicates in variant choices here, but both of
8907 -- those activities were being done too early, since we can't check the
8908 -- choices until the statically predicated subtypes are frozen, which can
8909 -- happen as late as the free point of the record, and we can't change the
8910 -- last choice to an others before checking the choices, which is now done
8911 -- at the freeze point of the record.
8913 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
8916 end Expand_N_Variant_Part
;
8918 ---------------------------------
8919 -- Expand_Previous_Access_Type --
8920 ---------------------------------
8922 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
8923 Ptr_Typ
: Entity_Id
;
8926 -- Find all access types in the current scope whose designated type is
8927 -- Def_Id and build master renamings for them.
8929 Ptr_Typ
:= First_Entity
(Current_Scope
);
8930 while Present
(Ptr_Typ
) loop
8931 if Is_Access_Type
(Ptr_Typ
)
8932 and then Designated_Type
(Ptr_Typ
) = Def_Id
8933 and then No
(Master_Id
(Ptr_Typ
))
8935 -- Ensure that the designated type has a master
8937 Build_Master_Entity
(Def_Id
);
8939 -- Private and incomplete types complicate the insertion of master
8940 -- renamings because the access type may precede the full view of
8941 -- the designated type. For this reason, the master renamings are
8942 -- inserted relative to the designated type.
8944 Build_Master_Renaming
(Ptr_Typ
, Ins_Nod
=> Parent
(Def_Id
));
8947 Next_Entity
(Ptr_Typ
);
8949 end Expand_Previous_Access_Type
;
8951 -----------------------------
8952 -- Expand_Record_Extension --
8953 -----------------------------
8955 -- Add a field _parent at the beginning of the record extension. This is
8956 -- used to implement inheritance. Here are some examples of expansion:
8958 -- 1. no discriminants
8959 -- type T2 is new T1 with null record;
8961 -- type T2 is new T1 with record
8965 -- 2. renamed discriminants
8966 -- type T2 (B, C : Int) is new T1 (A => B) with record
8967 -- _Parent : T1 (A => B);
8971 -- 3. inherited discriminants
8972 -- type T2 is new T1 with record -- discriminant A inherited
8973 -- _Parent : T1 (A);
8977 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
8978 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
8979 Loc
: constant Source_Ptr
:= Sloc
(Def
);
8980 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
8981 Par_Subtype
: Entity_Id
;
8982 Comp_List
: Node_Id
;
8983 Comp_Decl
: Node_Id
;
8986 List_Constr
: constant List_Id
:= New_List
;
8989 -- Expand_Record_Extension is called directly from the semantics, so
8990 -- we must check to see whether expansion is active before proceeding,
8991 -- because this affects the visibility of selected components in bodies
8992 -- of instances. Within a generic we still need to set Parent_Subtype
8993 -- link because the visibility of inherited components will have to be
8994 -- verified in subsequent instances.
8996 if not Expander_Active
then
8997 if Inside_A_Generic
and then Ekind
(T
) = E_Record_Type
then
8998 Set_Parent_Subtype
(T
, Etype
(T
));
9003 -- This may be a derivation of an untagged private type whose full
9004 -- view is tagged, in which case the Derived_Type_Definition has no
9005 -- extension part. Build an empty one now.
9007 if No
(Rec_Ext_Part
) then
9009 Make_Record_Definition
(Loc
,
9011 Component_List
=> Empty
,
9012 Null_Present
=> True);
9014 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
9015 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
9018 Comp_List
:= Component_List
(Rec_Ext_Part
);
9020 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
9022 -- If the derived type inherits its discriminants the type of the
9023 -- _parent field must be constrained by the inherited discriminants
9025 if Has_Discriminants
(T
)
9026 and then Nkind
(Indic
) /= N_Subtype_Indication
9027 and then not Is_Constrained
(Entity
(Indic
))
9029 D
:= First_Discriminant
(T
);
9030 while Present
(D
) loop
9031 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
9032 Next_Discriminant
(D
);
9037 Make_Subtype_Indication
(Loc
,
9038 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Indic
), Loc
),
9040 Make_Index_Or_Discriminant_Constraint
(Loc
,
9041 Constraints
=> List_Constr
)),
9044 -- Otherwise the original subtype_indication is just what is needed
9047 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
9050 Set_Parent_Subtype
(T
, Par_Subtype
);
9053 Make_Component_Declaration
(Loc
,
9054 Defining_Identifier
=> Parent_N
,
9055 Component_Definition
=>
9056 Make_Component_Definition
(Loc
,
9057 Aliased_Present
=> False,
9058 Subtype_Indication
=> New_Occurrence_Of
(Par_Subtype
, Loc
)));
9060 if Null_Present
(Rec_Ext_Part
) then
9061 Set_Component_List
(Rec_Ext_Part
,
9062 Make_Component_List
(Loc
,
9063 Component_Items
=> New_List
(Comp_Decl
),
9064 Variant_Part
=> Empty
,
9065 Null_Present
=> False));
9066 Set_Null_Present
(Rec_Ext_Part
, False);
9068 elsif Null_Present
(Comp_List
)
9069 or else Is_Empty_List
(Component_Items
(Comp_List
))
9071 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9072 Set_Null_Present
(Comp_List
, False);
9075 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9078 Analyze
(Comp_Decl
);
9079 end Expand_Record_Extension
;
9081 ------------------------
9082 -- Expand_Tagged_Root --
9083 ------------------------
9085 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
9086 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
9087 Comp_List
: Node_Id
;
9088 Comp_Decl
: Node_Id
;
9089 Sloc_N
: Source_Ptr
;
9092 if Null_Present
(Def
) then
9093 Set_Component_List
(Def
,
9094 Make_Component_List
(Sloc
(Def
),
9095 Component_Items
=> Empty_List
,
9096 Variant_Part
=> Empty
,
9097 Null_Present
=> True));
9100 Comp_List
:= Component_List
(Def
);
9102 if Null_Present
(Comp_List
)
9103 or else Is_Empty_List
(Component_Items
(Comp_List
))
9105 Sloc_N
:= Sloc
(Comp_List
);
9107 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
9111 Make_Component_Declaration
(Sloc_N
,
9112 Defining_Identifier
=> First_Tag_Component
(T
),
9113 Component_Definition
=>
9114 Make_Component_Definition
(Sloc_N
,
9115 Aliased_Present
=> False,
9116 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RE_Tag
), Sloc_N
)));
9118 if Null_Present
(Comp_List
)
9119 or else Is_Empty_List
(Component_Items
(Comp_List
))
9121 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9122 Set_Null_Present
(Comp_List
, False);
9125 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9128 -- We don't Analyze the whole expansion because the tag component has
9129 -- already been analyzed previously. Here we just insure that the tree
9130 -- is coherent with the semantic decoration
9132 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
9135 when RE_Not_Available
=>
9137 end Expand_Tagged_Root
;
9139 ------------------------------
9140 -- Freeze_Stream_Operations --
9141 ------------------------------
9143 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
9144 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
9149 Stream_Op
: Entity_Id
;
9152 -- Primitive operations of tagged types are frozen when the dispatch
9153 -- table is constructed.
9155 if not Comes_From_Source
(Typ
) or else Is_Tagged_Type
(Typ
) then
9159 for J
in Names
'Range loop
9160 Stream_Op
:= TSS
(Typ
, Names
(J
));
9162 if Present
(Stream_Op
)
9163 and then Is_Subprogram
(Stream_Op
)
9164 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
9165 N_Subprogram_Declaration
9166 and then not Is_Frozen
(Stream_Op
)
9168 Append_Freeze_Actions
(Typ
, Freeze_Entity
(Stream_Op
, N
));
9171 end Freeze_Stream_Operations
;
9177 -- Full type declarations are expanded at the point at which the type is
9178 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
9179 -- declarations generated by the freezing (e.g. the procedure generated
9180 -- for initialization) are chained in the Actions field list of the freeze
9181 -- node using Append_Freeze_Actions.
9183 -- WARNING: This routine manages Ghost regions. Return statements must be
9184 -- replaced by gotos which jump to the end of the routine and restore the
9187 function Freeze_Type
(N
: Node_Id
) return Boolean is
9188 procedure Process_RACW_Types
(Typ
: Entity_Id
);
9189 -- Validate and generate stubs for all RACW types associated with type
9192 procedure Process_Pending_Access_Types
(Typ
: Entity_Id
);
9193 -- Associate type Typ's Finalize_Address primitive with the finalization
9194 -- masters of pending access-to-Typ types.
9196 ------------------------
9197 -- Process_RACW_Types --
9198 ------------------------
9200 procedure Process_RACW_Types
(Typ
: Entity_Id
) is
9201 List
: constant Elist_Id
:= Access_Types_To_Process
(N
);
9203 Seen
: Boolean := False;
9206 if Present
(List
) then
9207 E
:= First_Elmt
(List
);
9208 while Present
(E
) loop
9209 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
9210 Validate_RACW_Primitives
(Node
(E
));
9218 -- If there are RACWs designating this type, make stubs now
9221 Remote_Types_Tagged_Full_View_Encountered
(Typ
);
9223 end Process_RACW_Types
;
9225 ----------------------------------
9226 -- Process_Pending_Access_Types --
9227 ----------------------------------
9229 procedure Process_Pending_Access_Types
(Typ
: Entity_Id
) is
9233 -- Finalize_Address is not generated in CodePeer mode because the
9234 -- body contains address arithmetic. This processing is disabled.
9236 if CodePeer_Mode
then
9239 -- Certain itypes are generated for contexts that cannot allocate
9240 -- objects and should not set primitive Finalize_Address.
9242 elsif Is_Itype
(Typ
)
9243 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
9244 N_Explicit_Dereference
9248 -- When an access type is declared after the incomplete view of a
9249 -- Taft-amendment type, the access type is considered pending in
9250 -- case the full view of the Taft-amendment type is controlled. If
9251 -- this is indeed the case, associate the Finalize_Address routine
9252 -- of the full view with the finalization masters of all pending
9253 -- access types. This scenario applies to anonymous access types as
9256 elsif Needs_Finalization
(Typ
)
9257 and then Present
(Pending_Access_Types
(Typ
))
9259 E
:= First_Elmt
(Pending_Access_Types
(Typ
));
9260 while Present
(E
) loop
9263 -- Set_Finalize_Address
9264 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
9266 Append_Freeze_Action
(Typ
,
9267 Make_Set_Finalize_Address_Call
9269 Ptr_Typ
=> Node
(E
)));
9274 end Process_Pending_Access_Types
;
9278 Def_Id
: constant Entity_Id
:= Entity
(N
);
9280 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
9281 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
9282 -- Save the Ghost-related attributes to restore on exit
9284 Result
: Boolean := False;
9286 -- Start of processing for Freeze_Type
9289 -- The type being frozen may be subject to pragma Ghost. Set the mode
9290 -- now to ensure that any nodes generated during freezing are properly
9293 Set_Ghost_Mode
(Def_Id
);
9295 -- Process any remote access-to-class-wide types designating the type
9298 Process_RACW_Types
(Def_Id
);
9300 -- Freeze processing for record types
9302 if Is_Record_Type
(Def_Id
) then
9303 if Ekind
(Def_Id
) = E_Record_Type
then
9304 Expand_Freeze_Record_Type
(N
);
9305 elsif Is_Class_Wide_Type
(Def_Id
) then
9306 Expand_Freeze_Class_Wide_Type
(N
);
9309 -- Freeze processing for array types
9311 elsif Is_Array_Type
(Def_Id
) then
9312 Expand_Freeze_Array_Type
(N
);
9314 -- Freeze processing for access types
9316 -- For pool-specific access types, find out the pool object used for
9317 -- this type, needs actual expansion of it in some cases. Here are the
9318 -- different cases :
9320 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
9321 -- ---> don't use any storage pool
9323 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
9325 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
9327 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9328 -- ---> Storage Pool is the specified one
9330 -- See GNAT Pool packages in the Run-Time for more details
9332 elsif Ekind
(Def_Id
) in E_Access_Type | E_General_Access_Type
then
9334 Loc
: constant Source_Ptr
:= Sloc
(N
);
9335 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
9337 Freeze_Action_Typ
: Entity_Id
;
9338 Pool_Object
: Entity_Id
;
9343 -- Rep Clause "for Def_Id'Storage_Size use 0;"
9344 -- ---> don't use any storage pool
9346 if No_Pool_Assigned
(Def_Id
) then
9351 -- Rep Clause : for Def_Id'Storage_Size use Expr.
9353 -- Def_Id__Pool : Stack_Bounded_Pool
9354 -- (Expr, DT'Size, DT'Alignment);
9356 elsif Has_Storage_Size_Clause
(Def_Id
) then
9362 -- For unconstrained composite types we give a size of zero
9363 -- so that the pool knows that it needs a special algorithm
9364 -- for variable size object allocation.
9366 if Is_Composite_Type
(Desig_Type
)
9367 and then not Is_Constrained
(Desig_Type
)
9369 DT_Size
:= Make_Integer_Literal
(Loc
, 0);
9370 DT_Align
:= Make_Integer_Literal
(Loc
, Maximum_Alignment
);
9374 Make_Attribute_Reference
(Loc
,
9375 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9376 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
9379 Make_Attribute_Reference
(Loc
,
9380 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9381 Attribute_Name
=> Name_Alignment
);
9385 Make_Defining_Identifier
(Loc
,
9386 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
9388 -- We put the code associated with the pools in the entity
9389 -- that has the later freeze node, usually the access type
9390 -- but it can also be the designated_type; because the pool
9391 -- code requires both those types to be frozen
9393 if Is_Frozen
(Desig_Type
)
9394 and then (No
(Freeze_Node
(Desig_Type
))
9395 or else Analyzed
(Freeze_Node
(Desig_Type
)))
9397 Freeze_Action_Typ
:= Def_Id
;
9399 -- A Taft amendment type cannot get the freeze actions
9400 -- since the full view is not there.
9402 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
9403 and then No
(Full_View
(Desig_Type
))
9405 Freeze_Action_Typ
:= Def_Id
;
9408 Freeze_Action_Typ
:= Desig_Type
;
9411 Append_Freeze_Action
(Freeze_Action_Typ
,
9412 Make_Object_Declaration
(Loc
,
9413 Defining_Identifier
=> Pool_Object
,
9414 Object_Definition
=>
9415 Make_Subtype_Indication
(Loc
,
9418 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
9421 Make_Index_Or_Discriminant_Constraint
(Loc
,
9422 Constraints
=> New_List
(
9424 -- First discriminant is the Pool Size
9427 Storage_Size_Variable
(Def_Id
), Loc
),
9429 -- Second discriminant is the element size
9433 -- Third discriminant is the alignment
9438 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
9442 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9443 -- ---> Storage Pool is the specified one
9445 -- When compiling in Ada 2012 mode, ensure that the accessibility
9446 -- level of the subpool access type is not deeper than that of the
9447 -- pool_with_subpools.
9449 elsif Ada_Version
>= Ada_2012
9450 and then Present
(Associated_Storage_Pool
(Def_Id
))
9451 and then RTU_Loaded
(System_Storage_Pools_Subpools
)
9454 Loc
: constant Source_Ptr
:= Sloc
(Def_Id
);
9455 Pool
: constant Entity_Id
:=
9456 Associated_Storage_Pool
(Def_Id
);
9459 -- It is known that the accessibility level of the access
9460 -- type is deeper than that of the pool.
9462 if Type_Access_Level
(Def_Id
)
9463 > Static_Accessibility_Level
(Pool
, Object_Decl_Level
)
9464 and then Is_Class_Wide_Type
(Etype
(Pool
))
9465 and then not Accessibility_Checks_Suppressed
(Def_Id
)
9466 and then not Accessibility_Checks_Suppressed
(Pool
)
9468 -- When the pool is of a class-wide type, it may or may
9469 -- not support subpools depending on the path of
9470 -- derivation. Generate:
9472 -- if Def_Id in RSPWS'Class then
9473 -- raise Program_Error;
9476 Append_Freeze_Action
(Def_Id
,
9477 Make_If_Statement
(Loc
,
9480 Left_Opnd
=> New_Occurrence_Of
(Pool
, Loc
),
9485 (RE_Root_Storage_Pool_With_Subpools
)),
9487 Then_Statements
=> New_List
(
9488 Make_Raise_Program_Error
(Loc
,
9489 Reason
=> PE_Accessibility_Check_Failed
))));
9494 -- For access-to-controlled types (including class-wide types and
9495 -- Taft-amendment types, which potentially have controlled
9496 -- components), expand the list controller object that will store
9497 -- the dynamically allocated objects. Don't do this transformation
9498 -- for expander-generated access types, except do it for types
9499 -- that are the full view of types derived from other private
9500 -- types and for access types used to implement indirect temps.
9501 -- Also suppress the list controller in the case of a designated
9502 -- type with convention Java, since this is used when binding to
9503 -- Java API specs, where there's no equivalent of a finalization
9504 -- list and we don't want to pull in the finalization support if
9507 if not Comes_From_Source
(Def_Id
)
9508 and then not Has_Private_Declaration
(Def_Id
)
9509 and then not Old_Attr_Util
.Indirect_Temps
9510 .Is_Access_Type_For_Indirect_Temp
(Def_Id
)
9514 -- An exception is made for types defined in the run-time because
9515 -- Ada.Tags.Tag itself is such a type and cannot afford this
9516 -- unnecessary overhead that would generates a loop in the
9517 -- expansion scheme. Another exception is if Restrictions
9518 -- (No_Finalization) is active, since then we know nothing is
9521 elsif Restriction_Active
(No_Finalization
)
9522 or else In_Runtime
(Def_Id
)
9526 -- Create a finalization master for an access-to-controlled type
9527 -- or an access-to-incomplete type. It is assumed that the full
9528 -- view will be controlled.
9530 elsif Needs_Finalization
(Desig_Type
)
9531 or else (Is_Incomplete_Type
(Desig_Type
)
9532 and then No
(Full_View
(Desig_Type
)))
9534 Build_Finalization_Master
(Def_Id
);
9536 -- Create a finalization master when the designated type contains
9537 -- a private component. It is assumed that the full view will be
9540 elsif Has_Private_Component
(Desig_Type
) then
9541 Build_Finalization_Master
9543 For_Private
=> True,
9544 Context_Scope
=> Scope
(Def_Id
),
9545 Insertion_Node
=> Declaration_Node
(Desig_Type
));
9549 -- Freeze processing for enumeration types
9551 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
9553 -- We only have something to do if we have a non-standard
9554 -- representation (i.e. at least one literal whose pos value
9555 -- is not the same as its representation)
9557 if Has_Non_Standard_Rep
(Def_Id
) then
9558 Expand_Freeze_Enumeration_Type
(N
);
9561 -- Private types that are completed by a derivation from a private
9562 -- type have an internally generated full view, that needs to be
9563 -- frozen. This must be done explicitly because the two views share
9564 -- the freeze node, and the underlying full view is not visible when
9565 -- the freeze node is analyzed.
9567 elsif Is_Private_Type
(Def_Id
)
9568 and then Is_Derived_Type
(Def_Id
)
9569 and then Present
(Full_View
(Def_Id
))
9570 and then Is_Itype
(Full_View
(Def_Id
))
9571 and then Has_Private_Declaration
(Full_View
(Def_Id
))
9572 and then Freeze_Node
(Full_View
(Def_Id
)) = N
9574 Set_Entity
(N
, Full_View
(Def_Id
));
9575 Result
:= Freeze_Type
(N
);
9576 Set_Entity
(N
, Def_Id
);
9578 -- All other types require no expander action. There are such cases
9579 -- (e.g. task types and protected types). In such cases, the freeze
9580 -- nodes are there for use by Gigi.
9584 -- Complete the initialization of all pending access types' finalization
9585 -- masters now that the designated type has been is frozen and primitive
9586 -- Finalize_Address generated.
9588 Process_Pending_Access_Types
(Def_Id
);
9589 Freeze_Stream_Operations
(N
, Def_Id
);
9591 -- Generate the [spec and] body of the invariant procedure tasked with
9592 -- the runtime verification of all invariants that pertain to the type.
9593 -- This includes invariants on the partial and full view, inherited
9594 -- class-wide invariants from parent types or interfaces, and invariants
9595 -- on array elements or record components. But skip internal types.
9597 if Is_Itype
(Def_Id
) then
9600 elsif Is_Interface
(Def_Id
) then
9602 -- Interfaces are treated as the partial view of a private type in
9603 -- order to achieve uniformity with the general case. As a result, an
9604 -- interface receives only a "partial" invariant procedure which is
9607 if Has_Own_Invariants
(Def_Id
) then
9608 Build_Invariant_Procedure_Body
9610 Partial_Invariant
=> Is_Interface
(Def_Id
));
9613 -- Non-interface types
9615 -- Do not generate invariant procedure within other assertion
9616 -- subprograms, which may involve local declarations of local
9617 -- subtypes to which these checks do not apply.
9620 if Has_Invariants
(Def_Id
) then
9621 if not Predicate_Check_In_Scope
(Def_Id
)
9622 or else (Ekind
(Current_Scope
) = E_Function
9623 and then Is_Predicate_Function
(Current_Scope
))
9627 Build_Invariant_Procedure_Body
(Def_Id
);
9631 -- Generate the [spec and] body of the procedure tasked with the
9632 -- run-time verification of pragma Default_Initial_Condition's
9635 if Has_DIC
(Def_Id
) then
9636 Build_DIC_Procedure_Body
(Def_Id
);
9640 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9645 when RE_Not_Available
=>
9646 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9651 -------------------------
9652 -- Get_Simple_Init_Val --
9653 -------------------------
9655 function Get_Simple_Init_Val
9658 Size
: Uint
:= No_Uint
) return Node_Id
9660 IV_Attribute
: constant Boolean :=
9661 Nkind
(N
) = N_Attribute_Reference
9662 and then Attribute_Name
(N
) = Name_Invalid_Value
;
9664 Loc
: constant Source_Ptr
:= Sloc
(N
);
9666 procedure Extract_Subtype_Bounds
9667 (Lo_Bound
: out Uint
;
9668 Hi_Bound
: out Uint
);
9669 -- Inspect subtype Typ as well its ancestor subtypes and derived types
9670 -- to determine the best known information about the bounds of the type.
9671 -- The output parameters are set as follows:
9673 -- * Lo_Bound - Set to No_Unit when there is no information available,
9674 -- or to the known low bound.
9676 -- * Hi_Bound - Set to No_Unit when there is no information available,
9677 -- or to the known high bound.
9679 function Simple_Init_Array_Type
return Node_Id
;
9680 -- Build an expression to initialize array type Typ
9682 function Simple_Init_Defaulted_Type
return Node_Id
;
9683 -- Build an expression to initialize type Typ which is subject to
9684 -- aspect Default_Value.
9686 function Simple_Init_Initialize_Scalars_Type
9687 (Size_To_Use
: Uint
) return Node_Id
;
9688 -- Build an expression to initialize scalar type Typ which is subject to
9689 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
9691 function Simple_Init_Normalize_Scalars_Type
9692 (Size_To_Use
: Uint
) return Node_Id
;
9693 -- Build an expression to initialize scalar type Typ which is subject to
9694 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
9696 function Simple_Init_Private_Type
return Node_Id
;
9697 -- Build an expression to initialize private type Typ
9699 function Simple_Init_Scalar_Type
return Node_Id
;
9700 -- Build an expression to initialize scalar type Typ
9702 ----------------------------
9703 -- Extract_Subtype_Bounds --
9704 ----------------------------
9706 procedure Extract_Subtype_Bounds
9707 (Lo_Bound
: out Uint
;
9708 Hi_Bound
: out Uint
)
9718 Lo_Bound
:= No_Uint
;
9719 Hi_Bound
:= No_Uint
;
9721 -- Loop to climb ancestor subtypes and derived types
9725 if not Is_Discrete_Type
(ST1
) then
9729 Lo
:= Type_Low_Bound
(ST1
);
9730 Hi
:= Type_High_Bound
(ST1
);
9732 if Compile_Time_Known_Value
(Lo
) then
9733 Lo_Val
:= Expr_Value
(Lo
);
9735 if No
(Lo_Bound
) or else Lo_Bound
< Lo_Val
then
9740 if Compile_Time_Known_Value
(Hi
) then
9741 Hi_Val
:= Expr_Value
(Hi
);
9743 if No
(Hi_Bound
) or else Hi_Bound
> Hi_Val
then
9748 ST2
:= Ancestor_Subtype
(ST1
);
9754 exit when ST1
= ST2
;
9757 end Extract_Subtype_Bounds
;
9759 ----------------------------
9760 -- Simple_Init_Array_Type --
9761 ----------------------------
9763 function Simple_Init_Array_Type
return Node_Id
is
9764 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
9766 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
;
9767 -- Initialize a single array dimension with index constraint Index
9769 --------------------
9770 -- Simple_Init_Dimension --
9771 --------------------
9773 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
is
9775 -- Process the current dimension
9777 if Present
(Index
) then
9779 -- Build a suitable "others" aggregate for the next dimension,
9780 -- or initialize the component itself. Generate:
9785 Make_Aggregate
(Loc
,
9786 Component_Associations
=> New_List
(
9787 Make_Component_Association
(Loc
,
9788 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
9790 Simple_Init_Dimension
(Next_Index
(Index
)))));
9792 -- Otherwise all dimensions have been processed. Initialize the
9793 -- component itself.
9800 Size
=> Esize
(Comp_Typ
));
9802 end Simple_Init_Dimension
;
9804 -- Start of processing for Simple_Init_Array_Type
9807 return Simple_Init_Dimension
(First_Index
(Typ
));
9808 end Simple_Init_Array_Type
;
9810 --------------------------------
9811 -- Simple_Init_Defaulted_Type --
9812 --------------------------------
9814 function Simple_Init_Defaulted_Type
return Node_Id
is
9815 Subtyp
: Entity_Id
:= First_Subtype
(Typ
);
9818 -- When the first subtype is private, retrieve the expression of the
9819 -- Default_Value from the underlying type.
9821 if Is_Private_Type
(Subtyp
) then
9822 Subtyp
:= Full_View
(Subtyp
);
9825 -- Use the Sloc of the context node when constructing the initial
9826 -- value because the expression of Default_Value may come from a
9827 -- different unit. Updating the Sloc will result in accurate error
9835 (Source
=> Default_Aspect_Value
(Subtyp
),
9837 end Simple_Init_Defaulted_Type
;
9839 -----------------------------------------
9840 -- Simple_Init_Initialize_Scalars_Type --
9841 -----------------------------------------
9843 function Simple_Init_Initialize_Scalars_Type
9844 (Size_To_Use
: Uint
) return Node_Id
9846 Float_Typ
: Entity_Id
;
9849 Scal_Typ
: Scalar_Id
;
9852 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
9856 if Is_Floating_Point_Type
(Typ
) then
9857 Float_Typ
:= Root_Type
(Typ
);
9859 if Float_Typ
= Standard_Short_Float
then
9860 Scal_Typ
:= Name_Short_Float
;
9861 elsif Float_Typ
= Standard_Float
then
9862 Scal_Typ
:= Name_Float
;
9863 elsif Float_Typ
= Standard_Long_Float
then
9864 Scal_Typ
:= Name_Long_Float
;
9865 else pragma Assert
(Float_Typ
= Standard_Long_Long_Float
);
9866 Scal_Typ
:= Name_Long_Long_Float
;
9869 -- If zero is invalid, it is a convenient value to use that is for
9870 -- sure an appropriate invalid value in all situations.
9872 elsif Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
9873 return Make_Integer_Literal
(Loc
, 0);
9877 elsif Is_Unsigned_Type
(Typ
) then
9878 if Size_To_Use
<= 8 then
9879 Scal_Typ
:= Name_Unsigned_8
;
9880 elsif Size_To_Use
<= 16 then
9881 Scal_Typ
:= Name_Unsigned_16
;
9882 elsif Size_To_Use
<= 32 then
9883 Scal_Typ
:= Name_Unsigned_32
;
9884 elsif Size_To_Use
<= 64 then
9885 Scal_Typ
:= Name_Unsigned_64
;
9887 Scal_Typ
:= Name_Unsigned_128
;
9893 if Size_To_Use
<= 8 then
9894 Scal_Typ
:= Name_Signed_8
;
9895 elsif Size_To_Use
<= 16 then
9896 Scal_Typ
:= Name_Signed_16
;
9897 elsif Size_To_Use
<= 32 then
9898 Scal_Typ
:= Name_Signed_32
;
9899 elsif Size_To_Use
<= 64 then
9900 Scal_Typ
:= Name_Signed_64
;
9902 Scal_Typ
:= Name_Signed_128
;
9906 -- Use the values specified by pragma Initialize_Scalars or the ones
9907 -- provided by the binder. Higher precedence is given to the pragma.
9909 return Invalid_Scalar_Value
(Loc
, Scal_Typ
);
9910 end Simple_Init_Initialize_Scalars_Type
;
9912 ----------------------------------------
9913 -- Simple_Init_Normalize_Scalars_Type --
9914 ----------------------------------------
9916 function Simple_Init_Normalize_Scalars_Type
9917 (Size_To_Use
: Uint
) return Node_Id
9919 Signed_Size
: constant Uint
:= UI_Min
(Uint_63
, Size_To_Use
- 1);
9926 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
9928 -- If zero is invalid, it is a convenient value to use that is for
9929 -- sure an appropriate invalid value in all situations.
9931 if Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
9932 Expr
:= Make_Integer_Literal
(Loc
, 0);
9934 -- Cases where all one bits is the appropriate invalid value
9936 -- For modular types, all 1 bits is either invalid or valid. If it
9937 -- is valid, then there is nothing that can be done since there are
9938 -- no invalid values (we ruled out zero already).
9940 -- For signed integer types that have no negative values, either
9941 -- there is room for negative values, or there is not. If there
9942 -- is, then all 1-bits may be interpreted as minus one, which is
9943 -- certainly invalid. Alternatively it is treated as the largest
9944 -- positive value, in which case the observation for modular types
9947 -- For float types, all 1-bits is a NaN (not a number), which is
9948 -- certainly an appropriately invalid value.
9950 elsif Is_Enumeration_Type
(Typ
)
9951 or else Is_Floating_Point_Type
(Typ
)
9952 or else Is_Unsigned_Type
(Typ
)
9954 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Size_To_Use
- 1);
9956 -- Resolve as Long_Long_Long_Unsigned, because the largest number
9957 -- we can generate is out of range of universal integer.
9959 Analyze_And_Resolve
(Expr
, Standard_Long_Long_Long_Unsigned
);
9961 -- Case of signed types
9964 -- Normally we like to use the most negative number. The one
9965 -- exception is when this number is in the known subtype range and
9966 -- the largest positive number is not in the known subtype range.
9968 -- For this exceptional case, use largest positive value
9970 if Present
(Lo_Bound
) and then Present
(Hi_Bound
)
9971 and then Lo_Bound
<= (-(2 ** Signed_Size
))
9972 and then Hi_Bound
< 2 ** Signed_Size
9974 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Signed_Size
- 1);
9976 -- Normal case of largest negative value
9979 Expr
:= Make_Integer_Literal
(Loc
, -(2 ** Signed_Size
));
9984 end Simple_Init_Normalize_Scalars_Type
;
9986 ------------------------------
9987 -- Simple_Init_Private_Type --
9988 ------------------------------
9990 function Simple_Init_Private_Type
return Node_Id
is
9991 Under_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
9995 -- The availability of the underlying view must be checked by routine
9996 -- Needs_Simple_Initialization.
9998 pragma Assert
(Present
(Under_Typ
));
10000 Expr
:= Get_Simple_Init_Val
(Under_Typ
, N
, Size
);
10002 -- If the initial value is null or an aggregate, qualify it with the
10003 -- underlying type in order to provide a proper context.
10005 if Nkind
(Expr
) in N_Aggregate | N_Null
then
10007 Make_Qualified_Expression
(Loc
,
10008 Subtype_Mark
=> New_Occurrence_Of
(Under_Typ
, Loc
),
10009 Expression
=> Expr
);
10012 Expr
:= Unchecked_Convert_To
(Typ
, Expr
);
10014 -- Do not truncate the result when scalar types are involved and
10015 -- Initialize/Normalize_Scalars is in effect.
10017 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
10018 and then Is_Scalar_Type
(Under_Typ
)
10020 Set_No_Truncation
(Expr
);
10024 end Simple_Init_Private_Type
;
10026 -----------------------------
10027 -- Simple_Init_Scalar_Type --
10028 -----------------------------
10030 function Simple_Init_Scalar_Type
return Node_Id
is
10032 Size_To_Use
: Uint
;
10035 pragma Assert
(Init_Or_Norm_Scalars
or IV_Attribute
);
10037 -- Determine the size of the object. This is either the size provided
10038 -- by the caller, or the Esize of the scalar type.
10040 if No
(Size
) or else Size
<= Uint_0
then
10041 Size_To_Use
:= UI_Max
(Uint_1
, Esize
(Typ
));
10043 Size_To_Use
:= Size
;
10046 -- The maximum size to use is System_Max_Integer_Size bits. This
10047 -- will create values of type Long_Long_Long_Unsigned and the range
10048 -- must fit this type.
10050 if Present
(Size_To_Use
)
10051 and then Size_To_Use
> System_Max_Integer_Size
10053 Size_To_Use
:= UI_From_Int
(System_Max_Integer_Size
);
10056 if Normalize_Scalars
and then not IV_Attribute
then
10057 Expr
:= Simple_Init_Normalize_Scalars_Type
(Size_To_Use
);
10059 Expr
:= Simple_Init_Initialize_Scalars_Type
(Size_To_Use
);
10062 -- The final expression is obtained by doing an unchecked conversion
10063 -- of this result to the base type of the required subtype. Use the
10064 -- base type to prevent the unchecked conversion from chopping bits,
10065 -- and then we set Kill_Range_Check to preserve the "bad" value.
10067 Expr
:= Unchecked_Convert_To
(Base_Type
(Typ
), Expr
);
10069 -- Ensure that the expression is not truncated since the "bad" bits
10070 -- are desired, and also kill the range checks.
10072 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
10073 Set_Kill_Range_Check
(Expr
);
10074 Set_No_Truncation
(Expr
);
10078 end Simple_Init_Scalar_Type
;
10080 -- Start of processing for Get_Simple_Init_Val
10083 if Is_Private_Type
(Typ
) then
10084 return Simple_Init_Private_Type
;
10086 elsif Is_Scalar_Type
(Typ
) then
10087 if Has_Default_Aspect
(Typ
) then
10088 return Simple_Init_Defaulted_Type
;
10090 return Simple_Init_Scalar_Type
;
10093 -- Array type with Initialize or Normalize_Scalars
10095 elsif Is_Array_Type
(Typ
) then
10096 pragma Assert
(Init_Or_Norm_Scalars
);
10097 return Simple_Init_Array_Type
;
10099 -- Access type is initialized to null
10101 elsif Is_Access_Type
(Typ
) then
10102 return Make_Null
(Loc
);
10104 -- No other possibilities should arise, since we should only be calling
10105 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
10106 -- indicating one of the above cases held.
10109 raise Program_Error
;
10113 when RE_Not_Available
=>
10115 end Get_Simple_Init_Val
;
10117 ------------------------------
10118 -- Has_New_Non_Standard_Rep --
10119 ------------------------------
10121 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
10123 if not Is_Derived_Type
(T
) then
10124 return Has_Non_Standard_Rep
(T
)
10125 or else Has_Non_Standard_Rep
(Root_Type
(T
));
10127 -- If Has_Non_Standard_Rep is not set on the derived type, the
10128 -- representation is fully inherited.
10130 elsif not Has_Non_Standard_Rep
(T
) then
10134 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
10136 -- May need a more precise check here: the First_Rep_Item may be a
10137 -- stream attribute, which does not affect the representation of the
10141 end Has_New_Non_Standard_Rep
;
10143 ----------------------
10144 -- Inline_Init_Proc --
10145 ----------------------
10147 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean is
10149 -- The initialization proc of protected records is not worth inlining.
10150 -- In addition, when compiled for another unit for inlining purposes,
10151 -- it may make reference to entities that have not been elaborated yet.
10152 -- The initialization proc of records that need finalization contains
10153 -- a nested clean-up procedure that makes it impractical to inline as
10154 -- well, except for simple controlled types themselves. And similar
10155 -- considerations apply to task types.
10157 if Is_Concurrent_Type
(Typ
) then
10160 elsif Needs_Finalization
(Typ
) and then not Is_Controlled
(Typ
) then
10163 elsif Has_Task
(Typ
) then
10169 end Inline_Init_Proc
;
10175 function In_Runtime
(E
: Entity_Id
) return Boolean is
10180 while Scope
(S1
) /= Standard_Standard
loop
10184 return Is_RTU
(S1
, System
) or else Is_RTU
(S1
, Ada
);
10187 package body Initialization_Control
is
10189 ------------------------
10190 -- Requires_Late_Init --
10191 ------------------------
10193 function Requires_Late_Init
10195 Rec_Type
: Entity_Id
) return Boolean
10197 References_Current_Instance
: Boolean := False;
10198 Has_Access_Discriminant
: Boolean := False;
10199 Has_Internal_Call
: Boolean := False;
10201 function Find_Access_Discriminant
10202 (N
: Node_Id
) return Traverse_Result
;
10203 -- Look for a name denoting an access discriminant
10205 function Find_Current_Instance
10206 (N
: Node_Id
) return Traverse_Result
;
10207 -- Look for a reference to the current instance of the type
10209 function Find_Internal_Call
10210 (N
: Node_Id
) return Traverse_Result
;
10211 -- Look for an internal protected function call
10213 ------------------------------
10214 -- Find_Access_Discriminant --
10215 ------------------------------
10217 function Find_Access_Discriminant
10218 (N
: Node_Id
) return Traverse_Result
is
10220 if Is_Entity_Name
(N
)
10221 and then Denotes_Discriminant
(N
)
10222 and then Is_Access_Type
(Etype
(N
))
10224 Has_Access_Discriminant
:= True;
10229 end Find_Access_Discriminant
;
10231 ---------------------------
10232 -- Find_Current_Instance --
10233 ---------------------------
10235 function Find_Current_Instance
10236 (N
: Node_Id
) return Traverse_Result
is
10238 if Is_Entity_Name
(N
)
10239 and then Present
(Entity
(N
))
10240 and then Is_Current_Instance
(N
)
10242 References_Current_Instance
:= True;
10247 end Find_Current_Instance
;
10249 ------------------------
10250 -- Find_Internal_Call --
10251 ------------------------
10253 function Find_Internal_Call
(N
: Node_Id
) return Traverse_Result
is
10255 function Call_Scope
(N
: Node_Id
) return Entity_Id
;
10256 -- Return the scope enclosing a given call node N
10262 function Call_Scope
(N
: Node_Id
) return Entity_Id
is
10263 Nam
: constant Node_Id
:= Name
(N
);
10265 if Nkind
(Nam
) = N_Selected_Component
then
10266 return Scope
(Entity
(Prefix
(Nam
)));
10268 return Scope
(Entity
(Nam
));
10273 if Nkind
(N
) = N_Function_Call
10274 and then Call_Scope
(N
)
10275 = Corresponding_Concurrent_Type
(Rec_Type
)
10277 Has_Internal_Call
:= True;
10282 end Find_Internal_Call
;
10284 procedure Search_Access_Discriminant
is new
10285 Traverse_Proc
(Find_Access_Discriminant
);
10287 procedure Search_Current_Instance
is new
10288 Traverse_Proc
(Find_Current_Instance
);
10290 procedure Search_Internal_Call
is new
10291 Traverse_Proc
(Find_Internal_Call
);
10293 -- Start of processing for Requires_Late_Init
10296 -- A component of an object is said to require late initialization
10299 -- it has an access discriminant value constrained by a per-object
10302 if Has_Access_Constraint
(Defining_Identifier
(Decl
))
10303 and then No
(Expression
(Decl
))
10307 elsif Present
(Expression
(Decl
)) then
10309 -- it has an initialization expression that includes a name
10310 -- denoting an access discriminant;
10312 Search_Access_Discriminant
(Expression
(Decl
));
10314 if Has_Access_Discriminant
then
10318 -- or it has an initialization expression that includes a
10319 -- reference to the current instance of the type either by
10322 Search_Current_Instance
(Expression
(Decl
));
10324 if References_Current_Instance
then
10328 -- ...or implicitly as the target object of a call.
10330 if Is_Protected_Record_Type
(Rec_Type
) then
10331 Search_Internal_Call
(Expression
(Decl
));
10333 if Has_Internal_Call
then
10340 end Requires_Late_Init
;
10342 -----------------------------
10343 -- Has_Late_Init_Component --
10344 -----------------------------
10346 function Has_Late_Init_Component
10347 (Tagged_Rec_Type
: Entity_Id
) return Boolean
10349 Comp_Id
: Entity_Id
:=
10350 First_Component
(Implementation_Base_Type
(Tagged_Rec_Type
));
10352 while Present
(Comp_Id
) loop
10353 if Requires_Late_Init
(Decl
=> Parent
(Comp_Id
),
10354 Rec_Type
=> Tagged_Rec_Type
)
10356 return True; -- found a component that requires late init
10358 elsif Chars
(Comp_Id
) = Name_uParent
10359 and then Has_Late_Init_Component
(Etype
(Comp_Id
))
10361 return True; -- an ancestor type has a late init component
10364 Next_Component
(Comp_Id
);
10368 end Has_Late_Init_Component
;
10370 ------------------------
10371 -- Tag_Init_Condition --
10372 ------------------------
10374 function Tag_Init_Condition
10376 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10378 return Make_Op_Eq
(Loc
,
10379 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10380 Make_Mode_Literal
(Loc
, Full_Init
));
10381 end Tag_Init_Condition
;
10383 --------------------------
10384 -- Early_Init_Condition --
10385 --------------------------
10387 function Early_Init_Condition
10389 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10391 return Make_Op_Ne
(Loc
,
10392 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10393 Make_Mode_Literal
(Loc
, Late_Init_Only
));
10394 end Early_Init_Condition
;
10396 -------------------------
10397 -- Late_Init_Condition --
10398 -------------------------
10400 function Late_Init_Condition
10402 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10404 return Make_Op_Ne
(Loc
,
10405 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10406 Make_Mode_Literal
(Loc
, Early_Init_Only
));
10407 end Late_Init_Condition
;
10409 end Initialization_Control
;
10411 ----------------------------
10412 -- Initialization_Warning --
10413 ----------------------------
10415 procedure Initialization_Warning
(E
: Entity_Id
) is
10416 Warning_Needed
: Boolean;
10419 Warning_Needed
:= False;
10421 if Ekind
(Current_Scope
) = E_Package
10422 and then Static_Elaboration_Desired
(Current_Scope
)
10424 if Is_Type
(E
) then
10425 if Is_Record_Type
(E
) then
10426 if Has_Discriminants
(E
)
10427 or else Is_Limited_Type
(E
)
10428 or else Has_Non_Standard_Rep
(E
)
10430 Warning_Needed
:= True;
10433 -- Verify that at least one component has an initialization
10434 -- expression. No need for a warning on a type if all its
10435 -- components have no initialization.
10441 Comp
:= First_Component
(E
);
10442 while Present
(Comp
) loop
10444 (Nkind
(Parent
(Comp
)) = N_Component_Declaration
);
10446 if Present
(Expression
(Parent
(Comp
))) then
10447 Warning_Needed
:= True;
10451 Next_Component
(Comp
);
10456 if Warning_Needed
then
10458 ("objects of the type cannot be initialized statically "
10459 & "by default??", Parent
(E
));
10464 Error_Msg_N
("object cannot be initialized statically??", E
);
10467 end Initialization_Warning
;
10473 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
10475 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10476 Unc_Arr
: constant Boolean :=
10477 Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
);
10478 With_Prot
: constant Boolean :=
10479 Has_Protected
(Typ
)
10480 or else (Is_Record_Type
(Typ
)
10481 and then Is_Protected_Record_Type
(Typ
));
10482 With_Task
: constant Boolean :=
10483 not Global_No_Tasking
10486 or else (Is_Record_Type
(Typ
)
10487 and then Is_Task_Record_Type
(Typ
)));
10491 -- The first parameter is always _Init : [in] out Typ. Note that we need
10492 -- it to be in/out in the case of an unconstrained array, because of the
10493 -- need to have the bounds, and in the case of protected or task record
10494 -- value, because there are default record fields that may be referenced
10495 -- in the generated initialization routine.
10497 Formals
:= New_List
(
10498 Make_Parameter_Specification
(Loc
,
10499 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uInit
),
10500 In_Present
=> Unc_Arr
or else With_Prot
or else With_Task
,
10501 Out_Present
=> True,
10502 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
10504 -- For task record value, or type that contains tasks, add two more
10505 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
10506 -- We also add these parameters for the task record type case.
10509 Append_To
(Formals
,
10510 Make_Parameter_Specification
(Loc
,
10511 Defining_Identifier
=>
10512 Make_Defining_Identifier
(Loc
, Name_uMaster
),
10514 New_Occurrence_Of
(Standard_Integer
, Loc
)));
10516 Set_Has_Master_Entity
(Proc_Id
);
10518 -- Add _Chain (not done for sequential elaboration policy, see
10519 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
10521 if Partition_Elaboration_Policy
/= 'S' then
10522 Append_To
(Formals
,
10523 Make_Parameter_Specification
(Loc
,
10524 Defining_Identifier
=>
10525 Make_Defining_Identifier
(Loc
, Name_uChain
),
10526 In_Present
=> True,
10527 Out_Present
=> True,
10529 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
)));
10532 Append_To
(Formals
,
10533 Make_Parameter_Specification
(Loc
,
10534 Defining_Identifier
=>
10535 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
10536 In_Present
=> True,
10537 Parameter_Type
=> New_Occurrence_Of
(Standard_String
, Loc
)));
10540 -- Due to certain edge cases such as arrays with null-excluding
10541 -- components being built with the secondary stack it becomes necessary
10542 -- to add a formal to the Init_Proc which controls whether we raise
10543 -- Constraint_Errors on generated calls for internal object
10546 if Needs_Conditional_Null_Excluding_Check
(Typ
) then
10547 Append_To
(Formals
,
10548 Make_Parameter_Specification
(Loc
,
10549 Defining_Identifier
=>
10550 Make_Defining_Identifier
(Loc
,
10551 New_External_Name
(Chars
10552 (Component_Type
(Typ
)), "_skip_null_excluding_check")),
10553 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
10554 In_Present
=> True,
10556 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
10562 when RE_Not_Available
=>
10566 -------------------------
10567 -- Init_Secondary_Tags --
10568 -------------------------
10570 procedure Init_Secondary_Tags
10573 Init_Tags_List
: List_Id
;
10574 Stmts_List
: List_Id
;
10575 Fixed_Comps
: Boolean := True;
10576 Variable_Comps
: Boolean := True)
10578 Loc
: constant Source_Ptr
:= Sloc
(Target
);
10580 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
10581 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10583 procedure Initialize_Tag
10586 Tag_Comp
: Entity_Id
;
10587 Iface_Tag
: Node_Id
);
10588 -- Initialize the tag of the secondary dispatch table of Typ associated
10589 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10590 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
10591 -- of Typ CPP tagged type we generate code to inherit the contents of
10592 -- the dispatch table directly from the ancestor.
10594 --------------------
10595 -- Initialize_Tag --
10596 --------------------
10598 procedure Initialize_Tag
10601 Tag_Comp
: Entity_Id
;
10602 Iface_Tag
: Node_Id
)
10604 Comp_Typ
: Entity_Id
;
10605 Offset_To_Top_Comp
: Entity_Id
:= Empty
;
10608 -- Initialize pointer to secondary DT associated with the interface
10610 if not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
10611 Append_To
(Init_Tags_List
,
10612 Make_Assignment_Statement
(Loc
,
10614 Make_Selected_Component
(Loc
,
10615 Prefix
=> New_Copy_Tree
(Target
),
10616 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10618 New_Occurrence_Of
(Iface_Tag
, Loc
)));
10621 Comp_Typ
:= Scope
(Tag_Comp
);
10623 -- Initialize the entries of the table of interfaces. We generate a
10624 -- different call when the parent of the type has variable size
10627 if Comp_Typ
/= Etype
(Comp_Typ
)
10628 and then Is_Variable_Size_Record
(Etype
(Comp_Typ
))
10629 and then Chars
(Tag_Comp
) /= Name_uTag
10631 pragma Assert
(Present
(DT_Offset_To_Top_Func
(Tag_Comp
)));
10633 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
10634 -- configurable run-time environment.
10636 if not RTE_Available
(RE_Set_Dynamic_Offset_To_Top
) then
10638 ("variable size record with interface types", Typ
);
10643 -- Set_Dynamic_Offset_To_Top
10645 -- Prim_T => Typ'Tag,
10646 -- Interface_T => Iface'Tag,
10647 -- Offset_Value => n,
10648 -- Offset_Func => Fn'Unrestricted_Access)
10650 Append_To
(Stmts_List
,
10651 Make_Procedure_Call_Statement
(Loc
,
10653 New_Occurrence_Of
(RTE
(RE_Set_Dynamic_Offset_To_Top
), Loc
),
10654 Parameter_Associations
=> New_List
(
10655 Make_Attribute_Reference
(Loc
,
10656 Prefix
=> New_Copy_Tree
(Target
),
10657 Attribute_Name
=> Name_Address
),
10659 Unchecked_Convert_To
(RTE
(RE_Tag
),
10661 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10663 Unchecked_Convert_To
(RTE
(RE_Tag
),
10665 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
10668 Unchecked_Convert_To
10669 (RTE
(RE_Storage_Offset
),
10670 Make_Op_Minus
(Loc
,
10671 Make_Attribute_Reference
(Loc
,
10673 Make_Selected_Component
(Loc
,
10674 Prefix
=> New_Copy_Tree
(Target
),
10676 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10677 Attribute_Name
=> Name_Position
))),
10679 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Function_Ptr
),
10680 Make_Attribute_Reference
(Loc
,
10681 Prefix
=> New_Occurrence_Of
10682 (DT_Offset_To_Top_Func
(Tag_Comp
), Loc
),
10683 Attribute_Name
=> Name_Unrestricted_Access
)))));
10685 -- In this case the next component stores the value of the offset
10688 Offset_To_Top_Comp
:= Next_Entity
(Tag_Comp
);
10689 pragma Assert
(Present
(Offset_To_Top_Comp
));
10691 Append_To
(Init_Tags_List
,
10692 Make_Assignment_Statement
(Loc
,
10694 Make_Selected_Component
(Loc
,
10695 Prefix
=> New_Copy_Tree
(Target
),
10697 New_Occurrence_Of
(Offset_To_Top_Comp
, Loc
)),
10700 Make_Op_Minus
(Loc
,
10701 Make_Attribute_Reference
(Loc
,
10703 Make_Selected_Component
(Loc
,
10704 Prefix
=> New_Copy_Tree
(Target
),
10705 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10706 Attribute_Name
=> Name_Position
))));
10708 -- Normal case: No discriminants in the parent type
10711 -- Don't need to set any value if the offset-to-top field is
10712 -- statically set or if this interface shares the primary
10715 if not Building_Static_Secondary_DT
(Typ
)
10716 and then not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True)
10718 Append_To
(Stmts_List
,
10719 Build_Set_Static_Offset_To_Top
(Loc
,
10720 Iface_Tag
=> New_Occurrence_Of
(Iface_Tag
, Loc
),
10722 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10723 Make_Op_Minus
(Loc
,
10724 Make_Attribute_Reference
(Loc
,
10726 Make_Selected_Component
(Loc
,
10727 Prefix
=> New_Copy_Tree
(Target
),
10729 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10730 Attribute_Name
=> Name_Position
)))));
10734 -- Register_Interface_Offset
10735 -- (Prim_T => Typ'Tag,
10736 -- Interface_T => Iface'Tag,
10737 -- Is_Constant => True,
10738 -- Offset_Value => n,
10739 -- Offset_Func => null);
10741 if not Building_Static_Secondary_DT
(Typ
)
10742 and then RTE_Available
(RE_Register_Interface_Offset
)
10744 Append_To
(Stmts_List
,
10745 Make_Procedure_Call_Statement
(Loc
,
10748 (RTE
(RE_Register_Interface_Offset
), Loc
),
10749 Parameter_Associations
=> New_List
(
10750 Unchecked_Convert_To
(RTE
(RE_Tag
),
10752 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10754 Unchecked_Convert_To
(RTE
(RE_Tag
),
10756 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))), Loc
)),
10758 New_Occurrence_Of
(Standard_True
, Loc
),
10760 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10761 Make_Op_Minus
(Loc
,
10762 Make_Attribute_Reference
(Loc
,
10764 Make_Selected_Component
(Loc
,
10765 Prefix
=> New_Copy_Tree
(Target
),
10767 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10768 Attribute_Name
=> Name_Position
))),
10770 Make_Null
(Loc
))));
10773 end Initialize_Tag
;
10777 Full_Typ
: Entity_Id
;
10778 Ifaces_List
: Elist_Id
;
10779 Ifaces_Comp_List
: Elist_Id
;
10780 Ifaces_Tag_List
: Elist_Id
;
10781 Iface_Elmt
: Elmt_Id
;
10782 Iface_Comp_Elmt
: Elmt_Id
;
10783 Iface_Tag_Elmt
: Elmt_Id
;
10784 Tag_Comp
: Node_Id
;
10785 In_Variable_Pos
: Boolean;
10787 -- Start of processing for Init_Secondary_Tags
10790 -- Handle private types
10792 if Present
(Full_View
(Typ
)) then
10793 Full_Typ
:= Full_View
(Typ
);
10798 Collect_Interfaces_Info
10799 (Full_Typ
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
10801 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
10802 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
10803 Iface_Tag_Elmt
:= First_Elmt
(Ifaces_Tag_List
);
10804 while Present
(Iface_Elmt
) loop
10805 Tag_Comp
:= Node
(Iface_Comp_Elmt
);
10807 -- Check if parent of record type has variable size components
10809 In_Variable_Pos
:= Scope
(Tag_Comp
) /= Etype
(Scope
(Tag_Comp
))
10810 and then Is_Variable_Size_Record
(Etype
(Scope
(Tag_Comp
)));
10812 -- If we are compiling under the CPP full ABI compatibility mode and
10813 -- the ancestor is a CPP_Pragma tagged type then we generate code to
10814 -- initialize the secondary tag components from tags that reference
10815 -- secondary tables filled with copy of parent slots.
10817 if Is_CPP_Class
(Root_Type
(Full_Typ
)) then
10819 -- Reject interface components located at variable offset in
10820 -- C++ derivations. This is currently unsupported.
10822 if not Fixed_Comps
and then In_Variable_Pos
then
10824 -- Locate the first dynamic component of the record. Done to
10825 -- improve the text of the warning.
10829 Comp_Typ
: Entity_Id
;
10832 Comp
:= First_Entity
(Typ
);
10833 while Present
(Comp
) loop
10834 Comp_Typ
:= Etype
(Comp
);
10836 if Ekind
(Comp
) /= E_Discriminant
10837 and then not Is_Tag
(Comp
)
10840 (Is_Record_Type
(Comp_Typ
)
10842 Is_Variable_Size_Record
(Base_Type
(Comp_Typ
)))
10844 (Is_Array_Type
(Comp_Typ
)
10845 and then Is_Variable_Size_Array
(Comp_Typ
));
10848 Next_Entity
(Comp
);
10851 pragma Assert
(Present
(Comp
));
10853 -- Move this check to sem???
10854 Error_Msg_Node_2
:= Comp
;
10856 ("parent type & with dynamic component & cannot be parent"
10857 & " of 'C'P'P derivation if new interfaces are present",
10858 Typ
, Scope
(Original_Record_Component
(Comp
)));
10861 Sloc
(Scope
(Original_Record_Component
(Comp
)));
10863 ("type derived from 'C'P'P type & defined #",
10864 Typ
, Scope
(Original_Record_Component
(Comp
)));
10866 -- Avoid duplicated warnings
10871 -- Initialize secondary tags
10876 Iface
=> Node
(Iface_Elmt
),
10877 Tag_Comp
=> Tag_Comp
,
10878 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
10881 -- Otherwise generate code to initialize the tag
10884 if (In_Variable_Pos
and then Variable_Comps
)
10885 or else (not In_Variable_Pos
and then Fixed_Comps
)
10889 Iface
=> Node
(Iface_Elmt
),
10890 Tag_Comp
=> Tag_Comp
,
10891 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
10895 Next_Elmt
(Iface_Elmt
);
10896 Next_Elmt
(Iface_Comp_Elmt
);
10897 Next_Elmt
(Iface_Tag_Elmt
);
10899 end Init_Secondary_Tags
;
10901 ----------------------------
10902 -- Is_Null_Statement_List --
10903 ----------------------------
10905 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean is
10909 -- We must skip SCIL nodes because they may have been added to the list
10910 -- by Insert_Actions.
10912 Stmt
:= First_Non_SCIL_Node
(Stmts
);
10913 while Present
(Stmt
) loop
10914 if Nkind
(Stmt
) = N_Case_Statement
then
10918 Alt
:= First
(Alternatives
(Stmt
));
10919 while Present
(Alt
) loop
10920 if not Is_Null_Statement_List
(Statements
(Alt
)) then
10928 elsif Nkind
(Stmt
) /= N_Null_Statement
then
10932 Stmt
:= Next_Non_SCIL_Node
(Stmt
);
10936 end Is_Null_Statement_List
;
10938 ----------------------------------------
10939 -- Make_Controlling_Function_Wrappers --
10940 ----------------------------------------
10942 procedure Make_Controlling_Function_Wrappers
10943 (Tag_Typ
: Entity_Id
;
10944 Decl_List
: out List_Id
;
10945 Body_List
: out List_Id
)
10947 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
10949 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
;
10950 -- Returns a function specification with the same profile as Subp
10952 --------------------------------
10953 -- Make_Wrapper_Specification --
10954 --------------------------------
10956 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
is
10959 Make_Function_Specification
(Loc
,
10960 Defining_Unit_Name
=>
10961 Make_Defining_Identifier
(Loc
,
10962 Chars
=> Chars
(Subp
)),
10963 Parameter_Specifications
=>
10964 Copy_Parameter_List
(Subp
),
10965 Result_Definition
=>
10966 New_Occurrence_Of
(Etype
(Subp
), Loc
));
10967 end Make_Wrapper_Specification
;
10969 Prim_Elmt
: Elmt_Id
;
10971 Actual_List
: List_Id
;
10972 Formal
: Entity_Id
;
10973 Par_Formal
: Entity_Id
;
10974 Ext_Aggr
: Node_Id
;
10975 Formal_Node
: Node_Id
;
10976 Func_Body
: Node_Id
;
10977 Func_Decl
: Node_Id
;
10978 Func_Id
: Entity_Id
;
10980 -- Start of processing for Make_Controlling_Function_Wrappers
10983 Decl_List
:= New_List
;
10984 Body_List
:= New_List
;
10986 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
10987 while Present
(Prim_Elmt
) loop
10988 Subp
:= Node
(Prim_Elmt
);
10990 -- If a primitive function with a controlling result of the type has
10991 -- not been overridden by the user, then we must create a wrapper
10992 -- function here that effectively overrides it and invokes the
10993 -- (non-abstract) parent function. This can only occur for a null
10994 -- extension. Note that functions with anonymous controlling access
10995 -- results don't qualify and must be overridden. We also exclude
10996 -- Input attributes, since each type will have its own version of
10997 -- Input constructed by the expander. The test for Comes_From_Source
10998 -- is needed to distinguish inherited operations from renamings
10999 -- (which also have Alias set). We exclude internal entities with
11000 -- Interface_Alias to avoid generating duplicated wrappers since
11001 -- the primitive which covers the interface is also available in
11002 -- the list of primitive operations.
11004 -- The function may be abstract, or require_Overriding may be set
11005 -- for it, because tests for null extensions may already have reset
11006 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
11007 -- set, functions that need wrappers are recognized by having an
11008 -- alias that returns the parent type.
11010 if Comes_From_Source
(Subp
)
11011 or else No
(Alias
(Subp
))
11012 or else Present
(Interface_Alias
(Subp
))
11013 or else Ekind
(Subp
) /= E_Function
11014 or else not Has_Controlling_Result
(Subp
)
11015 or else Is_Access_Type
(Etype
(Subp
))
11016 or else Is_Abstract_Subprogram
(Alias
(Subp
))
11017 or else Is_TSS
(Subp
, TSS_Stream_Input
)
11021 elsif Is_Abstract_Subprogram
(Subp
)
11022 or else Requires_Overriding
(Subp
)
11024 (Is_Null_Extension
(Etype
(Subp
))
11025 and then Etype
(Alias
(Subp
)) /= Etype
(Subp
))
11027 -- If there is a non-overloadable homonym in the current
11028 -- scope, the implicit declaration remains invisible.
11029 -- We check the current entity with the same name, or its
11030 -- homonym in case the derivation takes place after the
11031 -- hiding object declaration.
11033 if Present
(Current_Entity
(Subp
)) then
11035 Curr
: constant Entity_Id
:= Current_Entity
(Subp
);
11036 Prev
: constant Entity_Id
:= Homonym
(Curr
);
11038 if (Comes_From_Source
(Curr
)
11039 and then Scope
(Curr
) = Current_Scope
11040 and then not Is_Overloadable
(Curr
))
11043 and then Comes_From_Source
(Prev
)
11044 and then Scope
(Prev
) = Current_Scope
11045 and then not Is_Overloadable
(Prev
))
11053 Make_Subprogram_Declaration
(Loc
,
11054 Specification
=> Make_Wrapper_Specification
(Subp
));
11056 Append_To
(Decl_List
, Func_Decl
);
11058 -- Build a wrapper body that calls the parent function. The body
11059 -- contains a single return statement that returns an extension
11060 -- aggregate whose ancestor part is a call to the parent function,
11061 -- passing the formals as actuals (with any controlling arguments
11062 -- converted to the types of the corresponding formals of the
11063 -- parent function, which might be anonymous access types), and
11064 -- having a null extension.
11066 Formal
:= First_Formal
(Subp
);
11067 Par_Formal
:= First_Formal
(Alias
(Subp
));
11069 First
(Parameter_Specifications
(Specification
(Func_Decl
)));
11071 if Present
(Formal
) then
11072 Actual_List
:= New_List
;
11074 while Present
(Formal
) loop
11075 if Is_Controlling_Formal
(Formal
) then
11076 Append_To
(Actual_List
,
11077 Make_Type_Conversion
(Loc
,
11079 New_Occurrence_Of
(Etype
(Par_Formal
), Loc
),
11082 (Defining_Identifier
(Formal_Node
), Loc
)));
11087 (Defining_Identifier
(Formal_Node
), Loc
));
11090 Next_Formal
(Formal
);
11091 Next_Formal
(Par_Formal
);
11092 Next
(Formal_Node
);
11095 Actual_List
:= No_List
;
11099 Make_Extension_Aggregate
(Loc
,
11101 Make_Function_Call
(Loc
,
11103 New_Occurrence_Of
(Alias
(Subp
), Loc
),
11104 Parameter_Associations
=> Actual_List
),
11105 Null_Record_Present
=> True);
11107 -- GNATprove will use expression of an expression function as an
11108 -- implicit postcondition. GNAT will not benefit from expression
11109 -- function (and would struggle if we add an expression function
11110 -- to freezing actions).
11112 if GNATprove_Mode
then
11114 Make_Expression_Function
(Loc
,
11116 Make_Wrapper_Specification
(Subp
),
11117 Expression
=> Ext_Aggr
);
11120 Make_Subprogram_Body
(Loc
,
11122 Make_Wrapper_Specification
(Subp
),
11123 Declarations
=> Empty_List
,
11124 Handled_Statement_Sequence
=>
11125 Make_Handled_Sequence_Of_Statements
(Loc
,
11126 Statements
=> New_List
(
11127 Make_Simple_Return_Statement
(Loc
,
11128 Expression
=> Ext_Aggr
))));
11131 Append_To
(Body_List
, Func_Body
);
11133 -- Replace the inherited function with the wrapper function in the
11134 -- primitive operations list. We add the minimum decoration needed
11135 -- to override interface primitives.
11137 Func_Id
:= Defining_Unit_Name
(Specification
(Func_Decl
));
11139 Mutate_Ekind
(Func_Id
, E_Function
);
11140 Set_Is_Wrapper
(Func_Id
);
11142 -- Corresponding_Spec will be set again to the same value during
11143 -- analysis, but we need this information earlier.
11144 -- Expand_N_Freeze_Entity needs to know whether a subprogram body
11145 -- is a wrapper's body in order to get check suppression right.
11147 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
11149 Override_Dispatching_Operation
(Tag_Typ
, Subp
, New_Op
=> Func_Id
);
11153 Next_Elmt
(Prim_Elmt
);
11155 end Make_Controlling_Function_Wrappers
;
11161 function Make_Eq_Body
11163 Eq_Name
: Name_Id
) return Node_Id
11165 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Typ
));
11167 Def
: constant Node_Id
:= Parent
(Typ
);
11168 Stmts
: constant List_Id
:= New_List
;
11169 Variant_Case
: Boolean := Has_Discriminants
(Typ
);
11170 Comps
: Node_Id
:= Empty
;
11171 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
11175 Predef_Spec_Or_Body
(Loc
,
11178 Profile
=> New_List
(
11179 Make_Parameter_Specification
(Loc
,
11180 Defining_Identifier
=>
11181 Make_Defining_Identifier
(Loc
, Name_X
),
11182 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
11184 Make_Parameter_Specification
(Loc
,
11185 Defining_Identifier
=>
11186 Make_Defining_Identifier
(Loc
, Name_Y
),
11187 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
11189 Ret_Type
=> Standard_Boolean
,
11192 if Variant_Case
then
11193 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
11194 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
11197 if Present
(Typ_Def
) then
11198 Comps
:= Component_List
(Typ_Def
);
11202 Present
(Comps
) and then Present
(Variant_Part
(Comps
));
11205 if Variant_Case
then
11207 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
11208 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
11210 Make_Simple_Return_Statement
(Loc
,
11211 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11215 Make_Simple_Return_Statement
(Loc
,
11217 Expand_Record_Equality
11220 Lhs
=> Make_Identifier
(Loc
, Name_X
),
11221 Rhs
=> Make_Identifier
(Loc
, Name_Y
))));
11224 Set_Handled_Statement_Sequence
11225 (Decl
, Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
11233 -- <Make_Eq_If shared components>
11236 -- when V1 => <Make_Eq_Case> on subcomponents
11238 -- when Vn => <Make_Eq_Case> on subcomponents
11241 function Make_Eq_Case
11244 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
11246 Loc
: constant Source_Ptr
:= Sloc
(E
);
11247 Result
: constant List_Id
:= New_List
;
11249 Alt_List
: List_Id
;
11251 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
;
11252 -- Given the discriminant that controls a given variant of an unchecked
11253 -- union, find the formal of the equality function that carries the
11254 -- inferred value of the discriminant.
11256 function External_Name
(E
: Entity_Id
) return Name_Id
;
11257 -- The value of a given discriminant is conveyed in the corresponding
11258 -- formal parameter of the equality routine. The name of this formal
11259 -- parameter carries a one-character suffix which is removed here.
11261 --------------------------
11262 -- Corresponding_Formal --
11263 --------------------------
11265 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
is
11266 Discr
: constant Entity_Id
:= Entity
(Name
(Variant_Part
(C
)));
11270 Elm
:= First_Elmt
(Discrs
);
11271 while Present
(Elm
) loop
11272 if Chars
(Discr
) = External_Name
(Node
(Elm
)) then
11279 -- A formal of the proper name must be found
11281 raise Program_Error
;
11282 end Corresponding_Formal
;
11284 -------------------
11285 -- External_Name --
11286 -------------------
11288 function External_Name
(E
: Entity_Id
) return Name_Id
is
11290 Get_Name_String
(Chars
(E
));
11291 Name_Len
:= Name_Len
- 1;
11295 -- Start of processing for Make_Eq_Case
11298 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
11300 if No
(Variant_Part
(CL
)) then
11304 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
11306 if No
(Variant
) then
11310 Alt_List
:= New_List
;
11311 while Present
(Variant
) loop
11312 Append_To
(Alt_List
,
11313 Make_Case_Statement_Alternative
(Loc
,
11314 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
11316 Make_Eq_Case
(E
, Component_List
(Variant
), Discrs
)));
11317 Next_Non_Pragma
(Variant
);
11320 -- If we have an Unchecked_Union, use one of the parameters of the
11321 -- enclosing equality routine that captures the discriminant, to use
11322 -- as the expression in the generated case statement.
11324 if Is_Unchecked_Union
(E
) then
11326 Make_Case_Statement
(Loc
,
11328 New_Occurrence_Of
(Corresponding_Formal
(CL
), Loc
),
11329 Alternatives
=> Alt_List
));
11333 Make_Case_Statement
(Loc
,
11335 Make_Selected_Component
(Loc
,
11336 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11337 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
11338 Alternatives
=> Alt_List
));
11359 -- or a null statement if the list L is empty
11361 -- Equality may be user-defined for a given component type, in which case
11362 -- a function call is constructed instead of an operator node. This is an
11363 -- Ada 2012 change in the composability of equality for untagged composite
11366 function Make_Eq_If
11368 L
: List_Id
) return Node_Id
11370 Loc
: constant Source_Ptr
:= Sloc
(E
);
11374 Field_Name
: Name_Id
;
11375 Next_Test
: Node_Id
;
11380 return Make_Null_Statement
(Loc
);
11385 C
:= First_Non_Pragma
(L
);
11386 while Present
(C
) loop
11387 Typ
:= Etype
(Defining_Identifier
(C
));
11388 Field_Name
:= Chars
(Defining_Identifier
(C
));
11390 -- The tags must not be compared: they are not part of the value.
11391 -- Ditto for parent interfaces because their equality operator is
11394 -- Note also that in the following, we use Make_Identifier for
11395 -- the component names. Use of New_Occurrence_Of to identify the
11396 -- components would be incorrect because the wrong entities for
11397 -- discriminants could be picked up in the private type case.
11399 if Field_Name
= Name_uParent
11400 and then Is_Interface
(Typ
)
11404 elsif Field_Name
/= Name_uTag
then
11406 Lhs
: constant Node_Id
:=
11407 Make_Selected_Component
(Loc
,
11408 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11409 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11411 Rhs
: constant Node_Id
:=
11412 Make_Selected_Component
(Loc
,
11413 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
11414 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11418 -- Build equality code with a user-defined operator, if
11419 -- available, and with the predefined "=" otherwise. For
11420 -- compatibility with older Ada versions, we also use the
11421 -- predefined operation if the component-type equality is
11422 -- abstract, rather than raising Program_Error.
11424 if Ada_Version
< Ada_2012
then
11425 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11428 Eq_Call
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
11430 if No
(Eq_Call
) then
11431 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11433 -- If a component has a defined abstract equality, its
11434 -- application raises Program_Error on that component
11435 -- and therefore on the current variant.
11437 elsif Nkind
(Eq_Call
) = N_Raise_Program_Error
then
11438 Set_Etype
(Eq_Call
, Standard_Boolean
);
11439 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11442 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11447 Evolve_Or_Else
(Cond
, Next_Test
);
11450 Next_Non_Pragma
(C
);
11454 return Make_Null_Statement
(Loc
);
11458 Make_Implicit_If_Statement
(E
,
11460 Then_Statements
=> New_List
(
11461 Make_Simple_Return_Statement
(Loc
,
11462 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
11467 -------------------
11468 -- Make_Neq_Body --
11469 -------------------
11471 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
is
11473 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean;
11474 -- Returns true if Prim is a renaming of an unresolved predefined
11475 -- inequality operation.
11477 --------------------------------
11478 -- Is_Predefined_Neq_Renaming --
11479 --------------------------------
11481 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean is
11483 return Chars
(Prim
) /= Name_Op_Ne
11484 and then Present
(Alias
(Prim
))
11485 and then Comes_From_Source
(Prim
)
11486 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11487 and then Chars
(Alias
(Prim
)) = Name_Op_Ne
;
11488 end Is_Predefined_Neq_Renaming
;
11492 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Tag_Typ
));
11494 Eq_Prim
: Entity_Id
;
11495 Left_Op
: Entity_Id
;
11496 Renaming_Prim
: Entity_Id
;
11497 Right_Op
: Entity_Id
;
11498 Target
: Entity_Id
;
11500 -- Start of processing for Make_Neq_Body
11503 -- For a call on a renaming of a dispatching subprogram that is
11504 -- overridden, if the overriding occurred before the renaming, then
11505 -- the body executed is that of the overriding declaration, even if the
11506 -- overriding declaration is not visible at the place of the renaming;
11507 -- otherwise, the inherited or predefined subprogram is called, see
11510 -- Stage 1: Search for a renaming of the inequality primitive and also
11511 -- search for an overriding of the equality primitive located before the
11512 -- renaming declaration.
11520 Renaming_Prim
:= Empty
;
11522 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11523 while Present
(Elmt
) loop
11524 Prim
:= Node
(Elmt
);
11526 if Is_User_Defined_Equality
(Prim
) and then No
(Alias
(Prim
)) then
11527 if No
(Renaming_Prim
) then
11528 pragma Assert
(No
(Eq_Prim
));
11532 elsif Is_Predefined_Neq_Renaming
(Prim
) then
11533 Renaming_Prim
:= Prim
;
11540 -- No further action needed if no renaming was found
11542 if No
(Renaming_Prim
) then
11546 -- Stage 2: Replace the renaming declaration by a subprogram declaration
11547 -- (required to add its body)
11549 Decl
:= Parent
(Parent
(Renaming_Prim
));
11551 Make_Subprogram_Declaration
(Loc
,
11552 Specification
=> Specification
(Decl
)));
11553 Set_Analyzed
(Decl
);
11555 -- Remove the decoration of intrinsic renaming subprogram
11557 Set_Is_Intrinsic_Subprogram
(Renaming_Prim
, False);
11558 Set_Convention
(Renaming_Prim
, Convention_Ada
);
11559 Set_Alias
(Renaming_Prim
, Empty
);
11560 Set_Has_Completion
(Renaming_Prim
, False);
11562 -- Stage 3: Build the corresponding body
11564 Left_Op
:= First_Formal
(Renaming_Prim
);
11565 Right_Op
:= Next_Formal
(Left_Op
);
11568 Predef_Spec_Or_Body
(Loc
,
11569 Tag_Typ
=> Tag_Typ
,
11570 Name
=> Chars
(Renaming_Prim
),
11571 Profile
=> New_List
(
11572 Make_Parameter_Specification
(Loc
,
11573 Defining_Identifier
=>
11574 Make_Defining_Identifier
(Loc
, Chars
(Left_Op
)),
11575 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11577 Make_Parameter_Specification
(Loc
,
11578 Defining_Identifier
=>
11579 Make_Defining_Identifier
(Loc
, Chars
(Right_Op
)),
11580 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11582 Ret_Type
=> Standard_Boolean
,
11585 -- If the overriding of the equality primitive occurred before the
11586 -- renaming, then generate:
11588 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11590 -- return not Oeq (X, Y);
11593 if Present
(Eq_Prim
) then
11596 -- Otherwise build a nested subprogram which performs the predefined
11597 -- evaluation of the equality operator. That is, generate:
11599 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11600 -- function Oeq (X : Y) return Boolean is
11602 -- <<body of default implementation>>
11605 -- return not Oeq (X, Y);
11610 Local_Subp
: Node_Id
;
11612 Local_Subp
:= Make_Eq_Body
(Tag_Typ
, Name_Op_Eq
);
11613 Set_Declarations
(Decl
, New_List
(Local_Subp
));
11614 Target
:= Defining_Entity
(Local_Subp
);
11618 Set_Handled_Statement_Sequence
11620 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
11621 Make_Simple_Return_Statement
(Loc
,
11624 Make_Function_Call
(Loc
,
11625 Name
=> New_Occurrence_Of
(Target
, Loc
),
11626 Parameter_Associations
=> New_List
(
11627 Make_Identifier
(Loc
, Chars
(Left_Op
)),
11628 Make_Identifier
(Loc
, Chars
(Right_Op
)))))))));
11633 -------------------------------
11634 -- Make_Null_Procedure_Specs --
11635 -------------------------------
11637 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
is
11638 Decl_List
: constant List_Id
:= New_List
;
11639 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11640 Formal
: Entity_Id
;
11641 New_Param_Spec
: Node_Id
;
11642 New_Spec
: Node_Id
;
11643 Parent_Subp
: Entity_Id
;
11644 Prim_Elmt
: Elmt_Id
;
11648 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11649 while Present
(Prim_Elmt
) loop
11650 Subp
:= Node
(Prim_Elmt
);
11652 -- If a null procedure inherited from an interface has not been
11653 -- overridden, then we build a null procedure declaration to
11654 -- override the inherited procedure.
11656 Parent_Subp
:= Alias
(Subp
);
11658 if Present
(Parent_Subp
)
11659 and then Is_Null_Interface_Primitive
(Parent_Subp
)
11661 -- The null procedure spec is copied from the inherited procedure,
11662 -- except for the IS NULL (which must be added) and the overriding
11663 -- indicators (which must be removed, if present).
11666 Copy_Subprogram_Spec
(Subprogram_Specification
(Subp
), Loc
);
11668 Set_Null_Present
(New_Spec
, True);
11669 Set_Must_Override
(New_Spec
, False);
11670 Set_Must_Not_Override
(New_Spec
, False);
11672 Formal
:= First_Formal
(Subp
);
11673 New_Param_Spec
:= First
(Parameter_Specifications
(New_Spec
));
11675 while Present
(Formal
) loop
11677 -- For controlling arguments we must change their parameter
11678 -- type to reference the tagged type (instead of the interface
11681 if Is_Controlling_Formal
(Formal
) then
11682 if Nkind
(Parameter_Type
(Parent
(Formal
))) = N_Identifier
11684 Set_Parameter_Type
(New_Param_Spec
,
11685 New_Occurrence_Of
(Tag_Typ
, Loc
));
11688 (Nkind
(Parameter_Type
(Parent
(Formal
))) =
11689 N_Access_Definition
);
11690 Set_Subtype_Mark
(Parameter_Type
(New_Param_Spec
),
11691 New_Occurrence_Of
(Tag_Typ
, Loc
));
11695 Next_Formal
(Formal
);
11696 Next
(New_Param_Spec
);
11699 Append_To
(Decl_List
,
11700 Make_Subprogram_Declaration
(Loc
,
11701 Specification
=> New_Spec
));
11704 Next_Elmt
(Prim_Elmt
);
11708 end Make_Null_Procedure_Specs
;
11710 ---------------------------------------
11711 -- Make_Predefined_Primitive_Eq_Spec --
11712 ---------------------------------------
11714 procedure Make_Predefined_Primitive_Eq_Spec
11715 (Tag_Typ
: Entity_Id
;
11716 Predef_List
: List_Id
;
11717 Renamed_Eq
: out Entity_Id
)
11719 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
11720 -- Returns true if Prim is a renaming of an unresolved predefined
11721 -- equality operation.
11723 -------------------------------
11724 -- Is_Predefined_Eq_Renaming --
11725 -------------------------------
11727 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
11729 return Chars
(Prim
) /= Name_Op_Eq
11730 and then Present
(Alias
(Prim
))
11731 and then Comes_From_Source
(Prim
)
11732 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11733 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
11734 end Is_Predefined_Eq_Renaming
;
11738 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11740 Eq_Name
: Name_Id
:= Name_Op_Eq
;
11741 Eq_Needed
: Boolean := True;
11745 Has_Predef_Eq_Renaming
: Boolean := False;
11746 -- Set to True if Tag_Typ has a primitive that renames the predefined
11747 -- equality operator. Used to implement (RM 8-5-4(8)).
11749 -- Start of processing for Make_Predefined_Primitive_Specs
11752 Renamed_Eq
:= Empty
;
11754 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11755 while Present
(Prim
) loop
11757 -- If a primitive is encountered that renames the predefined equality
11758 -- operator before reaching any explicit equality primitive, then we
11759 -- still need to create a predefined equality function, because calls
11760 -- to it can occur via the renaming. A new name is created for the
11761 -- equality to avoid conflicting with any user-defined equality.
11762 -- (Note that this doesn't account for renamings of equality nested
11763 -- within subpackages???)
11765 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
11766 Has_Predef_Eq_Renaming
:= True;
11767 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
11769 -- User-defined equality
11771 elsif Is_User_Defined_Equality
(Node
(Prim
)) then
11772 if No
(Alias
(Node
(Prim
)))
11773 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
11774 N_Subprogram_Renaming_Declaration
11776 Eq_Needed
:= False;
11779 -- If the parent is not an interface type and has an abstract
11780 -- equality function explicitly defined in the sources, then the
11781 -- inherited equality is abstract as well, and no body can be
11784 elsif not Is_Interface
(Etype
(Tag_Typ
))
11785 and then Present
(Alias
(Node
(Prim
)))
11786 and then Comes_From_Source
(Alias
(Node
(Prim
)))
11787 and then Is_Abstract_Subprogram
(Alias
(Node
(Prim
)))
11789 Eq_Needed
:= False;
11792 -- If the type has an equality function corresponding with a
11793 -- primitive defined in an interface type, the inherited equality
11794 -- is abstract as well, and no body can be created for it.
11796 elsif Present
(Alias
(Node
(Prim
)))
11797 and then Comes_From_Source
(Ultimate_Alias
(Node
(Prim
)))
11800 (Find_Dispatching_Type
(Ultimate_Alias
(Node
(Prim
))))
11802 Eq_Needed
:= False;
11810 -- If a renaming of predefined equality was found but there was no
11811 -- user-defined equality (so Eq_Needed is still true), then set the name
11812 -- back to Name_Op_Eq. But in the case where a user-defined equality was
11813 -- located after such a renaming, then the predefined equality function
11814 -- is still needed, so Eq_Needed must be set back to True.
11816 if Eq_Name
/= Name_Op_Eq
then
11818 Eq_Name
:= Name_Op_Eq
;
11825 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
11826 Tag_Typ
=> Tag_Typ
,
11828 Profile
=> New_List
(
11829 Make_Parameter_Specification
(Loc
,
11830 Defining_Identifier
=>
11831 Make_Defining_Identifier
(Loc
, Name_X
),
11832 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11834 Make_Parameter_Specification
(Loc
,
11835 Defining_Identifier
=>
11836 Make_Defining_Identifier
(Loc
, Name_Y
),
11837 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11838 Ret_Type
=> Standard_Boolean
);
11839 Append_To
(Predef_List
, Eq_Spec
);
11841 if Has_Predef_Eq_Renaming
then
11842 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
11844 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11845 while Present
(Prim
) loop
11847 -- Any renamings of equality that appeared before an overriding
11848 -- equality must be updated to refer to the entity for the
11849 -- predefined equality, otherwise calls via the renaming would
11850 -- get incorrectly resolved to call the user-defined equality
11853 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
11854 Set_Alias
(Node
(Prim
), Renamed_Eq
);
11856 -- Exit upon encountering a user-defined equality
11858 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
11859 and then No
(Alias
(Node
(Prim
)))
11868 end Make_Predefined_Primitive_Eq_Spec
;
11870 -------------------------------------
11871 -- Make_Predefined_Primitive_Specs --
11872 -------------------------------------
11874 procedure Make_Predefined_Primitive_Specs
11875 (Tag_Typ
: Entity_Id
;
11876 Predef_List
: out List_Id
;
11877 Renamed_Eq
: out Entity_Id
)
11879 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11880 Res
: constant List_Id
:= New_List
;
11885 Renamed_Eq
:= Empty
;
11889 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11890 Tag_Typ
=> Tag_Typ
,
11891 Name
=> Name_uSize
,
11892 Profile
=> New_List
(
11893 Make_Parameter_Specification
(Loc
,
11894 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
11895 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11897 Ret_Type
=> Standard_Long_Long_Integer
));
11899 -- Spec of Put_Image
11901 if (not No_Run_Time_Mode
)
11902 and then RTE_Available
(RE_Root_Buffer_Type
)
11904 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
11905 -- (like any tagged type) will be rejected. Given this, avoid
11906 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
11909 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11910 Tag_Typ
=> Tag_Typ
,
11911 Name
=> Make_TSS_Name
(Tag_Typ
, TSS_Put_Image
),
11912 Profile
=> Build_Put_Image_Profile
(Loc
, Tag_Typ
)));
11915 -- Specs for dispatching stream attributes
11918 Stream_Op_TSS_Names
:
11919 constant array (Positive range <>) of TSS_Name_Type
:=
11923 TSS_Stream_Output
);
11926 for Op
in Stream_Op_TSS_Names
'Range loop
11927 if Stream_Operation_OK
(Tag_Typ
, Stream_Op_TSS_Names
(Op
)) then
11929 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
,
11930 Stream_Op_TSS_Names
(Op
)));
11935 -- Spec of "=" is expanded if the type is not limited and if a user
11936 -- defined "=" was not already declared for the non-full view of a
11937 -- private extension.
11939 if not Is_Limited_Type
(Tag_Typ
) then
11940 Make_Predefined_Primitive_Eq_Spec
(Tag_Typ
, Res
, Renamed_Eq
);
11942 -- Spec for dispatching assignment
11944 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
11945 Tag_Typ
=> Tag_Typ
,
11946 Name
=> Name_uAssign
,
11947 Profile
=> New_List
(
11948 Make_Parameter_Specification
(Loc
,
11949 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
11950 Out_Present
=> True,
11951 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11953 Make_Parameter_Specification
(Loc
,
11954 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
11955 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)))));
11958 -- Ada 2005: Generate declarations for the following primitive
11959 -- operations for limited interfaces and synchronized types that
11960 -- implement a limited interface.
11962 -- Disp_Asynchronous_Select
11963 -- Disp_Conditional_Select
11964 -- Disp_Get_Prim_Op_Kind
11965 -- Disp_Get_Task_Id
11967 -- Disp_Timed_Select
11969 -- Disable the generation of these bodies if Ravenscar or ZFP is active
11971 if Ada_Version
>= Ada_2005
11972 and then not Restriction_Active
(No_Select_Statements
)
11973 and then RTE_Available
(RE_Select_Specific_Data
)
11975 -- These primitives are defined abstract in interface types
11977 if Is_Interface
(Tag_Typ
)
11978 and then Is_Limited_Record
(Tag_Typ
)
11981 Make_Abstract_Subprogram_Declaration
(Loc
,
11983 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
11986 Make_Abstract_Subprogram_Declaration
(Loc
,
11988 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
11991 Make_Abstract_Subprogram_Declaration
(Loc
,
11993 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
11996 Make_Abstract_Subprogram_Declaration
(Loc
,
11998 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12001 Make_Abstract_Subprogram_Declaration
(Loc
,
12003 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12006 Make_Abstract_Subprogram_Declaration
(Loc
,
12008 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12010 -- If ancestor is an interface type, declare non-abstract primitives
12011 -- to override the abstract primitives of the interface type.
12013 -- In VM targets we define these primitives in all root tagged types
12014 -- that are not interface types. Done because in VM targets we don't
12015 -- have secondary dispatch tables and any derivation of Tag_Typ may
12016 -- cover limited interfaces (which always have these primitives since
12017 -- they may be ancestors of synchronized interface types).
12019 elsif (not Is_Interface
(Tag_Typ
)
12020 and then Is_Interface
(Etype
(Tag_Typ
))
12021 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12023 (Is_Concurrent_Record_Type
(Tag_Typ
)
12024 and then Has_Interfaces
(Tag_Typ
))
12026 (not Tagged_Type_Expansion
12027 and then not Is_Interface
(Tag_Typ
)
12028 and then Tag_Typ
= Root_Type
(Tag_Typ
))
12031 Make_Subprogram_Declaration
(Loc
,
12033 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
12036 Make_Subprogram_Declaration
(Loc
,
12038 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
12041 Make_Subprogram_Declaration
(Loc
,
12043 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
12046 Make_Subprogram_Declaration
(Loc
,
12048 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12051 Make_Subprogram_Declaration
(Loc
,
12053 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12056 Make_Subprogram_Declaration
(Loc
,
12058 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12062 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
12063 -- regardless of whether they are controlled or may contain controlled
12066 -- Do not generate the routines if finalization is disabled
12068 if Restriction_Active
(No_Finalization
) then
12072 if not Is_Limited_Type
(Tag_Typ
) then
12073 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
12076 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
12079 Predef_List
:= Res
;
12080 end Make_Predefined_Primitive_Specs
;
12082 -------------------------
12083 -- Make_Tag_Assignment --
12084 -------------------------
12086 function Make_Tag_Assignment
(N
: Node_Id
) return Node_Id
is
12087 Loc
: constant Source_Ptr
:= Sloc
(N
);
12088 Def_If
: constant Entity_Id
:= Defining_Identifier
(N
);
12089 Expr
: constant Node_Id
:= Expression
(N
);
12090 Typ
: constant Entity_Id
:= Etype
(Def_If
);
12091 Full_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
12096 -- This expansion activity is called during analysis
12098 if Is_Tagged_Type
(Typ
)
12099 and then not Is_Class_Wide_Type
(Typ
)
12100 and then not Is_CPP_Class
(Typ
)
12101 and then Tagged_Type_Expansion
12102 and then Nkind
(Expr
) /= N_Aggregate
12103 and then (Nkind
(Expr
) /= N_Qualified_Expression
12104 or else Nkind
(Expression
(Expr
)) /= N_Aggregate
)
12107 Make_Selected_Component
(Loc
,
12108 Prefix
=> New_Occurrence_Of
(Def_If
, Loc
),
12110 New_Occurrence_Of
(First_Tag_Component
(Full_Typ
), Loc
));
12112 Set_Assignment_OK
(New_Ref
);
12115 Make_Assignment_Statement
(Loc
,
12118 Unchecked_Convert_To
(RTE
(RE_Tag
),
12120 (Node
(First_Elmt
(Access_Disp_Table
(Full_Typ
))), Loc
)));
12124 end Make_Tag_Assignment
;
12126 ----------------------
12127 -- Predef_Deep_Spec --
12128 ----------------------
12130 function Predef_Deep_Spec
12132 Tag_Typ
: Entity_Id
;
12133 Name
: TSS_Name_Type
;
12134 For_Body
: Boolean := False) return Node_Id
12139 -- V : in out Tag_Typ
12141 Formals
:= New_List
(
12142 Make_Parameter_Specification
(Loc
,
12143 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
12144 In_Present
=> True,
12145 Out_Present
=> True,
12146 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)));
12148 -- F : Boolean := True
12150 if Name
= TSS_Deep_Adjust
12151 or else Name
= TSS_Deep_Finalize
12153 Append_To
(Formals
,
12154 Make_Parameter_Specification
(Loc
,
12155 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
12156 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12157 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12161 Predef_Spec_Or_Body
(Loc
,
12162 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12163 Tag_Typ
=> Tag_Typ
,
12164 Profile
=> Formals
,
12165 For_Body
=> For_Body
);
12168 when RE_Not_Available
=>
12170 end Predef_Deep_Spec
;
12172 -------------------------
12173 -- Predef_Spec_Or_Body --
12174 -------------------------
12176 function Predef_Spec_Or_Body
12178 Tag_Typ
: Entity_Id
;
12181 Ret_Type
: Entity_Id
:= Empty
;
12182 For_Body
: Boolean := False) return Node_Id
12184 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
12188 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
12190 -- The internal flag is set to mark these declarations because they have
12191 -- specific properties. First, they are primitives even if they are not
12192 -- defined in the type scope (the freezing point is not necessarily in
12193 -- the same scope). Second, the predefined equality can be overridden by
12194 -- a user-defined equality, no body will be generated in this case.
12196 Set_Is_Internal
(Id
);
12198 if not Debug_Generated_Code
then
12199 Set_Debug_Info_Off
(Id
);
12202 if No
(Ret_Type
) then
12204 Make_Procedure_Specification
(Loc
,
12205 Defining_Unit_Name
=> Id
,
12206 Parameter_Specifications
=> Profile
);
12209 Make_Function_Specification
(Loc
,
12210 Defining_Unit_Name
=> Id
,
12211 Parameter_Specifications
=> Profile
,
12212 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
12215 -- Declare an abstract subprogram for primitive subprograms of an
12216 -- interface type (except for "=").
12218 if Is_Interface
(Tag_Typ
) then
12219 if Name
/= Name_Op_Eq
then
12220 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12222 -- The equality function (if any) for an interface type is defined
12223 -- to be nonabstract, so we create an expression function for it that
12224 -- always returns False. Note that the function can never actually be
12225 -- invoked because interface types are abstract, so there aren't any
12226 -- objects of such types (and their equality operation will always
12230 return Make_Expression_Function
12231 (Loc
, Spec
, New_Occurrence_Of
(Standard_False
, Loc
));
12234 -- If body case, return empty subprogram body. Note that this is ill-
12235 -- formed, because there is not even a null statement, and certainly not
12236 -- a return in the function case. The caller is expected to do surgery
12237 -- on the body to add the appropriate stuff.
12239 elsif For_Body
then
12240 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
12242 -- For the case of an Input attribute predefined for an abstract type,
12243 -- generate an abstract specification. This will never be called, but we
12244 -- need the slot allocated in the dispatching table so that attributes
12245 -- typ'Class'Input and typ'Class'Output will work properly.
12247 elsif Is_TSS
(Name
, TSS_Stream_Input
)
12248 and then Is_Abstract_Type
(Tag_Typ
)
12250 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12252 -- Normal spec case, where we return a subprogram declaration
12255 return Make_Subprogram_Declaration
(Loc
, Spec
);
12257 end Predef_Spec_Or_Body
;
12259 -----------------------------
12260 -- Predef_Stream_Attr_Spec --
12261 -----------------------------
12263 function Predef_Stream_Attr_Spec
12265 Tag_Typ
: Entity_Id
;
12266 Name
: TSS_Name_Type
) return Node_Id
12268 Ret_Type
: Entity_Id
;
12271 if Name
= TSS_Stream_Input
then
12272 Ret_Type
:= Tag_Typ
;
12278 Predef_Spec_Or_Body
12280 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12281 Tag_Typ
=> Tag_Typ
,
12282 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
12283 Ret_Type
=> Ret_Type
,
12284 For_Body
=> False);
12285 end Predef_Stream_Attr_Spec
;
12287 ----------------------------------
12288 -- Predefined_Primitive_Eq_Body --
12289 ----------------------------------
12291 procedure Predefined_Primitive_Eq_Body
12292 (Tag_Typ
: Entity_Id
;
12293 Predef_List
: List_Id
;
12294 Renamed_Eq
: Entity_Id
)
12297 Eq_Needed
: Boolean;
12302 -- See if we have a predefined "=" operator
12304 if Present
(Renamed_Eq
) then
12306 Eq_Name
:= Chars
(Renamed_Eq
);
12308 -- If the parent is an interface type then it has defined all the
12309 -- predefined primitives abstract and we need to check if the type
12310 -- has some user defined "=" function which matches the profile of
12311 -- the Ada predefined equality operator to avoid generating it.
12313 elsif Is_Interface
(Etype
(Tag_Typ
)) then
12315 Eq_Name
:= Name_Op_Eq
;
12317 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12318 while Present
(Prim
) loop
12319 if Is_User_Defined_Equality
(Node
(Prim
))
12320 and then not Is_Internal
(Node
(Prim
))
12322 Eq_Needed
:= False;
12323 Eq_Name
:= No_Name
;
12331 Eq_Needed
:= False;
12332 Eq_Name
:= No_Name
;
12334 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12335 while Present
(Prim
) loop
12336 if Is_User_Defined_Equality
(Node
(Prim
))
12337 and then Is_Internal
(Node
(Prim
))
12340 Eq_Name
:= Name_Op_Eq
;
12348 -- If equality is needed, we will have its name
12350 pragma Assert
(Eq_Needed
= Present
(Eq_Name
));
12352 -- Body for equality
12355 Decl
:= Make_Eq_Body
(Tag_Typ
, Eq_Name
);
12356 Append_To
(Predef_List
, Decl
);
12359 -- Body for inequality (if required)
12361 Decl
:= Make_Neq_Body
(Tag_Typ
);
12363 if Present
(Decl
) then
12364 Append_To
(Predef_List
, Decl
);
12366 end Predefined_Primitive_Eq_Body
;
12368 ---------------------------------
12369 -- Predefined_Primitive_Bodies --
12370 ---------------------------------
12372 function Predefined_Primitive_Bodies
12373 (Tag_Typ
: Entity_Id
;
12374 Renamed_Eq
: Entity_Id
) return List_Id
12376 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12377 Res
: constant List_Id
:= New_List
;
12378 Adj_Call
: Node_Id
;
12380 Fin_Call
: Node_Id
;
12383 pragma Warnings
(Off
, Ent
);
12388 pragma Assert
(not Is_Interface
(Tag_Typ
));
12392 Decl
:= Predef_Spec_Or_Body
(Loc
,
12393 Tag_Typ
=> Tag_Typ
,
12394 Name
=> Name_uSize
,
12395 Profile
=> New_List
(
12396 Make_Parameter_Specification
(Loc
,
12397 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12398 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12400 Ret_Type
=> Standard_Long_Long_Integer
,
12403 Set_Handled_Statement_Sequence
(Decl
,
12404 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12405 Make_Simple_Return_Statement
(Loc
,
12407 Make_Attribute_Reference
(Loc
,
12408 Prefix
=> Make_Identifier
(Loc
, Name_X
),
12409 Attribute_Name
=> Name_Size
)))));
12411 Append_To
(Res
, Decl
);
12413 -- Body of Put_Image
12415 if No
(TSS
(Tag_Typ
, TSS_Put_Image
))
12416 and then (not No_Run_Time_Mode
)
12417 and then RTE_Available
(RE_Root_Buffer_Type
)
12419 Build_Record_Put_Image_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12420 Append_To
(Res
, Decl
);
12423 -- Bodies for Dispatching stream IO routines. We need these only for
12424 -- non-limited types (in the limited case there is no dispatching).
12425 -- We also skip them if dispatching or finalization are not available
12426 -- or if stream operations are prohibited by restriction No_Streams or
12427 -- from use of pragma/aspect No_Tagged_Streams.
12429 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Read
)
12430 and then No
(TSS
(Tag_Typ
, TSS_Stream_Read
))
12432 Build_Record_Read_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12433 Append_To
(Res
, Decl
);
12436 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Write
)
12437 and then No
(TSS
(Tag_Typ
, TSS_Stream_Write
))
12439 Build_Record_Write_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12440 Append_To
(Res
, Decl
);
12443 -- Skip body of _Input for the abstract case, since the corresponding
12444 -- spec is abstract (see Predef_Spec_Or_Body).
12446 if not Is_Abstract_Type
(Tag_Typ
)
12447 and then Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Input
)
12448 and then No
(TSS
(Tag_Typ
, TSS_Stream_Input
))
12450 Build_Record_Or_Elementary_Input_Function
12451 (Loc
, Tag_Typ
, Decl
, Ent
);
12452 Append_To
(Res
, Decl
);
12455 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Output
)
12456 and then No
(TSS
(Tag_Typ
, TSS_Stream_Output
))
12458 Build_Record_Or_Elementary_Output_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
12459 Append_To
(Res
, Decl
);
12462 -- Ada 2005: Generate bodies for the following primitive operations for
12463 -- limited interfaces and synchronized types that implement a limited
12466 -- disp_asynchronous_select
12467 -- disp_conditional_select
12468 -- disp_get_prim_op_kind
12469 -- disp_get_task_id
12470 -- disp_timed_select
12472 -- The interface versions will have null bodies
12474 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12476 -- In VM targets we define these primitives in all root tagged types
12477 -- that are not interface types. Done because in VM targets we don't
12478 -- have secondary dispatch tables and any derivation of Tag_Typ may
12479 -- cover limited interfaces (which always have these primitives since
12480 -- they may be ancestors of synchronized interface types).
12482 if Ada_Version
>= Ada_2005
12484 ((Is_Interface
(Etype
(Tag_Typ
))
12485 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12487 (Is_Concurrent_Record_Type
(Tag_Typ
)
12488 and then Has_Interfaces
(Tag_Typ
))
12490 (not Tagged_Type_Expansion
12491 and then Tag_Typ
= Root_Type
(Tag_Typ
)))
12492 and then not Restriction_Active
(No_Select_Statements
)
12493 and then RTE_Available
(RE_Select_Specific_Data
)
12495 Append_To
(Res
, Make_Disp_Asynchronous_Select_Body
(Tag_Typ
));
12496 Append_To
(Res
, Make_Disp_Conditional_Select_Body
(Tag_Typ
));
12497 Append_To
(Res
, Make_Disp_Get_Prim_Op_Kind_Body
(Tag_Typ
));
12498 Append_To
(Res
, Make_Disp_Get_Task_Id_Body
(Tag_Typ
));
12499 Append_To
(Res
, Make_Disp_Requeue_Body
(Tag_Typ
));
12500 Append_To
(Res
, Make_Disp_Timed_Select_Body
(Tag_Typ
));
12503 if not Is_Limited_Type
(Tag_Typ
) then
12504 -- Body for equality and inequality
12506 Predefined_Primitive_Eq_Body
(Tag_Typ
, Res
, Renamed_Eq
);
12508 -- Body for dispatching assignment
12511 Predef_Spec_Or_Body
(Loc
,
12512 Tag_Typ
=> Tag_Typ
,
12513 Name
=> Name_uAssign
,
12514 Profile
=> New_List
(
12515 Make_Parameter_Specification
(Loc
,
12516 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12517 Out_Present
=> True,
12518 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12520 Make_Parameter_Specification
(Loc
,
12521 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12522 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12525 Set_Handled_Statement_Sequence
(Decl
,
12526 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12527 Make_Assignment_Statement
(Loc
,
12528 Name
=> Make_Identifier
(Loc
, Name_X
),
12529 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
12531 Append_To
(Res
, Decl
);
12534 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
12535 -- tagged types which do not contain controlled components.
12537 -- Do not generate the routines if finalization is disabled
12539 if Restriction_Active
(No_Finalization
) then
12542 elsif not Has_Controlled_Component
(Tag_Typ
) then
12543 if not Is_Limited_Type
(Tag_Typ
) then
12545 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
12547 if Is_Controlled
(Tag_Typ
) then
12550 Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12554 if No
(Adj_Call
) then
12555 Adj_Call
:= Make_Null_Statement
(Loc
);
12558 Set_Handled_Statement_Sequence
(Decl
,
12559 Make_Handled_Sequence_Of_Statements
(Loc
,
12560 Statements
=> New_List
(Adj_Call
)));
12562 Append_To
(Res
, Decl
);
12566 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
12568 if Is_Controlled
(Tag_Typ
) then
12571 (Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12575 if No
(Fin_Call
) then
12576 Fin_Call
:= Make_Null_Statement
(Loc
);
12579 Set_Handled_Statement_Sequence
(Decl
,
12580 Make_Handled_Sequence_Of_Statements
(Loc
,
12581 Statements
=> New_List
(Fin_Call
)));
12583 Append_To
(Res
, Decl
);
12587 end Predefined_Primitive_Bodies
;
12589 ---------------------------------
12590 -- Predefined_Primitive_Freeze --
12591 ---------------------------------
12593 function Predefined_Primitive_Freeze
12594 (Tag_Typ
: Entity_Id
) return List_Id
12596 Res
: constant List_Id
:= New_List
;
12601 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12602 while Present
(Prim
) loop
12603 if Is_Predefined_Dispatching_Operation
(Node
(Prim
)) then
12604 Frnodes
:= Freeze_Entity
(Node
(Prim
), Tag_Typ
);
12606 if Present
(Frnodes
) then
12607 Append_List_To
(Res
, Frnodes
);
12615 end Predefined_Primitive_Freeze
;
12617 -------------------------
12618 -- Stream_Operation_OK --
12619 -------------------------
12621 function Stream_Operation_OK
12623 Operation
: TSS_Name_Type
) return Boolean
12625 Has_Predefined_Or_Specified_Stream_Attribute
: Boolean := False;
12628 -- Special case of a limited type extension: a default implementation
12629 -- of the stream attributes Read or Write exists if that attribute
12630 -- has been specified or is available for an ancestor type; a default
12631 -- implementation of the attribute Output (resp. Input) exists if the
12632 -- attribute has been specified or Write (resp. Read) is available for
12633 -- an ancestor type. The last condition only applies under Ada 2005.
12635 if Is_Limited_Type
(Typ
) and then Is_Tagged_Type
(Typ
) then
12636 if Operation
= TSS_Stream_Read
then
12637 Has_Predefined_Or_Specified_Stream_Attribute
:=
12638 Has_Specified_Stream_Read
(Typ
);
12640 elsif Operation
= TSS_Stream_Write
then
12641 Has_Predefined_Or_Specified_Stream_Attribute
:=
12642 Has_Specified_Stream_Write
(Typ
);
12644 elsif Operation
= TSS_Stream_Input
then
12645 Has_Predefined_Or_Specified_Stream_Attribute
:=
12646 Has_Specified_Stream_Input
(Typ
)
12648 (Ada_Version
>= Ada_2005
12649 and then Stream_Operation_OK
(Typ
, TSS_Stream_Read
));
12651 elsif Operation
= TSS_Stream_Output
then
12652 Has_Predefined_Or_Specified_Stream_Attribute
:=
12653 Has_Specified_Stream_Output
(Typ
)
12655 (Ada_Version
>= Ada_2005
12656 and then Stream_Operation_OK
(Typ
, TSS_Stream_Write
));
12659 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
12661 if not Has_Predefined_Or_Specified_Stream_Attribute
12662 and then Is_Derived_Type
(Typ
)
12663 and then (Operation
= TSS_Stream_Read
12664 or else Operation
= TSS_Stream_Write
)
12666 Has_Predefined_Or_Specified_Stream_Attribute
:=
12668 (Find_Inherited_TSS
(Base_Type
(Etype
(Typ
)), Operation
));
12672 -- If the type is not limited, or else is limited but the attribute is
12673 -- explicitly specified or is predefined for the type, then return True,
12674 -- unless other conditions prevail, such as restrictions prohibiting
12675 -- streams or dispatching operations. We also return True for limited
12676 -- interfaces, because they may be extended by nonlimited types and
12677 -- permit inheritance in this case (addresses cases where an abstract
12678 -- extension doesn't get 'Input declared, as per comments below, but
12679 -- 'Class'Input must still be allowed). Note that attempts to apply
12680 -- stream attributes to a limited interface or its class-wide type
12681 -- (or limited extensions thereof) will still get properly rejected
12682 -- by Check_Stream_Attribute.
12684 -- We exclude the Input operation from being a predefined subprogram in
12685 -- the case where the associated type is an abstract extension, because
12686 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
12687 -- we don't want an abstract version created because types derived from
12688 -- the abstract type may not even have Input available (for example if
12689 -- derived from a private view of the abstract type that doesn't have
12690 -- a visible Input).
12692 -- Do not generate stream routines for type Finalization_Master because
12693 -- a master may never appear in types and therefore cannot be read or
12697 (not Is_Limited_Type
(Typ
)
12698 or else Is_Interface
(Typ
)
12699 or else Has_Predefined_Or_Specified_Stream_Attribute
)
12701 (Operation
/= TSS_Stream_Input
12702 or else not Is_Abstract_Type
(Typ
)
12703 or else not Is_Derived_Type
(Typ
))
12704 and then not Has_Unknown_Discriminants
(Typ
)
12705 and then not Is_Concurrent_Interface
(Typ
)
12706 and then not Restriction_Active
(No_Streams
)
12707 and then not Restriction_Active
(No_Dispatch
)
12708 and then No
(No_Tagged_Streams_Pragma
(Typ
))
12709 and then not No_Run_Time_Mode
12710 and then RTE_Available
(RE_Tag
)
12711 and then No
(Type_Without_Stream_Operation
(Typ
))
12712 and then RTE_Available
(RE_Root_Stream_Type
)
12713 and then not Is_RTE
(Typ
, RE_Finalization_Master
);
12714 end Stream_Operation_OK
;