1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Mutably_Tagged
; use Mutably_Tagged
;
53 with Namet
; use Namet
;
54 with Nlists
; use Nlists
;
55 with Nmake
; use Nmake
;
57 with Restrict
; use Restrict
;
58 with Rident
; use Rident
;
59 with Rtsfind
; use Rtsfind
;
61 with Sem_Aux
; use Sem_Aux
;
62 with Sem_Attr
; use Sem_Attr
;
63 with Sem_Cat
; use Sem_Cat
;
64 with Sem_Ch3
; use Sem_Ch3
;
65 with Sem_Ch6
; use Sem_Ch6
;
66 with Sem_Ch8
; use Sem_Ch8
;
67 with Sem_Disp
; use Sem_Disp
;
68 with Sem_Eval
; use Sem_Eval
;
69 with Sem_Mech
; use Sem_Mech
;
70 with Sem_Res
; use Sem_Res
;
71 with Sem_SCIL
; use Sem_SCIL
;
72 with Sem_Type
; use Sem_Type
;
73 with Sem_Util
; use Sem_Util
;
74 with Sinfo
; use Sinfo
;
75 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
76 with Sinfo
.Utils
; use Sinfo
.Utils
;
77 with Stand
; use Stand
;
78 with Snames
; use Snames
;
79 with Tbuild
; use Tbuild
;
80 with Ttypes
; use Ttypes
;
81 with Validsw
; use Validsw
;
83 package body Exp_Ch3
is
85 -----------------------
86 -- Local Subprograms --
87 -----------------------
89 procedure Adjust_Discriminants
(Rtype
: Entity_Id
);
90 -- This is used when freezing a record type. It attempts to construct
91 -- more restrictive subtypes for discriminants so that the max size of
92 -- the record can be calculated more accurately. See the body of this
93 -- procedure for details.
95 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
);
96 -- Build initialization procedure for given array type. Nod is a node
97 -- used for attachment of any actions required in its construction.
98 -- It also supplies the source location used for the procedure.
100 function Build_Discriminant_Formals
102 Use_Dl
: Boolean) return List_Id
;
103 -- This function uses the discriminants of a type to build a list of
104 -- formal parameters, used in Build_Init_Procedure among other places.
105 -- If the flag Use_Dl is set, the list is built using the already
106 -- defined discriminals of the type, as is the case for concurrent
107 -- types with discriminants. Otherwise new identifiers are created,
108 -- with the source names of the discriminants.
110 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
);
111 -- For each variant component, builds a function which checks whether
112 -- the component name is consistent with the current discriminants
113 -- and sets the component's Dcheck_Function attribute to refer to it.
114 -- N is the full type declaration node; the discriminant checking
115 -- functions are inserted after this node.
117 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
;
118 -- This function builds a static aggregate that can serve as the initial
119 -- value for an array type whose bounds are static, and whose component
120 -- type is a composite type that has a static equivalent aggregate.
121 -- The equivalent array aggregate is used both for object initialization
122 -- and for component initialization, when used in the following function.
124 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
;
125 -- This function builds a static aggregate that can serve as the initial
126 -- value for a record type whose components are scalar and initialized
127 -- with compile-time values, or arrays with similar initialization or
128 -- defaults. When possible, initialization of an object of the type can
129 -- be achieved by using a copy of the aggregate as an initial value, thus
130 -- removing the implicit call that would otherwise constitute elaboration
133 procedure Build_Record_Init_Proc
(N
: Node_Id
; Rec_Ent
: Entity_Id
);
134 -- Build record initialization procedure. N is the type declaration
135 -- node, and Rec_Ent is the corresponding entity for the record type.
137 procedure Build_Slice_Assignment
(Typ
: Entity_Id
);
138 -- Build assignment procedure for one-dimensional arrays of controlled
139 -- types. Other array and slice assignments are expanded in-line, but
140 -- the code expansion for controlled components (when control actions
141 -- are active) can lead to very large blocks that GCC handles poorly.
143 procedure Build_Untagged_Record_Equality
(Typ
: Entity_Id
);
144 -- AI05-0123: Equality on untagged records composes. This procedure
145 -- builds the equality routine for an untagged record that has components
146 -- of a record type that has user-defined primitive equality operations.
147 -- The resulting operation is a TSS subprogram.
149 procedure Check_Stream_Attributes
(Typ
: Entity_Id
);
150 -- Check that if a limited extension has a parent with user-defined stream
151 -- attributes, and does not itself have user-defined stream-attributes,
152 -- then any limited component of the extension also has the corresponding
153 -- user-defined stream attributes.
155 procedure Clean_Task_Names
157 Proc_Id
: Entity_Id
);
158 -- If an initialization procedure includes calls to generate names
159 -- for task subcomponents, indicate that secondary stack cleanup is
160 -- needed after an initialization. Typ is the component type, and Proc_Id
161 -- the initialization procedure for the enclosing composite type.
163 procedure Copy_Discr_Checking_Funcs
(N
: Node_Id
);
164 -- For a derived untagged type, copy the attributes that were set
165 -- for the components of the parent type onto the components of the
166 -- derived type. No new subprograms are constructed.
167 -- N is the full type declaration node, as for Build_Discr_Checking_Funcs.
169 procedure Expand_Freeze_Array_Type
(N
: Node_Id
);
170 -- Freeze an array type. Deals with building the initialization procedure,
171 -- creating the packed array type for a packed array and also with the
172 -- creation of the controlling procedures for the controlled case. The
173 -- argument N is the N_Freeze_Entity node for the type.
175 procedure Expand_Freeze_Class_Wide_Type
(N
: Node_Id
);
176 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
177 -- of finalizing controlled derivations from the class-wide's root type.
179 procedure Expand_Freeze_Enumeration_Type
(N
: Node_Id
);
180 -- Freeze enumeration type with non-standard representation. Builds the
181 -- array and function needed to convert between enumeration pos and
182 -- enumeration representation values. N is the N_Freeze_Entity node
185 procedure Expand_Freeze_Record_Type
(N
: Node_Id
);
186 -- Freeze record type. Builds all necessary discriminant checking
187 -- and other ancillary functions, and builds dispatch tables where
188 -- needed. The argument N is the N_Freeze_Entity node. This processing
189 -- applies only to E_Record_Type entities, not to class wide types,
190 -- record subtypes, or private types.
192 procedure Expand_Tagged_Root
(T
: Entity_Id
);
193 -- Add a field _Tag at the beginning of the record. This field carries
194 -- the value of the access to the Dispatch table. This procedure is only
195 -- called on root type, the _Tag field being inherited by the descendants.
197 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
);
198 -- Treat user-defined stream operations as renaming_as_body if the
199 -- subprogram they rename is not frozen when the type is frozen.
201 package Initialization_Control
is
203 function Requires_Late_Init
204 (Decl
: Node_Id
; Rec_Type
: Entity_Id
) return Boolean;
205 -- Return True iff the given component declaration requires late
206 -- initialization, as defined by 3.3.1 (8.1/5).
208 function Has_Late_Init_Component
209 (Tagged_Rec_Type
: Entity_Id
) return Boolean;
210 -- Return True iff the given tagged record type has at least one
211 -- component that requires late initialization; this includes
212 -- components of ancestor types.
214 type Initialization_Mode
is
215 (Full_Init
, Full_Init_Except_Tag
, Early_Init_Only
, Late_Init_Only
);
216 -- The initialization routine for a tagged type is passed in a
217 -- formal parameter of this type, indicating what initialization
218 -- is to be performed. This parameter defaults to Full_Init in all
219 -- cases except when the init proc of a type extension (let's call
220 -- that type T2) calls the init proc of its parent (let's call that
221 -- type T1). In that case, one of the other 3 values will
222 -- be passed in. In all three of those cases, the Tag component has
223 -- already been initialized before the call and is therefore not to be
224 -- modified. T2's init proc will either call T1's init proc
225 -- once (with Full_Init_Except_Tag as the parameter value) or twice
226 -- (first with Early_Init_Only, then later with Late_Init_Only),
227 -- depending on the result returned by Has_Late_Init_Component (T1).
228 -- In the latter case, the first call does not initialize any
229 -- components that require late initialization and the second call
230 -- then performs that deferred initialization.
231 -- Strictly speaking, the formal parameter subtype is actually Natural
232 -- but calls will only pass in values corresponding to literals
233 -- of this enumeration type.
235 function Make_Mode_Literal
236 (Loc
: Source_Ptr
; Mode
: Initialization_Mode
) return Node_Id
237 is (Make_Integer_Literal
(Loc
, Initialization_Mode
'Pos (Mode
)));
238 -- Generate an integer literal for a given mode value.
240 function Tag_Init_Condition
242 Init_Control_Formal
: Entity_Id
) return Node_Id
;
243 function Early_Init_Condition
245 Init_Control_Formal
: Entity_Id
) return Node_Id
;
246 function Late_Init_Condition
248 Init_Control_Formal
: Entity_Id
) return Node_Id
;
249 -- These three functions each return a Boolean expression that
250 -- can be used to determine whether a given call to the initialization
251 -- expression for a tagged type should initialize (respectively)
252 -- the Tag component, the non-Tag components that do not require late
253 -- initialization, and the components that do require late
256 end Initialization_Control
;
258 procedure Initialization_Warning
(E
: Entity_Id
);
259 -- If static elaboration of the package is requested, indicate
260 -- when a type does meet the conditions for static initialization. If
261 -- E is a type, it has components that have no static initialization.
262 -- if E is an entity, its initial expression is not compile-time known.
264 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
;
265 -- This function builds the list of formals for an initialization routine.
266 -- The first formal is always _Init with the given type. For task value
267 -- record types and types containing tasks, three additional formals are
268 -- added and Proc_Id is decorated with attribute Has_Master_Entity:
270 -- _Master : Master_Id
271 -- _Chain : in out Activation_Chain
272 -- _Task_Name : String
274 -- The caller must append additional entries for discriminants if required.
276 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean;
277 -- Returns true if the initialization procedure of Typ should be inlined
279 function In_Runtime
(E
: Entity_Id
) return Boolean;
280 -- Check if E is defined in the RTL (in a child of Ada or System). Used
281 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
283 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean;
284 -- Returns true if Stmts is made of null statements only, possibly wrapped
285 -- in a case statement, recursively. This latter pattern may occur for the
286 -- initialization procedure of an unchecked union.
288 function Make_Eq_Body
290 Eq_Name
: Name_Id
) return Node_Id
;
291 -- Build the body of a primitive equality operation for a tagged record
292 -- type, or in Ada 2012 for any record type that has components with a
293 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
295 function Make_Eq_Case
298 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
;
299 -- Building block for variant record equality. Defined to share the code
300 -- between the tagged and untagged case. Given a Component_List node CL,
301 -- it generates an 'if' followed by a 'case' statement that compares all
302 -- components of local temporaries named X and Y (that are declared as
303 -- formals at some upper level). E provides the Sloc to be used for the
306 -- IF E is an unchecked_union, Discrs is the list of formals created for
307 -- the inferred discriminants of one operand. These formals are used in
308 -- the generated case statements for each variant of the unchecked union.
312 L
: List_Id
) return Node_Id
;
313 -- Building block for variant record equality. Defined to share the code
314 -- between the tagged and untagged case. Given the list of components
315 -- (or discriminants) L, it generates a return statement that compares all
316 -- components of local temporaries named X and Y (that are declared as
317 -- formals at some upper level). E provides the Sloc to be used for the
320 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
;
321 -- Search for a renaming of the inequality dispatching primitive of
322 -- this tagged type. If found then build and return the corresponding
323 -- rename-as-body inequality subprogram; otherwise return Empty.
325 procedure Make_Predefined_Primitive_Specs
326 (Tag_Typ
: Entity_Id
;
327 Predef_List
: out List_Id
;
328 Renamed_Eq
: out Entity_Id
);
329 -- Create a list with the specs of the predefined primitive operations.
330 -- For tagged types that are interfaces all these primitives are defined
333 -- The following entries are present for all tagged types, and provide
334 -- the results of the corresponding attribute applied to the object.
335 -- Dispatching is required in general, since the result of the attribute
336 -- will vary with the actual object subtype.
338 -- _size provides result of 'Size attribute
339 -- typSR provides result of 'Read attribute
340 -- typSW provides result of 'Write attribute
341 -- typSI provides result of 'Input attribute
342 -- typSO provides result of 'Output attribute
343 -- typPI provides result of 'Put_Image attribute
345 -- The following entries are additionally present for non-limited tagged
346 -- types, and implement additional dispatching operations for predefined
349 -- _equality implements "=" operator
350 -- _assign implements assignment operation
351 -- typDF implements deep finalization
352 -- typDA implements deep adjust
354 -- The latter two are empty procedures unless the type contains some
355 -- controlled components that require finalization actions (the deep
356 -- in the name refers to the fact that the action applies to components).
358 -- The list of specs is returned in Predef_List
360 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean;
361 -- Returns True if there are representation clauses for type T that are not
362 -- inherited. If the result is false, the init_proc and the discriminant
363 -- checking functions of the parent can be reused by a derived type.
365 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
;
366 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
367 -- null procedures inherited from an interface type that have not been
368 -- overridden. Only one null procedure will be created for a given set of
369 -- inherited null procedures with homographic profiles.
371 function Predef_Spec_Or_Body
376 Ret_Type
: Entity_Id
:= Empty
;
377 For_Body
: Boolean := False) return Node_Id
;
378 -- This function generates the appropriate expansion for a predefined
379 -- primitive operation specified by its name, parameter profile and
380 -- return type (Empty means this is a procedure). If For_Body is false,
381 -- then the returned node is a subprogram declaration. If For_Body is
382 -- true, then the returned node is a empty subprogram body containing
383 -- no declarations and no statements.
385 function Predef_Stream_Attr_Spec
388 Name
: TSS_Name_Type
) return Node_Id
;
389 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
390 -- input and output attribute whose specs are constructed in Exp_Strm.
392 function Predef_Deep_Spec
395 Name
: TSS_Name_Type
;
396 For_Body
: Boolean := False) return Node_Id
;
397 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
398 -- and _deep_finalize
400 function Predefined_Primitive_Bodies
401 (Tag_Typ
: Entity_Id
;
402 Renamed_Eq
: Entity_Id
) return List_Id
;
403 -- Create the bodies of the predefined primitives that are described in
404 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
405 -- the defining unit name of the type's predefined equality as returned
406 -- by Make_Predefined_Primitive_Specs.
408 function Predefined_Primitive_Freeze
(Tag_Typ
: Entity_Id
) return List_Id
;
409 -- Freeze entities of all predefined primitive operations. This is needed
410 -- because the bodies of these operations do not normally do any freezing.
412 --------------------------
413 -- Adjust_Discriminants --
414 --------------------------
416 -- This procedure attempts to define subtypes for discriminants that are
417 -- more restrictive than those declared. Such a replacement is possible if
418 -- we can demonstrate that values outside the restricted range would cause
419 -- constraint errors in any case. The advantage of restricting the
420 -- discriminant types in this way is that the maximum size of the variant
421 -- record can be calculated more conservatively.
423 -- An example of a situation in which we can perform this type of
424 -- restriction is the following:
426 -- subtype B is range 1 .. 10;
427 -- type Q is array (B range <>) of Integer;
429 -- type V (N : Natural) is record
433 -- In this situation, we can restrict the upper bound of N to 10, since
434 -- any larger value would cause a constraint error in any case.
436 -- There are many situations in which such restriction is possible, but
437 -- for now, we just look for cases like the above, where the component
438 -- in question is a one dimensional array whose upper bound is one of
439 -- the record discriminants. Also the component must not be part of
440 -- any variant part, since then the component does not always exist.
442 procedure Adjust_Discriminants
(Rtype
: Entity_Id
) is
443 Loc
: constant Source_Ptr
:= Sloc
(Rtype
);
460 Comp
:= First_Component
(Rtype
);
461 while Present
(Comp
) loop
463 -- If our parent is a variant, quit, we do not look at components
464 -- that are in variant parts, because they may not always exist.
466 P
:= Parent
(Comp
); -- component declaration
467 P
:= Parent
(P
); -- component list
469 exit when Nkind
(Parent
(P
)) = N_Variant
;
471 -- We are looking for a one dimensional array type
473 Ctyp
:= Etype
(Comp
);
475 if not Is_Array_Type
(Ctyp
) or else Number_Dimensions
(Ctyp
) > 1 then
479 -- The lower bound must be constant, and the upper bound is a
480 -- discriminant (which is a discriminant of the current record).
482 Ityp
:= Etype
(First_Index
(Ctyp
));
483 Lo
:= Type_Low_Bound
(Ityp
);
484 Hi
:= Type_High_Bound
(Ityp
);
486 if not Compile_Time_Known_Value
(Lo
)
487 or else Nkind
(Hi
) /= N_Identifier
488 or else No
(Entity
(Hi
))
489 or else Ekind
(Entity
(Hi
)) /= E_Discriminant
494 -- We have an array with appropriate bounds
496 Loval
:= Expr_Value
(Lo
);
497 Discr
:= Entity
(Hi
);
498 Dtyp
:= Etype
(Discr
);
500 -- See if the discriminant has a known upper bound
502 Dhi
:= Type_High_Bound
(Dtyp
);
504 if not Compile_Time_Known_Value
(Dhi
) then
508 Dhiv
:= Expr_Value
(Dhi
);
510 -- See if base type of component array has known upper bound
512 Ahi
:= Type_High_Bound
(Etype
(First_Index
(Base_Type
(Ctyp
))));
514 if not Compile_Time_Known_Value
(Ahi
) then
518 Ahiv
:= Expr_Value
(Ahi
);
520 -- The condition for doing the restriction is that the high bound
521 -- of the discriminant is greater than the low bound of the array,
522 -- and is also greater than the high bound of the base type index.
524 if Dhiv
> Loval
and then Dhiv
> Ahiv
then
526 -- We can reset the upper bound of the discriminant type to
527 -- whichever is larger, the low bound of the component, or
528 -- the high bound of the base type array index.
530 -- We build a subtype that is declared as
532 -- subtype Tnn is discr_type range discr_type'First .. max;
534 -- And insert this declaration into the tree. The type of the
535 -- discriminant is then reset to this more restricted subtype.
537 Tnn
:= Make_Temporary
(Loc
, 'T');
539 Insert_Action
(Declaration_Node
(Rtype
),
540 Make_Subtype_Declaration
(Loc
,
541 Defining_Identifier
=> Tnn
,
542 Subtype_Indication
=>
543 Make_Subtype_Indication
(Loc
,
544 Subtype_Mark
=> New_Occurrence_Of
(Dtyp
, Loc
),
546 Make_Range_Constraint
(Loc
,
550 Make_Attribute_Reference
(Loc
,
551 Attribute_Name
=> Name_First
,
552 Prefix
=> New_Occurrence_Of
(Dtyp
, Loc
)),
554 Make_Integer_Literal
(Loc
,
555 Intval
=> UI_Max
(Loval
, Ahiv
)))))));
557 Set_Etype
(Discr
, Tnn
);
561 Next_Component
(Comp
);
563 end Adjust_Discriminants
;
565 ------------------------------------------
566 -- Build_Access_Subprogram_Wrapper_Body --
567 ------------------------------------------
569 procedure Build_Access_Subprogram_Wrapper_Body
573 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
574 Actuals
: constant List_Id
:= New_List
;
575 Type_Def
: constant Node_Id
:= Type_Definition
(Decl
);
576 Type_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
577 Spec_Node
: constant Node_Id
:=
578 Copy_Subprogram_Spec
(Specification
(New_Decl
));
579 -- This copy creates new identifiers for formals and subprogram.
587 -- Create List of actuals for indirect call. The last parameter of the
588 -- subprogram declaration is the access value for the indirect call.
590 Act
:= First
(Parameter_Specifications
(Spec_Node
));
592 while Present
(Act
) loop
593 exit when Act
= Last
(Parameter_Specifications
(Spec_Node
));
595 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Act
))));
601 (Last
(Parameter_Specifications
(Specification
(New_Decl
))));
603 if Nkind
(Type_Def
) = N_Access_Procedure_Definition
then
604 Call_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
606 Make_Explicit_Dereference
607 (Loc
, New_Occurrence_Of
(Ptr
, Loc
)),
608 Parameter_Associations
=> Actuals
);
610 Call_Stmt
:= Make_Simple_Return_Statement
(Loc
,
612 Make_Function_Call
(Loc
,
613 Name
=> Make_Explicit_Dereference
614 (Loc
, New_Occurrence_Of
(Ptr
, Loc
)),
615 Parameter_Associations
=> Actuals
));
618 Body_Node
:= Make_Subprogram_Body
(Loc
,
619 Specification
=> Spec_Node
,
620 Declarations
=> New_List
,
621 Handled_Statement_Sequence
=>
622 Make_Handled_Sequence_Of_Statements
(Loc
,
623 Statements
=> New_List
(Call_Stmt
)));
625 -- Place body in list of freeze actions for the type.
627 Append_Freeze_Action
(Type_Id
, Body_Node
);
628 end Build_Access_Subprogram_Wrapper_Body
;
630 ---------------------------
631 -- Build_Array_Init_Proc --
632 ---------------------------
634 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
) is
635 -- Obtain the corresponding mutably tagged type's parent subtype to
636 -- handle default initialization.
638 Comp_Type
: constant Entity_Id
:=
639 Get_Corresponding_Tagged_Type_If_Present
(Component_Type
(A_Type
));
641 Comp_Simple_Init
: constant Boolean :=
642 Needs_Simple_Initialization
645 not (Validity_Check_Copies
and Is_Bit_Packed_Array
(A_Type
)));
646 -- True if the component needs simple initialization, based on its type,
647 -- plus the fact that we do not do simple initialization for components
648 -- of bit-packed arrays when validity checks are enabled, because the
649 -- initialization with deliberately out-of-range values would raise
652 Body_Stmts
: List_Id
;
653 Has_Default_Init
: Boolean;
654 Index_List
: List_Id
;
656 Parameters
: List_Id
;
659 function Init_Component
return List_Id
;
660 -- Create one statement to initialize one array component, designated
661 -- by a full set of indexes.
663 function Init_One_Dimension
(N
: Int
) return List_Id
;
664 -- Create loop to initialize one dimension of the array. The single
665 -- statement in the loop body initializes the inner dimensions if any,
666 -- or else the single component. Note that this procedure is called
667 -- recursively, with N being the dimension to be initialized. A call
668 -- with N greater than the number of dimensions simply generates the
669 -- component initialization, terminating the recursion.
675 function Init_Component
return List_Id
is
680 Make_Indexed_Component
(Loc
,
681 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
682 Expressions
=> Index_List
);
684 if Has_Default_Aspect
(A_Type
) then
685 Set_Assignment_OK
(Comp
);
687 Make_Assignment_Statement
(Loc
,
690 Convert_To
(Comp_Type
,
691 Default_Aspect_Component_Value
(First_Subtype
(A_Type
)))));
693 elsif Comp_Simple_Init
then
694 Set_Assignment_OK
(Comp
);
696 Make_Assignment_Statement
(Loc
,
702 Size
=> Component_Size
(A_Type
))));
705 Clean_Task_Names
(Comp_Type
, Proc_Id
);
707 Build_Initialization_Call
711 In_Init_Proc
=> True,
712 Enclos_Type
=> A_Type
);
716 ------------------------
717 -- Init_One_Dimension --
718 ------------------------
720 function Init_One_Dimension
(N
: Int
) return List_Id
is
723 Result_List
: List_Id
;
725 function Possible_DIC_Call
return Node_Id
;
726 -- If the component type has Default_Initial_Conditions and a DIC
727 -- procedure that is not an empty body, then builds a call to the
728 -- DIC procedure and returns it.
730 -----------------------
731 -- Possible_DIC_Call --
732 -----------------------
734 function Possible_DIC_Call
return Node_Id
is
736 -- When the component's type has a Default_Initial_Condition, then
737 -- create a call for the DIC check.
739 if Has_DIC
(Comp_Type
)
740 -- In GNATprove mode, the component DICs are checked by other
741 -- means. They should not be added to the record type DIC
742 -- procedure, so that the procedure can be used to check the
743 -- record type invariants or DICs if any.
745 and then not GNATprove_Mode
747 -- DIC checks for components of controlled types are done later
748 -- (see Exp_Ch7.Make_Deep_Array_Body).
750 and then not Is_Controlled
(Comp_Type
)
752 and then Present
(DIC_Procedure
(Comp_Type
))
754 and then not Has_Null_Body
(DIC_Procedure
(Comp_Type
))
758 Make_Indexed_Component
(Loc
,
759 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
760 Expressions
=> Index_List
),
765 end Possible_DIC_Call
;
767 -- Start of processing for Init_One_Dimension
770 -- If the component does not need initializing, then there is nothing
771 -- to do here, so we return a null body. This occurs when generating
772 -- the dummy Init_Proc needed for Initialize_Scalars processing.
773 -- An exception is if component type has a Default_Initial_Condition,
774 -- in which case we generate a call to the type's DIC procedure.
776 if not Has_Non_Null_Base_Init_Proc
(Comp_Type
)
777 and then not Comp_Simple_Init
778 and then not Has_Task
(Comp_Type
)
779 and then not Has_Default_Aspect
(A_Type
)
780 and then (not Has_DIC
(Comp_Type
)
781 or else N
> Number_Dimensions
(A_Type
))
783 DIC_Call
:= Possible_DIC_Call
;
785 if Present
(DIC_Call
) then
786 return New_List
(DIC_Call
);
788 return New_List
(Make_Null_Statement
(Loc
));
791 -- If all dimensions dealt with, we simply initialize the component
792 -- and append a call to component type's DIC procedure when needed.
794 elsif N
> Number_Dimensions
(A_Type
) then
795 DIC_Call
:= Possible_DIC_Call
;
797 if Present
(DIC_Call
) then
798 Result_List
:= Init_Component
;
799 Append
(DIC_Call
, Result_List
);
803 return Init_Component
;
806 -- Here we generate the required loop
810 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
812 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
815 Make_Implicit_Loop_Statement
(Nod
,
818 Make_Iteration_Scheme
(Loc
,
819 Loop_Parameter_Specification
=>
820 Make_Loop_Parameter_Specification
(Loc
,
821 Defining_Identifier
=> Index
,
822 Discrete_Subtype_Definition
=>
823 Make_Attribute_Reference
(Loc
,
825 Make_Identifier
(Loc
, Name_uInit
),
826 Attribute_Name
=> Name_Range
,
827 Expressions
=> New_List
(
828 Make_Integer_Literal
(Loc
, N
))))),
829 Statements
=> Init_One_Dimension
(N
+ 1)));
831 end Init_One_Dimension
;
833 -- Start of processing for Build_Array_Init_Proc
836 -- The init proc is created when analyzing the freeze node for the type,
837 -- but it properly belongs with the array type declaration. However, if
838 -- the freeze node is for a subtype of a type declared in another unit
839 -- it seems preferable to use the freeze node as the source location of
840 -- the init proc. In any case this is preferable for gcov usage, and
841 -- the Sloc is not otherwise used by the compiler.
843 if In_Open_Scopes
(Scope
(A_Type
)) then
844 Loc
:= Sloc
(A_Type
);
849 -- Nothing to generate in the following cases:
851 -- 1. Initialization is suppressed for the type
852 -- 2. An initialization already exists for the base type
854 if Initialization_Suppressed
(A_Type
)
855 or else Present
(Base_Init_Proc
(A_Type
))
860 Index_List
:= New_List
;
862 -- We need an initialization procedure if any of the following is true:
864 -- 1. The component type has an initialization procedure
865 -- 2. The component type needs simple initialization
866 -- 3. Tasks are present
867 -- 4. The type is marked as a public entity
868 -- 5. The array type has a Default_Component_Value aspect
869 -- 6. The array component type has a Default_Initialization_Condition
871 -- The reason for the public entity test is to deal properly with the
872 -- Initialize_Scalars pragma. This pragma can be set in the client and
873 -- not in the declaring package, this means the client will make a call
874 -- to the initialization procedure (because one of conditions 1-3 must
875 -- apply in this case), and we must generate a procedure (even if it is
876 -- null) to satisfy the call in this case.
878 -- Exception: do not build an array init_proc for a type whose root
879 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
880 -- is no place to put the code, and in any case we handle initialization
881 -- of such types (in the Initialize_Scalars case, that's the only time
882 -- the issue arises) in a special manner anyway which does not need an
885 Has_Default_Init
:= Has_Non_Null_Base_Init_Proc
(Comp_Type
)
886 or else Comp_Simple_Init
887 or else Has_Task
(Comp_Type
)
888 or else Has_Default_Aspect
(A_Type
)
889 or else Has_DIC
(Comp_Type
);
892 or else (not Restriction_Active
(No_Initialize_Scalars
)
893 and then Is_Public
(A_Type
)
894 and then not Is_Standard_String_Type
(A_Type
))
897 Make_Defining_Identifier
(Loc
,
898 Chars
=> Make_Init_Proc_Name
(A_Type
));
900 -- If No_Default_Initialization restriction is active, then we don't
901 -- want to build an init_proc, but we need to mark that an init_proc
902 -- would be needed if this restriction was not active (so that we can
903 -- detect attempts to call it), so set a dummy init_proc in place.
904 -- This is only done though when actual default initialization is
905 -- needed (and not done when only Is_Public is True), since otherwise
906 -- objects such as arrays of scalars could be wrongly flagged as
907 -- violating the restriction.
909 if Restriction_Active
(No_Default_Initialization
) then
910 if Has_Default_Init
then
911 Set_Init_Proc
(A_Type
, Proc_Id
);
917 Body_Stmts
:= Init_One_Dimension
(1);
918 Parameters
:= Init_Formals
(A_Type
, Proc_Id
);
921 Make_Subprogram_Body
(Loc
,
923 Make_Procedure_Specification
(Loc
,
924 Defining_Unit_Name
=> Proc_Id
,
925 Parameter_Specifications
=> Parameters
),
926 Declarations
=> New_List
,
927 Handled_Statement_Sequence
=>
928 Make_Handled_Sequence_Of_Statements
(Loc
,
929 Statements
=> Body_Stmts
)));
931 Mutate_Ekind
(Proc_Id
, E_Procedure
);
932 Set_Is_Public
(Proc_Id
, Is_Public
(A_Type
));
933 Set_Is_Internal
(Proc_Id
);
934 Set_Has_Completion
(Proc_Id
);
936 if not Debug_Generated_Code
then
937 Set_Debug_Info_Off
(Proc_Id
);
940 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
941 -- component type itself (see also Build_Record_Init_Proc).
943 Set_Is_Inlined
(Proc_Id
, Inline_Init_Proc
(Comp_Type
));
945 -- Associate Init_Proc with type, and determine if the procedure
946 -- is null (happens because of the Initialize_Scalars pragma case,
947 -- where we have to generate a null procedure in case it is called
948 -- by a client with Initialize_Scalars set). Such procedures have
949 -- to be generated, but do not have to be called, so we mark them
950 -- as null to suppress the call. Kill also warnings for the _Init
951 -- out parameter, which is left entirely uninitialized.
953 Set_Init_Proc
(A_Type
, Proc_Id
);
955 if Is_Null_Statement_List
(Body_Stmts
) then
956 Set_Is_Null_Init_Proc
(Proc_Id
);
957 Set_Warnings_Off
(Defining_Identifier
(First
(Parameters
)));
960 -- Try to build a static aggregate to statically initialize
961 -- objects of the type. This can only be done for constrained
962 -- one-dimensional arrays with static bounds.
964 Set_Static_Initialization
966 Build_Equivalent_Array_Aggregate
(First_Subtype
(A_Type
)));
969 end Build_Array_Init_Proc
;
971 ----------------------------------
972 -- Build_Default_Initialization --
973 ----------------------------------
975 function Build_Default_Initialization
979 For_CW
: Boolean := False;
980 Target_Ref
: Node_Id
:= Empty
) return List_Id
982 Exceptions_OK
: constant Boolean :=
983 not Restriction_Active
(No_Exception_Propagation
);
984 Loc
: constant Source_Ptr
:= Sloc
(N
);
986 function New_Object_Reference
return Node_Id
;
987 -- Return either a reference to Obj_Id or a dereference of Obj_Id
989 --------------------------
990 -- New_Object_Reference --
991 --------------------------
993 function New_Object_Reference
return Node_Id
is
994 Obj_Ref
: Node_Id
:= New_Occurrence_Of
(Obj_Id
, Loc
);
997 if Nkind
(N
) = N_Object_Declaration
then
998 -- The call to the type init proc or [Deep_]Finalize must not
999 -- freeze the object since the call is internally generated.
1000 -- This prevents representation clauses from being rejected.
1001 -- Note that the initialization call may be removed if pragma
1002 -- Import is encountered or moved to the freeze actions of
1003 -- the object if an address clause is encountered.
1005 Set_Assignment_OK
(Obj_Ref
);
1006 Set_Must_Not_Freeze
(Obj_Ref
);
1008 else pragma Assert
(Nkind
(N
) = N_Allocator
);
1009 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
1011 -- If the designated subtype is unconstrained and the allocator
1012 -- specifies a constrained subtype, or such a subtype has been
1013 -- created, associate that subtype with the dereference of the
1014 -- allocator's access value. This is needed by the expander for
1015 -- cases where the access type has a Designated_Storage_Model
1016 -- in order to support allocation of a host object of the right
1017 -- size for passing to the initialization procedure.
1019 if not Is_Constrained
(Designated_Type
(Etype
(N
)))
1020 and then Is_Constrained
(Typ
)
1022 Set_Actual_Designated_Subtype
(Obj_Ref
, Typ
);
1025 -- The initialization procedure expects a specific type so.
1026 -- if the context is access to class-wide, indicate that the
1027 -- object being initialized has the right specific type.
1030 Obj_Ref
:= Unchecked_Convert_To
(Typ
, Obj_Ref
);
1035 end New_Object_Reference
;
1039 Comp_Init
: List_Id
:= No_List
;
1040 Fin_Block
: Node_Id
;
1042 Init_Stmts
: List_Id
:= No_List
;
1043 Obj_Init
: Node_Id
:= Empty
;
1046 -- Start of processing for Build_Default_Initialization
1049 -- The expansion performed by this routine is as follows:
1053 -- Type_Init_Proc (Obj);
1056 -- [Deep_]Initialize (Obj);
1060 -- [Deep_]Finalize (Obj, Self => False);
1064 -- Abort_Undefer_Direct;
1067 -- Initialize the components of the object
1069 if Has_Non_Null_Base_Init_Proc
(Typ
)
1070 and then not Initialization_Suppressed
(Typ
)
1072 -- Do not initialize the components if No_Default_Initialization
1073 -- applies as the actual restriction check will occur later when
1074 -- the object is frozen as it is not known yet whether the object
1075 -- is imported or not.
1077 if not Restriction_Active
(No_Default_Initialization
) then
1079 -- Invoke the type init proc, generate:
1080 -- Type_Init_Proc (Obj);
1082 Obj_Ref
:= New_Object_Reference
;
1084 if Comes_From_Source
(Obj_Id
) then
1085 Initialization_Warning
(Obj_Ref
);
1089 Build_Initialization_Call
(N
,
1090 Obj_Ref
, Typ
, Target_Ref
=> Target_Ref
);
1094 -- Initialize the object, generate:
1095 -- [Deep_]Initialize (Obj);
1097 if Needs_Finalization
(Typ
) then
1100 (Obj_Ref
=> New_Object_Reference
,
1104 -- Build a special finalization block when both the object and its
1105 -- controlled components are to be initialized. The block finalizes
1106 -- the components if the object initialization fails. Generate:
1117 if Has_Controlled_Component
(Typ
)
1118 and then Present
(Comp_Init
)
1119 and then Present
(Obj_Init
)
1120 and then Exceptions_OK
1122 Init_Stmts
:= Comp_Init
;
1126 (Obj_Ref
=> New_Object_Reference
,
1130 if Present
(Fin_Call
) then
1132 -- Do not emit warnings related to the elaboration order when a
1133 -- controlled object is declared before the body of Finalize is
1136 if Legacy_Elaboration_Checks
then
1137 Set_No_Elaboration_Check
(Fin_Call
);
1141 Make_Block_Statement
(Loc
,
1142 Declarations
=> No_List
,
1144 Handled_Statement_Sequence
=>
1145 Make_Handled_Sequence_Of_Statements
(Loc
,
1146 Statements
=> New_List
(Obj_Init
),
1148 Exception_Handlers
=> New_List
(
1149 Make_Exception_Handler
(Loc
,
1150 Exception_Choices
=> New_List
(
1151 Make_Others_Choice
(Loc
)),
1153 Statements
=> New_List
(
1155 Make_Raise_Statement
(Loc
))))));
1157 -- Signal the ABE mechanism that the block carries out
1158 -- initialization actions.
1160 Set_Is_Initialization_Block
(Fin_Block
);
1162 Append_To
(Init_Stmts
, Fin_Block
);
1165 -- Otherwise finalization is not required, the initialization calls
1166 -- are passed to the abort block building circuitry, generate:
1168 -- Type_Init_Proc (Obj);
1169 -- [Deep_]Initialize (Obj);
1172 if Present
(Comp_Init
) then
1173 Init_Stmts
:= Comp_Init
;
1176 if Present
(Obj_Init
) then
1177 if No
(Init_Stmts
) then
1178 Init_Stmts
:= New_List
;
1181 Append_To
(Init_Stmts
, Obj_Init
);
1185 -- Build an abort block to protect the initialization calls, except for
1186 -- a finalization collection, which does not need any protection.
1189 and then Present
(Comp_Init
)
1190 and then Present
(Obj_Init
)
1191 and then not Is_RTE
(Typ
, RE_Finalization_Collection
)
1196 Prepend_To
(Init_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1198 -- When exceptions are propagated, abort deferral must take place
1199 -- in the presence of initialization or finalization exceptions.
1206 -- Abort_Undefer_Direct;
1209 if Exceptions_OK
then
1210 Init_Stmts
:= New_List
(
1211 Build_Abort_Undefer_Block
(Loc
,
1212 Stmts
=> Init_Stmts
,
1215 -- Otherwise exceptions are not propagated. Generate:
1222 Append_To
(Init_Stmts
,
1223 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1228 end Build_Default_Initialization
;
1230 -----------------------------------------
1231 -- Build_Default_Simple_Initialization --
1232 -----------------------------------------
1234 function Build_Default_Simple_Initialization
1237 Obj_Id
: Entity_Id
) return Node_Id
1239 Loc
: constant Source_Ptr
:= Sloc
(N
);
1241 function Build_Equivalent_Aggregate
return Node_Id
;
1242 -- If the object has a constrained discriminated type and no initial
1243 -- value, it may be possible to build an equivalent aggregate instead,
1244 -- and prevent an actual call to the initialization procedure.
1246 function Simple_Initialization_OK
(Typ
: Entity_Id
) return Boolean;
1247 -- Determine whether object declaration N with entity Obj_Id if set, or
1248 -- object allocation N if Obj_Id is empty, needs simple initialization,
1249 -- assuming that it is of type Typ.
1251 --------------------------------
1252 -- Build_Equivalent_Aggregate --
1253 --------------------------------
1255 function Build_Equivalent_Aggregate
return Node_Id
is
1259 Full_Typ
: Entity_Id
;
1262 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
1263 Full_Typ
:= Full_View
(Typ
);
1268 -- Only do this transformation for a package entity of a constrained
1269 -- record type and if Elaboration_Code is forbidden or undesirable.
1271 -- If Initialize_Scalars might be active this transformation cannot
1272 -- be performed either, because it will lead to different semantics
1273 -- or because elaboration code will in fact be created.
1275 if Ekind
(Full_Typ
) /= E_Record_Subtype
1276 or else not Has_Discriminants
(Full_Typ
)
1277 or else not Is_Constrained
(Full_Typ
)
1278 or else Is_Controlled
(Full_Typ
)
1279 or else Is_Limited_Type
(Full_Typ
)
1280 or else Ekind
(Current_Scope
) /= E_Package
1281 or else not (Is_Preelaborated
(Current_Scope
)
1282 or else Restriction_Active
(No_Elaboration_Code
))
1283 or else not Restriction_Active
(No_Initialize_Scalars
)
1288 -- Building a static aggregate is possible if the discriminants
1289 -- have static values and the other components have static
1290 -- defaults or none.
1292 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Typ
));
1293 while Present
(Discr
) loop
1294 if not Is_OK_Static_Expression
(Node
(Discr
)) then
1301 -- Check that initialized components are OK, and that non-
1302 -- initialized components do not require a call to their own
1303 -- initialization procedure.
1305 Comp
:= First_Component
(Full_Typ
);
1306 while Present
(Comp
) loop
1307 if Present
(Expression
(Parent
(Comp
)))
1308 and then not Is_OK_Static_Expression
(Expression
(Parent
(Comp
)))
1312 elsif Has_Non_Null_Base_Init_Proc
(Etype
(Comp
)) then
1317 Next_Component
(Comp
);
1320 -- Everything is static, assemble the aggregate, discriminant
1324 Make_Aggregate
(Loc
,
1325 Expressions
=> New_List
,
1326 Component_Associations
=> New_List
);
1327 Set_Parent
(Aggr
, N
);
1329 Discr
:= First_Elmt
(Discriminant_Constraint
(Full_Typ
));
1330 while Present
(Discr
) loop
1331 Append_To
(Expressions
(Aggr
), New_Copy
(Node
(Discr
)));
1335 -- Now collect values of initialized components
1337 Comp
:= First_Component
(Full_Typ
);
1338 while Present
(Comp
) loop
1339 if Present
(Expression
(Parent
(Comp
))) then
1340 Append_To
(Component_Associations
(Aggr
),
1341 Make_Component_Association
(Loc
,
1342 Choices
=> New_List
(New_Occurrence_Of
(Comp
, Loc
)),
1343 Expression
=> New_Copy_Tree
1344 (Expression
(Parent
(Comp
)))));
1347 Next_Component
(Comp
);
1350 -- Finally, box-initialize remaining components
1352 Append_To
(Component_Associations
(Aggr
),
1353 Make_Component_Association
(Loc
,
1354 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1355 Expression
=> Empty
));
1356 Set_Box_Present
(Last
(Component_Associations
(Aggr
)));
1358 if Typ
/= Full_Typ
then
1359 Analyze_And_Resolve
(Aggr
, Full_View
(Base_Type
(Full_Typ
)));
1360 Rewrite
(Aggr
, Unchecked_Convert_To
(Typ
, Aggr
));
1364 end Build_Equivalent_Aggregate
;
1366 ------------------------------
1367 -- Simple_Initialization_OK --
1368 ------------------------------
1370 function Simple_Initialization_OK
(Typ
: Entity_Id
) return Boolean is
1372 -- Skip internal entities as specified in Einfo
1375 not (Present
(Obj_Id
) and then Is_Internal
(Obj_Id
))
1376 and then not Is_Mutably_Tagged_CW_Equivalent_Type
(Typ
)
1378 Needs_Simple_Initialization
1382 and then (No
(Obj_Id
)
1383 or else No
(Following_Address_Clause
(N
))));
1384 end Simple_Initialization_OK
;
1388 Aggr_Init
: Node_Id
;
1390 -- Start of processing for Build_Default_Simple_Initialization
1393 if Has_Non_Null_Base_Init_Proc
(Typ
)
1394 and then not Is_Dispatching_Operation
(Base_Init_Proc
(Typ
))
1395 and then not Initialization_Suppressed
(Typ
)
1397 -- Do not initialize the components if No_Default_Initialization
1398 -- applies as the actual restriction check will occur later when
1399 -- the object is frozen as it is not known yet whether the object
1400 -- is imported or not.
1402 if not Restriction_Active
(No_Default_Initialization
) then
1404 -- If the values of the components are compile-time known, use
1405 -- their prebuilt aggregate form directly.
1407 Aggr_Init
:= Static_Initialization
(Base_Init_Proc
(Typ
));
1408 if Present
(Aggr_Init
) then
1409 return New_Copy_Tree
(Aggr_Init
, New_Scope
=> Current_Scope
);
1412 -- If type has discriminants, try to build an equivalent
1413 -- aggregate using discriminant values from the declaration.
1414 -- This is a useful optimization, in particular if restriction
1415 -- No_Elaboration_Code is active.
1417 Aggr_Init
:= Build_Equivalent_Aggregate
;
1418 if Present
(Aggr_Init
) then
1422 -- Optimize the default initialization of an array object when
1423 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
1424 -- Construct an in-place initialization aggregate which may be
1425 -- convert into a fast memset by the backend.
1427 if Init_Or_Norm_Scalars
1428 and then Is_Array_Type
(Typ
)
1430 -- The array must lack atomic components because they are
1431 -- treated as non-static, and as a result the backend will
1432 -- not initialize the memory in one go.
1434 and then not Has_Atomic_Components
(Typ
)
1436 -- The array must not be packed because the invalid values
1437 -- in System.Scalar_Values are multiples of Storage_Unit.
1439 and then not Is_Packed
(Typ
)
1441 -- The array must have static non-empty ranges, otherwise
1442 -- the backend cannot initialize the memory in one go.
1444 and then Has_Static_Non_Empty_Array_Bounds
(Typ
)
1446 -- The optimization is only relevant for arrays of scalar
1449 and then Is_Scalar_Type
(Component_Type
(Typ
))
1451 -- Similar to regular array initialization using a type
1452 -- init proc, predicate checks are not performed because the
1453 -- initialization values are intentionally invalid, and may
1454 -- violate the predicate.
1456 and then not Has_Predicates
(Component_Type
(Typ
))
1458 -- Array default component value takes precedence over
1459 -- Init_Or_Norm_Scalars.
1461 and then No
(Find_Aspect
(Typ
, Aspect_Default_Component_Value
))
1463 -- The component type must have a single initialization value
1465 and then Simple_Initialization_OK
(Component_Type
(Typ
))
1471 Size
=> (if Known_Esize
(Typ
)
1477 -- Provide a default value if the object needs simple initialization
1479 elsif Simple_Initialization_OK
(Typ
) then
1484 Size
=> (if Known_Esize
(Typ
)
1490 end Build_Default_Simple_Initialization
;
1492 --------------------------------
1493 -- Build_Discr_Checking_Funcs --
1494 --------------------------------
1496 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
) is
1499 Enclosing_Func_Id
: Entity_Id
;
1500 Sequence
: Nat
:= 1;
1504 function Build_Case_Statement
1505 (Case_Id
: Entity_Id
;
1506 Variant
: Node_Id
) return Node_Id
;
1507 -- Build a case statement containing only two alternatives. The first
1508 -- alternative corresponds to the discrete choices given on the variant
1509 -- that contains the components that we are generating the checks
1510 -- for. If the discriminant is one of these return False. The second
1511 -- alternative is an OTHERS choice that returns True indicating the
1512 -- discriminant did not match.
1514 function Build_Dcheck_Function
1515 (Case_Id
: Entity_Id
;
1516 Variant
: Node_Id
) return Entity_Id
;
1517 -- Build the discriminant checking function for a given variant
1519 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
);
1520 -- Builds the discriminant checking function for each variant of the
1521 -- given variant part of the record type.
1523 --------------------------
1524 -- Build_Case_Statement --
1525 --------------------------
1527 function Build_Case_Statement
1528 (Case_Id
: Entity_Id
;
1529 Variant
: Node_Id
) return Node_Id
1531 Alt_List
: constant List_Id
:= New_List
;
1532 Actuals_List
: List_Id
;
1533 Case_Node
: Node_Id
;
1534 Case_Alt_Node
: Node_Id
;
1536 Choice_List
: List_Id
;
1538 Return_Node
: Node_Id
;
1541 Case_Node
:= New_Node
(N_Case_Statement
, Loc
);
1542 Set_End_Span
(Case_Node
, Uint_0
);
1544 -- Replace the discriminant which controls the variant with the name
1545 -- of the formal of the checking function.
1547 Set_Expression
(Case_Node
, Make_Identifier
(Loc
, Chars
(Case_Id
)));
1549 Choice
:= First
(Discrete_Choices
(Variant
));
1551 if Nkind
(Choice
) = N_Others_Choice
then
1552 Choice_List
:= New_Copy_List
(Others_Discrete_Choices
(Choice
));
1554 Choice_List
:= New_Copy_List
(Discrete_Choices
(Variant
));
1557 if not Is_Empty_List
(Choice_List
) then
1558 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
1559 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
1561 -- In case this is a nested variant, we need to return the result
1562 -- of the discriminant checking function for the immediately
1563 -- enclosing variant.
1565 if Present
(Enclosing_Func_Id
) then
1566 Actuals_List
:= New_List
;
1568 D
:= First_Discriminant
(Rec_Id
);
1569 while Present
(D
) loop
1570 Append
(Make_Identifier
(Loc
, Chars
(D
)), Actuals_List
);
1571 Next_Discriminant
(D
);
1575 Make_Simple_Return_Statement
(Loc
,
1577 Make_Function_Call
(Loc
,
1579 New_Occurrence_Of
(Enclosing_Func_Id
, Loc
),
1580 Parameter_Associations
=>
1585 Make_Simple_Return_Statement
(Loc
,
1587 New_Occurrence_Of
(Standard_False
, Loc
));
1590 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
1591 Append
(Case_Alt_Node
, Alt_List
);
1594 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
1595 Choice_List
:= New_List
(New_Node
(N_Others_Choice
, Loc
));
1596 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
1599 Make_Simple_Return_Statement
(Loc
,
1601 New_Occurrence_Of
(Standard_True
, Loc
));
1603 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
1604 Append
(Case_Alt_Node
, Alt_List
);
1606 Set_Alternatives
(Case_Node
, Alt_List
);
1608 end Build_Case_Statement
;
1610 ---------------------------
1611 -- Build_Dcheck_Function --
1612 ---------------------------
1614 function Build_Dcheck_Function
1615 (Case_Id
: Entity_Id
;
1616 Variant
: Node_Id
) return Entity_Id
1618 Body_Node
: Node_Id
;
1619 Func_Id
: Entity_Id
;
1620 Parameter_List
: List_Id
;
1621 Spec_Node
: Node_Id
;
1624 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
1625 Sequence
:= Sequence
+ 1;
1628 Make_Defining_Identifier
(Loc
,
1629 Chars
=> New_External_Name
(Chars
(Rec_Id
), 'D', Sequence
));
1630 Set_Is_Discriminant_Check_Function
(Func_Id
);
1632 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
1633 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
1635 Parameter_List
:= Build_Discriminant_Formals
(Rec_Id
, False);
1637 Set_Parameter_Specifications
(Spec_Node
, Parameter_List
);
1638 Set_Result_Definition
(Spec_Node
,
1639 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1640 Set_Specification
(Body_Node
, Spec_Node
);
1641 Set_Declarations
(Body_Node
, New_List
);
1643 Set_Handled_Statement_Sequence
(Body_Node
,
1644 Make_Handled_Sequence_Of_Statements
(Loc
,
1645 Statements
=> New_List
(
1646 Build_Case_Statement
(Case_Id
, Variant
))));
1648 Mutate_Ekind
(Func_Id
, E_Function
);
1649 Set_Mechanism
(Func_Id
, Default_Mechanism
);
1650 Set_Is_Inlined
(Func_Id
, True);
1651 Set_Is_Pure
(Func_Id
, True);
1652 Set_Is_Public
(Func_Id
, Is_Public
(Rec_Id
));
1653 Set_Is_Internal
(Func_Id
, True);
1655 if not Debug_Generated_Code
then
1656 Set_Debug_Info_Off
(Func_Id
);
1659 Analyze
(Body_Node
);
1661 Append_Freeze_Action
(Rec_Id
, Body_Node
);
1662 Set_Dcheck_Function
(Variant
, Func_Id
);
1664 end Build_Dcheck_Function
;
1666 ----------------------------
1667 -- Build_Dcheck_Functions --
1668 ----------------------------
1670 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
) is
1671 Component_List_Node
: Node_Id
;
1673 Discr_Name
: Entity_Id
;
1674 Func_Id
: Entity_Id
;
1676 Saved_Enclosing_Func_Id
: Entity_Id
;
1679 -- Build the discriminant-checking function for each variant, and
1680 -- label all components of that variant with the function's name.
1681 -- We only Generate a discriminant-checking function when the
1682 -- variant is not empty, to prevent the creation of dead code.
1684 Discr_Name
:= Entity
(Name
(Variant_Part_Node
));
1685 Variant
:= First_Non_Pragma
(Variants
(Variant_Part_Node
));
1687 while Present
(Variant
) loop
1688 Component_List_Node
:= Component_List
(Variant
);
1690 if not Null_Present
(Component_List_Node
) then
1691 Func_Id
:= Build_Dcheck_Function
(Discr_Name
, Variant
);
1694 First_Non_Pragma
(Component_Items
(Component_List_Node
));
1695 while Present
(Decl
) loop
1696 Set_Discriminant_Checking_Func
1697 (Defining_Identifier
(Decl
), Func_Id
);
1698 Next_Non_Pragma
(Decl
);
1701 if Present
(Variant_Part
(Component_List_Node
)) then
1702 Saved_Enclosing_Func_Id
:= Enclosing_Func_Id
;
1703 Enclosing_Func_Id
:= Func_Id
;
1704 Build_Dcheck_Functions
(Variant_Part
(Component_List_Node
));
1705 Enclosing_Func_Id
:= Saved_Enclosing_Func_Id
;
1709 Next_Non_Pragma
(Variant
);
1711 end Build_Dcheck_Functions
;
1713 -- Start of processing for Build_Discr_Checking_Funcs
1716 -- Only build if not done already
1718 if not Discr_Check_Funcs_Built
(N
) then
1719 Type_Def
:= Type_Definition
(N
);
1721 if Nkind
(Type_Def
) = N_Record_Definition
then
1722 if No
(Component_List
(Type_Def
)) then -- null record.
1725 V
:= Variant_Part
(Component_List
(Type_Def
));
1728 else pragma Assert
(Nkind
(Type_Def
) = N_Derived_Type_Definition
);
1729 if No
(Component_List
(Record_Extension_Part
(Type_Def
))) then
1733 (Component_List
(Record_Extension_Part
(Type_Def
)));
1737 Rec_Id
:= Defining_Identifier
(N
);
1739 if Present
(V
) and then not Is_Unchecked_Union
(Rec_Id
) then
1741 Enclosing_Func_Id
:= Empty
;
1742 Build_Dcheck_Functions
(V
);
1745 Set_Discr_Check_Funcs_Built
(N
);
1747 end Build_Discr_Checking_Funcs
;
1749 ----------------------------------------
1750 -- Build_Or_Copy_Discr_Checking_Funcs --
1751 ----------------------------------------
1753 procedure Build_Or_Copy_Discr_Checking_Funcs
(N
: Node_Id
) is
1754 Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
1756 if Is_Unchecked_Union
(Typ
) or else not Has_Discriminants
(Typ
) then
1758 elsif not Is_Derived_Type
(Typ
)
1759 or else Has_New_Non_Standard_Rep
(Typ
)
1760 or else Is_Tagged_Type
(Typ
)
1762 Build_Discr_Checking_Funcs
(N
);
1764 Copy_Discr_Checking_Funcs
(N
);
1766 end Build_Or_Copy_Discr_Checking_Funcs
;
1768 --------------------------------
1769 -- Build_Discriminant_Formals --
1770 --------------------------------
1772 function Build_Discriminant_Formals
1773 (Rec_Id
: Entity_Id
;
1774 Use_Dl
: Boolean) return List_Id
1776 Loc
: Source_Ptr
:= Sloc
(Rec_Id
);
1777 Parameter_List
: constant List_Id
:= New_List
;
1780 Formal_Type
: Entity_Id
;
1781 Param_Spec_Node
: Node_Id
;
1784 if Has_Discriminants
(Rec_Id
) then
1785 D
:= First_Discriminant
(Rec_Id
);
1786 while Present
(D
) loop
1790 Formal
:= Discriminal
(D
);
1791 Formal_Type
:= Etype
(Formal
);
1793 Formal
:= Make_Defining_Identifier
(Loc
, Chars
(D
));
1794 Formal_Type
:= Etype
(D
);
1798 Make_Parameter_Specification
(Loc
,
1799 Defining_Identifier
=> Formal
,
1801 New_Occurrence_Of
(Formal_Type
, Loc
));
1802 Append
(Param_Spec_Node
, Parameter_List
);
1803 Next_Discriminant
(D
);
1807 return Parameter_List
;
1808 end Build_Discriminant_Formals
;
1810 --------------------------------------
1811 -- Build_Equivalent_Array_Aggregate --
1812 --------------------------------------
1814 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
is
1815 Loc
: constant Source_Ptr
:= Sloc
(T
);
1816 Comp_Type
: constant Entity_Id
:= Component_Type
(T
);
1817 Index_Type
: constant Entity_Id
:= Etype
(First_Index
(T
));
1818 Proc
: constant Entity_Id
:= Base_Init_Proc
(T
);
1824 if not Is_Constrained
(T
)
1825 or else Number_Dimensions
(T
) > 1
1828 Initialization_Warning
(T
);
1832 Lo
:= Type_Low_Bound
(Index_Type
);
1833 Hi
:= Type_High_Bound
(Index_Type
);
1835 if not Compile_Time_Known_Value
(Lo
)
1836 or else not Compile_Time_Known_Value
(Hi
)
1838 Initialization_Warning
(T
);
1842 if Is_Record_Type
(Comp_Type
)
1843 and then Present
(Base_Init_Proc
(Comp_Type
))
1845 Expr
:= Static_Initialization
(Base_Init_Proc
(Comp_Type
));
1848 Initialization_Warning
(T
);
1853 Initialization_Warning
(T
);
1857 Aggr
:= Make_Aggregate
(Loc
, No_List
, New_List
);
1858 Set_Etype
(Aggr
, T
);
1859 Set_Aggregate_Bounds
(Aggr
,
1861 Low_Bound
=> New_Copy
(Lo
),
1862 High_Bound
=> New_Copy
(Hi
)));
1863 Set_Parent
(Aggr
, Parent
(Proc
));
1865 Append_To
(Component_Associations
(Aggr
),
1866 Make_Component_Association
(Loc
,
1870 Low_Bound
=> New_Copy
(Lo
),
1871 High_Bound
=> New_Copy
(Hi
))),
1872 Expression
=> Expr
));
1874 if Static_Array_Aggregate
(Aggr
) then
1877 Initialization_Warning
(T
);
1880 end Build_Equivalent_Array_Aggregate
;
1882 ---------------------------------------
1883 -- Build_Equivalent_Record_Aggregate --
1884 ---------------------------------------
1886 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
is
1889 Comp_Type
: Entity_Id
;
1892 if not Is_Record_Type
(T
)
1893 or else Has_Discriminants
(T
)
1894 or else Is_Limited_Type
(T
)
1895 or else Has_Non_Standard_Rep
(T
)
1896 or else Needs_Finalization
(T
)
1898 Initialization_Warning
(T
);
1902 Comp
:= First_Component
(T
);
1904 -- A null record needs no warning
1910 while Present
(Comp
) loop
1912 -- Array components are acceptable if initialized by a positional
1913 -- aggregate with static components.
1915 if Is_Array_Type
(Etype
(Comp
)) then
1916 Comp_Type
:= Component_Type
(Etype
(Comp
));
1918 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1919 or else No
(Expression
(Parent
(Comp
)))
1920 or else Nkind
(Expression
(Parent
(Comp
))) /= N_Aggregate
1922 Initialization_Warning
(T
);
1925 elsif Is_Scalar_Type
(Component_Type
(Etype
(Comp
)))
1927 (not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1929 not Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
)))
1931 Initialization_Warning
(T
);
1935 not Static_Array_Aggregate
(Expression
(Parent
(Comp
)))
1937 Initialization_Warning
(T
);
1940 -- We need to return empty if the type has predicates because
1941 -- this would otherwise duplicate calls to the predicate
1942 -- function. If the type hasn't been frozen before being
1943 -- referenced in the current record, the extraneous call to
1944 -- the predicate function would be inserted somewhere before
1945 -- the predicate function is elaborated, which would result in
1948 elsif Has_Predicates
(Etype
(Comp
)) then
1952 elsif Is_Scalar_Type
(Etype
(Comp
)) then
1953 Comp_Type
:= Etype
(Comp
);
1955 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1956 or else No
(Expression
(Parent
(Comp
)))
1957 or else not Compile_Time_Known_Value
(Expression
(Parent
(Comp
)))
1958 or else not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1960 Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
))
1961 or else Has_Predicates
(Etype
(Comp
))
1963 Initialization_Warning
(T
);
1967 -- For now, other types are excluded
1970 Initialization_Warning
(T
);
1974 Next_Component
(Comp
);
1977 -- All components have static initialization. Build positional aggregate
1978 -- from the given expressions or defaults.
1980 Agg
:= Make_Aggregate
(Sloc
(T
), New_List
, New_List
);
1981 Set_Parent
(Agg
, Parent
(T
));
1983 Comp
:= First_Component
(T
);
1984 while Present
(Comp
) loop
1986 (New_Copy_Tree
(Expression
(Parent
(Comp
))), Expressions
(Agg
));
1987 Next_Component
(Comp
);
1990 Analyze_And_Resolve
(Agg
, T
);
1992 end Build_Equivalent_Record_Aggregate
;
1994 -------------------------------
1995 -- Build_Initialization_Call --
1996 -------------------------------
1998 -- References to a discriminant inside the record type declaration can
1999 -- appear either in the subtype_indication to constrain a record or an
2000 -- array, or as part of a larger expression given for the initial value
2001 -- of a component. In both of these cases N appears in the record
2002 -- initialization procedure and needs to be replaced by the formal
2003 -- parameter of the initialization procedure which corresponds to that
2006 -- In the example below, references to discriminants D1 and D2 in proc_1
2007 -- are replaced by references to formals with the same name
2010 -- A similar replacement is done for calls to any record initialization
2011 -- procedure for any components that are themselves of a record type.
2013 -- type R (D1, D2 : Integer) is record
2014 -- X : Integer := F * D1;
2015 -- Y : Integer := F * D2;
2018 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
2022 -- Out_2.X := F * D1;
2023 -- Out_2.Y := F * D2;
2026 function Build_Initialization_Call
2030 In_Init_Proc
: Boolean := False;
2031 Enclos_Type
: Entity_Id
:= Empty
;
2032 Target_Ref
: Node_Id
:= Empty
;
2033 Discr_Map
: Elist_Id
:= New_Elmt_List
;
2034 With_Default_Init
: Boolean := False;
2035 Constructor_Ref
: Node_Id
:= Empty
;
2036 Init_Control_Actual
: Entity_Id
:= Empty
) return List_Id
2038 Loc
: constant Source_Ptr
:= Sloc
(N
);
2039 Res
: constant List_Id
:= New_List
;
2041 Full_Type
: Entity_Id
;
2043 procedure Check_Predicated_Discriminant
2046 -- Discriminants whose subtypes have predicates are checked in two
2048 -- a) When an object is default-initialized and assertions are enabled
2049 -- we check that the value of the discriminant obeys the predicate.
2051 -- b) In all cases, if the discriminant controls a variant and the
2052 -- variant has no others_choice, Constraint_Error must be raised if
2053 -- the predicate is violated, because there is no variant covered
2054 -- by the illegal discriminant value.
2056 -----------------------------------
2057 -- Check_Predicated_Discriminant --
2058 -----------------------------------
2060 procedure Check_Predicated_Discriminant
2064 Typ
: constant Entity_Id
:= Etype
(Discr
);
2066 procedure Check_Missing_Others
(V
: Node_Id
);
2067 -- Check that a given variant and its nested variants have an others
2068 -- choice, and generate a constraint error raise when it does not.
2070 --------------------------
2071 -- Check_Missing_Others --
2072 --------------------------
2074 procedure Check_Missing_Others
(V
: Node_Id
) is
2080 Last_Var
:= Last_Non_Pragma
(Variants
(V
));
2081 Choice
:= First
(Discrete_Choices
(Last_Var
));
2083 -- An others_choice is added during expansion for gcc use, but
2084 -- does not cover the illegality.
2086 if Entity
(Name
(V
)) = Discr
then
2088 and then (Nkind
(Choice
) /= N_Others_Choice
2089 or else not Comes_From_Source
(Choice
))
2091 Check_Expression_Against_Static_Predicate
(Val
, Typ
);
2093 if not Is_Static_Expression
(Val
) then
2095 Make_Raise_Constraint_Error
(Loc
,
2098 Right_Opnd
=> Make_Predicate_Call
(Typ
, Val
)),
2099 Reason
=> CE_Invalid_Data
));
2104 -- Check whether some nested variant is ruled by the predicated
2107 Alt
:= First
(Variants
(V
));
2108 while Present
(Alt
) loop
2109 if Nkind
(Alt
) = N_Variant
2110 and then Present
(Variant_Part
(Component_List
(Alt
)))
2112 Check_Missing_Others
2113 (Variant_Part
(Component_List
(Alt
)));
2118 end Check_Missing_Others
;
2124 -- Start of processing for Check_Predicated_Discriminant
2127 if Ekind
(Base_Type
(Full_Type
)) = E_Record_Type
then
2128 Def
:= Type_Definition
(Parent
(Base_Type
(Full_Type
)));
2133 if Policy_In_Effect
(Name_Assert
) = Name_Check
2134 and then not Predicates_Ignored
(Etype
(Discr
))
2136 Prepend_To
(Res
, Make_Predicate_Check
(Typ
, Val
));
2139 -- If discriminant controls a variant, verify that predicate is
2140 -- obeyed or else an Others_Choice is present.
2142 if Nkind
(Def
) = N_Record_Definition
2143 and then Present
(Variant_Part
(Component_List
(Def
)))
2144 and then Policy_In_Effect
(Name_Assert
) = Name_Ignore
2146 Check_Missing_Others
(Variant_Part
(Component_List
(Def
)));
2148 end Check_Predicated_Discriminant
;
2158 First_Arg
: Node_Id
;
2159 Full_Init_Type
: Entity_Id
;
2160 Init_Call
: Node_Id
;
2161 Init_Type
: Entity_Id
;
2164 -- Start of processing for Build_Initialization_Call
2167 pragma Assert
(Constructor_Ref
= Empty
2168 or else Is_CPP_Constructor_Call
(Constructor_Ref
));
2170 if No
(Constructor_Ref
) then
2171 Proc
:= Base_Init_Proc
(Typ
);
2173 Proc
:= Base_Init_Proc
(Typ
, Entity
(Name
(Constructor_Ref
)));
2176 pragma Assert
(Present
(Proc
));
2177 Init_Type
:= Etype
(First_Formal
(Proc
));
2178 Full_Init_Type
:= Underlying_Type
(Init_Type
);
2180 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
2181 -- is active (in which case we make the call anyway, since in the
2182 -- actual compiled client it may be non null).
2184 if Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
then
2187 -- Nothing to do for an array of controlled components that have only
2188 -- the inherited Initialize primitive. This is a useful optimization
2191 elsif Is_Trivial_Subprogram
(Proc
)
2192 and then Is_Array_Type
(Full_Init_Type
)
2194 return New_List
(Make_Null_Statement
(Loc
));
2197 -- Use the [underlying] full view when dealing with a private type. This
2198 -- may require several steps depending on derivations.
2202 if Is_Private_Type
(Full_Type
) then
2203 if Present
(Full_View
(Full_Type
)) then
2204 Full_Type
:= Full_View
(Full_Type
);
2206 elsif Present
(Underlying_Full_View
(Full_Type
)) then
2207 Full_Type
:= Underlying_Full_View
(Full_Type
);
2209 -- When a private type acts as a generic actual and lacks a full
2210 -- view, use the base type.
2212 elsif Is_Generic_Actual_Type
(Full_Type
) then
2213 Full_Type
:= Base_Type
(Full_Type
);
2215 elsif Ekind
(Full_Type
) = E_Private_Subtype
2216 and then (not Has_Discriminants
(Full_Type
)
2217 or else No
(Discriminant_Constraint
(Full_Type
)))
2219 Full_Type
:= Etype
(Full_Type
);
2221 -- The loop has recovered the [underlying] full view, stop the
2228 -- The type is not private, nothing to do
2235 -- If Typ is derived, the procedure is the initialization procedure for
2236 -- the root type. Wrap the argument in an conversion to make it type
2237 -- honest. Actually it isn't quite type honest, because there can be
2238 -- conflicts of views in the private type case. That is why we set
2239 -- Conversion_OK in the conversion node.
2241 if (Is_Record_Type
(Typ
)
2242 or else Is_Array_Type
(Typ
)
2243 or else Is_Private_Type
(Typ
))
2244 and then Init_Type
/= Base_Type
(Typ
)
2246 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
2247 Set_Etype
(First_Arg
, Init_Type
);
2250 First_Arg
:= Id_Ref
;
2253 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
2255 -- In the tasks case, add _Master as the value of the _Master parameter
2256 -- and _Chain as the value of the _Chain parameter. At the outer level,
2257 -- these will be variables holding the corresponding values obtained
2258 -- from GNARL. At inner levels, they will be the parameters passed down
2259 -- through the outer routines.
2261 if Has_Task
(Full_Type
) then
2262 if Restriction_Active
(No_Task_Hierarchy
) then
2263 Append_To
(Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
2264 elsif Present
(Target_Ref
) then
2267 (Master_Id
(Base_Type
(Root_Type
(Etype
(Target_Ref
)))), Loc
));
2269 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
2272 -- Add _Chain (not done for sequential elaboration policy, see
2273 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2275 if Partition_Elaboration_Policy
/= 'S' then
2276 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2279 -- Ada 2005 (AI-287): In case of default initialized components
2280 -- with tasks, we generate a null string actual parameter.
2281 -- This is just a workaround that must be improved later???
2283 if With_Default_Init
then
2284 Append_To
(Args
, Make_String_Literal
(Loc
, Strval
=> ""));
2287 if Present
(Enclos_Type
) then
2288 A_Type
:= Enclos_Type
;
2290 elsif Present
(Target_Ref
)
2291 and then Nkind
(Target_Ref
) in N_Indexed_Component
2292 | N_Selected_Component
2294 A_Type
:= Etype
(Prefix
(Target_Ref
));
2297 A_Type
:= Full_Type
;
2301 Build_Task_Image_Decls
(Loc
,
2302 (if Present
(Target_Ref
) then Target_Ref
else Id_Ref
),
2305 Decl
:= Last
(Decls
);
2308 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
2309 Append_List
(Decls
, Res
);
2317 -- Handle the optionally generated formal *_skip_null_excluding_checks
2319 -- Look at the associated node for the object we are referencing and
2320 -- verify that we are expanding a call to an Init_Proc for an internally
2321 -- generated object declaration before passing True and skipping the
2324 if Needs_Conditional_Null_Excluding_Check
(Full_Init_Type
)
2325 and then Nkind
(Id_Ref
) in N_Has_Entity
2326 and then (Comes_From_Source
(Id_Ref
)
2327 or else (Present
(Associated_Node
(Id_Ref
))
2328 and then Comes_From_Source
2329 (Associated_Node
(Id_Ref
))))
2331 Append_To
(Args
, New_Occurrence_Of
(Standard_True
, Loc
));
2334 -- Add discriminant values if discriminants are present
2336 if Has_Discriminants
(Full_Init_Type
) then
2337 -- If an allocated object will be constrained by the default
2338 -- values for discriminants, then build a subtype with those
2339 -- defaults, and change the allocated subtype to that. Note
2340 -- that this happens in fewer cases in Ada 2005 (AI95-0363).
2342 if Nkind
(N
) = N_Allocator
2343 and then not Is_Constrained
(Full_Type
)
2346 (Discriminant_Default_Value
(First_Discriminant
(Full_Type
)))
2347 and then (Ada_Version
< Ada_2005
2348 or else not Object_Type_Has_Constrained_Partial_View
2349 (Full_Type
, Current_Scope
))
2351 Full_Type
:= Build_Default_Subtype
(Full_Type
, N
);
2352 Set_Expression
(N
, New_Occurrence_Of
(Full_Type
, Loc
));
2355 Discr
:= First_Discriminant
(Full_Init_Type
);
2356 while Present
(Discr
) loop
2358 -- If this is a discriminated concurrent type, the init_proc
2359 -- for the corresponding record is being called. Use that type
2360 -- directly to find the discriminant value, to handle properly
2361 -- intervening renamed discriminants.
2364 T
: Entity_Id
:= Full_Type
;
2367 if Is_Protected_Type
(T
) then
2368 T
:= Corresponding_Record_Type
(T
);
2372 Get_Discriminant_Value
(
2375 Discriminant_Constraint
(Full_Type
));
2378 -- If the target has access discriminants, and is constrained by
2379 -- an access to the enclosing construct, i.e. a current instance,
2380 -- replace the reference to the type by a reference to the object.
2382 if Nkind
(Arg
) = N_Attribute_Reference
2383 and then Is_Access_Type
(Etype
(Arg
))
2384 and then Is_Entity_Name
(Prefix
(Arg
))
2385 and then Is_Type
(Entity
(Prefix
(Arg
)))
2388 Make_Attribute_Reference
(Loc
,
2389 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
2390 Attribute_Name
=> Name_Unrestricted_Access
);
2392 elsif In_Init_Proc
then
2394 -- Replace any possible references to the discriminant in the
2395 -- call to the record initialization procedure with references
2396 -- to the appropriate formal parameter.
2398 if Nkind
(Arg
) = N_Identifier
2399 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2401 Arg
:= New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
);
2403 -- Otherwise make a copy of the default expression. Note that
2404 -- we use the current Sloc for this, because we do not want the
2405 -- call to appear to be at the declaration point. Within the
2406 -- expression, replace discriminants with their discriminals.
2410 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
2414 if Is_Constrained
(Full_Type
) then
2415 Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
2417 -- The constraints come from the discriminant default exps,
2418 -- they must be reevaluated, so we use New_Copy_Tree but we
2419 -- ensure the proper Sloc (for any embedded calls).
2420 -- In addition, if a predicate check is needed on the value
2421 -- of the discriminant, insert it ahead of the call.
2423 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
2426 if Has_Predicates
(Etype
(Discr
)) then
2427 Check_Predicated_Discriminant
(Arg
, Discr
);
2431 -- Ada 2005 (AI-287): In case of default initialized components,
2432 -- if the component is constrained with a discriminant of the
2433 -- enclosing type, we need to generate the corresponding selected
2434 -- component node to access the discriminant value. In other cases
2435 -- this is not required, either because we are inside the init
2436 -- proc and we use the corresponding formal, or else because the
2437 -- component is constrained by an expression.
2439 if With_Default_Init
2440 and then Nkind
(Id_Ref
) = N_Selected_Component
2441 and then Nkind
(Arg
) = N_Identifier
2442 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2445 Make_Selected_Component
(Loc
,
2446 Prefix
=> New_Copy_Tree
(Prefix
(Id_Ref
)),
2447 Selector_Name
=> Arg
));
2449 Append_To
(Args
, Arg
);
2452 Next_Discriminant
(Discr
);
2456 -- If this is a call to initialize the parent component of a derived
2457 -- tagged type, indicate that the tag should not be set in the parent.
2458 -- This is done via the actual parameter value for the Init_Control
2459 -- formal parameter, which is also used to deal with late initialization
2462 -- We pass in Full_Init_Except_Tag unless the caller tells us to do
2463 -- otherwise (by passing in a nonempty Init_Control_Actual parameter).
2465 if Is_Tagged_Type
(Full_Init_Type
)
2466 and then not Is_CPP_Class
(Full_Init_Type
)
2467 and then Nkind
(Id_Ref
) = N_Selected_Component
2468 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
2471 use Initialization_Control
;
2474 (if Present
(Init_Control_Actual
)
2475 then Init_Control_Actual
2476 else Make_Mode_Literal
(Loc
, Full_Init_Except_Tag
)));
2478 elsif Present
(Constructor_Ref
) then
2479 Append_List_To
(Args
,
2480 New_Copy_List
(Parameter_Associations
(Constructor_Ref
)));
2483 -- Pass the extra accessibility level parameter associated with the
2484 -- level of the object being initialized when required.
2486 if Is_Entity_Name
(Id_Ref
)
2487 and then Present
(Init_Proc_Level_Formal
(Proc
))
2490 Make_Parameter_Association
(Loc
,
2492 Make_Identifier
(Loc
, Name_uInit_Level
),
2493 Explicit_Actual_Parameter
=>
2494 Accessibility_Level
(Id_Ref
, Dynamic_Level
)));
2498 Make_Procedure_Call_Statement
(Loc
,
2499 Name
=> New_Occurrence_Of
(Proc
, Loc
),
2500 Parameter_Associations
=> Args
));
2502 if Needs_Finalization
(Typ
)
2503 and then Nkind
(Id_Ref
) = N_Selected_Component
2505 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
2508 (Obj_Ref
=> New_Copy_Tree
(First_Arg
),
2511 -- Guard against a missing [Deep_]Initialize when the type was not
2514 if Present
(Init_Call
) then
2515 Append_To
(Res
, Init_Call
);
2523 when RE_Not_Available
=>
2525 end Build_Initialization_Call
;
2527 ----------------------------
2528 -- Build_Record_Init_Proc --
2529 ----------------------------
2531 procedure Build_Record_Init_Proc
(N
: Node_Id
; Rec_Ent
: Entity_Id
) is
2532 Decls
: constant List_Id
:= New_List
;
2533 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
2534 Loc
: constant Source_Ptr
:= Sloc
(Rec_Ent
);
2536 Proc_Id
: Entity_Id
;
2537 Rec_Type
: Entity_Id
;
2539 Init_Control_Formal
: Entity_Id
:= Empty
; -- set in Build_Init_Statements
2540 Has_Late_Init_Comp
: Boolean := False; -- set in Build_Init_Statements
2542 function Build_Assignment
2544 Default
: Node_Id
) return List_Id
;
2545 -- Build an assignment statement that assigns the default expression to
2546 -- its corresponding record component if defined. The left-hand side of
2547 -- the assignment is marked Assignment_OK so that initialization of
2548 -- limited private records works correctly. This routine may also build
2549 -- an adjustment call if the component is controlled.
2551 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
2552 -- If the record has discriminants, add assignment statements to
2553 -- Statement_List to initialize the discriminant values from the
2554 -- arguments of the initialization procedure.
2556 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
2557 -- Build a list representing a sequence of statements which initialize
2558 -- components of the given component list. This may involve building
2559 -- case statements for the variant parts. Append any locally declared
2560 -- objects on list Decls.
2562 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
;
2563 -- Given an untagged type-derivation that declares discriminants, e.g.
2565 -- type R (R1, R2 : Integer) is record ... end record;
2566 -- type D (D1 : Integer) is new R (1, D1);
2568 -- we make the _init_proc of D be
2570 -- procedure _init_proc (X : D; D1 : Integer) is
2572 -- _init_proc (R (X), 1, D1);
2575 -- This function builds the call statement in this _init_proc.
2577 procedure Build_CPP_Init_Procedure
;
2578 -- Build the tree corresponding to the procedure specification and body
2579 -- of the IC procedure that initializes the C++ part of the dispatch
2580 -- table of an Ada tagged type that is a derivation of a CPP type.
2581 -- Install it as the CPP_Init TSS.
2583 procedure Build_Init_Procedure
;
2584 -- Build the tree corresponding to the procedure specification and body
2585 -- of the initialization procedure and install it as the _init TSS.
2587 procedure Build_Offset_To_Top_Functions
;
2588 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
2589 -- and body of Offset_To_Top, a function used in conjuction with types
2590 -- having secondary dispatch tables.
2592 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
2593 -- Add range checks to components of discriminated records. S is a
2594 -- subtype indication of a record component. Check_List is a list
2595 -- to which the check actions are appended.
2597 function Component_Needs_Simple_Initialization
2598 (T
: Entity_Id
) return Boolean;
2599 -- Determine if a component needs simple initialization, given its type
2600 -- T. This routine is the same as Needs_Simple_Initialization except for
2601 -- components of type Tag and Interface_Tag. These two access types do
2602 -- not require initialization since they are explicitly initialized by
2605 function Parent_Subtype_Renaming_Discrims
return Boolean;
2606 -- Returns True for base types N that rename discriminants, else False
2608 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
2609 -- Determine whether a record initialization procedure needs to be
2610 -- generated for the given record type.
2612 ----------------------
2613 -- Build_Assignment --
2614 ----------------------
2616 function Build_Assignment
2618 Default
: Node_Id
) return List_Id
2620 Default_Loc
: constant Source_Ptr
:= Sloc
(Default
);
2621 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
2631 Make_Selected_Component
(Default_Loc
,
2632 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2633 Selector_Name
=> New_Occurrence_Of
(Id
, Default_Loc
));
2634 Set_Assignment_OK
(Lhs
);
2636 -- Take copy of Default to ensure that later copies of this component
2637 -- declaration in derived types see the original tree, not a node
2638 -- rewritten during expansion of the init_proc. If the copy contains
2639 -- itypes, the scope of the new itypes is the init_proc being built.
2642 Map
: Elist_Id
:= No_Elist
;
2645 if Has_Late_Init_Comp
then
2646 -- Map the type to the _Init parameter in order to
2647 -- handle "current instance" references.
2649 Map
:= New_Elmt_List
2651 Elmt2
=> Defining_Identifier
(First
2652 (Parameter_Specifications
2653 (Parent
(Proc_Id
)))));
2655 -- If the type has an incomplete view, a current instance
2656 -- may have an incomplete type. In that case, it must also be
2657 -- replaced by the formal of the Init_Proc.
2659 if Nkind
(Parent
(Rec_Type
)) = N_Full_Type_Declaration
2660 and then Present
(Incomplete_View
(Parent
(Rec_Type
)))
2663 N
=> Incomplete_View
(Parent
(Rec_Type
)),
2666 N
=> Defining_Identifier
2668 (Parameter_Specifications
2669 (Parent
(Proc_Id
)))),
2674 Exp
:= New_Copy_Tree
(Default
, New_Scope
=> Proc_Id
, Map
=> Map
);
2678 Make_Assignment_Statement
(Loc
,
2680 Expression
=> Exp
));
2682 Set_No_Ctrl_Actions
(First
(Res
));
2684 Exp_Q
:= Unqualify
(Exp
);
2686 -- Adjust the tag if tagged (because of possible view conversions).
2687 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2688 -- tags are represented implicitly in objects, and when the record is
2689 -- initialized with a raise expression.
2691 if Is_Tagged_Type
(Typ
)
2692 and then Tagged_Type_Expansion
2693 and then Nkind
(Exp_Q
) /= N_Raise_Expression
2696 Make_Tag_Assignment_From_Type
2698 New_Copy_Tree
(Lhs
, New_Scope
=> Proc_Id
),
2699 Underlying_Type
(Typ
)));
2702 -- Adjust the component if controlled except if it is an aggregate
2703 -- that will be expanded inline.
2705 if Needs_Finalization
(Typ
)
2706 and then Nkind
(Exp_Q
) not in N_Aggregate | N_Extension_Aggregate
2707 and then not Is_Build_In_Place_Function_Call
(Exp
)
2711 (Obj_Ref
=> New_Copy_Tree
(Lhs
),
2714 -- Guard against a missing [Deep_]Adjust when the component type
2715 -- was not properly frozen.
2717 if Present
(Adj_Call
) then
2718 Append_To
(Res
, Adj_Call
);
2725 when RE_Not_Available
=>
2727 end Build_Assignment
;
2729 ------------------------------------
2730 -- Build_Discriminant_Assignments --
2731 ------------------------------------
2733 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
2734 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
2739 if Has_Discriminants
(Rec_Type
)
2740 and then not Is_Unchecked_Union
(Rec_Type
)
2742 D
:= First_Discriminant
(Rec_Type
);
2743 while Present
(D
) loop
2745 -- Don't generate the assignment for discriminants in derived
2746 -- tagged types if the discriminant is a renaming of some
2747 -- ancestor discriminant. This initialization will be done
2748 -- when initializing the _parent field of the derived record.
2751 and then Present
(Corresponding_Discriminant
(D
))
2757 Append_List_To
(Statement_List
,
2758 Build_Assignment
(D
,
2759 New_Occurrence_Of
(Discriminal
(D
), D_Loc
)));
2762 Next_Discriminant
(D
);
2765 end Build_Discriminant_Assignments
;
2767 --------------------------
2768 -- Build_Init_Call_Thru --
2769 --------------------------
2771 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
is
2772 Parent_Proc
: constant Entity_Id
:=
2773 Base_Init_Proc
(Etype
(Rec_Type
));
2775 Parent_Type
: constant Entity_Id
:=
2776 Etype
(First_Formal
(Parent_Proc
));
2778 Uparent_Type
: constant Entity_Id
:=
2779 Underlying_Type
(Parent_Type
);
2781 First_Discr_Param
: Node_Id
;
2785 First_Arg
: Node_Id
;
2786 Parent_Discr
: Entity_Id
;
2790 -- First argument (_Init) is the object to be initialized.
2791 -- ??? not sure where to get a reasonable Loc for First_Arg
2794 OK_Convert_To
(Parent_Type
,
2796 (Defining_Identifier
(First
(Parameters
)), Loc
));
2798 Set_Etype
(First_Arg
, Parent_Type
);
2800 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
2802 -- In the tasks case,
2803 -- add _Master as the value of the _Master parameter
2804 -- add _Chain as the value of the _Chain parameter.
2805 -- add _Task_Name as the value of the _Task_Name parameter.
2806 -- At the outer level, these will be variables holding the
2807 -- corresponding values obtained from GNARL or the expander.
2809 -- At inner levels, they will be the parameters passed down through
2810 -- the outer routines.
2812 First_Discr_Param
:= Next
(First
(Parameters
));
2814 if Has_Task
(Rec_Type
) then
2815 if Restriction_Active
(No_Task_Hierarchy
) then
2817 (Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
2819 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
2822 -- Add _Chain (not done for sequential elaboration policy, see
2823 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2825 if Partition_Elaboration_Policy
/= 'S' then
2826 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2829 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
2830 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
2833 -- Append discriminant values
2835 if Has_Discriminants
(Uparent_Type
) then
2836 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
2838 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
2839 while Present
(Parent_Discr
) loop
2841 -- Get the initial value for this discriminant
2842 -- ??? needs to be cleaned up to use parent_Discr_Constr
2846 Discr
: Entity_Id
:=
2847 First_Stored_Discriminant
(Uparent_Type
);
2849 Discr_Value
: Elmt_Id
:=
2850 First_Elmt
(Stored_Constraint
(Rec_Type
));
2853 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
2854 Next_Stored_Discriminant
(Discr
);
2855 Next_Elmt
(Discr_Value
);
2858 Arg
:= Node
(Discr_Value
);
2861 -- Append it to the list
2863 if Nkind
(Arg
) = N_Identifier
2864 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2867 New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
));
2869 -- Case of access discriminants. We replace the reference
2870 -- to the type by a reference to the actual object.
2872 -- Is above comment right??? Use of New_Copy below seems mighty
2876 Append_To
(Args
, New_Copy
(Arg
));
2879 Next_Discriminant
(Parent_Discr
);
2885 Make_Procedure_Call_Statement
(Loc
,
2887 New_Occurrence_Of
(Parent_Proc
, Loc
),
2888 Parameter_Associations
=> Args
));
2891 end Build_Init_Call_Thru
;
2893 -----------------------------------
2894 -- Build_Offset_To_Top_Functions --
2895 -----------------------------------
2897 procedure Build_Offset_To_Top_Functions
is
2899 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
);
2901 -- function Fxx (O : Address) return Storage_Offset is
2902 -- type Acc is access all <Typ>;
2904 -- return Acc!(O).Iface_Comp'Position;
2907 ----------------------------------
2908 -- Build_Offset_To_Top_Function --
2909 ----------------------------------
2911 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
) is
2912 Body_Node
: Node_Id
;
2913 Func_Id
: Entity_Id
;
2914 Spec_Node
: Node_Id
;
2915 Acc_Type
: Entity_Id
;
2918 Func_Id
:= Make_Temporary
(Loc
, 'F');
2919 Set_DT_Offset_To_Top_Func
(Iface_Comp
, Func_Id
);
2922 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2924 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
2925 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
2926 Set_Parameter_Specifications
(Spec_Node
, New_List
(
2927 Make_Parameter_Specification
(Loc
,
2928 Defining_Identifier
=>
2929 Make_Defining_Identifier
(Loc
, Name_uO
),
2932 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))));
2933 Set_Result_Definition
(Spec_Node
,
2934 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
));
2937 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2939 -- return -O.Iface_Comp'Position;
2942 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2943 Set_Specification
(Body_Node
, Spec_Node
);
2945 Acc_Type
:= Make_Temporary
(Loc
, 'T');
2946 Set_Declarations
(Body_Node
, New_List
(
2947 Make_Full_Type_Declaration
(Loc
,
2948 Defining_Identifier
=> Acc_Type
,
2950 Make_Access_To_Object_Definition
(Loc
,
2951 All_Present
=> True,
2952 Null_Exclusion_Present
=> False,
2953 Constant_Present
=> False,
2954 Subtype_Indication
=>
2955 New_Occurrence_Of
(Rec_Type
, Loc
)))));
2957 Set_Handled_Statement_Sequence
(Body_Node
,
2958 Make_Handled_Sequence_Of_Statements
(Loc
,
2959 Statements
=> New_List
(
2960 Make_Simple_Return_Statement
(Loc
,
2963 Make_Attribute_Reference
(Loc
,
2965 Make_Selected_Component
(Loc
,
2967 Make_Explicit_Dereference
(Loc
,
2968 Unchecked_Convert_To
(Acc_Type
,
2969 Make_Identifier
(Loc
, Name_uO
))),
2971 New_Occurrence_Of
(Iface_Comp
, Loc
)),
2972 Attribute_Name
=> Name_Position
))))));
2974 Mutate_Ekind
(Func_Id
, E_Function
);
2975 Set_Mechanism
(Func_Id
, Default_Mechanism
);
2976 Set_Is_Internal
(Func_Id
, True);
2978 if not Debug_Generated_Code
then
2979 Set_Debug_Info_Off
(Func_Id
);
2982 Analyze
(Body_Node
);
2984 Append_Freeze_Action
(Rec_Type
, Body_Node
);
2985 end Build_Offset_To_Top_Function
;
2989 Iface_Comp
: Node_Id
;
2990 Iface_Comp_Elmt
: Elmt_Id
;
2991 Ifaces_Comp_List
: Elist_Id
;
2993 -- Start of processing for Build_Offset_To_Top_Functions
2996 -- Offset_To_Top_Functions are built only for derivations of types
2997 -- with discriminants that cover interface types.
2998 -- Nothing is needed either in case of virtual targets, since
2999 -- interfaces are handled directly by the target.
3001 if not Is_Tagged_Type
(Rec_Type
)
3002 or else Etype
(Rec_Type
) = Rec_Type
3003 or else not Has_Discriminants
(Etype
(Rec_Type
))
3004 or else not Tagged_Type_Expansion
3009 Collect_Interface_Components
(Rec_Type
, Ifaces_Comp_List
);
3011 -- For each interface type with secondary dispatch table we generate
3012 -- the Offset_To_Top_Functions (required to displace the pointer in
3013 -- interface conversions)
3015 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
3016 while Present
(Iface_Comp_Elmt
) loop
3017 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
3018 pragma Assert
(Is_Interface
(Related_Type
(Iface_Comp
)));
3020 -- If the interface is a parent of Rec_Type it shares the primary
3021 -- dispatch table and hence there is no need to build the function
3023 if not Is_Ancestor
(Related_Type
(Iface_Comp
), Rec_Type
,
3024 Use_Full_View
=> True)
3026 Build_Offset_To_Top_Function
(Iface_Comp
);
3029 Next_Elmt
(Iface_Comp_Elmt
);
3031 end Build_Offset_To_Top_Functions
;
3033 ------------------------------
3034 -- Build_CPP_Init_Procedure --
3035 ------------------------------
3037 procedure Build_CPP_Init_Procedure
is
3038 Body_Node
: Node_Id
;
3039 Body_Stmts
: List_Id
;
3040 Flag_Id
: Entity_Id
;
3041 Handled_Stmt_Node
: Node_Id
;
3042 Init_Tags_List
: List_Id
;
3043 Proc_Id
: Entity_Id
;
3044 Proc_Spec_Node
: Node_Id
;
3047 -- Check cases requiring no IC routine
3049 if not Is_CPP_Class
(Root_Type
(Rec_Type
))
3050 or else Is_CPP_Class
(Rec_Type
)
3051 or else CPP_Num_Prims
(Rec_Type
) = 0
3052 or else not Tagged_Type_Expansion
3053 or else No_Run_Time_Mode
3060 -- Flag : Boolean := False;
3062 -- procedure Typ_IC is
3065 -- Copy C++ dispatch table slots from parent
3066 -- Update C++ slots of overridden primitives
3070 Flag_Id
:= Make_Temporary
(Loc
, 'F');
3072 Append_Freeze_Action
(Rec_Type
,
3073 Make_Object_Declaration
(Loc
,
3074 Defining_Identifier
=> Flag_Id
,
3075 Object_Definition
=>
3076 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3078 New_Occurrence_Of
(Standard_True
, Loc
)));
3080 Body_Stmts
:= New_List
;
3081 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
3083 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
3086 Make_Defining_Identifier
(Loc
,
3087 Chars
=> Make_TSS_Name
(Rec_Type
, TSS_CPP_Init_Proc
));
3089 Mutate_Ekind
(Proc_Id
, E_Procedure
);
3090 Set_Is_Internal
(Proc_Id
);
3092 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
3094 Set_Parameter_Specifications
(Proc_Spec_Node
, New_List
);
3095 Set_Specification
(Body_Node
, Proc_Spec_Node
);
3096 Set_Declarations
(Body_Node
, New_List
);
3098 Init_Tags_List
:= Build_Inherit_CPP_Prims
(Rec_Type
);
3100 Append_To
(Init_Tags_List
,
3101 Make_Assignment_Statement
(Loc
,
3103 New_Occurrence_Of
(Flag_Id
, Loc
),
3105 New_Occurrence_Of
(Standard_False
, Loc
)));
3107 Append_To
(Body_Stmts
,
3108 Make_If_Statement
(Loc
,
3109 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
3110 Then_Statements
=> Init_Tags_List
));
3112 Handled_Stmt_Node
:=
3113 New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
3114 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
3115 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
3116 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
3118 if not Debug_Generated_Code
then
3119 Set_Debug_Info_Off
(Proc_Id
);
3122 -- Associate CPP_Init_Proc with type
3124 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3125 end Build_CPP_Init_Procedure
;
3127 --------------------------
3128 -- Build_Init_Procedure --
3129 --------------------------
3131 procedure Build_Init_Procedure
is
3132 Body_Stmts
: List_Id
;
3133 Body_Node
: Node_Id
;
3134 Handled_Stmt_Node
: Node_Id
;
3135 Init_Tags_List
: List_Id
;
3136 Parameters
: List_Id
;
3137 Proc_Spec_Node
: Node_Id
;
3138 Record_Extension_Node
: Node_Id
;
3140 use Initialization_Control
;
3142 Body_Stmts
:= New_List
;
3143 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
3144 Mutate_Ekind
(Proc_Id
, E_Procedure
);
3146 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
3147 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
3149 Parameters
:= Init_Formals
(Rec_Type
, Proc_Id
);
3150 Append_List_To
(Parameters
,
3151 Build_Discriminant_Formals
(Rec_Type
, True));
3153 -- For tagged types, we add a parameter to indicate what
3154 -- portion of the object's initialization is to be performed.
3155 -- This is used for two purposes:
3156 -- 1) When a type extension's initialization procedure calls
3157 -- the initialization procedure of the parent type, we do
3158 -- not want the parent to initialize the Tag component;
3159 -- it has been set already.
3160 -- 2) If an ancestor type has at least one component that requires
3161 -- late initialization, then we need to be able to initialize
3162 -- those components separately after initializing any other
3165 if Is_Tagged_Type
(Rec_Type
) then
3166 Init_Control_Formal
:= Make_Temporary
(Loc
, 'P');
3168 Append_To
(Parameters
,
3169 Make_Parameter_Specification
(Loc
,
3170 Defining_Identifier
=> Init_Control_Formal
,
3172 New_Occurrence_Of
(Standard_Natural
, Loc
),
3173 Expression
=> Make_Mode_Literal
(Loc
, Full_Init
)));
3176 -- Create an extra accessibility parameter to capture the level of
3177 -- the object being initialized when its type is a limited record.
3179 if Is_Limited_Record
(Rec_Type
) then
3180 Append_To
(Parameters
,
3181 Make_Parameter_Specification
(Loc
,
3182 Defining_Identifier
=> Make_Defining_Identifier
3183 (Loc
, Name_uInit_Level
),
3185 New_Occurrence_Of
(Standard_Natural
, Loc
),
3187 Make_Integer_Literal
3188 (Loc
, Scope_Depth
(Standard_Standard
))));
3191 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
3192 Set_Specification
(Body_Node
, Proc_Spec_Node
);
3193 Set_Declarations
(Body_Node
, Decls
);
3195 -- N is a Derived_Type_Definition that renames the parameters of the
3196 -- ancestor type. We initialize it by expanding our discriminants and
3197 -- call the ancestor _init_proc with a type-converted object.
3199 if Parent_Subtype_Renaming_Discrims
then
3200 Append_List_To
(Body_Stmts
, Build_Init_Call_Thru
(Parameters
));
3202 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
3203 Build_Discriminant_Assignments
(Body_Stmts
);
3205 if not Null_Present
(Type_Definition
(N
)) then
3206 Append_List_To
(Body_Stmts
,
3207 Build_Init_Statements
(Component_List
(Type_Definition
(N
))));
3210 -- N is a Derived_Type_Definition with a possible non-empty
3211 -- extension. The initialization of a type extension consists in the
3212 -- initialization of the components in the extension.
3215 Build_Discriminant_Assignments
(Body_Stmts
);
3217 Record_Extension_Node
:=
3218 Record_Extension_Part
(Type_Definition
(N
));
3220 if not Null_Present
(Record_Extension_Node
) then
3222 Stmts
: constant List_Id
:=
3223 Build_Init_Statements
(
3224 Component_List
(Record_Extension_Node
));
3227 -- The parent field must be initialized first because the
3228 -- offset of the new discriminants may depend on it. This is
3229 -- not needed if the parent is an interface type because in
3230 -- such case the initialization of the _parent field was not
3233 if not Is_Interface
(Etype
(Rec_Ent
)) then
3235 Parent_IP
: constant Name_Id
:=
3236 Make_Init_Proc_Name
(Etype
(Rec_Ent
));
3237 Stmt
: Node_Id
:= First
(Stmts
);
3238 IP_Call
: Node_Id
:= Empty
;
3240 -- Look for a call to the parent IP associated with
3241 -- the record extension.
3242 -- The call will be inside not one but two
3243 -- if-statements (with the same condition). Testing
3244 -- the same Early_Init condition twice might seem
3245 -- redundant. However, as soon as we exit this loop,
3246 -- we are going to hoist the inner if-statement out
3247 -- of the outer one; the "redundant" test was built
3248 -- in anticipation of this hoisting.
3250 while Present
(Stmt
) loop
3251 if Nkind
(Stmt
) = N_If_Statement
then
3253 Then_Stmt1
: Node_Id
:=
3254 First
(Then_Statements
(Stmt
));
3255 Then_Stmt2
: Node_Id
;
3257 while Present
(Then_Stmt1
) loop
3258 if Nkind
(Then_Stmt1
) = N_If_Statement
then
3260 First
(Then_Statements
(Then_Stmt1
));
3262 if Nkind
(Then_Stmt2
) =
3263 N_Procedure_Call_Statement
3264 and then Chars
(Name
(Then_Stmt2
)) =
3267 -- IP_Call is a call wrapped in an
3269 IP_Call
:= Then_Stmt1
;
3281 -- If found then move it to the beginning of the
3282 -- statements of this IP routine
3284 if Present
(IP_Call
) then
3286 Prepend_List_To
(Body_Stmts
, New_List
(IP_Call
));
3291 Append_List_To
(Body_Stmts
, Stmts
);
3296 -- Add here the assignment to instantiate the Tag
3298 -- The assignment corresponds to the code:
3300 -- _Init._Tag := Typ'Tag;
3302 -- Suppress the tag assignment when not Tagged_Type_Expansion because
3303 -- tags are represented implicitly in objects. It is also suppressed
3304 -- in case of CPP_Class types because in this case the tag is
3305 -- initialized in the C++ side.
3307 if Is_Tagged_Type
(Rec_Type
)
3308 and then Tagged_Type_Expansion
3309 and then not No_Run_Time_Mode
3311 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
3312 -- the actual object and invoke the IP of the parent (in this
3313 -- order). The tag must be initialized before the call to the IP
3314 -- of the parent and the assignments to other components because
3315 -- the initial value of the components may depend on the tag (eg.
3316 -- through a dispatching operation on an access to the current
3317 -- type). The tag assignment is not done when initializing the
3318 -- parent component of a type extension, because in that case the
3319 -- tag is set in the extension.
3321 if not Is_CPP_Class
(Root_Type
(Rec_Type
)) then
3323 -- Initialize the primary tag component
3325 Init_Tags_List
:= New_List
(
3326 Make_Tag_Assignment_From_Type
3327 (Loc
, Make_Identifier
(Loc
, Name_uInit
), Rec_Type
));
3329 -- Ada 2005 (AI-251): Initialize the secondary tags components
3330 -- located at fixed positions (tags whose position depends on
3331 -- variable size components are initialized later ---see below)
3333 if Ada_Version
>= Ada_2005
3334 and then not Is_Interface
(Rec_Type
)
3335 and then Has_Interfaces
(Rec_Type
)
3338 Elab_Sec_DT_Stmts_List
: constant List_Id
:= New_List
;
3339 Elab_List
: List_Id
:= New_List
;
3344 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3345 Init_Tags_List
=> Init_Tags_List
,
3346 Stmts_List
=> Elab_Sec_DT_Stmts_List
,
3347 Fixed_Comps
=> True,
3348 Variable_Comps
=> False);
3350 Elab_List
:= New_List
(
3351 Make_If_Statement
(Loc
,
3353 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
3354 Then_Statements
=> Init_Tags_List
));
3356 if Elab_Flag_Needed
(Rec_Type
) then
3357 Append_To
(Elab_Sec_DT_Stmts_List
,
3358 Make_Assignment_Statement
(Loc
,
3361 (Access_Disp_Table_Elab_Flag
(Rec_Type
),
3364 New_Occurrence_Of
(Standard_False
, Loc
)));
3366 Append_To
(Elab_List
,
3367 Make_If_Statement
(Loc
,
3370 (Access_Disp_Table_Elab_Flag
(Rec_Type
), Loc
),
3371 Then_Statements
=> Elab_Sec_DT_Stmts_List
));
3374 Prepend_List_To
(Body_Stmts
, Elab_List
);
3377 Prepend_To
(Body_Stmts
,
3378 Make_If_Statement
(Loc
,
3380 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
3381 Then_Statements
=> Init_Tags_List
));
3384 -- Case 2: CPP type. The imported C++ constructor takes care of
3385 -- tags initialization. No action needed here because the IP
3386 -- is built by Set_CPP_Constructors; in this case the IP is a
3387 -- wrapper that invokes the C++ constructor and copies the C++
3388 -- tags locally. Done to inherit the C++ slots in Ada derivations
3391 elsif Is_CPP_Class
(Rec_Type
) then
3392 pragma Assert
(False);
3395 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
3396 -- type derivations. Derivations of imported C++ classes add a
3397 -- complication, because we cannot inhibit tag setting in the
3398 -- constructor for the parent. Hence we initialize the tag after
3399 -- the call to the parent IP (that is, in reverse order compared
3400 -- with pure Ada hierarchies ---see comment on case 1).
3403 -- Initialize the primary tag
3405 Init_Tags_List
:= New_List
(
3406 Make_Tag_Assignment_From_Type
3407 (Loc
, Make_Identifier
(Loc
, Name_uInit
), Rec_Type
));
3409 -- Ada 2005 (AI-251): Initialize the secondary tags components
3410 -- located at fixed positions (tags whose position depends on
3411 -- variable size components are initialized later ---see below)
3413 if Ada_Version
>= Ada_2005
3414 and then not Is_Interface
(Rec_Type
)
3415 and then Has_Interfaces
(Rec_Type
)
3419 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3420 Init_Tags_List
=> Init_Tags_List
,
3421 Stmts_List
=> Init_Tags_List
,
3422 Fixed_Comps
=> True,
3423 Variable_Comps
=> False);
3426 -- Initialize the tag component after invocation of parent IP.
3429 -- parent_IP(_init.parent); // Invokes the C++ constructor
3430 -- [ typIC; ] // Inherit C++ slots from parent
3437 -- Search for the call to the IP of the parent. We assume
3438 -- that the first init_proc call is for the parent.
3439 -- It is wrapped in an "if Early_Init_Condition"
3442 Ins_Nod
:= First
(Body_Stmts
);
3443 while Present
(Next
(Ins_Nod
))
3445 (Nkind
(Ins_Nod
) /= N_If_Statement
3446 or else Nkind
(First
(Then_Statements
(Ins_Nod
)))
3447 /= N_Procedure_Call_Statement
3448 or else not Is_Init_Proc
3449 (Name
(First
(Then_Statements
3455 -- The IC routine copies the inherited slots of the C+ part
3456 -- of the dispatch table from the parent and updates the
3457 -- overridden C++ slots.
3459 if CPP_Num_Prims
(Rec_Type
) > 0 then
3461 Init_DT
: Entity_Id
;
3465 Init_DT
:= CPP_Init_Proc
(Rec_Type
);
3466 pragma Assert
(Present
(Init_DT
));
3469 Make_Procedure_Call_Statement
(Loc
,
3470 New_Occurrence_Of
(Init_DT
, Loc
));
3471 Insert_After
(Ins_Nod
, New_Nod
);
3473 -- Update location of init tag statements
3479 Insert_List_After
(Ins_Nod
, Init_Tags_List
);
3483 -- Ada 2005 (AI-251): Initialize the secondary tag components
3484 -- located at variable positions. We delay the generation of this
3485 -- code until here because the value of the attribute 'Position
3486 -- applied to variable size components of the parent type that
3487 -- depend on discriminants is only safely read at runtime after
3488 -- the parent components have been initialized.
3490 if Ada_Version
>= Ada_2005
3491 and then not Is_Interface
(Rec_Type
)
3492 and then Has_Interfaces
(Rec_Type
)
3493 and then Has_Discriminants
(Etype
(Rec_Type
))
3494 and then Is_Variable_Size_Record
(Etype
(Rec_Type
))
3496 Init_Tags_List
:= New_List
;
3500 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3501 Init_Tags_List
=> Init_Tags_List
,
3502 Stmts_List
=> Init_Tags_List
,
3503 Fixed_Comps
=> False,
3504 Variable_Comps
=> True);
3506 Append_List_To
(Body_Stmts
, Init_Tags_List
);
3510 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
3511 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
3514 -- Deep_Finalize (_init, C1, ..., CN);
3518 and then Needs_Finalization
(Rec_Type
)
3519 and then not Is_Abstract_Type
(Rec_Type
)
3520 and then not Restriction_Active
(No_Exception_Propagation
)
3527 -- Create a local version of Deep_Finalize which has indication
3528 -- of partial initialization state.
3531 Make_Defining_Identifier
(Loc
,
3532 Chars
=> New_External_Name
(Name_uFinalizer
));
3534 Append_To
(Decls
, Make_Local_Deep_Finalize
(Rec_Type
, DF_Id
));
3537 Make_Procedure_Call_Statement
(Loc
,
3538 Name
=> New_Occurrence_Of
(DF_Id
, Loc
),
3539 Parameter_Associations
=> New_List
(
3540 Make_Identifier
(Loc
, Name_uInit
),
3541 New_Occurrence_Of
(Standard_False
, Loc
)));
3543 -- Do not emit warnings related to the elaboration order when a
3544 -- controlled object is declared before the body of Finalize is
3547 if Legacy_Elaboration_Checks
then
3548 Set_No_Elaboration_Check
(DF_Call
);
3551 Set_Exception_Handlers
(Handled_Stmt_Node
, New_List
(
3552 Make_Exception_Handler
(Loc
,
3553 Exception_Choices
=> New_List
(
3554 Make_Others_Choice
(Loc
)),
3555 Statements
=> New_List
(
3557 Make_Raise_Statement
(Loc
)))));
3560 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
3563 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
3565 if not Debug_Generated_Code
then
3566 Set_Debug_Info_Off
(Proc_Id
);
3569 -- Associate Init_Proc with type, and determine if the procedure
3570 -- is null (happens because of the Initialize_Scalars pragma case,
3571 -- where we have to generate a null procedure in case it is called
3572 -- by a client with Initialize_Scalars set). Such procedures have
3573 -- to be generated, but do not have to be called, so we mark them
3574 -- as null to suppress the call. Kill also warnings for the _Init
3575 -- out parameter, which is left entirely uninitialized.
3577 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3579 if Is_Null_Statement_List
(Body_Stmts
) then
3580 Set_Is_Null_Init_Proc
(Proc_Id
);
3581 Set_Warnings_Off
(Defining_Identifier
(First
(Parameters
)));
3583 end Build_Init_Procedure
;
3585 ---------------------------
3586 -- Build_Init_Statements --
3587 ---------------------------
3589 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
3590 Checks
: constant List_Id
:= New_List
;
3591 Actions
: List_Id
:= No_List
;
3592 Counter_Id
: Entity_Id
:= Empty
;
3593 Comp_Loc
: Source_Ptr
;
3596 Parent_Stmts
: List_Id
;
3597 Parent_Id
: Entity_Id
:= Empty
;
3598 Stmts
, Late_Stmts
: List_Id
:= Empty_List
;
3601 procedure Increment_Counter
3602 (Loc
: Source_Ptr
; Late
: Boolean := False);
3603 -- Generate an "increment by one" statement for the current counter
3604 -- and append it to the appropriate statement list.
3606 procedure Make_Counter
(Loc
: Source_Ptr
);
3607 -- Create a new counter for the current component list. The routine
3608 -- creates a new defining Id, adds an object declaration and sets
3609 -- the Id generator for the next variant.
3611 -----------------------
3612 -- Increment_Counter --
3613 -----------------------
3615 procedure Increment_Counter
3616 (Loc
: Source_Ptr
; Late
: Boolean := False) is
3619 -- Counter := Counter + 1;
3621 Append_To
((if Late
then Late_Stmts
else Stmts
),
3622 Make_Assignment_Statement
(Loc
,
3623 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3626 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3627 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
3628 end Increment_Counter
;
3634 procedure Make_Counter
(Loc
: Source_Ptr
) is
3636 -- Increment the Id generator
3638 Counter
:= Counter
+ 1;
3640 -- Create the entity and declaration
3643 Make_Defining_Identifier
(Loc
,
3644 Chars
=> New_External_Name
('C', Counter
));
3647 -- Cnn : Integer := 0;
3650 Make_Object_Declaration
(Loc
,
3651 Defining_Identifier
=> Counter_Id
,
3652 Object_Definition
=>
3653 New_Occurrence_Of
(Standard_Integer
, Loc
),
3655 Make_Integer_Literal
(Loc
, 0)));
3658 -- Start of processing for Build_Init_Statements
3661 if Null_Present
(Comp_List
) then
3662 return New_List
(Make_Null_Statement
(Loc
));
3665 Parent_Stmts
:= New_List
;
3668 -- Loop through visible declarations of task types and protected
3669 -- types moving any expanded code from the spec to the body of the
3672 if Is_Concurrent_Record_Type
(Rec_Type
) then
3674 Decl
: constant Node_Id
:=
3675 Parent
(Corresponding_Concurrent_Type
(Rec_Type
));
3681 if Is_Task_Record_Type
(Rec_Type
) then
3682 Def
:= Task_Definition
(Decl
);
3684 Def
:= Protected_Definition
(Decl
);
3687 if Present
(Def
) then
3688 N1
:= First
(Visible_Declarations
(Def
));
3689 while Present
(N1
) loop
3693 if Nkind
(N2
) in N_Statement_Other_Than_Procedure_Call
3694 or else Nkind
(N2
) in N_Raise_xxx_Error
3695 or else Nkind
(N2
) = N_Procedure_Call_Statement
3698 New_Copy_Tree
(N2
, New_Scope
=> Proc_Id
));
3699 Rewrite
(N2
, Make_Null_Statement
(Sloc
(N2
)));
3707 -- Loop through components, skipping pragmas, in 2 steps. The first
3708 -- step deals with regular components. The second step deals with
3709 -- components that require late initialization.
3711 -- First pass : regular components
3713 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
3714 while Present
(Decl
) loop
3715 Comp_Loc
:= Sloc
(Decl
);
3717 (Subtype_Indication
(Component_Definition
(Decl
)), Checks
);
3719 Id
:= Defining_Identifier
(Decl
);
3721 -- Obtain the corresponding mutably tagged type's parent subtype
3722 -- to handle default initialization.
3724 Typ
:= Get_Corresponding_Tagged_Type_If_Present
(Etype
(Id
));
3726 -- Leave any processing of component requiring late initialization
3727 -- for the second pass.
3729 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
) then
3730 if not Has_Late_Init_Comp
then
3731 Late_Stmts
:= New_List
;
3733 Has_Late_Init_Comp
:= True;
3735 -- Regular component cases
3738 -- In the context of the init proc, references to discriminants
3739 -- resolve to denote the discriminals: this is where we can
3740 -- freeze discriminant dependent component subtypes.
3742 if not Is_Frozen
(Typ
) then
3743 Append_List_To
(Stmts
, Freeze_Entity
(Typ
, N
));
3746 -- Explicit initialization
3748 if Present
(Expression
(Decl
)) then
3749 if Is_CPP_Constructor_Call
(Expression
(Decl
)) then
3751 Build_Initialization_Call
3754 Make_Selected_Component
(Comp_Loc
,
3756 Make_Identifier
(Comp_Loc
, Name_uInit
),
3758 New_Occurrence_Of
(Id
, Comp_Loc
)),
3760 In_Init_Proc
=> True,
3761 Enclos_Type
=> Rec_Type
,
3762 Discr_Map
=> Discr_Map
,
3763 Constructor_Ref
=> Expression
(Decl
));
3765 Actions
:= Build_Assignment
(Id
, Expression
(Decl
));
3768 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3769 -- components are filled in with the corresponding rep-item
3770 -- expression of the concurrent type (if any).
3772 elsif Ekind
(Scope
(Id
)) = E_Record_Type
3773 and then Present
(Corresponding_Concurrent_Type
(Scope
(Id
)))
3774 and then Chars
(Id
) in Name_uCPU
3775 | Name_uDispatching_Domain
3777 | Name_uSecondary_Stack_Size
3782 pragma Warnings
(Off
, Nam
);
3786 if Chars
(Id
) = Name_uCPU
then
3789 elsif Chars
(Id
) = Name_uDispatching_Domain
then
3790 Nam
:= Name_Dispatching_Domain
;
3792 elsif Chars
(Id
) = Name_uPriority
then
3793 Nam
:= Name_Priority
;
3795 elsif Chars
(Id
) = Name_uSecondary_Stack_Size
then
3796 Nam
:= Name_Secondary_Stack_Size
;
3799 -- Get the Rep Item (aspect specification, attribute
3800 -- definition clause or pragma) of the corresponding
3805 (Corresponding_Concurrent_Type
(Scope
(Id
)),
3807 Check_Parents
=> False);
3809 if Present
(Ritem
) then
3813 if Nkind
(Ritem
) = N_Pragma
then
3816 (First
(Pragma_Argument_Associations
(Ritem
)));
3818 -- Conversion for Priority expression
3820 if Nam
= Name_Priority
then
3821 if Pragma_Name
(Ritem
) = Name_Priority
3822 and then not GNAT_Mode
3824 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3827 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3831 -- Aspect/Attribute definition clause case
3834 Exp
:= Expression
(Ritem
);
3836 -- Conversion for Priority expression
3838 if Nam
= Name_Priority
then
3839 if Chars
(Ritem
) = Name_Priority
3840 and then not GNAT_Mode
3842 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3845 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3850 -- Conversion for Dispatching_Domain value
3852 if Nam
= Name_Dispatching_Domain
then
3854 Unchecked_Convert_To
3855 (RTE
(RE_Dispatching_Domain_Access
), Exp
);
3857 -- Conversion for Secondary_Stack_Size value
3859 elsif Nam
= Name_Secondary_Stack_Size
then
3860 Exp
:= Convert_To
(RTE
(RE_Size_Type
), Exp
);
3863 Actions
:= Build_Assignment
(Id
, Exp
);
3865 -- Nothing needed if no Rep Item
3872 -- Composite component with its own Init_Proc
3874 elsif not Is_Interface
(Typ
)
3875 and then Has_Non_Null_Base_Init_Proc
(Typ
)
3878 use Initialization_Control
;
3879 Init_Control_Actual
: Node_Id
:= Empty
;
3880 Is_Parent
: constant Boolean := Chars
(Id
) = Name_uParent
;
3881 Init_Call_Stmts
: List_Id
;
3883 if Is_Parent
and then Has_Late_Init_Component
(Etype
(Id
))
3885 Init_Control_Actual
:=
3886 Make_Mode_Literal
(Comp_Loc
, Early_Init_Only
);
3887 -- Parent_Id used later in second call to parent's
3888 -- init proc to initialize late-init components.
3893 Build_Initialization_Call
3895 Make_Selected_Component
(Comp_Loc
,
3897 Make_Identifier
(Comp_Loc
, Name_uInit
),
3898 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
3900 In_Init_Proc
=> True,
3901 Enclos_Type
=> Rec_Type
,
3902 Discr_Map
=> Discr_Map
,
3903 Init_Control_Actual
=> Init_Control_Actual
);
3906 -- This is tricky. At first it looks like
3907 -- we are going to end up with nested
3908 -- if-statements with the same condition:
3909 -- if Early_Init_Condition then
3910 -- if Early_Init_Condition then
3911 -- Parent_TypeIP (...);
3914 -- But later we will hoist the inner if-statement
3915 -- out of the outer one; we do this because the
3916 -- init-proc call for the _Parent component of a type
3917 -- extension has to precede any other initialization.
3919 New_List
(Make_If_Statement
(Loc
,
3921 Early_Init_Condition
(Loc
, Init_Control_Formal
),
3922 Then_Statements
=> Init_Call_Stmts
));
3924 Actions
:= Init_Call_Stmts
;
3928 Clean_Task_Names
(Typ
, Proc_Id
);
3930 -- Simple initialization. If the Esize is not yet set, we pass
3931 -- Uint_0 as expected by Get_Simple_Init_Val.
3933 elsif Component_Needs_Simple_Initialization
(Typ
) then
3942 (if Known_Esize
(Id
) then Esize
(Id
)
3945 -- Nothing needed for this case
3951 -- When the component's type has a Default_Initial_Condition,
3952 -- and the component is default initialized, then check the
3956 and then No
(Expression
(Decl
))
3957 and then Present
(DIC_Procedure
(Typ
))
3958 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
3960 -- The DICs of ancestors are checked as part of the type's
3963 and then Chars
(Id
) /= Name_uParent
3965 -- In GNATprove mode, the component DICs are checked by other
3966 -- means. They should not be added to the record type DIC
3967 -- procedure, so that the procedure can be used to check the
3968 -- record type invariants or DICs if any.
3970 and then not GNATprove_Mode
3972 Append_New_To
(Actions
,
3975 Make_Selected_Component
(Comp_Loc
,
3977 Make_Identifier
(Comp_Loc
, Name_uInit
),
3979 New_Occurrence_Of
(Id
, Comp_Loc
)),
3983 if Present
(Checks
) then
3984 if Chars
(Id
) = Name_uParent
then
3985 Append_List_To
(Parent_Stmts
, Checks
);
3987 Append_List_To
(Stmts
, Checks
);
3991 if Present
(Actions
) then
3992 if Chars
(Id
) = Name_uParent
then
3993 Append_List_To
(Parent_Stmts
, Actions
);
3995 Append_List_To
(Stmts
, Actions
);
3997 -- Preserve initialization state in the current counter
3999 if Needs_Finalization
(Typ
) then
4000 if No
(Counter_Id
) then
4001 Make_Counter
(Comp_Loc
);
4004 Increment_Counter
(Comp_Loc
);
4010 Next_Non_Pragma
(Decl
);
4013 -- The parent field must be initialized first because variable
4014 -- size components of the parent affect the location of all the
4017 Prepend_List_To
(Stmts
, Parent_Stmts
);
4019 -- Set up tasks and protected object support. This needs to be done
4020 -- before any component with a per-object access discriminant
4021 -- constraint, or any variant part (which may contain such
4022 -- components) is initialized, because the initialization of these
4023 -- components may reference the enclosing concurrent object.
4025 -- For a task record type, add the task create call and calls to bind
4026 -- any interrupt (signal) entries.
4028 if Is_Task_Record_Type
(Rec_Type
) then
4030 -- In the case of the restricted run time the ATCB has already
4031 -- been preallocated.
4033 if Restricted_Profile
then
4035 Make_Assignment_Statement
(Loc
,
4037 Make_Selected_Component
(Loc
,
4038 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
4039 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
4041 Make_Attribute_Reference
(Loc
,
4043 Make_Selected_Component
(Loc
,
4044 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
4045 Selector_Name
=> Make_Identifier
(Loc
, Name_uATCB
)),
4046 Attribute_Name
=> Name_Unchecked_Access
)));
4049 Append_To
(Stmts
, Make_Task_Create_Call
(Rec_Type
));
4052 Task_Type
: constant Entity_Id
:=
4053 Corresponding_Concurrent_Type
(Rec_Type
);
4054 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
4055 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
4056 Decl_Loc
: Source_Ptr
;
4061 if Present
(Task_Def
) then
4062 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
4063 while Present
(Vis_Decl
) loop
4064 Decl_Loc
:= Sloc
(Vis_Decl
);
4066 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
4067 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
4070 Ent
:= Entity
(Name
(Vis_Decl
));
4072 if Ekind
(Ent
) = E_Entry
then
4074 Make_Procedure_Call_Statement
(Decl_Loc
,
4076 New_Occurrence_Of
(RTE
(
4077 RE_Bind_Interrupt_To_Entry
), Decl_Loc
),
4078 Parameter_Associations
=> New_List
(
4079 Make_Selected_Component
(Decl_Loc
,
4081 Make_Identifier
(Decl_Loc
, Name_uInit
),
4084 (Decl_Loc
, Name_uTask_Id
)),
4085 Entry_Index_Expression
4086 (Decl_Loc
, Ent
, Empty
, Task_Type
),
4087 Expression
(Vis_Decl
))));
4097 -- For a protected type, add statements generated by
4098 -- Make_Initialize_Protection.
4100 elsif Is_Protected_Record_Type
(Rec_Type
) then
4101 Append_List_To
(Stmts
,
4102 Make_Initialize_Protection
(Rec_Type
));
4105 -- Second pass: components that require late initialization
4107 if Present
(Parent_Id
) then
4109 Parent_Loc
: constant Source_Ptr
:= Sloc
(Parent
(Parent_Id
));
4110 use Initialization_Control
;
4112 -- We are building the init proc for a type extension.
4113 -- Call the parent type's init proc a second time, this
4114 -- time to initialize the parent's components that require
4115 -- late initialization.
4117 Append_List_To
(Late_Stmts
,
4118 Build_Initialization_Call
4119 (N
=> Parent
(Parent_Id
),
4121 Make_Selected_Component
(Parent_Loc
,
4122 Prefix
=> Make_Identifier
4123 (Parent_Loc
, Name_uInit
),
4124 Selector_Name
=> New_Occurrence_Of
(Parent_Id
,
4126 Typ
=> Etype
(Parent_Id
),
4127 In_Init_Proc
=> True,
4128 Enclos_Type
=> Rec_Type
,
4129 Discr_Map
=> Discr_Map
,
4130 Init_Control_Actual
=> Make_Mode_Literal
4131 (Parent_Loc
, Late_Init_Only
)));
4135 if Has_Late_Init_Comp
then
4136 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
4137 while Present
(Decl
) loop
4138 Comp_Loc
:= Sloc
(Decl
);
4139 Id
:= Defining_Identifier
(Decl
);
4141 -- Obtain the corresponding mutably tagged type's parent
4142 -- subtype to handle default initialization.
4144 Typ
:= Get_Corresponding_Tagged_Type_If_Present
(Etype
(Id
));
4146 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
)
4148 if Present
(Expression
(Decl
)) then
4149 Append_List_To
(Late_Stmts
,
4150 Build_Assignment
(Id
, Expression
(Decl
)));
4152 elsif Has_Non_Null_Base_Init_Proc
(Typ
) then
4153 Append_List_To
(Late_Stmts
,
4154 Build_Initialization_Call
(Decl
,
4155 Make_Selected_Component
(Comp_Loc
,
4157 Make_Identifier
(Comp_Loc
, Name_uInit
),
4158 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
4160 In_Init_Proc
=> True,
4161 Enclos_Type
=> Rec_Type
,
4162 Discr_Map
=> Discr_Map
));
4164 Clean_Task_Names
(Typ
, Proc_Id
);
4166 -- Preserve initialization state in the current counter
4168 if Needs_Finalization
(Typ
) then
4169 if No
(Counter_Id
) then
4170 Make_Counter
(Comp_Loc
);
4173 Increment_Counter
(Comp_Loc
, Late
=> True);
4175 elsif Component_Needs_Simple_Initialization
(Typ
) then
4176 Append_List_To
(Late_Stmts
,
4183 Size
=> Esize
(Id
))));
4187 Next_Non_Pragma
(Decl
);
4191 -- Process the variant part (incorrectly ignoring late
4192 -- initialization requirements for components therein).
4194 if Present
(Variant_Part
(Comp_List
)) then
4196 Variant_Alts
: constant List_Id
:= New_List
;
4197 Var_Loc
: Source_Ptr
:= No_Location
;
4202 First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
4203 while Present
(Variant
) loop
4204 Var_Loc
:= Sloc
(Variant
);
4205 Append_To
(Variant_Alts
,
4206 Make_Case_Statement_Alternative
(Var_Loc
,
4208 New_Copy_List
(Discrete_Choices
(Variant
)),
4210 Build_Init_Statements
(Component_List
(Variant
))));
4211 Next_Non_Pragma
(Variant
);
4214 -- The expression of the case statement which is a reference
4215 -- to one of the discriminants is replaced by the appropriate
4216 -- formal parameter of the initialization procedure.
4219 Make_Case_Statement
(Var_Loc
,
4221 New_Occurrence_Of
(Discriminal
(
4222 Entity
(Name
(Variant_Part
(Comp_List
)))), Var_Loc
),
4223 Alternatives
=> Variant_Alts
));
4227 if No
(Init_Control_Formal
) then
4228 Append_List_To
(Stmts
, Late_Stmts
);
4230 -- If no initializations were generated for component declarations
4231 -- and included in Stmts, then append a null statement to Stmts
4232 -- to make it a valid Ada tree.
4234 if Is_Empty_List
(Stmts
) then
4235 Append
(Make_Null_Statement
(Loc
), Stmts
);
4241 use Initialization_Control
;
4243 If_Early
: constant Node_Id
:=
4244 (if Is_Empty_List
(Stmts
) then
4245 Make_Null_Statement
(Loc
)
4247 Make_If_Statement
(Loc
,
4249 Early_Init_Condition
(Loc
, Init_Control_Formal
),
4250 Then_Statements
=> Stmts
));
4251 If_Late
: constant Node_Id
:=
4252 (if Is_Empty_List
(Late_Stmts
) then
4253 Make_Null_Statement
(Loc
)
4255 Make_If_Statement
(Loc
,
4257 Late_Init_Condition
(Loc
, Init_Control_Formal
),
4258 Then_Statements
=> Late_Stmts
));
4260 return New_List
(If_Early
, If_Late
);
4264 when RE_Not_Available
=>
4266 end Build_Init_Statements
;
4268 -------------------------
4269 -- Build_Record_Checks --
4270 -------------------------
4272 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
4273 Subtype_Mark_Id
: Entity_Id
;
4275 procedure Constrain_Array
4277 Check_List
: List_Id
);
4278 -- Apply a list of index constraints to an unconstrained array type.
4279 -- The first parameter is the entity for the resulting subtype.
4280 -- Check_List is a list to which the check actions are appended.
4282 ---------------------
4283 -- Constrain_Array --
4284 ---------------------
4286 procedure Constrain_Array
4288 Check_List
: List_Id
)
4290 C
: constant Node_Id
:= Constraint
(SI
);
4291 Number_Of_Constraints
: Nat
:= 0;
4295 procedure Constrain_Index
4298 Check_List
: List_Id
);
4299 -- Process an index constraint in a constrained array declaration.
4300 -- The constraint can be either a subtype name or a range with or
4301 -- without an explicit subtype mark. Index is the corresponding
4302 -- index of the unconstrained array. S is the range expression.
4303 -- Check_List is a list to which the check actions are appended.
4305 ---------------------
4306 -- Constrain_Index --
4307 ---------------------
4309 procedure Constrain_Index
4312 Check_List
: List_Id
)
4314 T
: constant Entity_Id
:= Etype
(Index
);
4317 if Nkind
(S
) = N_Range
then
4318 Process_Range_Expr_In_Decl
(S
, T
, Check_List
=> Check_List
);
4320 end Constrain_Index
;
4322 -- Start of processing for Constrain_Array
4325 T
:= Entity
(Subtype_Mark
(SI
));
4327 if Is_Access_Type
(T
) then
4328 T
:= Designated_Type
(T
);
4331 S
:= First
(Constraints
(C
));
4332 while Present
(S
) loop
4333 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
4337 -- In either case, the index constraint must provide a discrete
4338 -- range for each index of the array type and the type of each
4339 -- discrete range must be the same as that of the corresponding
4340 -- index. (RM 3.6.1)
4342 S
:= First
(Constraints
(C
));
4343 Index
:= First_Index
(T
);
4346 -- Apply constraints to each index type
4348 for J
in 1 .. Number_Of_Constraints
loop
4349 Constrain_Index
(Index
, S
, Check_List
);
4353 end Constrain_Array
;
4355 -- Start of processing for Build_Record_Checks
4358 if Nkind
(S
) = N_Subtype_Indication
then
4359 Find_Type
(Subtype_Mark
(S
));
4360 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
4362 -- Remaining processing depends on type
4364 case Ekind
(Subtype_Mark_Id
) is
4366 Constrain_Array
(S
, Check_List
);
4372 end Build_Record_Checks
;
4374 -------------------------------------------
4375 -- Component_Needs_Simple_Initialization --
4376 -------------------------------------------
4378 function Component_Needs_Simple_Initialization
4379 (T
: Entity_Id
) return Boolean
4383 Needs_Simple_Initialization
(T
)
4384 and then not Is_RTE
(T
, RE_Tag
)
4386 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
4388 and then not Is_RTE
(T
, RE_Interface_Tag
);
4389 end Component_Needs_Simple_Initialization
;
4391 --------------------------------------
4392 -- Parent_Subtype_Renaming_Discrims --
4393 --------------------------------------
4395 function Parent_Subtype_Renaming_Discrims
return Boolean is
4400 if Base_Type
(Rec_Ent
) /= Rec_Ent
then
4404 if Etype
(Rec_Ent
) = Rec_Ent
4405 or else not Has_Discriminants
(Rec_Ent
)
4406 or else Is_Constrained
(Rec_Ent
)
4407 or else Is_Tagged_Type
(Rec_Ent
)
4412 -- If there are no explicit stored discriminants we have inherited
4413 -- the root type discriminants so far, so no renamings occurred.
4415 if First_Discriminant
(Rec_Ent
) =
4416 First_Stored_Discriminant
(Rec_Ent
)
4421 -- Check if we have done some trivial renaming of the parent
4422 -- discriminants, i.e. something like
4424 -- type DT (X1, X2: int) is new PT (X1, X2);
4426 De
:= First_Discriminant
(Rec_Ent
);
4427 Dp
:= First_Discriminant
(Etype
(Rec_Ent
));
4428 while Present
(De
) loop
4429 pragma Assert
(Present
(Dp
));
4431 if Corresponding_Discriminant
(De
) /= Dp
then
4435 Next_Discriminant
(De
);
4436 Next_Discriminant
(Dp
);
4439 return Present
(Dp
);
4440 end Parent_Subtype_Renaming_Discrims
;
4442 ------------------------
4443 -- Requires_Init_Proc --
4444 ------------------------
4446 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
4447 Comp_Decl
: Node_Id
;
4452 -- Definitely do not need one if specifically suppressed
4454 if Initialization_Suppressed
(Rec_Id
) then
4458 -- If it is a type derived from a type with unknown discriminants,
4459 -- we cannot build an initialization procedure for it.
4461 if Has_Unknown_Discriminants
(Rec_Id
)
4462 or else Has_Unknown_Discriminants
(Etype
(Rec_Id
))
4467 -- Otherwise we need to generate an initialization procedure if
4468 -- Is_CPP_Class is False and at least one of the following applies:
4470 -- 1. Discriminants are present, since they need to be initialized
4471 -- with the appropriate discriminant constraint expressions.
4472 -- However, the discriminant of an unchecked union does not
4473 -- count, since the discriminant is not present.
4475 -- 2. The type is a tagged type, since the implicit Tag component
4476 -- needs to be initialized with a pointer to the dispatch table.
4478 -- 3. The type contains tasks
4480 -- 4. One or more components has an initial value
4482 -- 5. One or more components is for a type which itself requires
4483 -- an initialization procedure.
4485 -- 6. One or more components is a type that requires simple
4486 -- initialization (see Needs_Simple_Initialization), except
4487 -- that types Tag and Interface_Tag are excluded, since fields
4488 -- of these types are initialized by other means.
4490 -- 7. The type is the record type built for a task type (since at
4491 -- the very least, Create_Task must be called)
4493 -- 8. The type is the record type built for a protected type (since
4494 -- at least Initialize_Protection must be called)
4496 -- 9. The type is marked as a public entity. The reason we add this
4497 -- case (even if none of the above apply) is to properly handle
4498 -- Initialize_Scalars. If a package is compiled without an IS
4499 -- pragma, and the client is compiled with an IS pragma, then
4500 -- the client will think an initialization procedure is present
4501 -- and call it, when in fact no such procedure is required, but
4502 -- since the call is generated, there had better be a routine
4503 -- at the other end of the call, even if it does nothing).
4505 -- Note: the reason we exclude the CPP_Class case is because in this
4506 -- case the initialization is performed by the C++ constructors, and
4507 -- the IP is built by Set_CPP_Constructors.
4509 if Is_CPP_Class
(Rec_Id
) then
4512 elsif Is_Interface
(Rec_Id
) then
4515 elsif (Has_Discriminants
(Rec_Id
)
4516 and then not Is_Unchecked_Union
(Rec_Id
))
4517 or else Is_Tagged_Type
(Rec_Id
)
4518 or else Is_Concurrent_Record_Type
(Rec_Id
)
4519 or else Has_Task
(Rec_Id
)
4524 Id
:= First_Component
(Rec_Id
);
4525 while Present
(Id
) loop
4526 Comp_Decl
:= Parent
(Id
);
4529 if Present
(Expression
(Comp_Decl
))
4530 or else Has_Non_Null_Base_Init_Proc
(Typ
)
4531 or else Component_Needs_Simple_Initialization
(Typ
)
4536 Next_Component
(Id
);
4539 -- As explained above, a record initialization procedure is needed
4540 -- for public types in case Initialize_Scalars applies to a client.
4541 -- However, such a procedure is not needed in the case where either
4542 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
4543 -- applies. No_Initialize_Scalars excludes the possibility of using
4544 -- Initialize_Scalars in any partition, and No_Default_Initialization
4545 -- implies that no initialization should ever be done for objects of
4546 -- the type, so is incompatible with Initialize_Scalars.
4548 if not Restriction_Active
(No_Initialize_Scalars
)
4549 and then not Restriction_Active
(No_Default_Initialization
)
4550 and then Is_Public
(Rec_Id
)
4556 end Requires_Init_Proc
;
4558 -- Start of processing for Build_Record_Init_Proc
4561 Rec_Type
:= Defining_Identifier
(N
);
4563 -- This may be full declaration of a private type, in which case
4564 -- the visible entity is a record, and the private entity has been
4565 -- exchanged with it in the private part of the current package.
4566 -- The initialization procedure is built for the record type, which
4567 -- is retrievable from the private entity.
4569 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
4570 Rec_Type
:= Underlying_Type
(Rec_Type
);
4573 -- If we have a variant record with restriction No_Implicit_Conditionals
4574 -- in effect, then we skip building the procedure. This is safe because
4575 -- if we can see the restriction, so can any caller, calls to initialize
4576 -- such records are not allowed for variant records if this restriction
4579 if Has_Variant_Part
(Rec_Type
)
4580 and then Restriction_Active
(No_Implicit_Conditionals
)
4585 -- If there are discriminants, build the discriminant map to replace
4586 -- discriminants by their discriminals in complex bound expressions.
4587 -- These only arise for the corresponding records of synchronized types.
4589 if Is_Concurrent_Record_Type
(Rec_Type
)
4590 and then Has_Discriminants
(Rec_Type
)
4595 Disc
:= First_Discriminant
(Rec_Type
);
4596 while Present
(Disc
) loop
4597 Append_Elmt
(Disc
, Discr_Map
);
4598 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
4599 Next_Discriminant
(Disc
);
4604 -- Derived types that have no type extension can use the initialization
4605 -- procedure of their parent and do not need a procedure of their own.
4606 -- This is only correct if there are no representation clauses for the
4607 -- type or its parent, and if the parent has in fact been frozen so
4608 -- that its initialization procedure exists.
4610 if Is_Derived_Type
(Rec_Type
)
4611 and then not Is_Tagged_Type
(Rec_Type
)
4612 and then not Is_Unchecked_Union
(Rec_Type
)
4613 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
4614 and then not Parent_Subtype_Renaming_Discrims
4615 and then Present
(Base_Init_Proc
(Etype
(Rec_Type
)))
4617 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
4619 -- Otherwise if we need an initialization procedure, then build one,
4620 -- mark it as public and inlinable and as having a completion.
4622 elsif Requires_Init_Proc
(Rec_Type
)
4623 or else Is_Unchecked_Union
(Rec_Type
)
4626 Make_Defining_Identifier
(Loc
,
4627 Chars
=> Make_Init_Proc_Name
(Rec_Type
));
4629 -- If No_Default_Initialization restriction is active, then we don't
4630 -- want to build an init_proc, but we need to mark that an init_proc
4631 -- would be needed if this restriction was not active (so that we can
4632 -- detect attempts to call it), so set a dummy init_proc in place.
4634 if Restriction_Active
(No_Default_Initialization
) then
4635 Set_Init_Proc
(Rec_Type
, Proc_Id
);
4639 Build_Offset_To_Top_Functions
;
4640 Build_CPP_Init_Procedure
;
4641 Build_Init_Procedure
;
4643 Set_Is_Public
(Proc_Id
, Is_Public
(Rec_Ent
));
4644 Set_Is_Internal
(Proc_Id
);
4645 Set_Has_Completion
(Proc_Id
);
4647 if not Debug_Generated_Code
then
4648 Set_Debug_Info_Off
(Proc_Id
);
4651 Set_Is_Inlined
(Proc_Id
, Inline_Init_Proc
(Rec_Type
));
4653 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4654 -- needed and may generate early references to non frozen types
4655 -- since we expand aggregate much more systematically.
4657 if Modify_Tree_For_C
then
4662 Agg
: constant Node_Id
:=
4663 Build_Equivalent_Record_Aggregate
(Rec_Type
);
4665 procedure Collect_Itypes
(Comp
: Node_Id
);
4666 -- Generate references to itypes in the aggregate, because
4667 -- the first use of the aggregate may be in a nested scope.
4669 --------------------
4670 -- Collect_Itypes --
4671 --------------------
4673 procedure Collect_Itypes
(Comp
: Node_Id
) is
4676 Typ
: constant Entity_Id
:= Etype
(Comp
);
4679 if Is_Array_Type
(Typ
) and then Is_Itype
(Typ
) then
4680 Ref
:= Make_Itype_Reference
(Loc
);
4681 Set_Itype
(Ref
, Typ
);
4682 Append_Freeze_Action
(Rec_Type
, Ref
);
4684 Ref
:= Make_Itype_Reference
(Loc
);
4685 Set_Itype
(Ref
, Etype
(First_Index
(Typ
)));
4686 Append_Freeze_Action
(Rec_Type
, Ref
);
4688 -- Recurse on nested arrays
4690 Sub_Aggr
:= First
(Expressions
(Comp
));
4691 while Present
(Sub_Aggr
) loop
4692 Collect_Itypes
(Sub_Aggr
);
4699 -- If there is a static initialization aggregate for the type,
4700 -- generate itype references for the types of its (sub)components,
4701 -- to prevent out-of-scope errors in the resulting tree.
4702 -- The aggregate may have been rewritten as a Raise node, in which
4703 -- case there are no relevant itypes.
4705 if Present
(Agg
) and then Nkind
(Agg
) = N_Aggregate
then
4706 Set_Static_Initialization
(Proc_Id
, Agg
);
4711 Comp
:= First
(Component_Associations
(Agg
));
4712 while Present
(Comp
) loop
4713 Collect_Itypes
(Expression
(Comp
));
4720 end Build_Record_Init_Proc
;
4722 ----------------------------
4723 -- Build_Slice_Assignment --
4724 ----------------------------
4726 -- Generates the following subprogram:
4728 -- procedure array_typeSA
4729 -- (Source, Target : Array_Type,
4730 -- Left_Lo, Left_Hi : Index;
4731 -- Right_Lo, Right_Hi : Index;
4738 -- if Left_Hi < Left_Lo then
4751 -- Target (Li1) := Source (Ri1);
4754 -- exit when Li1 = Left_Lo;
4755 -- Li1 := Index'pred (Li1);
4756 -- Ri1 := Index'pred (Ri1);
4758 -- exit when Li1 = Left_Hi;
4759 -- Li1 := Index'succ (Li1);
4760 -- Ri1 := Index'succ (Ri1);
4763 -- end array_typeSA;
4765 procedure Build_Slice_Assignment
(Typ
: Entity_Id
) is
4766 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4767 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
4769 Larray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4770 Rarray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4771 Left_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4772 Left_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4773 Right_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4774 Right_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4775 Rev
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
4776 -- Formal parameters of procedure
4778 Proc_Name
: constant Entity_Id
:=
4779 Make_Defining_Identifier
(Loc
,
4780 Chars
=> Make_TSS_Name
(Typ
, TSS_Slice_Assign
));
4782 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4783 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4784 -- Subscripts for left and right sides
4791 -- Build declarations for indexes
4796 Make_Object_Declaration
(Loc
,
4797 Defining_Identifier
=> Lnn
,
4798 Object_Definition
=>
4799 New_Occurrence_Of
(Index
, Loc
)));
4802 Make_Object_Declaration
(Loc
,
4803 Defining_Identifier
=> Rnn
,
4804 Object_Definition
=>
4805 New_Occurrence_Of
(Index
, Loc
)));
4809 -- Build test for empty slice case
4812 Make_If_Statement
(Loc
,
4815 Left_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
),
4816 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
)),
4817 Then_Statements
=> New_List
(Make_Simple_Return_Statement
(Loc
))));
4819 -- Build initializations for indexes
4822 F_Init
: constant List_Id
:= New_List
;
4823 B_Init
: constant List_Id
:= New_List
;
4827 Make_Assignment_Statement
(Loc
,
4828 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4829 Expression
=> New_Occurrence_Of
(Left_Lo
, Loc
)));
4832 Make_Assignment_Statement
(Loc
,
4833 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4834 Expression
=> New_Occurrence_Of
(Right_Lo
, Loc
)));
4837 Make_Assignment_Statement
(Loc
,
4838 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4839 Expression
=> New_Occurrence_Of
(Left_Hi
, Loc
)));
4842 Make_Assignment_Statement
(Loc
,
4843 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4844 Expression
=> New_Occurrence_Of
(Right_Hi
, Loc
)));
4847 Make_If_Statement
(Loc
,
4848 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4849 Then_Statements
=> B_Init
,
4850 Else_Statements
=> F_Init
));
4853 -- Now construct the assignment statement
4856 Make_Loop_Statement
(Loc
,
4857 Statements
=> New_List
(
4858 Make_Assignment_Statement
(Loc
,
4860 Make_Indexed_Component
(Loc
,
4861 Prefix
=> New_Occurrence_Of
(Larray
, Loc
),
4862 Expressions
=> New_List
(New_Occurrence_Of
(Lnn
, Loc
))),
4864 Make_Indexed_Component
(Loc
,
4865 Prefix
=> New_Occurrence_Of
(Rarray
, Loc
),
4866 Expressions
=> New_List
(New_Occurrence_Of
(Rnn
, Loc
))))),
4867 End_Label
=> Empty
);
4869 -- Build the exit condition and increment/decrement statements
4872 F_Ass
: constant List_Id
:= New_List
;
4873 B_Ass
: constant List_Id
:= New_List
;
4877 Make_Exit_Statement
(Loc
,
4880 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4881 Right_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
))));
4884 Make_Assignment_Statement
(Loc
,
4885 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4887 Make_Attribute_Reference
(Loc
,
4889 New_Occurrence_Of
(Index
, Loc
),
4890 Attribute_Name
=> Name_Succ
,
4891 Expressions
=> New_List
(
4892 New_Occurrence_Of
(Lnn
, Loc
)))));
4895 Make_Assignment_Statement
(Loc
,
4896 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4898 Make_Attribute_Reference
(Loc
,
4900 New_Occurrence_Of
(Index
, Loc
),
4901 Attribute_Name
=> Name_Succ
,
4902 Expressions
=> New_List
(
4903 New_Occurrence_Of
(Rnn
, Loc
)))));
4906 Make_Exit_Statement
(Loc
,
4909 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4910 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
))));
4913 Make_Assignment_Statement
(Loc
,
4914 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4916 Make_Attribute_Reference
(Loc
,
4918 New_Occurrence_Of
(Index
, Loc
),
4919 Attribute_Name
=> Name_Pred
,
4920 Expressions
=> New_List
(
4921 New_Occurrence_Of
(Lnn
, Loc
)))));
4924 Make_Assignment_Statement
(Loc
,
4925 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4927 Make_Attribute_Reference
(Loc
,
4929 New_Occurrence_Of
(Index
, Loc
),
4930 Attribute_Name
=> Name_Pred
,
4931 Expressions
=> New_List
(
4932 New_Occurrence_Of
(Rnn
, Loc
)))));
4934 Append_To
(Statements
(Loops
),
4935 Make_If_Statement
(Loc
,
4936 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4937 Then_Statements
=> B_Ass
,
4938 Else_Statements
=> F_Ass
));
4941 Append_To
(Stats
, Loops
);
4948 Formals
:= New_List
(
4949 Make_Parameter_Specification
(Loc
,
4950 Defining_Identifier
=> Larray
,
4951 Out_Present
=> True,
4953 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4955 Make_Parameter_Specification
(Loc
,
4956 Defining_Identifier
=> Rarray
,
4958 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4960 Make_Parameter_Specification
(Loc
,
4961 Defining_Identifier
=> Left_Lo
,
4963 New_Occurrence_Of
(Index
, Loc
)),
4965 Make_Parameter_Specification
(Loc
,
4966 Defining_Identifier
=> Left_Hi
,
4968 New_Occurrence_Of
(Index
, Loc
)),
4970 Make_Parameter_Specification
(Loc
,
4971 Defining_Identifier
=> Right_Lo
,
4973 New_Occurrence_Of
(Index
, Loc
)),
4975 Make_Parameter_Specification
(Loc
,
4976 Defining_Identifier
=> Right_Hi
,
4978 New_Occurrence_Of
(Index
, Loc
)));
4981 Make_Parameter_Specification
(Loc
,
4982 Defining_Identifier
=> Rev
,
4984 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4987 Make_Procedure_Specification
(Loc
,
4988 Defining_Unit_Name
=> Proc_Name
,
4989 Parameter_Specifications
=> Formals
);
4992 Make_Subprogram_Body
(Loc
,
4993 Specification
=> Spec
,
4994 Declarations
=> Decls
,
4995 Handled_Statement_Sequence
=>
4996 Make_Handled_Sequence_Of_Statements
(Loc
,
4997 Statements
=> Stats
)));
5000 Set_TSS
(Typ
, Proc_Name
);
5001 Set_Is_Pure
(Proc_Name
);
5002 end Build_Slice_Assignment
;
5004 ------------------------------------
5005 -- Build_Untagged_Record_Equality --
5006 ------------------------------------
5008 procedure Build_Untagged_Record_Equality
(Typ
: Entity_Id
) is
5015 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
;
5016 -- Check whether the type T has a user-defined primitive equality. If so
5017 -- return it, else return Empty. If true for a component of Typ, we have
5018 -- to build the primitive equality for it.
5020 ---------------------
5021 -- User_Defined_Eq --
5022 ---------------------
5024 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
is
5025 Op
: constant Entity_Id
:= TSS
(T
, TSS_Composite_Equality
);
5028 if Present
(Op
) then
5031 return Get_User_Defined_Equality
(T
);
5033 end User_Defined_Eq
;
5035 -- Start of processing for Build_Untagged_Record_Equality
5038 -- If a record component has a primitive equality operation, we must
5039 -- build the corresponding one for the current type.
5042 Comp
:= First_Component
(Typ
);
5043 while Present
(Comp
) loop
5044 if Is_Record_Type
(Etype
(Comp
))
5045 and then Present
(User_Defined_Eq
(Etype
(Comp
)))
5051 Next_Component
(Comp
);
5054 -- If there is a user-defined equality for the type, we do not create
5055 -- the implicit one.
5057 Eq_Op
:= Get_User_Defined_Equality
(Typ
);
5058 if Present
(Eq_Op
) then
5059 if Comes_From_Source
(Eq_Op
) then
5066 -- If the type is derived, inherit the operation, if present, from the
5067 -- parent type. It may have been declared after the type derivation. If
5068 -- the parent type itself is derived, it may have inherited an operation
5069 -- that has itself been overridden, so update its alias and related
5070 -- flags. Ditto for inequality.
5072 if No
(Eq_Op
) and then Is_Derived_Type
(Typ
) then
5073 Eq_Op
:= Get_User_Defined_Equality
(Etype
(Typ
));
5074 if Present
(Eq_Op
) then
5075 Copy_TSS
(Eq_Op
, Typ
);
5079 Op
: constant Entity_Id
:= User_Defined_Eq
(Typ
);
5080 NE_Op
: constant Entity_Id
:= Next_Entity
(Eq_Op
);
5083 if Present
(Op
) then
5084 Set_Alias
(Op
, Eq_Op
);
5085 Set_Is_Abstract_Subprogram
5086 (Op
, Is_Abstract_Subprogram
(Eq_Op
));
5088 if Chars
(Next_Entity
(Op
)) = Name_Op_Ne
then
5089 Set_Is_Abstract_Subprogram
5090 (Next_Entity
(Op
), Is_Abstract_Subprogram
(NE_Op
));
5097 -- If not inherited and not user-defined, build body as for a type with
5098 -- components of record type (i.e. a type for which "=" composes when
5099 -- used as a component in an outer composite type).
5103 Make_Eq_Body
(Typ
, Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
5104 Op
:= Defining_Entity
(Decl
);
5108 if Is_Library_Level_Entity
(Typ
) then
5112 end Build_Untagged_Record_Equality
;
5114 -----------------------------------
5115 -- Build_Variant_Record_Equality --
5116 -----------------------------------
5120 -- function <<Body_Id>> (Left, Right : T) return Boolean is
5121 -- [ X : T renames Left; ]
5122 -- [ Y : T renames Right; ]
5123 -- -- The above renamings are generated only if the parameters of
5124 -- -- this built function (which are passed by the caller) are not
5125 -- -- named 'X' and 'Y'; these names are required to reuse several
5126 -- -- expander routines when generating this body.
5129 -- -- Compare discriminants
5131 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
5135 -- -- Compare components
5137 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
5141 -- -- Compare variant part
5145 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
5150 -- if X.Cn /= Y.Cn or else ... then
5158 function Build_Variant_Record_Equality
5160 Spec_Id
: Entity_Id
;
5161 Body_Id
: Entity_Id
;
5162 Param_Specs
: List_Id
) return Node_Id
5164 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5165 Def
: constant Node_Id
:= Parent
(Typ
);
5166 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
5167 Left
: constant Entity_Id
:= Defining_Identifier
(First
(Param_Specs
));
5168 Right
: constant Entity_Id
:=
5169 Defining_Identifier
(Next
(First
(Param_Specs
)));
5170 Decls
: constant List_Id
:= New_List
;
5171 Stmts
: constant List_Id
:= New_List
;
5173 Subp_Body
: Node_Id
;
5176 pragma Assert
(not Is_Tagged_Type
(Typ
));
5178 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
5179 -- the name of the formals must be X and Y; otherwise we generate two
5180 -- renaming declarations for such purpose.
5182 if Chars
(Left
) /= Name_X
then
5184 Make_Object_Renaming_Declaration
(Loc
,
5185 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5186 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5187 Name
=> Make_Identifier
(Loc
, Chars
(Left
))));
5190 if Chars
(Right
) /= Name_Y
then
5192 Make_Object_Renaming_Declaration
(Loc
,
5193 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
5194 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5195 Name
=> Make_Identifier
(Loc
, Chars
(Right
))));
5198 -- Unchecked_Unions require additional machinery to support equality.
5199 -- Two extra parameters (A and B) are added to the equality function
5200 -- parameter list for each discriminant of the type, in order to
5201 -- capture the inferred values of the discriminants in equality calls.
5202 -- The names of the parameters match the names of the corresponding
5203 -- discriminant, with an added suffix.
5205 if Is_Unchecked_Union
(Typ
) then
5207 Right_Formal
: constant Entity_Id
:=
5208 (if Present
(Spec_Id
) then Last_Formal
(Spec_Id
) else Right
);
5209 Scop
: constant Entity_Id
:=
5210 (if Present
(Spec_Id
) then Spec_Id
else Body_Id
);
5212 procedure Decorate_Extra_Formal
(F
, F_Typ
: Entity_Id
);
5213 -- Decorate extra formal F with type F_Typ
5215 ---------------------------
5216 -- Decorate_Extra_Formal --
5217 ---------------------------
5219 procedure Decorate_Extra_Formal
(F
, F_Typ
: Entity_Id
) is
5221 Mutate_Ekind
(F
, E_In_Parameter
);
5222 Set_Etype
(F
, F_Typ
);
5223 Set_Scope
(F
, Scop
);
5224 Set_Mechanism
(F
, By_Copy
);
5225 end Decorate_Extra_Formal
;
5230 Discr_Type
: Entity_Id
;
5231 Last_Extra
: Entity_Id
:= Empty
;
5232 New_Discrs
: Elist_Id
;
5235 Mutate_Ekind
(Body_Id
, E_Subprogram_Body
);
5236 New_Discrs
:= New_Elmt_List
;
5238 Discr
:= First_Discriminant
(Typ
);
5239 while Present
(Discr
) loop
5240 Discr_Type
:= Etype
(Discr
);
5242 -- Add the new parameters as extra formals
5245 Make_Defining_Identifier
(Loc
,
5246 Chars
=> New_External_Name
(Chars
(Discr
), 'A'));
5248 Decorate_Extra_Formal
(A
, Discr_Type
);
5250 if Present
(Last_Extra
) then
5251 Set_Extra_Formal
(Last_Extra
, A
);
5253 Set_Extra_Formal
(Right_Formal
, A
);
5254 Set_Extra_Formals
(Scop
, A
);
5257 Append_Elmt
(A
, New_Discrs
);
5260 Make_Defining_Identifier
(Loc
,
5261 Chars
=> New_External_Name
(Chars
(Discr
), 'B'));
5263 Decorate_Extra_Formal
(B
, Discr_Type
);
5265 Set_Extra_Formal
(A
, B
);
5268 -- Generate the following code to compare each of the inferred
5276 Make_If_Statement
(Loc
,
5279 Left_Opnd
=> New_Occurrence_Of
(A
, Loc
),
5280 Right_Opnd
=> New_Occurrence_Of
(B
, Loc
)),
5281 Then_Statements
=> New_List
(
5282 Make_Simple_Return_Statement
(Loc
,
5284 New_Occurrence_Of
(Standard_False
, Loc
)))));
5286 Next_Discriminant
(Discr
);
5289 -- Generate component-by-component comparison. Note that we must
5290 -- propagate the inferred discriminants formals to act as the case
5291 -- statement switch. Their value is added when an equality call on
5292 -- unchecked unions is expanded.
5294 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
, New_Discrs
));
5297 -- Normal case (not unchecked union)
5301 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
5302 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
5306 Make_Simple_Return_Statement
(Loc
,
5307 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
5310 Make_Subprogram_Body
(Loc
,
5312 Make_Function_Specification
(Loc
,
5313 Defining_Unit_Name
=> Body_Id
,
5314 Parameter_Specifications
=> Param_Specs
,
5315 Result_Definition
=>
5316 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5317 Declarations
=> Decls
,
5318 Handled_Statement_Sequence
=>
5319 Make_Handled_Sequence_Of_Statements
(Loc
,
5320 Statements
=> Stmts
));
5323 end Build_Variant_Record_Equality
;
5325 -----------------------------
5326 -- Check_Stream_Attributes --
5327 -----------------------------
5329 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
5331 Par_Read
: constant Boolean :=
5332 Stream_Attribute_Available
(Typ
, TSS_Stream_Read
)
5333 and then not Has_Specified_Stream_Read
(Typ
);
5334 Par_Write
: constant Boolean :=
5335 Stream_Attribute_Available
(Typ
, TSS_Stream_Write
)
5336 and then not Has_Specified_Stream_Write
(Typ
);
5338 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
);
5339 -- Check that Comp has a user-specified Nam stream attribute
5345 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
) is
5347 -- Move this check to sem???
5349 if not Stream_Attribute_Available
(Etype
(Comp
), TSS_Nam
) then
5350 Error_Msg_Name_1
:= Nam
;
5352 ("|component& in limited extension must have% attribute", Comp
);
5356 -- Start of processing for Check_Stream_Attributes
5359 if Par_Read
or else Par_Write
then
5360 Comp
:= First_Component
(Typ
);
5361 while Present
(Comp
) loop
5362 if Comes_From_Source
(Comp
)
5363 and then Original_Record_Component
(Comp
) = Comp
5364 and then Is_Limited_Type
(Etype
(Comp
))
5367 Check_Attr
(Name_Read
, TSS_Stream_Read
);
5371 Check_Attr
(Name_Write
, TSS_Stream_Write
);
5375 Next_Component
(Comp
);
5378 end Check_Stream_Attributes
;
5380 ----------------------
5381 -- Clean_Task_Names --
5382 ----------------------
5384 procedure Clean_Task_Names
5386 Proc_Id
: Entity_Id
)
5390 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
5391 and then not Global_Discard_Names
5392 and then Tagged_Type_Expansion
5394 Set_Uses_Sec_Stack
(Proc_Id
);
5396 end Clean_Task_Names
;
5398 -------------------------------
5399 -- Copy_Discr_Checking_Funcs --
5400 -------------------------------
5402 procedure Copy_Discr_Checking_Funcs
(N
: Node_Id
) is
5403 Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
5404 Comp
: Entity_Id
:= First_Component
(Typ
);
5405 Old_Comp
: Entity_Id
:= First_Component
5406 (Base_Type
(Underlying_Type
(Etype
(Typ
))));
5408 while Present
(Comp
) loop
5409 if Chars
(Comp
) = Chars
(Old_Comp
) then
5410 Set_Discriminant_Checking_Func
5411 (Comp
, Discriminant_Checking_Func
(Old_Comp
));
5414 Next_Component
(Old_Comp
);
5415 Next_Component
(Comp
);
5417 end Copy_Discr_Checking_Funcs
;
5419 ------------------------------
5420 -- Expand_Freeze_Array_Type --
5421 ------------------------------
5423 procedure Expand_Freeze_Array_Type
(N
: Node_Id
) is
5424 Typ
: constant Entity_Id
:= Entity
(N
);
5425 Base
: constant Entity_Id
:= Base_Type
(Typ
);
5427 -- Obtain the corresponding mutably tagged type if necessary
5429 Comp_Typ
: constant Entity_Id
:=
5430 Get_Corresponding_Mutably_Tagged_Type_If_Present
5431 (Component_Type
(Typ
));
5434 if not Is_Bit_Packed_Array
(Typ
) then
5435 if No
(Init_Proc
(Base
)) then
5437 -- If this is an anonymous array created for a declaration with
5438 -- an initial value, its init_proc will never be called. The
5439 -- initial value itself may have been expanded into assignments,
5440 -- in which case the object declaration is carries the
5441 -- No_Initialization flag.
5444 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
5445 N_Object_Declaration
5447 (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
5448 or else No_Initialization
(Associated_Node_For_Itype
(Base
)))
5452 -- We do not need an init proc for string or wide [wide] string,
5453 -- since the only time these need initialization in normalize or
5454 -- initialize scalars mode, and these types are treated specially
5455 -- and do not need initialization procedures.
5457 elsif Is_Standard_String_Type
(Base
) then
5460 -- Otherwise we have to build an init proc for the subtype
5463 Build_Array_Init_Proc
(Base
, N
);
5467 if Typ
= Base
and then Has_Controlled_Component
(Base
) then
5468 Build_Controlling_Procs
(Base
);
5470 if not Is_Limited_Type
(Comp_Typ
)
5471 and then Number_Dimensions
(Typ
) = 1
5473 Build_Slice_Assignment
(Typ
);
5477 -- For packed case, default initialization, except if the component type
5478 -- is itself a packed structure with an initialization procedure, or
5479 -- initialize/normalize scalars active, and we have a base type, or the
5480 -- type is public, because in that case a client might specify
5481 -- Normalize_Scalars and there better be a public Init_Proc for it.
5483 elsif (Present
(Init_Proc
(Component_Type
(Base
)))
5484 and then No
(Base_Init_Proc
(Base
)))
5485 or else (Init_Or_Norm_Scalars
and then Base
= Typ
)
5486 or else Is_Public
(Typ
)
5488 Build_Array_Init_Proc
(Base
, N
);
5490 end Expand_Freeze_Array_Type
;
5492 -----------------------------------
5493 -- Expand_Freeze_Class_Wide_Type --
5494 -----------------------------------
5496 procedure Expand_Freeze_Class_Wide_Type
(N
: Node_Id
) is
5497 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean;
5498 -- Given a type, determine whether it is derived from a C or C++ root
5500 ---------------------
5501 -- Is_C_Derivation --
5502 ---------------------
5504 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean is
5511 or else Convention
(T
) = Convention_C
5512 or else Convention
(T
) = Convention_CPP
5517 exit when T
= Etype
(T
);
5523 end Is_C_Derivation
;
5527 Typ
: constant Entity_Id
:= Entity
(N
);
5528 Root
: constant Entity_Id
:= Root_Type
(Typ
);
5530 -- Start of processing for Expand_Freeze_Class_Wide_Type
5533 -- Certain run-time configurations and targets do not provide support
5534 -- for controlled types.
5536 if Restriction_Active
(No_Finalization
) then
5539 -- Do not create TSS routine Finalize_Address when dispatching calls are
5540 -- disabled since the core of the routine is a dispatching call.
5542 elsif Restriction_Active
(No_Dispatching_Calls
) then
5545 -- Do not create TSS routine Finalize_Address for concurrent class-wide
5546 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
5547 -- non-Ada side will handle their destruction.
5549 -- Concurrent Ada types are functionally represented by an associated
5550 -- "corresponding record type" (typenameV), which owns the actual TSS
5551 -- finalize bodies for the type (and technically class-wide type).
5553 elsif Is_Concurrent_Type
(Root
)
5554 or else Is_C_Derivation
(Root
)
5555 or else Convention
(Typ
) = Convention_CPP
5559 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
5560 -- mode since the routine contains an Unchecked_Conversion.
5562 elsif CodePeer_Mode
then
5566 -- Create the body of TSS primitive Finalize_Address. This automatically
5567 -- sets the TSS entry for the class-wide type.
5569 if No
(Finalize_Address
(Typ
)) then
5570 Make_Finalize_Address_Body
(Typ
);
5572 end Expand_Freeze_Class_Wide_Type
;
5574 ------------------------------------
5575 -- Expand_Freeze_Enumeration_Type --
5576 ------------------------------------
5578 procedure Expand_Freeze_Enumeration_Type
(N
: Node_Id
) is
5579 Typ
: constant Entity_Id
:= Entity
(N
);
5580 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5585 Is_Contiguous
: Boolean;
5586 Index_Typ
: Entity_Id
;
5594 pragma Warnings
(Off
, Func
);
5597 -- Various optimizations possible if given representation is contiguous
5599 Is_Contiguous
:= True;
5601 Ent
:= First_Literal
(Typ
);
5602 Last_Repval
:= Enumeration_Rep
(Ent
);
5606 while Present
(Ent
) loop
5607 if Enumeration_Rep
(Ent
) - Last_Repval
/= 1 then
5608 Is_Contiguous
:= False;
5610 Last_Repval
:= Enumeration_Rep
(Ent
);
5617 if Is_Contiguous
then
5618 Set_Has_Contiguous_Rep
(Typ
);
5620 -- Now build a subtype declaration
5622 -- subtype typI is new Natural range 0 .. num - 1
5625 Make_Defining_Identifier
(Loc
,
5626 Chars
=> New_External_Name
(Chars
(Typ
), 'I'));
5628 Append_Freeze_Action
(Typ
,
5629 Make_Subtype_Declaration
(Loc
,
5630 Defining_Identifier
=> Index_Typ
,
5631 Subtype_Indication
=>
5632 Make_Subtype_Indication
(Loc
,
5634 New_Occurrence_Of
(Standard_Natural
, Loc
),
5636 Make_Range_Constraint
(Loc
,
5640 Make_Integer_Literal
(Loc
, 0),
5642 Make_Integer_Literal
(Loc
, Num
- 1))))));
5644 Set_Enum_Pos_To_Rep
(Typ
, Index_Typ
);
5647 -- Build list of literal references
5650 Ent
:= First_Literal
(Typ
);
5651 while Present
(Ent
) loop
5652 Append_To
(Lst
, New_Occurrence_Of
(Ent
, Sloc
(Ent
)));
5656 -- Now build an array declaration
5658 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5659 -- (v, v, v, v, v, ....)
5662 Make_Defining_Identifier
(Loc
,
5663 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
5665 Append_Freeze_Action
(Typ
,
5666 Make_Object_Declaration
(Loc
,
5667 Defining_Identifier
=> Arr
,
5668 Constant_Present
=> True,
5670 Object_Definition
=>
5671 Make_Constrained_Array_Definition
(Loc
,
5672 Discrete_Subtype_Definitions
=> New_List
(
5673 Make_Subtype_Indication
(Loc
,
5675 New_Occurrence_Of
(Standard_Natural
, Loc
),
5677 Make_Range_Constraint
(Loc
,
5681 Make_Integer_Literal
(Loc
, 0),
5683 Make_Integer_Literal
(Loc
, Num
- 1))))),
5685 Component_Definition
=>
5686 Make_Component_Definition
(Loc
,
5687 Aliased_Present
=> False,
5688 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))),
5691 Make_Aggregate
(Loc
,
5692 Expressions
=> Lst
)));
5694 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
5697 -- Now we build the function that converts representation values to
5698 -- position values. This function has the form:
5700 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5703 -- when enum-lit'Enum_Rep => return posval;
5704 -- when enum-lit'Enum_Rep => return posval;
5707 -- [raise Constraint_Error when F "invalid data"]
5712 -- Note: the F parameter determines whether the others case (no valid
5713 -- representation) raises Constraint_Error or returns a unique value
5714 -- of minus one. The latter case is used, e.g. in 'Valid code.
5716 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5717 -- the code generator making inappropriate assumptions about the range
5718 -- of the values in the case where the value is invalid. ityp is a
5719 -- signed or unsigned integer type of appropriate width.
5721 -- Note: if exceptions are not supported, then we suppress the raise
5722 -- and return -1 unconditionally (this is an erroneous program in any
5723 -- case and there is no obligation to raise Constraint_Error here). We
5724 -- also do this if pragma Restrictions (No_Exceptions) is active.
5726 -- Is this right??? What about No_Exception_Propagation???
5728 -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly
5729 -- because it might have been inherited from the parent type.
5731 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
5732 Set_Is_Unsigned_Type
(Typ
, False);
5735 Ityp
:= Integer_Type_For
(Esize
(Typ
), Is_Unsigned_Type
(Typ
));
5737 -- The body of the function is a case statement. First collect case
5738 -- alternatives, or optimize the contiguous case.
5742 -- If representation is contiguous, Pos is computed by subtracting
5743 -- the representation of the first literal.
5745 if Is_Contiguous
then
5746 Ent
:= First_Literal
(Typ
);
5748 if Enumeration_Rep
(Ent
) = Last_Repval
then
5750 -- Another special case: for a single literal, Pos is zero
5752 Pos_Expr
:= Make_Integer_Literal
(Loc
, Uint_0
);
5756 Convert_To
(Standard_Integer
,
5757 Make_Op_Subtract
(Loc
,
5759 Unchecked_Convert_To
5760 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5762 Make_Integer_Literal
(Loc
,
5763 Intval
=> Enumeration_Rep
(First_Literal
(Typ
)))));
5767 Make_Case_Statement_Alternative
(Loc
,
5768 Discrete_Choices
=> New_List
(
5769 Make_Range
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5771 Make_Integer_Literal
(Loc
,
5772 Intval
=> Enumeration_Rep
(Ent
)),
5774 Make_Integer_Literal
(Loc
, Intval
=> Last_Repval
))),
5776 Statements
=> New_List
(
5777 Make_Simple_Return_Statement
(Loc
,
5778 Expression
=> Pos_Expr
))));
5781 Ent
:= First_Literal
(Typ
);
5782 while Present
(Ent
) loop
5784 Make_Case_Statement_Alternative
(Loc
,
5785 Discrete_Choices
=> New_List
(
5786 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5787 Intval
=> Enumeration_Rep
(Ent
))),
5789 Statements
=> New_List
(
5790 Make_Simple_Return_Statement
(Loc
,
5792 Make_Integer_Literal
(Loc
,
5793 Intval
=> Enumeration_Pos
(Ent
))))));
5799 -- In normal mode, add the others clause with the test.
5800 -- If Predicates_Ignored is True, validity checks do not apply to
5803 if not No_Exception_Handlers_Set
5804 and then not Predicates_Ignored
(Typ
)
5807 Make_Case_Statement_Alternative
(Loc
,
5808 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5809 Statements
=> New_List
(
5810 Make_Raise_Constraint_Error
(Loc
,
5811 Condition
=> Make_Identifier
(Loc
, Name_uF
),
5812 Reason
=> CE_Invalid_Data
),
5813 Make_Simple_Return_Statement
(Loc
,
5814 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5816 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5817 -- active then return -1 (we cannot usefully raise Constraint_Error in
5818 -- this case). See description above for further details.
5822 Make_Case_Statement_Alternative
(Loc
,
5823 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5824 Statements
=> New_List
(
5825 Make_Simple_Return_Statement
(Loc
,
5826 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5829 -- Now we can build the function body
5832 Make_Defining_Identifier
(Loc
, Make_TSS_Name
(Typ
, TSS_Rep_To_Pos
));
5835 Make_Subprogram_Body
(Loc
,
5837 Make_Function_Specification
(Loc
,
5838 Defining_Unit_Name
=> Fent
,
5839 Parameter_Specifications
=> New_List
(
5840 Make_Parameter_Specification
(Loc
,
5841 Defining_Identifier
=>
5842 Make_Defining_Identifier
(Loc
, Name_uA
),
5843 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
5844 Make_Parameter_Specification
(Loc
,
5845 Defining_Identifier
=>
5846 Make_Defining_Identifier
(Loc
, Name_uF
),
5848 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
5850 Result_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
5852 Declarations
=> Empty_List
,
5854 Handled_Statement_Sequence
=>
5855 Make_Handled_Sequence_Of_Statements
(Loc
,
5856 Statements
=> New_List
(
5857 Make_Case_Statement
(Loc
,
5859 Unchecked_Convert_To
5860 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5861 Alternatives
=> Lst
))));
5863 Set_TSS
(Typ
, Fent
);
5865 -- Set Pure flag (it will be reset if the current context is not Pure).
5866 -- We also pretend there was a pragma Pure_Function so that for purposes
5867 -- of optimization and constant-folding, we will consider the function
5868 -- Pure even if we are not in a Pure context).
5871 Set_Has_Pragma_Pure_Function
(Fent
);
5873 -- Unless we are in -gnatD mode, where we are debugging generated code,
5874 -- this is an internal entity for which we don't need debug info.
5876 if not Debug_Generated_Code
then
5877 Set_Debug_Info_Off
(Fent
);
5880 Set_Is_Inlined
(Fent
);
5883 when RE_Not_Available
=>
5885 end Expand_Freeze_Enumeration_Type
;
5887 -------------------------------
5888 -- Expand_Freeze_Record_Type --
5889 -------------------------------
5891 procedure Expand_Freeze_Record_Type
(N
: Node_Id
) is
5893 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
);
5894 -- Create internal subprograms of Typ primitives that have class-wide
5895 -- preconditions or postconditions; they are invoked by the caller to
5896 -- evaluate the conditions.
5898 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
5899 -- Create an equality function for the untagged variant record Typ and
5900 -- attach it to the TSS list.
5902 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
);
5903 -- Register dispatch-table wrappers in the dispatch table of Typ
5905 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
);
5906 -- Check extra formals of dispatching primitives of tagged type Typ.
5907 -- Used in pragma Debug.
5909 ---------------------------------------
5910 -- Build_Class_Condition_Subprograms --
5911 ---------------------------------------
5913 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
) is
5914 Prim_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
5915 Prim_Elmt
: Elmt_Id
:= First_Elmt
(Prim_List
);
5919 while Present
(Prim_Elmt
) loop
5920 Prim
:= Node
(Prim_Elmt
);
5922 -- Primitive with class-wide preconditions
5924 if Comes_From_Source
(Prim
)
5925 and then Has_Significant_Contract
(Prim
)
5927 (Present
(Class_Preconditions
(Prim
))
5928 or else Present
(Ignored_Class_Preconditions
(Prim
)))
5930 if Expander_Active
then
5931 Make_Class_Precondition_Subps
(Prim
);
5934 -- Wrapper of a primitive that has or inherits class-wide
5937 elsif Is_Primitive_Wrapper
(Prim
)
5939 (Present
(Nearest_Class_Condition_Subprogram
5941 Kind
=> Class_Precondition
))
5943 Present
(Nearest_Class_Condition_Subprogram
5945 Kind
=> Ignored_Class_Precondition
)))
5947 if Expander_Active
then
5948 Make_Class_Precondition_Subps
(Prim
);
5952 Next_Elmt
(Prim_Elmt
);
5954 end Build_Class_Condition_Subprograms
;
5956 -----------------------------------
5957 -- Build_Variant_Record_Equality --
5958 -----------------------------------
5960 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
5961 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5962 F
: constant Entity_Id
:=
5963 Make_Defining_Identifier
(Loc
,
5964 Chars
=> Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
5966 -- For a variant record with restriction No_Implicit_Conditionals
5967 -- in effect we skip building the procedure. This is safe because
5968 -- if we can see the restriction, so can any caller, and calls to
5969 -- equality test routines are not allowed for variant records if
5970 -- this restriction is active.
5972 if Restriction_Active
(No_Implicit_Conditionals
) then
5976 -- Derived Unchecked_Union types no longer inherit the equality
5977 -- function of their parent.
5979 if Is_Derived_Type
(Typ
)
5980 and then not Is_Unchecked_Union
(Typ
)
5981 and then not Has_New_Non_Standard_Rep
(Typ
)
5984 Parent_Eq
: constant Entity_Id
:=
5985 TSS
(Root_Type
(Typ
), TSS_Composite_Equality
);
5987 if Present
(Parent_Eq
) then
5988 Copy_TSS
(Parent_Eq
, Typ
);
5995 Build_Variant_Record_Equality
5999 Param_Specs
=> New_List
(
6000 Make_Parameter_Specification
(Loc
,
6001 Defining_Identifier
=>
6002 Make_Defining_Identifier
(Loc
, Name_X
),
6003 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
6005 Make_Parameter_Specification
(Loc
,
6006 Defining_Identifier
=>
6007 Make_Defining_Identifier
(Loc
, Name_Y
),
6008 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))));
6013 if not Debug_Generated_Code
then
6014 Set_Debug_Info_Off
(F
);
6016 end Build_Variant_Record_Equality
;
6018 --------------------------------------
6019 -- Register_Dispatch_Table_Wrappers --
6020 --------------------------------------
6022 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
) is
6023 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
6027 while Present
(Elmt
) loop
6028 Subp
:= Node
(Elmt
);
6030 if Is_Dispatch_Table_Wrapper
(Subp
) then
6031 Append_Freeze_Actions
(Typ
,
6032 Register_Primitive
(Sloc
(Subp
), Subp
));
6037 end Register_Dispatch_Table_Wrappers
;
6039 ----------------------------------------
6040 -- Validate_Tagged_Type_Extra_Formals --
6041 ----------------------------------------
6043 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
) is
6044 Ovr_Subp
: Entity_Id
;
6049 pragma Assert
(not Is_Class_Wide_Type
(Typ
));
6051 -- No check required if expansion is not active since we never
6052 -- generate extra formals in such case.
6054 if not Expander_Active
then
6058 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6059 while Present
(Elmt
) loop
6060 Subp
:= Node
(Elmt
);
6062 -- Extra formals of a dispatching primitive must match:
6064 -- 1) The extra formals of its covered interface primitive
6066 if Present
(Interface_Alias
(Subp
)) then
6068 (Extra_Formals_Match_OK
6069 (E
=> Interface_Alias
(Subp
),
6070 Ref_E
=> Alias
(Subp
)));
6073 -- 2) The extra formals of its renamed primitive
6075 if Present
(Alias
(Subp
)) then
6077 (Extra_Formals_Match_OK
6079 Ref_E
=> Ultimate_Alias
(Subp
)));
6082 -- 3) The extra formals of its overridden primitive
6084 if Present
(Overridden_Operation
(Subp
)) then
6085 Ovr_Subp
:= Overridden_Operation
(Subp
);
6087 -- Handle controlling function wrapper
6089 if Is_Wrapper
(Subp
)
6090 and then Ultimate_Alias
(Ovr_Subp
) = Subp
6092 if Present
(Overridden_Operation
(Ovr_Subp
)) then
6094 (Extra_Formals_Match_OK
6096 Ref_E
=> Overridden_Operation
(Ovr_Subp
)));
6101 (Extra_Formals_Match_OK
6103 Ref_E
=> Ovr_Subp
));
6109 end Validate_Tagged_Type_Extra_Formals
;
6113 Typ
: constant Node_Id
:= Entity
(N
);
6114 Typ_Decl
: constant Node_Id
:= Parent
(Typ
);
6116 Predef_List
: List_Id
;
6118 Wrapper_Decl_List
: List_Id
;
6119 Wrapper_Body_List
: List_Id
:= No_List
;
6121 Renamed_Eq
: Node_Id
:= Empty
;
6122 -- Defining unit name for the predefined equality function in the case
6123 -- where the type has a primitive operation that is a renaming of
6124 -- predefined equality (but only if there is also an overriding
6125 -- user-defined equality function). Used to pass this entity from
6126 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
6128 -- Start of processing for Expand_Freeze_Record_Type
6131 -- Build discriminant checking functions if not a derived type (for
6132 -- derived types that are not tagged types, always use the discriminant
6133 -- checking functions of the parent type). However, for untagged types
6134 -- the derivation may have taken place before the parent was frozen, so
6135 -- we copy explicitly the discriminant checking functions from the
6136 -- parent into the components of the derived type.
6138 Build_Or_Copy_Discr_Checking_Funcs
(Typ_Decl
);
6140 if Is_Derived_Type
(Typ
)
6141 and then Is_Limited_Type
(Typ
)
6142 and then Is_Tagged_Type
(Typ
)
6144 Check_Stream_Attributes
(Typ
);
6147 -- Handle constructors of untagged CPP_Class types
6149 if not Is_Tagged_Type
(Typ
) and then Is_CPP_Class
(Typ
) then
6150 Set_CPP_Constructors
(Typ
);
6153 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
6154 -- for regular tagged types as well as for Ada types deriving from a C++
6155 -- Class, but not for tagged types directly corresponding to C++ classes
6156 -- In the later case we assume that it is created in the C++ side and we
6159 if Is_Tagged_Type
(Typ
) then
6161 -- Add the _Tag component
6163 if Underlying_Type
(Etype
(Typ
)) = Typ
then
6164 Expand_Tagged_Root
(Typ
);
6167 if Is_CPP_Class
(Typ
) then
6168 Set_All_DT_Position
(Typ
);
6170 -- Create the tag entities with a minimum decoration
6172 if Tagged_Type_Expansion
then
6173 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
6176 Set_CPP_Constructors
(Typ
);
6179 if not Building_Static_DT
(Typ
) then
6181 -- Usually inherited primitives are not delayed but the first
6182 -- Ada extension of a CPP_Class is an exception since the
6183 -- address of the inherited subprogram has to be inserted in
6184 -- the new Ada Dispatch Table and this is a freezing action.
6186 -- Similarly, if this is an inherited operation whose parent is
6187 -- not frozen yet, it is not in the DT of the parent, and we
6188 -- generate an explicit freeze node for the inherited operation
6189 -- so it is properly inserted in the DT of the current type.
6196 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6197 while Present
(Elmt
) loop
6198 Subp
:= Node
(Elmt
);
6200 if Present
(Alias
(Subp
)) then
6201 if Is_CPP_Class
(Etype
(Typ
)) then
6202 Set_Has_Delayed_Freeze
(Subp
);
6204 elsif Has_Delayed_Freeze
(Alias
(Subp
))
6205 and then not Is_Frozen
(Alias
(Subp
))
6207 Set_Is_Frozen
(Subp
, False);
6208 Set_Has_Delayed_Freeze
(Subp
);
6217 -- Unfreeze momentarily the type to add the predefined primitives
6218 -- operations. The reason we unfreeze is so that these predefined
6219 -- operations will indeed end up as primitive operations (which
6220 -- must be before the freeze point).
6222 Set_Is_Frozen
(Typ
, False);
6224 -- Do not add the spec of predefined primitives in case of
6225 -- CPP tagged type derivations that have convention CPP.
6227 if Is_CPP_Class
(Root_Type
(Typ
))
6228 and then Convention
(Typ
) = Convention_CPP
6232 -- Do not add the spec of the predefined primitives if we are
6233 -- compiling under restriction No_Dispatching_Calls.
6235 elsif not Restriction_Active
(No_Dispatching_Calls
) then
6236 Make_Predefined_Primitive_Specs
(Typ
, Predef_List
, Renamed_Eq
);
6237 Insert_List_Before_And_Analyze
(N
, Predef_List
);
6240 -- Ada 2005 (AI-391): For a nonabstract null extension, create
6241 -- wrapper functions for each nonoverridden inherited function
6242 -- with a controlling result of the type. The wrapper for such
6243 -- a function returns an extension aggregate that invokes the
6246 if Ada_Version
>= Ada_2005
6247 and then not Is_Abstract_Type
(Typ
)
6248 and then Is_Null_Extension
(Typ
)
6250 Make_Controlling_Function_Wrappers
6251 (Typ
, Wrapper_Decl_List
, Wrapper_Body_List
);
6252 Insert_List_Before_And_Analyze
(N
, Wrapper_Decl_List
);
6255 -- Ada 2005 (AI-251): For a nonabstract type extension, build
6256 -- null procedure declarations for each set of homographic null
6257 -- procedures that are inherited from interface types but not
6258 -- overridden. This is done to ensure that the dispatch table
6259 -- entry associated with such null primitives are properly filled.
6261 if Ada_Version
>= Ada_2005
6262 and then Etype
(Typ
) /= Typ
6263 and then not Is_Abstract_Type
(Typ
)
6264 and then Has_Interfaces
(Typ
)
6266 Insert_Actions
(N
, Make_Null_Procedure_Specs
(Typ
));
6269 Set_Is_Frozen
(Typ
);
6271 if not Is_Derived_Type
(Typ
)
6272 or else Is_Tagged_Type
(Etype
(Typ
))
6274 Set_All_DT_Position
(Typ
);
6276 -- If this is a type derived from an untagged private type whose
6277 -- full view is tagged, the type is marked tagged for layout
6278 -- reasons, but it has no dispatch table.
6280 elsif Is_Derived_Type
(Typ
)
6281 and then Is_Private_Type
(Etype
(Typ
))
6282 and then not Is_Tagged_Type
(Etype
(Typ
))
6287 -- Create and decorate the tags. Suppress their creation when
6288 -- not Tagged_Type_Expansion because the dispatching mechanism is
6289 -- handled internally by the virtual target.
6291 if Tagged_Type_Expansion
then
6292 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
6294 -- Generate dispatch table of locally defined tagged type.
6295 -- Dispatch tables of library level tagged types are built
6296 -- later (see Build_Static_Dispatch_Tables).
6298 if not Building_Static_DT
(Typ
) then
6299 Append_Freeze_Actions
(Typ
, Make_DT
(Typ
));
6301 -- Register dispatch table wrappers in the dispatch table.
6302 -- It could not be done when these wrappers were built
6303 -- because, at that stage, the dispatch table was not
6306 Register_Dispatch_Table_Wrappers
(Typ
);
6310 -- If the type has unknown discriminants, propagate dispatching
6311 -- information to its underlying record view, which does not get
6312 -- its own dispatch table.
6314 if Is_Derived_Type
(Typ
)
6315 and then Has_Unknown_Discriminants
(Typ
)
6316 and then Present
(Underlying_Record_View
(Typ
))
6319 Rep
: constant Entity_Id
:= Underlying_Record_View
(Typ
);
6321 Set_Access_Disp_Table
6322 (Rep
, Access_Disp_Table
(Typ
));
6323 Set_Dispatch_Table_Wrappers
6324 (Rep
, Dispatch_Table_Wrappers
(Typ
));
6325 Set_Direct_Primitive_Operations
6326 (Rep
, Direct_Primitive_Operations
(Typ
));
6330 -- Make sure that the primitives Initialize, Adjust and Finalize
6331 -- are Frozen before other TSS subprograms. We don't want them
6334 if Is_Controlled
(Typ
) then
6335 Append_Freeze_Actions
(Typ
,
6337 (Find_Controlled_Prim_Op
(Typ
, Name_Initialize
), Typ
));
6339 if not Is_Limited_Type
(Typ
) then
6340 Append_Freeze_Actions
(Typ
,
6342 (Find_Controlled_Prim_Op
(Typ
, Name_Adjust
), Typ
));
6345 Append_Freeze_Actions
(Typ
,
6347 (Find_Controlled_Prim_Op
(Typ
, Name_Finalize
), Typ
));
6350 -- Freeze rest of primitive operations. There is no need to handle
6351 -- the predefined primitives if we are compiling under restriction
6352 -- No_Dispatching_Calls.
6354 if not Restriction_Active
(No_Dispatching_Calls
) then
6355 Append_Freeze_Actions
(Typ
, Predefined_Primitive_Freeze
(Typ
));
6359 -- In the untagged case, ever since Ada 83 an equality function must
6360 -- be provided for variant records that are not unchecked unions.
6362 elsif Has_Discriminants
(Typ
)
6363 and then not Is_Limited_Type
(Typ
)
6364 and then Present
(Component_List
(Type_Definition
(Typ_Decl
)))
6366 Present
(Variant_Part
(Component_List
(Type_Definition
(Typ_Decl
))))
6368 Build_Variant_Record_Equality
(Typ
);
6370 -- In Ada 2012 the equality function composes, and thus must be built
6371 -- explicitly just as for tagged records.
6373 -- This is done unconditionally to ensure that tools can be linked
6374 -- properly with user programs compiled with older language versions.
6375 -- In addition, this is needed because "=" composes for bounded strings
6376 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
6378 elsif Comes_From_Source
(Typ
)
6379 and then Convention
(Typ
) = Convention_Ada
6380 and then not Is_Limited_Type
(Typ
)
6382 Build_Untagged_Record_Equality
(Typ
);
6385 -- Before building the record initialization procedure, if we are
6386 -- dealing with a concurrent record value type, then we must go through
6387 -- the discriminants, exchanging discriminals between the concurrent
6388 -- type and the concurrent record value type. See the section "Handling
6389 -- of Discriminants" in the Einfo spec for details.
6391 if Is_Concurrent_Record_Type
(Typ
) and then Has_Discriminants
(Typ
) then
6393 Ctyp
: constant Entity_Id
:=
6394 Corresponding_Concurrent_Type
(Typ
);
6395 Conc_Discr
: Entity_Id
;
6396 Rec_Discr
: Entity_Id
;
6400 Conc_Discr
:= First_Discriminant
(Ctyp
);
6401 Rec_Discr
:= First_Discriminant
(Typ
);
6402 while Present
(Conc_Discr
) loop
6403 Temp
:= Discriminal
(Conc_Discr
);
6404 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
6405 Set_Discriminal
(Rec_Discr
, Temp
);
6407 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
6408 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
6410 Next_Discriminant
(Conc_Discr
);
6411 Next_Discriminant
(Rec_Discr
);
6416 if Has_Controlled_Component
(Typ
) then
6417 Build_Controlling_Procs
(Typ
);
6420 Adjust_Discriminants
(Typ
);
6422 -- Do not need init for interfaces on virtual targets since they're
6425 if not Is_Mutably_Tagged_CW_Equivalent_Type
(Typ
)
6426 and then (Tagged_Type_Expansion
or else not Is_Interface
(Typ
))
6428 Build_Record_Init_Proc
(Typ_Decl
, Typ
);
6431 -- Create the body of TSS primitive Finalize_Address. This must be done
6432 -- before the bodies of all predefined primitives are created. If Typ
6433 -- is limited, Stream_Input and Stream_Read may produce build-in-place
6434 -- allocations and for those the expander needs Finalize_Address.
6436 if Is_Controlled
(Typ
) then
6437 Make_Finalize_Address_Body
(Typ
);
6440 -- For tagged type that are not interfaces, build bodies of primitive
6441 -- operations. Note: do this after building the record initialization
6442 -- procedure, since the primitive operations may need the initialization
6443 -- routine. There is no need to add predefined primitives of interfaces
6444 -- because all their predefined primitives are abstract.
6446 if Is_Tagged_Type
(Typ
) and then not Is_Interface
(Typ
) then
6448 -- Do not add the body of predefined primitives in case of CPP tagged
6449 -- type derivations that have convention CPP.
6451 if Is_CPP_Class
(Root_Type
(Typ
))
6452 and then Convention
(Typ
) = Convention_CPP
6456 -- Do not add the body of the predefined primitives if we are
6457 -- compiling under restriction No_Dispatching_Calls.
6459 elsif not Restriction_Active
(No_Dispatching_Calls
) then
6460 -- Create the body of the class-wide type's TSS primitive
6461 -- Finalize_Address. This must be done before any class-wide
6462 -- precondition functions are created.
6464 Make_Finalize_Address_Body
(Class_Wide_Type
(Typ
));
6466 Predef_List
:= Predefined_Primitive_Bodies
(Typ
, Renamed_Eq
);
6467 Append_Freeze_Actions
(Typ
, Predef_List
);
6470 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
6471 -- inherited functions, then add their bodies to the freeze actions.
6473 Append_Freeze_Actions
(Typ
, Wrapper_Body_List
);
6475 -- Create body of an interface type's class-wide type's TSS primitive
6476 -- Finalize_Address.
6478 elsif Is_Tagged_Type
(Typ
)
6479 and then Is_Interface
(Typ
)
6480 and then not Restriction_Active
(No_Dispatching_Calls
)
6482 Make_Finalize_Address_Body
(Class_Wide_Type
(Typ
));
6485 -- Create extra formals for the primitive operations of the type.
6486 -- This must be done before analyzing the body of the initialization
6487 -- procedure, because a self-referential type might call one of these
6488 -- primitives in the body of the init_proc itself.
6490 -- This is not needed:
6491 -- 1) If expansion is disabled, because extra formals are only added
6492 -- when we are generating code.
6494 -- 2) For types with foreign convention since primitives with foreign
6495 -- convention don't have extra formals and AI95-117 requires that
6496 -- all primitives of a tagged type inherit the convention.
6499 and then Is_Tagged_Type
(Typ
)
6500 and then not Has_Foreign_Convention
(Typ
)
6507 -- Add extra formals to primitive operations
6509 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6510 while Present
(Elmt
) loop
6511 Create_Extra_Formals
(Node
(Elmt
));
6515 -- Add extra formals to renamings of primitive operations. The
6516 -- addition of extra formals is done in two steps to minimize
6517 -- the compile time required for this action; the evaluation of
6518 -- Find_Dispatching_Type() and Contains() is only done here for
6519 -- renamings that are not primitive operations.
6521 E
:= First_Entity
(Scope
(Typ
));
6522 while Present
(E
) loop
6523 if Is_Dispatching_Operation
(E
)
6524 and then Present
(Alias
(E
))
6525 and then Find_Dispatching_Type
(E
) = Typ
6526 and then not Contains
(Primitive_Operations
(Typ
), E
)
6528 Create_Extra_Formals
(E
);
6534 pragma Debug
(Validate_Tagged_Type_Extra_Formals
(Typ
));
6538 -- Build internal subprograms of primitives with class-wide
6539 -- pre/postconditions.
6541 if Is_Tagged_Type
(Typ
) then
6542 Build_Class_Condition_Subprograms
(Typ
);
6544 end Expand_Freeze_Record_Type
;
6546 ------------------------------------
6547 -- Expand_N_Full_Type_Declaration --
6548 ------------------------------------
6550 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
6551 procedure Build_Master
(Ptr_Typ
: Entity_Id
);
6552 -- Create the master associated with Ptr_Typ
6558 procedure Build_Master
(Ptr_Typ
: Entity_Id
) is
6559 Desig_Typ
: Entity_Id
:= Designated_Type
(Ptr_Typ
);
6562 -- If the designated type is an incomplete view coming from a
6563 -- limited-with'ed package, we need to use the nonlimited view in
6564 -- case it has tasks.
6566 if Is_Incomplete_Type
(Desig_Typ
)
6567 and then Present
(Non_Limited_View
(Desig_Typ
))
6569 Desig_Typ
:= Non_Limited_View
(Desig_Typ
);
6572 -- Anonymous access types are created for the components of the
6573 -- record parameter for an entry declaration. No master is created
6576 if Has_Task
(Desig_Typ
) then
6577 Build_Master_Entity
(Ptr_Typ
);
6578 Build_Master_Renaming
(Ptr_Typ
);
6580 -- Create a class-wide master because a Master_Id must be generated
6581 -- for access-to-limited-class-wide types whose root may be extended
6582 -- with task components.
6584 -- Note: This code covers access-to-limited-interfaces because they
6585 -- can be used to reference tasks implementing them.
6587 -- Suppress the master creation for access types created for entry
6588 -- formal parameters (parameter block component types). Seems like
6589 -- suppression should be more general for compiler-generated types,
6590 -- but testing Comes_From_Source may be too general in this case
6591 -- (affects some test output)???
6593 elsif not Is_Param_Block_Component_Type
(Ptr_Typ
)
6594 and then Is_Limited_Class_Wide_Type
(Desig_Typ
)
6596 Build_Class_Wide_Master
(Ptr_Typ
);
6600 -- Local declarations
6602 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6603 B_Id
: constant Entity_Id
:= Base_Type
(Def_Id
);
6607 -- Start of processing for Expand_N_Full_Type_Declaration
6610 if Is_Access_Type
(Def_Id
) then
6611 Build_Master
(Def_Id
);
6613 if Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
6614 Expand_Access_Protected_Subprogram_Type
(N
);
6617 -- Array of anonymous access-to-task pointers
6619 elsif Ada_Version
>= Ada_2005
6620 and then Is_Array_Type
(Def_Id
)
6621 and then Is_Access_Type
(Component_Type
(Def_Id
))
6622 and then Ekind
(Component_Type
(Def_Id
)) = E_Anonymous_Access_Type
6624 Build_Master
(Component_Type
(Def_Id
));
6626 elsif Has_Task
(Def_Id
) then
6627 Expand_Previous_Access_Type
(Def_Id
);
6629 -- Check the components of a record type or array of records for
6630 -- anonymous access-to-task pointers.
6632 elsif Ada_Version
>= Ada_2005
6633 and then (Is_Record_Type
(Def_Id
)
6635 (Is_Array_Type
(Def_Id
)
6636 and then Is_Record_Type
(Component_Type
(Def_Id
))))
6641 M_Id
: Entity_Id
:= Empty
;
6645 if Is_Array_Type
(Def_Id
) then
6646 Comp
:= First_Entity
(Component_Type
(Def_Id
));
6648 Comp
:= First_Entity
(Def_Id
);
6651 -- Examine all components looking for anonymous access-to-task
6655 while Present
(Comp
) loop
6656 Typ
:= Etype
(Comp
);
6658 if Ekind
(Typ
) = E_Anonymous_Access_Type
6659 and then Might_Have_Tasks
6660 (Available_View
(Designated_Type
(Typ
)))
6661 and then No
(Master_Id
(Typ
))
6663 -- Ensure that the record or array type have a _master
6666 Build_Master_Entity
(Def_Id
);
6667 Build_Master_Renaming
(Typ
);
6668 M_Id
:= Master_Id
(Typ
);
6672 -- Reuse the same master to service any additional types
6675 pragma Assert
(Present
(M_Id
));
6676 Set_Master_Id
(Typ
, M_Id
);
6685 -- Handle mutably tagged types by replacing their declarations with
6686 -- their class-wide equivalent types.
6691 if Is_Array_Type
(Def_Id
) then
6692 Comp
:= First_Entity
(Component_Type
(Def_Id
));
6694 Comp
:= First_Entity
(Def_Id
);
6697 while Present
(Comp
) loop
6698 if Ekind
(Etype
(Comp
)) /= E_Void
6699 and then Is_Mutably_Tagged_Type
(Etype
(Comp
))
6702 (Comp
, Class_Wide_Equivalent_Type
(Etype
(Comp
)));
6708 Par_Id
:= Etype
(B_Id
);
6710 -- The parent type is private then we need to inherit any TSS operations
6711 -- from the full view.
6713 if Is_Private_Type
(Par_Id
)
6714 and then Present
(Full_View
(Par_Id
))
6716 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
6719 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
6720 and then not Is_Tagged_Type
(Def_Id
)
6721 and then Present
(Freeze_Node
(Par_Id
))
6722 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
6724 Ensure_Freeze_Node
(B_Id
);
6725 FN
:= Freeze_Node
(B_Id
);
6727 if No
(TSS_Elist
(FN
)) then
6728 Set_TSS_Elist
(FN
, New_Elmt_List
);
6732 T_E
: constant Elist_Id
:= TSS_Elist
(FN
);
6736 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
6737 while Present
(Elmt
) loop
6738 if Chars
(Node
(Elmt
)) /= Name_uInit
then
6739 Append_Elmt
(Node
(Elmt
), T_E
);
6745 -- If the derived type itself is private with a full view, then
6746 -- associate the full view with the inherited TSS_Elist as well.
6748 if Is_Private_Type
(B_Id
)
6749 and then Present
(Full_View
(B_Id
))
6751 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
6753 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
6757 end Expand_N_Full_Type_Declaration
;
6759 ---------------------------------
6760 -- Expand_N_Object_Declaration --
6761 ---------------------------------
6763 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
6764 Loc
: constant Source_Ptr
:= Sloc
(N
);
6765 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6766 Expr
: constant Node_Id
:= Expression
(N
);
6767 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
6768 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
6769 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
6770 Next_N
: constant Node_Id
:= Next
(N
);
6772 Special_Ret_Obj
: constant Boolean := Is_Special_Return_Object
(Def_Id
);
6773 -- If this is a special return object, it will be allocated differently
6774 -- and ultimately rewritten as a renaming, so initialization activities
6775 -- need to be deferred until after that is done.
6777 Func_Id
: constant Entity_Id
:=
6778 (if Special_Ret_Obj
then Return_Applies_To
(Scope
(Def_Id
)) else Empty
);
6779 -- The function if this is a special return object, otherwise Empty
6781 function Build_Heap_Or_Pool_Allocator
6782 (Temp_Id
: Entity_Id
;
6783 Temp_Typ
: Entity_Id
;
6784 Ret_Typ
: Entity_Id
;
6785 Alloc_Expr
: Node_Id
) return Node_Id
;
6786 -- Create the statements necessary to allocate a return object on the
6787 -- heap or user-defined storage pool. The object may need finalization
6788 -- actions depending on the return type.
6790 -- * Controlled case
6792 -- if BIPcollection = null then
6793 -- Temp_Id := <Alloc_Expr>;
6796 -- type Ptr_Typ is access Ret_Typ;
6797 -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all;
6801 -- procedure Allocate (...) is
6803 -- System.Storage_Pools.Subpools.Allocate_Any (...);
6806 -- Local := <Alloc_Expr>;
6807 -- Temp_Id := Temp_Typ (Local);
6811 -- * Non-controlled case
6813 -- Temp_Id := <Alloc_Expr>;
6815 -- Temp_Id is the temporary which is used to reference the internally
6816 -- created object in all allocation forms. Temp_Typ is the type of the
6817 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
6818 -- type of Func_Id. Alloc_Expr is the actual allocator.
6820 function BIP_Function_Call_Id
return Entity_Id
;
6821 -- If the object initialization expression is a call to a build-in-place
6822 -- function, return the id of the called function; otherwise return
6825 procedure Count_Default_Sized_Task_Stacks
6827 Pri_Stacks
: out Int
;
6828 Sec_Stacks
: out Int
);
6829 -- Count the number of default-sized primary and secondary task stacks
6830 -- required for task objects contained within type Typ. If the number of
6831 -- task objects contained within the type is not known at compile time
6832 -- the procedure will return the stack counts of zero.
6834 procedure Default_Initialize_Object
(After
: Node_Id
);
6835 -- Generate all default initialization actions for object Def_Id. Any
6836 -- new code is inserted after node After.
6838 procedure Initialize_Return_Object
6839 (Tag_Assign
: Node_Id
;
6842 Init_Stmt
: Node_Id
;
6844 -- Generate all initialization actions for return object Def_Id. Any
6845 -- new code is inserted after node After.
6847 function Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean;
6848 -- If we are not at library level and the object declaration originally
6849 -- appears in the form:
6851 -- Obj : Typ := Func (...);
6853 -- and has been rewritten as the dereference of a captured reference
6854 -- to the function result built either on the primary or the secondary
6855 -- stack, then the declaration can be rewritten as the renaming of this
6858 -- type Ann is access all Typ;
6859 -- Rnn : constant Axx := Func (...)'reference;
6860 -- Obj : Typ renames Rnn.all;
6862 -- This will avoid making an extra copy and, in the case where Typ needs
6863 -- finalization, a pair of calls to the Adjust and Finalize primitives,
6864 -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
6865 -- has components that themselves need finalization.
6867 -- However, in the case of a special return object, we need to make sure
6868 -- that the object Rnn is recognized by the Is_Related_To_Func_Return
6869 -- predicate; otherwise, if it is of a type that needs finalization,
6870 -- then Requires_Cleanup_Actions would return true because of this and
6871 -- Build_Finalizer would finalize it prematurely because of this (see
6872 -- also Expand_Simple_Function_Return for the same test in the case of
6873 -- a simple return).
6875 -- Finally, in the case of a special return object, we also need to make
6876 -- sure that the two functions return on the same stack, otherwise we
6877 -- would create a dangling reference.
6879 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
;
6880 -- Make an allocator for a return object initialized with Expr
6882 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean;
6883 -- Return True if N denotes an entity with OK_To_Rename set
6885 ----------------------------------
6886 -- Build_Heap_Or_Pool_Allocator --
6887 ----------------------------------
6889 function Build_Heap_Or_Pool_Allocator
6890 (Temp_Id
: Entity_Id
;
6891 Temp_Typ
: Entity_Id
;
6892 Ret_Typ
: Entity_Id
;
6893 Alloc_Expr
: Node_Id
) return Node_Id
6896 pragma Assert
(Is_Build_In_Place_Function
(Func_Id
));
6898 -- Processing for objects that require finalization actions
6900 if Needs_Finalization
(Ret_Typ
) then
6902 Decls
: constant List_Id
:= New_List
;
6903 Fin_Coll_Id
: constant Entity_Id
:=
6904 Build_In_Place_Formal
(Func_Id
, BIP_Collection
);
6905 Orig_Expr
: constant Node_Id
:= New_Copy_Tree
(Alloc_Expr
);
6906 Stmts
: constant List_Id
:= New_List
;
6907 Local_Id
: Entity_Id
;
6908 Pool_Id
: Entity_Id
;
6909 Ptr_Typ
: Entity_Id
;
6913 -- Pool_Id renames BIPstoragepool.all;
6915 -- This formal is not added on ZFP as those targets do not
6918 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
6919 Pool_Id
:= Make_Temporary
(Loc
, 'P');
6922 Make_Object_Renaming_Declaration
(Loc
,
6923 Defining_Identifier
=> Pool_Id
,
6925 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
6927 Make_Explicit_Dereference
(Loc
,
6929 (Build_In_Place_Formal
6930 (Func_Id
, BIP_Storage_Pool
), Loc
))));
6935 -- Create an access type which uses the storage pool of the
6936 -- caller. This additional type is necessary because the
6937 -- finalization collection cannot be associated with the type
6938 -- of the temporary. Otherwise the secondary stack allocation
6942 -- type Ptr_Typ is access Ret_Typ;
6944 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
6947 Make_Full_Type_Declaration
(Loc
,
6948 Defining_Identifier
=> Ptr_Typ
,
6950 Make_Access_To_Object_Definition
(Loc
,
6951 Subtype_Indication
=>
6952 New_Occurrence_Of
(Ret_Typ
, Loc
))));
6954 -- Perform minor decoration in order to set the collection and
6955 -- the storage pool attributes.
6957 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
6958 Set_Finalization_Collection
(Ptr_Typ
, Fin_Coll_Id
);
6959 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
6961 -- Create the temporary, generate:
6962 -- Local_Id : Ptr_Typ;
6964 Local_Id
:= Make_Temporary
(Loc
, 'T');
6967 Make_Object_Declaration
(Loc
,
6968 Defining_Identifier
=> Local_Id
,
6969 Object_Definition
=>
6970 New_Occurrence_Of
(Ptr_Typ
, Loc
)));
6971 Set_No_Initialization
(Last
(Decls
));
6973 -- Allocate the object, generate:
6974 -- Local_Id := <Alloc_Expr>;
6977 Make_Assignment_Statement
(Loc
,
6978 Name
=> New_Occurrence_Of
(Local_Id
, Loc
),
6979 Expression
=> Alloc_Expr
));
6982 -- Temp_Id := Temp_Typ (Local_Id);
6985 Make_Assignment_Statement
(Loc
,
6986 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
6988 Unchecked_Convert_To
(Temp_Typ
,
6989 New_Occurrence_Of
(Local_Id
, Loc
))));
6991 -- Wrap the allocation in a block to make it conditioned by the
6992 -- presence of the caller's collection at run time.
6995 -- if BIPcollection = null then
6996 -- Temp_Id := <Orig_Expr>;
7006 Make_If_Statement
(Loc
,
7009 Left_Opnd
=> New_Occurrence_Of
(Fin_Coll_Id
, Loc
),
7010 Right_Opnd
=> Make_Null
(Loc
)),
7012 Then_Statements
=> New_List
(
7013 Make_Assignment_Statement
(Loc
,
7014 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
7015 Expression
=> Orig_Expr
)),
7017 Else_Statements
=> New_List
(
7018 Make_Block_Statement
(Loc
,
7019 Declarations
=> Decls
,
7020 Handled_Statement_Sequence
=>
7021 Make_Handled_Sequence_Of_Statements
(Loc
,
7022 Statements
=> Stmts
))));
7025 -- For all other cases, generate:
7026 -- Temp_Id := <Alloc_Expr>;
7030 Make_Assignment_Statement
(Loc
,
7031 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
7032 Expression
=> Alloc_Expr
);
7034 end Build_Heap_Or_Pool_Allocator
;
7036 --------------------------
7037 -- BIP_Function_Call_Id --
7038 --------------------------
7040 function BIP_Function_Call_Id
return Entity_Id
is
7042 function Func_Call_Id
(Function_Call
: Node_Id
) return Entity_Id
;
7043 -- Return the id of the called function.
7045 function Func_Call_Id
(Function_Call
: Node_Id
) return Entity_Id
is
7046 Call_Node
: constant Node_Id
:= Unqual_Conv
(Function_Call
);
7049 if Is_Entity_Name
(Name
(Call_Node
)) then
7050 return Entity
(Name
(Call_Node
));
7052 elsif Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
7053 return Etype
(Name
(Call_Node
));
7056 pragma Assert
(Nkind
(Name
(Call_Node
)) = N_Selected_Component
);
7057 return Etype
(Entity
(Selector_Name
(Name
(Call_Node
))));
7061 -- Local declarations
7063 BIP_Func_Call
: Node_Id
;
7064 Expr_Q
: constant Node_Id
:= Unqual_Conv
(Expr
);
7066 -- Start of processing for BIP_Function_Call_Id
7069 if Is_Build_In_Place_Function_Call
(Expr_Q
) then
7070 return Func_Call_Id
(Expr_Q
);
7073 BIP_Func_Call
:= Unqual_BIP_Iface_Function_Call
(Expr_Q
);
7075 if Present
(BIP_Func_Call
) then
7077 -- In the case of an explicitly dereferenced call, return the
7080 if Nkind
(Name
(BIP_Func_Call
)) = N_Explicit_Dereference
then
7081 return Etype
(Name
(BIP_Func_Call
));
7083 pragma Assert
(Is_Entity_Name
(Name
(BIP_Func_Call
)));
7084 return Entity
(Name
(BIP_Func_Call
));
7087 elsif Nkind
(Expr_Q
) = N_Reference
7088 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7090 return Func_Call_Id
(Prefix
(Expr_Q
));
7095 end BIP_Function_Call_Id
;
7097 -------------------------------------
7098 -- Count_Default_Sized_Task_Stacks --
7099 -------------------------------------
7101 procedure Count_Default_Sized_Task_Stacks
7103 Pri_Stacks
: out Int
;
7104 Sec_Stacks
: out Int
)
7106 Component
: Entity_Id
;
7109 -- To calculate the number of default-sized task stacks required for
7110 -- an object of Typ, a depth-first recursive traversal of the AST
7111 -- from the Typ entity node is undertaken. Only type nodes containing
7112 -- task objects are visited.
7117 if not Has_Task
(Typ
) then
7125 -- A task type is found marking the bottom of the descent. If
7126 -- the type has no representation aspect for the corresponding
7127 -- stack then that stack is using the default size.
7129 if Present
(Get_Rep_Item
(Typ
, Name_Storage_Size
)) then
7135 if Present
(Get_Rep_Item
(Typ
, Name_Secondary_Stack_Size
)) then
7141 when E_Array_Subtype
7144 -- First find the number of default stacks contained within an
7147 Count_Default_Sized_Task_Stacks
7148 (Component_Type
(Typ
),
7152 -- Then multiply the result by the size of the array
7155 Quantity
: constant Nat
:= Number_Of_Elements_In_Array
(Typ
);
7156 -- Number_Of_Elements_In_Array is non-trival, consequently
7157 -- its result is captured as an optimization.
7160 Pri_Stacks
:= Pri_Stacks
* Quantity
;
7161 Sec_Stacks
:= Sec_Stacks
* Quantity
;
7164 when E_Protected_Subtype
7169 Component
:= First_Component
(Typ
);
7171 -- Recursively descend each component of the composite type
7172 -- looking for tasks.
7174 while Present
(Component
) loop
7180 Count_Default_Sized_Task_Stacks
(Etype
(Component
), P
, S
);
7181 Pri_Stacks
:= Pri_Stacks
+ P
;
7182 Sec_Stacks
:= Sec_Stacks
+ S
;
7185 Next_Component
(Component
);
7188 when E_Limited_Private_Subtype
7189 | E_Limited_Private_Type
7190 | E_Record_Subtype_With_Private
7191 | E_Record_Type_With_Private
7193 -- Switch to the full view of the private type to continue
7196 Count_Default_Sized_Task_Stacks
7197 (Full_View
(Typ
), Pri_Stacks
, Sec_Stacks
);
7199 -- Other types should not contain tasks
7202 raise Program_Error
;
7204 end Count_Default_Sized_Task_Stacks
;
7206 -------------------------------
7207 -- Default_Initialize_Object --
7208 -------------------------------
7210 procedure Default_Initialize_Object
(After
: Node_Id
) is
7211 Init_Expr
: Node_Id
;
7212 Init_Stmts
: List_Id
;
7215 -- Nothing to do if the object has an initialization expression or
7216 -- need not be initialized.
7218 if Has_Init_Expression
(N
) or else No_Initialization
(N
) then
7221 -- Default initialization is suppressed for objects that are already
7222 -- known to be imported (i.e. whose declaration specifies the Import
7223 -- aspect). Note that for objects with a pragma Import, we generate
7224 -- initialization here, and then remove it downstream when processing
7225 -- the pragma. It is also suppressed for variables for which a pragma
7226 -- Suppress_Initialization has been explicitly given
7228 elsif Is_Imported
(Def_Id
)
7229 or else Suppress_Initialization
(Def_Id
)
7233 -- Nothing to do if the object being initialized is of a task type
7234 -- and restriction No_Tasking is in effect, because this is a direct
7235 -- violation of the restriction.
7237 elsif Is_Task_Type
(Base_Typ
)
7238 and then Restriction_Active
(No_Tasking
)
7243 -- First try a simple initialization; if it succeeds, then we just
7244 -- set the value as the expression of the declaration and let the
7245 -- code generator do the rest.
7247 Init_Expr
:= Build_Default_Simple_Initialization
(N
, Typ
, Def_Id
);
7249 if Present
(Init_Expr
) then
7250 Set_Expression
(N
, Init_Expr
);
7251 Analyze_And_Resolve
(Init_Expr
, Typ
);
7255 -- Or else build the fully-fledged initialization if need be
7257 if Is_Mutably_Tagged_Type
(Typ
) then
7259 Build_Default_Initialization
(N
, Etype
(Typ
), Def_Id
);
7261 Init_Stmts
:= Build_Default_Initialization
(N
, Typ
, Def_Id
);
7264 -- Insert the whole initialization sequence into the tree. If the
7265 -- object has a delayed freeze, as will be the case when it has
7266 -- aspect specifications, the initialization sequence is part of
7267 -- the freeze actions.
7269 if Present
(Init_Stmts
) then
7270 if Has_Delayed_Freeze
(Def_Id
) then
7271 Append_Freeze_Actions
(Def_Id
, Init_Stmts
);
7273 Insert_Actions_After
(After
, Init_Stmts
);
7276 end Default_Initialize_Object
;
7278 ------------------------------
7279 -- Initialize_Return_Object --
7280 ------------------------------
7282 procedure Initialize_Return_Object
7283 (Tag_Assign
: Node_Id
;
7286 Init_Stmt
: Node_Id
;
7290 if Present
(Tag_Assign
) then
7291 Insert_Action_After
(After
, Tag_Assign
);
7294 if Present
(Adj_Call
) then
7295 Insert_Action_After
(After
, Adj_Call
);
7299 Default_Initialize_Object
(After
);
7301 elsif Is_Delayed_Aggregate
(Expr
)
7302 and then not No_Initialization
(N
)
7304 Convert_Aggr_In_Object_Decl
(N
);
7306 elsif Present
(Init_Stmt
) then
7307 Insert_Action_After
(After
, Init_Stmt
);
7308 Set_Expression
(N
, Empty
);
7310 end Initialize_Return_Object
;
7312 --------------------------------
7313 -- Is_Renamable_Function_Call --
7314 --------------------------------
7316 function Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean is
7318 return not Is_Library_Level_Entity
(Def_Id
)
7319 and then Is_Captured_Function_Call
(Expr
)
7320 and then (not Special_Ret_Obj
7322 (Is_Related_To_Func_Return
(Entity
(Prefix
(Expr
)))
7323 and then Needs_Secondary_Stack
(Etype
(Expr
)) =
7324 Needs_Secondary_Stack
(Etype
(Func_Id
))));
7325 end Is_Renamable_Function_Call
;
7327 -------------------------------
7328 -- Make_Allocator_For_Return --
7329 -------------------------------
7331 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
is
7333 Alloc_Expr
: Entity_Id
;
7334 Alloc_Typ
: Entity_Id
;
7337 -- If the return object's declaration does not include an expression,
7338 -- then we use its subtype for the allocation. Likewise in the case
7339 -- of a degenerate expression like a raise expression.
7342 or else Nkind
(Original_Node
(Expr
)) = N_Raise_Expression
7346 -- If the return object's declaration includes an expression, then
7347 -- there are two cases: either the nominal subtype of the object is
7348 -- definite and we can use it for the allocation directly, or it is
7349 -- not and Analyze_Object_Declaration should have built an actual
7350 -- subtype from the expression.
7352 -- However, there are exceptions in the latter case for interfaces
7353 -- (see Analyze_Object_Declaration), as well as class-wide types and
7354 -- types with unknown discriminants if they are additionally limited
7355 -- (see Expand_Subtype_From_Expr), so we must cope with them.
7357 elsif Is_Interface
(Typ
) then
7358 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7360 -- For interfaces, we use the type of the expression, except if
7361 -- we need to put back a conversion that we have removed earlier
7362 -- in the processing.
7364 if Is_Class_Wide_Type
(Etype
(Expr
)) then
7367 Alloc_Typ
:= Etype
(Expr
);
7370 elsif Is_Class_Wide_Type
(Typ
) then
7372 -- For class-wide types, we have to make sure that we use the
7373 -- dynamic type of the expression for the allocation, either by
7374 -- means of its (static) subtype or through the actual subtype.
7376 if Has_Tag_Of_Type
(Expr
) then
7377 Alloc_Typ
:= Etype
(Expr
);
7379 else pragma Assert
(Ekind
(Typ
) = E_Class_Wide_Subtype
7380 and then Present
(Equivalent_Type
(Typ
)));
7385 else pragma Assert
(Is_Definite_Subtype
(Typ
)
7386 or else (Has_Unknown_Discriminants
(Typ
)
7387 and then Is_Inherently_Limited_Type
(Typ
)));
7392 -- If the return object's declaration includes an expression and the
7393 -- declaration isn't marked as No_Initialization, then we generate an
7394 -- allocator with a qualified expression. Although this is necessary
7395 -- only in the case where the result type is an interface (or class-
7396 -- wide interface), we do it in all cases for the sake of consistency
7397 -- instead of subsequently generating a separate assignment.
7400 and then not Is_Delayed_Aggregate
(Expr
)
7401 and then not No_Initialization
(N
)
7403 -- Ada 2005 (AI95-344): If the result type is class-wide, insert
7404 -- a check that the level of the return expression's underlying
7405 -- type is not deeper than the level of the master enclosing the
7408 -- AI12-043: The check is made immediately after the return object
7411 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
7412 Apply_CW_Accessibility_Check
(Expr
, Func_Id
);
7415 Alloc_Expr
:= New_Copy_Tree
(Expr
);
7417 if Etype
(Alloc_Expr
) /= Alloc_Typ
then
7418 Alloc_Expr
:= Convert_To
(Alloc_Typ
, Alloc_Expr
);
7422 Make_Allocator
(Loc
,
7424 Make_Qualified_Expression
(Loc
,
7426 New_Occurrence_Of
(Alloc_Typ
, Loc
),
7427 Expression
=> Alloc_Expr
));
7431 Make_Allocator
(Loc
,
7432 Expression
=> New_Occurrence_Of
(Alloc_Typ
, Loc
));
7434 -- If the return object requires default initialization, then it
7435 -- will happen later following the elaboration of the renaming.
7436 -- If we don't turn it off here, then the object will be default
7437 -- initialized twice.
7439 Set_No_Initialization
(Alloc
);
7442 -- Set the flag indicating that the allocator is made for a special
7443 -- return object. This is used to bypass various legality checks as
7444 -- well as to make sure that the result is not adjusted twice.
7446 Set_For_Special_Return_Object
(Alloc
);
7449 end Make_Allocator_For_Return
;
7451 ----------------------
7452 -- OK_To_Rename_Ref --
7453 ----------------------
7455 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean is
7457 return Is_Entity_Name
(N
)
7458 and then Ekind
(Entity
(N
)) = E_Variable
7459 and then OK_To_Rename
(Entity
(N
));
7460 end OK_To_Rename_Ref
;
7464 Adj_Call
: Node_Id
:= Empty
;
7465 Expr_Q
: Node_Id
:= Empty
;
7466 Tag_Assign
: Node_Id
:= Empty
;
7468 Init_After
: Node_Id
:= N
;
7469 -- Node after which the initialization actions are to be inserted. This
7470 -- is normally N, except for the case of a shared passive variable, in
7471 -- which case the init proc call must be inserted only after the bodies
7472 -- of the shared variable procedures have been seen.
7474 Has_BIP_Init_Expr
: Boolean := False;
7475 -- Whether the object is initialized with a BIP function call
7477 Rewrite_As_Renaming
: Boolean := False;
7478 -- Whether to turn the declaration into a renaming at the end
7480 -- Start of processing for Expand_N_Object_Declaration
7483 -- Don't do anything for deferred constants. All proper actions will be
7484 -- expanded during the full declaration.
7486 if No
(Expr
) and Constant_Present
(N
) then
7490 -- The type of the object cannot be abstract. This is diagnosed at the
7491 -- point the object is frozen, which happens after the declaration is
7492 -- fully expanded, so simply return now.
7494 if Is_Abstract_Type
(Typ
) then
7498 -- No action needed for the internal imported dummy object added by
7499 -- Make_DT to compute the offset of the components that reference
7500 -- secondary dispatch tables; required to avoid never-ending loop
7501 -- processing this internal object declaration.
7503 if Tagged_Type_Expansion
7504 and then Is_Internal
(Def_Id
)
7505 and then Is_Imported
(Def_Id
)
7506 and then Related_Type
(Def_Id
) = Implementation_Base_Type
(Typ
)
7511 -- Make shared memory routines for shared passive variable
7513 if Is_Shared_Passive
(Def_Id
) then
7514 Init_After
:= Make_Shared_Var_Procs
(N
);
7517 -- Determine whether the object is initialized with a BIP function call
7519 if Present
(Expr
) then
7520 Expr_Q
:= Unqualify
(Expr
);
7522 Has_BIP_Init_Expr
:=
7523 Is_Build_In_Place_Function_Call
(Expr_Q
)
7524 or else Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
))
7525 or else (Nkind
(Expr_Q
) = N_Reference
7527 Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
)));
7530 -- If tasks are being declared, make sure we have an activation chain
7531 -- defined for the tasks (has no effect if we already have one), and
7532 -- also that a Master variable is established (and that the appropriate
7533 -- enclosing construct is established as a task master).
7536 or else Might_Have_Tasks
(Typ
)
7537 or else (Has_BIP_Init_Expr
7538 and then Needs_BIP_Task_Actuals
(BIP_Function_Call_Id
))
7540 Build_Activation_Chain_Entity
(N
);
7542 if Has_Task
(Typ
) then
7543 Build_Master_Entity
(Def_Id
);
7545 -- Handle objects initialized with BIP function calls
7547 elsif Has_BIP_Init_Expr
then
7548 Build_Master_Entity
(Def_Id
);
7552 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
7553 -- restrictions are active then default-sized secondary stacks are
7554 -- generated by the binder and allocated by SS_Init. To provide the
7555 -- binder the number of stacks to generate, the number of default-sized
7556 -- stacks required for task objects contained within the object
7557 -- declaration N is calculated here as it is at this point where
7558 -- unconstrained types become constrained. The result is stored in the
7559 -- enclosing unit's Unit_Record.
7561 -- Note if N is an array object declaration that has an initialization
7562 -- expression, a second object declaration for the initialization
7563 -- expression is created by the compiler. To prevent double counting
7564 -- of the stacks in this scenario, the stacks of the first array are
7567 if Might_Have_Tasks
(Typ
)
7568 and then not Restriction_Active
(No_Secondary_Stack
)
7569 and then (Restriction_Active
(No_Implicit_Heap_Allocations
)
7570 or else Restriction_Active
(No_Implicit_Task_Allocations
))
7571 and then not (Is_Array_Type
(Typ
) and then Has_Init_Expression
(N
))
7574 PS_Count
, SS_Count
: Int
;
7576 Count_Default_Sized_Task_Stacks
(Typ
, PS_Count
, SS_Count
);
7577 Increment_Primary_Stack_Count
(PS_Count
);
7578 Increment_Sec_Stack_Count
(SS_Count
);
7582 -- Default initialization required, and no expression present
7585 -- If we have a type with a variant part, the initialization proc
7586 -- will contain implicit tests of the discriminant values, which
7587 -- counts as a violation of the restriction No_Implicit_Conditionals.
7589 if Has_Variant_Part
(Typ
) then
7594 Check_Restriction
(Msg
, No_Implicit_Conditionals
, Obj_Def
);
7598 ("\initialization of variant record tests discriminants",
7605 -- For the default initialization case, if we have a private type
7606 -- with invariants, and invariant checks are enabled, then insert an
7607 -- invariant check after the object declaration. Note that it is OK
7608 -- to clobber the object with an invalid value since if the exception
7609 -- is raised, then the object will go out of scope. In the case where
7610 -- an array object is initialized with an aggregate, the expression
7611 -- is removed. Check flag Has_Init_Expression to avoid generating a
7612 -- junk invariant check and flag No_Initialization to avoid checking
7613 -- an uninitialized object such as a compiler temporary used for an
7616 if Has_Invariants
(Base_Typ
)
7617 and then Present
(Invariant_Procedure
(Base_Typ
))
7618 and then not Has_Init_Expression
(N
)
7619 and then not No_Initialization
(N
)
7621 -- If entity has an address clause or aspect, make invariant
7622 -- call into a freeze action for the explicit freeze node for
7623 -- object. Otherwise insert invariant check after declaration.
7625 if Present
(Following_Address_Clause
(N
))
7626 or else Has_Aspect
(Def_Id
, Aspect_Address
)
7628 Ensure_Freeze_Node
(Def_Id
);
7629 Set_Has_Delayed_Freeze
(Def_Id
);
7630 Set_Is_Frozen
(Def_Id
, False);
7632 if not Partial_View_Has_Unknown_Discr
(Typ
) then
7633 Append_Freeze_Action
(Def_Id
,
7634 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7637 elsif not Partial_View_Has_Unknown_Discr
(Typ
) then
7639 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7643 if not Special_Ret_Obj
then
7644 Default_Initialize_Object
(Init_After
);
7646 -- Check whether an access object has been initialized above
7648 if Is_Access_Type
(Typ
) and then Present
(Expression
(N
)) then
7649 if Known_Non_Null
(Expression
(N
)) then
7650 Set_Is_Known_Non_Null
(Def_Id
);
7651 elsif Known_Null
(Expression
(N
)) then
7652 Set_Is_Known_Null
(Def_Id
);
7657 -- Generate attribute for Persistent_BSS if needed
7659 if Persistent_BSS_Mode
7660 and then Comes_From_Source
(N
)
7661 and then Is_Potentially_Persistent_Type
(Typ
)
7662 and then not Has_Init_Expression
(N
)
7663 and then Is_Library_Level_Entity
(Def_Id
)
7669 Make_Linker_Section_Pragma
7670 (Def_Id
, Sloc
(N
), ".persistent.bss");
7671 Insert_After
(N
, Prag
);
7676 -- Explicit initialization present
7679 -- Obtain actual expression from qualified expression
7681 Expr_Q
:= Unqualify
(Expr
);
7683 -- When we have the appropriate type of aggregate in the expression
7684 -- (it has been determined during analysis of the aggregate by
7685 -- setting the delay flag), let's perform in place assignment and
7686 -- thus avoid creating a temporary.
7688 if Is_Delayed_Aggregate
(Expr_Q
) then
7690 -- An aggregate that must be built in place is not resolved and
7691 -- expanded until the enclosing construct is expanded. This will
7692 -- happen when the aggregate is limited and the declared object
7693 -- has a following address clause; it happens also when generating
7694 -- C code for an aggregate that has an alignment or address clause
7695 -- (see Analyze_Object_Declaration). Resolution is done without
7696 -- expansion because it will take place when the declaration
7697 -- itself is expanded.
7699 if (Is_Limited_Type
(Typ
) or else Modify_Tree_For_C
)
7700 and then not Analyzed
(Expr
)
7702 Expander_Mode_Save_And_Set
(False);
7703 Resolve
(Expr
, Typ
);
7704 Expander_Mode_Restore
;
7707 -- For a special return object, the transformation must wait until
7708 -- after the object is turned into an allocator.
7710 if not Special_Ret_Obj
then
7711 Convert_Aggr_In_Object_Decl
(N
);
7714 -- If the initialization expression is a conditional expression whose
7715 -- expansion has been delayed, assign it explicitly to the object but
7716 -- only after analyzing it again and expanding it.
7718 elsif Is_Delayed_Conditional_Expression
(Expr_Q
) then
7719 -- For a special return object, the transformation must wait until
7720 -- after the object is turned into an allocator, and will be done
7721 -- during the expansion of the allocator.
7723 if not Special_Ret_Obj
then
7725 Assign
: constant Node_Id
:=
7726 Make_Assignment_Statement
(Loc
,
7727 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
7728 Expression
=> Relocate_Node
(Expr
));
7731 Set_Assignment_OK
(Name
(Assign
));
7732 Set_Analyzed
(Expression
(Assign
), False);
7733 Set_No_Finalize_Actions
(Assign
);
7734 Insert_Action_After
(Init_After
, Assign
);
7736 -- Save the assignment statement when declaring a controlled
7737 -- object. This reference is used later by the finalization
7738 -- machinery to mark the object as successfully initialized
7740 if Needs_Finalization
(Typ
) then
7741 Set_Last_Aggregate_Assignment
(Def_Id
, Assign
);
7744 Set_Expression
(N
, Empty
);
7745 Set_No_Initialization
(N
);
7749 -- Ada 2005 (AI-318-02): If the initialization expression is a call
7750 -- to a build-in-place function, then access to the declared object
7751 -- must be passed to the function. Currently we limit such functions
7752 -- to those with constrained limited result subtypes, but eventually
7753 -- plan to expand the allowed forms of functions that are treated as
7756 elsif Is_Build_In_Place_Function_Call
(Expr_Q
) then
7757 Make_Build_In_Place_Call_In_Object_Declaration
(N
, Expr_Q
);
7759 -- The previous call expands the expression initializing the
7760 -- built-in-place object into further code that will be analyzed
7761 -- later. No further expansion needed here.
7765 -- This is the same as the previous 'elsif', except that the call has
7766 -- been transformed by other expansion activities into something like
7767 -- F(...)'Reference.
7769 elsif Nkind
(Expr_Q
) = N_Reference
7770 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7771 and then not Is_Expanded_Build_In_Place_Call
7772 (Unqual_Conv
(Prefix
(Expr_Q
)))
7774 Make_Build_In_Place_Call_In_Anonymous_Context
(Prefix
(Expr_Q
));
7776 -- The previous call expands the expression initializing the
7777 -- built-in-place object into further code that will be analyzed
7778 -- later. No further expansion needed here.
7782 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7783 -- expressions containing a build-in-place function call whose
7784 -- returned object covers interface types, and Expr_Q has calls to
7785 -- Ada.Tags.Displace to displace the pointer to the returned build-
7786 -- in-place object to reference the secondary dispatch table of a
7787 -- covered interface type.
7789 elsif Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
)) then
7790 Make_Build_In_Place_Iface_Call_In_Object_Declaration
(N
, Expr_Q
);
7792 -- The previous call expands the expression initializing the
7793 -- built-in-place object into further code that will be analyzed
7794 -- later. No further expansion needed here.
7798 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7799 -- class-wide interface object to ensure that we copy the full
7800 -- object, unless we are targetting a VM where interfaces are handled
7801 -- by VM itself. Note that if the root type of Typ is an ancestor of
7802 -- Expr's type, both types share the same dispatch table and there is
7803 -- no need to displace the pointer.
7805 elsif Is_Interface
(Typ
)
7807 -- Avoid never-ending recursion because if Equivalent_Type is set
7808 -- then we've done it already and must not do it again.
7811 (Nkind
(Obj_Def
) = N_Identifier
7812 and then Present
(Equivalent_Type
(Entity
(Obj_Def
))))
7814 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7816 -- If the original node of the expression was a conversion
7817 -- to this specific class-wide interface type then restore
7818 -- the original node because we must copy the object before
7819 -- displacing the pointer to reference the secondary tag
7820 -- component. This code must be kept synchronized with the
7821 -- expansion done by routine Expand_Interface_Conversion
7823 if not Comes_From_Source
(Expr
)
7824 and then Nkind
(Expr
) = N_Explicit_Dereference
7825 and then Nkind
(Original_Node
(Expr
)) = N_Type_Conversion
7826 and then Etype
(Original_Node
(Expr
)) = Typ
7828 Rewrite
(Expr
, Original_Node
(Expression
(N
)));
7831 -- Avoid expansion of redundant interface conversion
7833 if Nkind
(Expr
) = N_Type_Conversion
7834 and then Etype
(Expr
) = Typ
7836 Expr_Q
:= Expression
(Expr
);
7841 -- We may use a renaming if the initialization expression is a
7842 -- captured function call that meets a few conditions.
7844 Rewrite_As_Renaming
:= Is_Renamable_Function_Call
(Expr_Q
);
7846 -- If the object is a special return object, then bypass special
7847 -- treatment of class-wide interface initialization below. In this
7848 -- case, the expansion of the return object will take care of this
7849 -- initialization via the expansion of the allocator.
7851 if Special_Ret_Obj
and then not Rewrite_As_Renaming
then
7853 -- If the type needs finalization and is not inherently
7854 -- limited, then the target is adjusted after the copy
7855 -- and attached to the finalization list.
7857 if Needs_Finalization
(Typ
)
7858 and then not Is_Inherently_Limited_Type
(Typ
)
7862 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
7866 -- Renaming an expression of the object's type is immediate
7868 elsif Rewrite_As_Renaming
7869 and then Base_Type
(Etype
(Expr_Q
)) = Base_Type
(Typ
)
7873 elsif Tagged_Type_Expansion
then
7875 Iface
: constant Entity_Id
:= Root_Type
(Typ
);
7877 Expr_Typ
: Entity_Id
;
7880 Ptr_Obj_Decl
: Node_Id
;
7881 Ptr_Obj_Id
: Entity_Id
;
7885 Expr_Typ
:= Base_Type
(Etype
(Expr_Q
));
7886 if Is_Class_Wide_Type
(Expr_Typ
) then
7887 Expr_Typ
:= Root_Type
(Expr_Typ
);
7890 -- Rename limited objects since they cannot be copied
7892 if Is_Limited_Record
(Expr_Typ
) then
7893 Rewrite_As_Renaming
:= True;
7896 Obj_Id
:= Make_Temporary
(Loc
, 'D', Expr_Q
);
7899 -- IW : I'Class := Expr;
7901 -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
7902 -- type Ityp is not null access I'Class;
7903 -- Rnn : constant Ityp :=
7904 -- Ityp!(Displace (Dnn'Address, I'Tag));
7905 -- IW : I'Class renames Rnn.all;
7907 if Rewrite_As_Renaming
then
7909 Make_Explicit_Dereference
(Loc
,
7910 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7911 Make_Attribute_Reference
(Loc
,
7912 Prefix
=> Relocate_Node
(Expr_Q
),
7913 Attribute_Name
=> Name_Address
)));
7915 -- Suppress junk access checks on RE_Tag_Ptr
7918 Make_Object_Renaming_Declaration
(Loc
,
7919 Defining_Identifier
=> Obj_Id
,
7921 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7923 Suppress
=> Access_Check
);
7925 -- Dynamically reference the tag associated with the
7929 Make_Function_Call
(Loc
,
7930 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
7931 Parameter_Associations
=> New_List
(
7932 Make_Attribute_Reference
(Loc
,
7933 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7934 Attribute_Name
=> Name_Address
),
7936 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
7940 -- IW : I'Class := Expr;
7942 -- Dnn : Typ := Expr;
7943 -- type Ityp is not null access I'Class;
7944 -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
7945 -- IW : I'Class renames Rnn.all;
7947 elsif Has_Tag_Of_Type
(Expr_Q
)
7948 and then Interface_Present_In_Ancestor
(Expr_Typ
, Typ
)
7949 and then (Expr_Typ
= Etype
(Expr_Typ
)
7951 Is_Variable_Size_Record
(Etype
(Expr_Typ
)))
7954 Make_Object_Declaration
(Loc
,
7955 Defining_Identifier
=> Obj_Id
,
7956 Object_Definition
=>
7957 New_Occurrence_Of
(Expr_Typ
, Loc
),
7958 Expression
=> Relocate_Node
(Expr_Q
)));
7960 -- Statically reference the tag associated with the
7964 Make_Selected_Component
(Loc
,
7965 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7968 (Find_Interface_Tag
(Expr_Typ
, Iface
), Loc
));
7971 -- IW : I'Class := Expr;
7973 -- type Equiv_Record is record ... end record;
7974 -- implicit subtype CW is <Class_Wide_Subtype>;
7975 -- Dnn : CW := CW!(Expr);
7976 -- type Ityp is not null access I'Class;
7977 -- Rnn : constant Ityp :=
7978 -- Ityp!(Displace (Dnn'Address, I'Tag));
7979 -- IW : I'Class renames Rnn.all;
7982 -- Generate the equivalent record type and update the
7983 -- subtype indication to reference it.
7985 Expand_Subtype_From_Expr
7988 Subtype_Indic
=> Obj_Def
,
7991 -- For interface types we use 'Address which displaces
7992 -- the pointer to the base of the object (if required).
7994 if Is_Interface
(Etype
(Expr_Q
)) then
7996 Unchecked_Convert_To
(Etype
(Obj_Def
),
7997 Make_Explicit_Dereference
(Loc
,
7998 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7999 Make_Attribute_Reference
(Loc
,
8000 Prefix
=> Relocate_Node
(Expr_Q
),
8001 Attribute_Name
=> Name_Address
))));
8003 -- For other types, no displacement is needed
8006 New_Expr
:= Relocate_Node
(Expr_Q
);
8009 -- Suppress junk access checks on RE_Tag_Ptr
8012 Make_Object_Declaration
(Loc
,
8013 Defining_Identifier
=> Obj_Id
,
8014 Object_Definition
=>
8015 New_Occurrence_Of
(Etype
(Obj_Def
), Loc
),
8016 Expression
=> New_Expr
),
8017 Suppress
=> Access_Check
);
8019 -- Dynamically reference the tag associated with the
8023 Make_Function_Call
(Loc
,
8024 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
8025 Parameter_Associations
=> New_List
(
8026 Make_Attribute_Reference
(Loc
,
8027 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
8028 Attribute_Name
=> Name_Address
),
8030 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
8034 -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
8035 -- to do the final conversion, but we insert an intermediate
8036 -- temporary before the dereference so that we can process
8037 -- the expansion as part of the analysis of the declaration
8038 -- of this temporary, and then rewrite manually the original
8039 -- object as the simple renaming of this dereference.
8041 Tag_Comp
:= Convert_Tag_To_Interface
(Typ
, Tag_Comp
);
8042 pragma Assert
(Nkind
(Tag_Comp
) = N_Explicit_Dereference
8044 Nkind
(Prefix
(Tag_Comp
)) = N_Unchecked_Type_Conversion
);
8046 Ptr_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8049 Make_Object_Declaration
(Loc
,
8050 Defining_Identifier
=> Ptr_Obj_Id
,
8051 Constant_Present
=> True,
8052 Object_Definition
=>
8054 (Entity
(Subtype_Mark
(Prefix
(Tag_Comp
))), Loc
),
8055 Expression
=> Prefix
(Tag_Comp
));
8057 Insert_Action
(N
, Ptr_Obj_Decl
, Suppress
=> All_Checks
);
8059 Set_Prefix
(Tag_Comp
, New_Occurrence_Of
(Ptr_Obj_Id
, Loc
));
8061 Set_Etype
(Expr_Q
, Typ
);
8062 Set_Parent
(Expr_Q
, N
);
8064 Rewrite_As_Renaming
:= True;
8071 -- Common case of explicit object initialization
8074 -- Small optimization: if the expression is a function call and
8075 -- the object is stand-alone, not declared at library level and of
8076 -- a class-wide type, then we capture the result of the call into
8077 -- a temporary, with the benefit that, if the result's type does
8078 -- not need finalization, nothing will be finalized and, if it
8079 -- does, the temporary only will be finalized by means of a direct
8080 -- call to the Finalize primitive if the result's type is not a
8081 -- class-wide type; whereas, in both cases, the stand-alone object
8082 -- itself would be finalized by means of a dispatching call to the
8083 -- Deep_Finalize routine.
8085 if Nkind
(Expr_Q
) = N_Function_Call
8086 and then not Special_Ret_Obj
8087 and then not Is_Library_Level_Entity
(Def_Id
)
8088 and then Is_Class_Wide_Type
(Typ
)
8090 Remove_Side_Effects
(Expr_Q
);
8093 -- In most cases, we must check that the initial value meets any
8094 -- constraint imposed by the declared type. However, there is one
8095 -- very important exception to this rule. If the entity has an
8096 -- unconstrained nominal subtype, then it acquired its constraints
8097 -- from the expression in the first place, and not only does this
8098 -- mean that the constraint check is not needed, but an attempt to
8099 -- perform the constraint check can cause order of elaboration
8102 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
8104 -- If this is an allocator for an aggregate that has been
8105 -- allocated in place, delay checks until assignments are
8106 -- made, because the discriminants are not initialized.
8108 if Nkind
(Expr
) = N_Allocator
8109 and then No_Initialization
(Expr
)
8113 -- Otherwise apply a constraint check now if no prev error
8115 elsif Nkind
(Expr
) /= N_Error
then
8116 Apply_Constraint_Check
(Expr
, Typ
);
8118 -- Deal with possible range check
8120 if Do_Range_Check
(Expr
) then
8122 -- If assignment checks are suppressed, turn off flag
8124 if Suppress_Assignment_Checks
(N
) then
8125 Set_Do_Range_Check
(Expr
, False);
8127 -- Otherwise generate the range check
8130 Generate_Range_Check
8131 (Expr
, Typ
, CE_Range_Check_Failed
);
8137 -- For tagged types, when an init value is given, the tag has to
8138 -- be re-initialized separately in order to avoid the propagation
8139 -- of a wrong tag coming from a view conversion unless the type
8140 -- is class wide (in this case the tag comes from the init value).
8141 -- Suppress the tag assignment when not Tagged_Type_Expansion
8142 -- because tags are represented implicitly in objects. Ditto for
8143 -- types that are CPP_CLASS, and for initializations that are
8144 -- aggregates, because they have to have the right tag.
8146 -- The re-assignment of the tag has to be done even if the object
8147 -- is a constant. The assignment must be analyzed after the
8148 -- declaration. If an address clause follows, this is handled as
8149 -- part of the freeze actions for the object, otherwise insert
8150 -- tag assignment here.
8152 Tag_Assign
:= Make_Tag_Assignment
(N
);
8154 if Present
(Tag_Assign
) then
8155 if Present
(Following_Address_Clause
(N
)) then
8156 Ensure_Freeze_Node
(Def_Id
);
8157 elsif not Special_Ret_Obj
then
8158 Insert_Action_After
(Init_After
, Tag_Assign
);
8161 -- Handle C++ constructor calls. Note that we do not check that
8162 -- Typ is a tagged type since the equivalent Ada type of a C++
8163 -- class that has no virtual methods is an untagged limited
8166 elsif Is_CPP_Constructor_Call
(Expr
) then
8168 Id_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
8171 -- The call to the initialization procedure does NOT freeze
8172 -- the object being initialized.
8174 Set_Must_Not_Freeze
(Id_Ref
);
8175 Set_Assignment_OK
(Id_Ref
);
8177 Insert_Actions_After
(Init_After
,
8178 Build_Initialization_Call
(N
, Id_Ref
, Typ
,
8179 Constructor_Ref
=> Expr
));
8181 -- We remove here the original call to the constructor
8182 -- to avoid its management in the backend
8184 Set_Expression
(N
, Empty
);
8188 -- Handle initialization of limited tagged types
8190 elsif Is_Tagged_Type
(Typ
)
8191 and then Is_Class_Wide_Type
(Typ
)
8192 and then Is_Limited_Record
(Typ
)
8193 and then not Is_Limited_Interface
(Typ
)
8195 -- Given that the type is limited we cannot perform a copy. If
8196 -- Expr_Q is the reference to a variable we mark the variable
8197 -- as OK_To_Rename to expand this declaration into a renaming
8198 -- declaration (see below).
8200 if Is_Entity_Name
(Expr_Q
) then
8201 Set_OK_To_Rename
(Entity
(Expr_Q
));
8203 -- If we cannot convert the expression into a renaming we must
8204 -- consider it an internal error because the backend does not
8205 -- have support to handle it. But avoid crashing on a raise
8206 -- expression or conditional expression.
8208 elsif Nkind
(Original_Node
(Expr_Q
)) not in
8209 N_Raise_Expression | N_If_Expression | N_Case_Expression
8211 raise Program_Error
;
8214 -- For discrete types, set the Is_Known_Valid flag if the
8215 -- initializing value is known to be valid. Only do this for
8216 -- source assignments, since otherwise we can end up turning
8217 -- on the known valid flag prematurely from inserted code.
8219 elsif Comes_From_Source
(N
)
8220 and then Is_Discrete_Type
(Typ
)
8221 and then Expr_Known_Valid
(Expr
)
8222 and then Safe_To_Capture_Value
(N
, Def_Id
)
8224 Set_Is_Known_Valid
(Def_Id
);
8226 -- For access types, set the Is_Known_Non_Null flag if the
8227 -- initializing value is known to be non-null. We can also
8228 -- set Can_Never_Be_Null if this is a constant.
8230 elsif Is_Access_Type
(Typ
) and then Known_Non_Null
(Expr
) then
8231 Set_Is_Known_Non_Null
(Def_Id
, True);
8233 if Constant_Present
(N
) then
8234 Set_Can_Never_Be_Null
(Def_Id
);
8238 -- If validity checking on copies, validate initial expression.
8239 -- But skip this if declaration is for a generic type, since it
8240 -- makes no sense to validate generic types. Not clear if this
8241 -- can happen for legal programs, but it definitely can arise
8242 -- from previous instantiation errors.
8244 if Validity_Checks_On
8245 and then Comes_From_Source
(N
)
8246 and then Validity_Check_Copies
8247 and then not Is_Generic_Type
(Typ
)
8249 Ensure_Valid
(Expr
);
8251 if Safe_To_Capture_Value
(N
, Def_Id
) then
8252 Set_Is_Known_Valid
(Def_Id
);
8256 -- Now determine whether we will use a renaming
8258 Rewrite_As_Renaming
:=
8260 -- The declaration cannot be rewritten if it has got constraints
8262 Is_Entity_Name
(Original_Node
(Obj_Def
))
8264 -- If we have "X : S := ...;", and S is a constrained array
8265 -- subtype, then we cannot rename, because renamings ignore
8266 -- the constraints of S, so that would change the semantics
8267 -- (sliding would not occur on the initial value). This is
8268 -- only a problem for source objects though, the others have
8269 -- the correct bounds.
8271 and then not (Comes_From_Source
(Obj_Def
)
8272 and then Is_Array_Type
(Typ
)
8273 and then Is_Constrained
(Typ
))
8275 -- Moreover, if we have "X : aliased S := "...;" and S is an
8276 -- unconstrained array type, then we can rename only if the
8277 -- initialization expression has an unconstrained subtype too,
8278 -- because the bounds must be present within X.
8280 and then not (Is_Constr_Array_Subt_With_Bounds
(Typ
)
8281 and then Is_Constrained
(Etype
(Expr_Q
)))
8283 -- We may use a renaming if the initialization expression is a
8284 -- captured function call that meets a few conditions.
8287 (Is_Renamable_Function_Call
(Expr_Q
)
8289 -- Or else if it is a variable with OK_To_Rename set
8291 or else (OK_To_Rename_Ref
(Expr_Q
)
8292 and then not Special_Ret_Obj
)
8294 -- Or else if it is a slice of such a variable
8296 or else (Nkind
(Expr_Q
) = N_Slice
8297 and then OK_To_Rename_Ref
(Prefix
(Expr_Q
))
8298 and then not Special_Ret_Obj
));
8300 -- If the type needs finalization and is not inherently limited,
8301 -- then the target is adjusted after the copy and attached to the
8302 -- finalization list. However, no adjustment is needed in the case
8303 -- where the object has been initialized by a call to a function
8304 -- returning on the primary stack (see Expand_Ctrl_Function_Call)
8305 -- since no copy occurred, given that the type is by-reference.
8306 -- Similarly, no adjustment is needed if we are going to rewrite
8307 -- the object declaration into a renaming declaration.
8309 if Needs_Finalization
(Typ
)
8310 and then not Is_Inherently_Limited_Type
(Typ
)
8311 and then Nkind
(Expr_Q
) /= N_Function_Call
8312 and then not Rewrite_As_Renaming
8316 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
8319 if Present
(Adj_Call
) and then not Special_Ret_Obj
then
8320 Insert_Action_After
(Init_After
, Adj_Call
);
8325 -- Cases where the back end cannot handle the initialization
8326 -- directly. In such cases, we expand an assignment that will
8327 -- be appropriately handled by Expand_N_Assignment_Statement.
8329 -- The exclusion of the unconstrained case is wrong, but for now it
8330 -- is too much trouble ???
8332 if (Is_Possibly_Unaligned_Slice
(Expr
)
8333 or else (Is_Possibly_Unaligned_Object
(Expr
)
8334 and then not Represented_As_Scalar
(Etype
(Expr
))))
8335 and then not (Is_Array_Type
(Etype
(Expr
))
8336 and then not Is_Constrained
(Etype
(Expr
)))
8339 Stat
: constant Node_Id
:=
8340 Make_Assignment_Statement
(Loc
,
8341 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8342 Expression
=> Relocate_Node
(Expr
));
8344 Set_Assignment_OK
(Name
(Stat
));
8345 Set_No_Ctrl_Actions
(Stat
);
8346 Insert_Action_After
(Init_After
, Stat
);
8347 Set_Expression
(N
, Empty
);
8348 Set_No_Initialization
(N
);
8353 if Nkind
(Obj_Def
) = N_Access_Definition
8354 and then not Is_Local_Anonymous_Access
(Typ
)
8356 -- An Ada 2012 stand-alone object of an anonymous access type
8359 Loc
: constant Source_Ptr
:= Sloc
(N
);
8361 Level
: constant Entity_Id
:=
8362 Make_Defining_Identifier
(Sloc
(N
),
8364 New_External_Name
(Chars
(Def_Id
), Suffix
=> "L"));
8366 Level_Decl
: Node_Id
;
8367 Level_Expr
: Node_Id
;
8370 Mutate_Ekind
(Level
, Ekind
(Def_Id
));
8371 Set_Etype
(Level
, Standard_Natural
);
8372 Set_Scope
(Level
, Scope
(Def_Id
));
8374 -- Set accessibility level of null
8378 Make_Integer_Literal
8379 (Loc
, Scope_Depth
(Standard_Standard
));
8381 -- When the expression of the object is a function which returns
8382 -- an anonymous access type the master of the call is the object
8383 -- being initialized instead of the type.
8385 elsif Nkind
(Expr
) = N_Function_Call
8386 and then Ekind
(Etype
(Name
(Expr
))) = E_Anonymous_Access_Type
8388 Level_Expr
:= Accessibility_Level
8389 (Def_Id
, Object_Decl_Level
);
8394 Level_Expr
:= Accessibility_Level
(Expr
, Dynamic_Level
);
8398 Make_Object_Declaration
(Loc
,
8399 Defining_Identifier
=> Level
,
8400 Object_Definition
=>
8401 New_Occurrence_Of
(Standard_Natural
, Loc
),
8402 Expression
=> Level_Expr
,
8403 Constant_Present
=> Constant_Present
(N
),
8404 Has_Init_Expression
=> True);
8406 Insert_Action_After
(Init_After
, Level_Decl
);
8408 Set_Extra_Accessibility
(Def_Id
, Level
);
8412 -- If the object is default initialized and its type is subject to
8413 -- pragma Default_Initial_Condition, add a runtime check to verify
8414 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
8416 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
8418 -- Note that the check is generated for source objects only
8420 if Comes_From_Source
(Def_Id
)
8421 and then Has_DIC
(Typ
)
8422 and then Present
(DIC_Procedure
(Typ
))
8423 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
8424 and then not Has_Init_Expression
(N
)
8426 and then not Is_Imported
(Def_Id
)
8429 DIC_Call
: constant Node_Id
:=
8431 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Typ
);
8433 if Present
(Next_N
) then
8434 Insert_Before_And_Analyze
(Next_N
, DIC_Call
);
8436 -- The object declaration is the last node in a declarative or a
8440 Append_To
(List_Containing
(N
), DIC_Call
);
8446 -- If this is the return object of a build-in-place function, locate the
8447 -- implicit BIPaccess parameter designating the caller-supplied return
8448 -- object and convert the declaration to a renaming of a dereference of
8449 -- this parameter. If the declaration includes an expression, add an
8450 -- assignment statement to ensure the return object gets initialized.
8452 -- Result : T [:= <expression>];
8456 -- Result : T renames BIPaccess.all;
8457 -- [Result := <expression>;]
8459 -- in the constrained case, or to
8461 -- type Txx is access all ...;
8462 -- Rxx : Txx := null;
8464 -- if BIPalloc = 1 then
8465 -- Rxx := BIPaccess;
8466 -- Rxx.all := <expression>;
8467 -- elsif BIPalloc = 2 then
8468 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8469 -- system__secondary_stack__ss_pool][procedure_to_call =
8470 -- system__secondary_stack__ss_allocate];
8471 -- elsif BIPalloc = 3 then
8472 -- Rxx := new <expression-type>'(<expression>)
8473 -- elsif BIPalloc = 4 then
8474 -- Pxx : system__storage_pools__root_storage_pool renames
8475 -- BIPstoragepool.all;
8476 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8477 -- Pxx][procedure_to_call =
8478 -- system__storage_pools__allocate_any];
8480 -- [program_error "build in place mismatch"]
8483 -- Result : T renames Rxx.all;
8485 -- in the unconstrained case.
8487 if Is_Build_In_Place_Return_Object
(Def_Id
) then
8489 Init_Stmt
: Node_Id
;
8490 Obj_Acc_Formal
: Entity_Id
;
8493 -- Retrieve the implicit access parameter passed by the caller
8496 Build_In_Place_Formal
(Func_Id
, BIP_Object_Access
);
8498 -- If the return object's declaration includes an expression
8499 -- and the declaration isn't marked as No_Initialization, then
8500 -- we need to generate an assignment to the object and insert
8501 -- it after the declaration before rewriting it as a renaming
8502 -- (otherwise we'll lose the initialization). The case where
8503 -- the result type is an interface (or class-wide interface)
8504 -- is also excluded because the context of the function call
8505 -- must be unconstrained, so the initialization will always
8506 -- be done as part of an allocator evaluation (storage pool
8507 -- or secondary stack), never to a constrained target object
8508 -- passed in by the caller. Besides the assignment being
8509 -- unneeded in this case, it avoids problems with trying to
8510 -- generate a dispatching assignment when the return expression
8511 -- is a nonlimited descendant of a limited interface (the
8512 -- interface has no assignment operation).
8515 and then not Is_Delayed_Aggregate
(Expr_Q
)
8516 and then not No_Initialization
(N
)
8517 and then not Is_Interface
(Typ
)
8519 if Is_Class_Wide_Type
(Typ
)
8520 and then not Is_Class_Wide_Type
(Etype
(Expr_Q
))
8523 Make_Assignment_Statement
(Loc
,
8524 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8526 Make_Type_Conversion
(Loc
,
8528 New_Occurrence_Of
(Typ
, Loc
),
8529 Expression
=> New_Copy_Tree
(Expr_Q
)));
8533 Make_Assignment_Statement
(Loc
,
8534 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8535 Expression
=> New_Copy_Tree
(Expr_Q
));
8538 Set_Assignment_OK
(Name
(Init_Stmt
));
8539 Set_No_Ctrl_Actions
(Init_Stmt
);
8545 -- When the function's subtype is unconstrained, a run-time
8546 -- test may be needed to decide the form of allocation to use
8547 -- for the return object. The function has an implicit formal
8548 -- parameter indicating this. If the BIP_Alloc_Form formal has
8549 -- the value one, then the caller has passed access to an
8550 -- existing object for use as the return object. If the value
8551 -- is two, then the return object must be allocated on the
8552 -- secondary stack. If the value is three, then the return
8553 -- object must be allocated on the heap. Otherwise, the object
8554 -- must be allocated in a storage pool. We generate an if
8555 -- statement to test the BIP_Alloc_Form formal and initialize
8556 -- a local access value appropriately.
8558 if Needs_BIP_Alloc_Form
(Func_Id
) then
8560 Desig_Typ
: constant Entity_Id
:=
8561 (if Ekind
(Typ
) = E_Array_Subtype
8562 then Etype
(Func_Id
) else Typ
);
8563 -- Ensure that the we use a fat pointer when allocating
8564 -- an unconstrained array on the heap. In this case the
8565 -- result object's type is a constrained array type even
8566 -- though the function's type is unconstrained.
8568 Obj_Alloc_Formal
: constant Entity_Id
:=
8569 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
8570 Pool_Id
: constant Entity_Id
:=
8571 Make_Temporary
(Loc
, 'P');
8573 Acc_Typ
: Entity_Id
;
8574 Alloc_Obj_Decl
: Node_Id
;
8575 Alloc_Obj_Id
: Entity_Id
;
8576 Alloc_Stmt
: Node_Id
;
8577 Guard_Except
: Node_Id
;
8578 Heap_Allocator
: Node_Id
;
8579 Pool_Allocator
: Node_Id
;
8580 Pool_Decl
: Node_Id
;
8581 Ptr_Typ_Decl
: Node_Id
;
8582 SS_Allocator
: Node_Id
;
8585 -- Create an access type designating the function's
8588 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8591 Make_Full_Type_Declaration
(Loc
,
8592 Defining_Identifier
=> Acc_Typ
,
8594 Make_Access_To_Object_Definition
(Loc
,
8595 All_Present
=> True,
8596 Subtype_Indication
=>
8597 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8599 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8601 -- Create an access object that will be initialized to an
8602 -- access value denoting the return object, either coming
8603 -- from an implicit access value passed in by the caller
8604 -- or from the result of an allocator.
8606 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8609 Make_Object_Declaration
(Loc
,
8610 Defining_Identifier
=> Alloc_Obj_Id
,
8611 Object_Definition
=>
8612 New_Occurrence_Of
(Acc_Typ
, Loc
));
8614 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8616 -- First create the Heap_Allocator
8618 Heap_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8620 -- The Pool_Allocator is just like the Heap_Allocator,
8621 -- except we set Storage_Pool and Procedure_To_Call so
8622 -- it will use the user-defined storage pool.
8624 Pool_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8626 -- Do not generate the renaming of the build-in-place
8627 -- pool parameter on ZFP because the parameter is not
8628 -- created in the first place.
8630 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
8632 Make_Object_Renaming_Declaration
(Loc
,
8633 Defining_Identifier
=> Pool_Id
,
8636 (RTE
(RE_Root_Storage_Pool
), Loc
),
8638 Make_Explicit_Dereference
(Loc
,
8640 (Build_In_Place_Formal
8641 (Func_Id
, BIP_Storage_Pool
), Loc
)));
8642 Set_Storage_Pool
(Pool_Allocator
, Pool_Id
);
8643 Set_Procedure_To_Call
8644 (Pool_Allocator
, RTE
(RE_Allocate_Any
));
8646 Pool_Decl
:= Make_Null_Statement
(Loc
);
8649 -- If the No_Allocators restriction is active, then only
8650 -- an allocator for secondary stack allocation is needed.
8651 -- It's OK for such allocators to have Comes_From_Source
8652 -- set to False, because gigi knows not to flag them as
8653 -- being a violation of No_Implicit_Heap_Allocations.
8655 if Restriction_Active
(No_Allocators
) then
8656 SS_Allocator
:= Heap_Allocator
;
8657 Heap_Allocator
:= Make_Null
(Loc
);
8658 Pool_Allocator
:= Make_Null
(Loc
);
8660 -- Otherwise the heap and pool allocators may be needed,
8661 -- so we make another allocator for secondary stack
8665 SS_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8667 -- The heap and pool allocators are marked as
8668 -- Comes_From_Source since they correspond to an
8669 -- explicit user-written allocator (that is, it will
8670 -- only be executed on behalf of callers that call the
8671 -- function as initialization for such an allocator).
8672 -- Prevents errors when No_Implicit_Heap_Allocations
8675 Set_Comes_From_Source
(Heap_Allocator
, True);
8676 Set_Comes_From_Source
(Pool_Allocator
, True);
8679 -- The allocator is returned on the secondary stack
8681 Check_Restriction
(No_Secondary_Stack
, N
);
8682 Set_Storage_Pool
(SS_Allocator
, RTE
(RE_SS_Pool
));
8683 Set_Procedure_To_Call
8684 (SS_Allocator
, RTE
(RE_SS_Allocate
));
8686 -- The allocator is returned on the secondary stack,
8687 -- so indicate that the function return, as well as
8688 -- all blocks that encloses the allocator, must not
8689 -- release it. The flags must be set now because
8690 -- the decision to use the secondary stack is done
8691 -- very late in the course of expanding the return
8692 -- statement, past the point where these flags are
8695 Set_Uses_Sec_Stack
(Func_Id
);
8696 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8697 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8699 -- Guard against poor expansion on the caller side by
8700 -- using a raise statement to catch out-of-range values
8701 -- of formal parameter BIP_Alloc_Form.
8703 if Exceptions_OK
then
8705 Make_Raise_Program_Error
(Loc
,
8706 Reason
=> PE_Build_In_Place_Mismatch
);
8708 Guard_Except
:= Make_Null_Statement
(Loc
);
8711 -- Create an if statement to test the BIP_Alloc_Form
8712 -- formal and initialize the access object to either the
8713 -- BIP_Object_Access formal (BIP_Alloc_Form =
8714 -- Caller_Allocation), the result of allocating the
8715 -- object in the secondary stack (BIP_Alloc_Form =
8716 -- Secondary_Stack), or else an allocator to create the
8717 -- return object in the heap or user-defined pool
8718 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
8720 -- ??? An unchecked type conversion must be made in the
8721 -- case of assigning the access object formal to the
8722 -- local access object, because a normal conversion would
8723 -- be illegal in some cases (such as converting access-
8724 -- to-unconstrained to access-to-constrained), but the
8725 -- the unchecked conversion will presumably fail to work
8726 -- right in just such cases. It's not clear at all how to
8730 Make_If_Statement
(Loc
,
8734 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8736 Make_Integer_Literal
(Loc
,
8737 UI_From_Int
(BIP_Allocation_Form
'Pos
8738 (Caller_Allocation
)))),
8740 Then_Statements
=> New_List
(
8741 Make_Assignment_Statement
(Loc
,
8743 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8745 Unchecked_Convert_To
8747 New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)))),
8749 Elsif_Parts
=> New_List
(
8750 Make_Elsif_Part
(Loc
,
8754 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8756 Make_Integer_Literal
(Loc
,
8757 UI_From_Int
(BIP_Allocation_Form
'Pos
8758 (Secondary_Stack
)))),
8760 Then_Statements
=> New_List
(
8761 Make_Assignment_Statement
(Loc
,
8763 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8764 Expression
=> SS_Allocator
))),
8766 Make_Elsif_Part
(Loc
,
8770 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8772 Make_Integer_Literal
(Loc
,
8773 UI_From_Int
(BIP_Allocation_Form
'Pos
8776 Then_Statements
=> New_List
(
8777 Build_Heap_Or_Pool_Allocator
8778 (Temp_Id
=> Alloc_Obj_Id
,
8779 Temp_Typ
=> Acc_Typ
,
8780 Ret_Typ
=> Desig_Typ
,
8781 Alloc_Expr
=> Heap_Allocator
))),
8783 -- ??? If all is well, we can put the following
8784 -- 'elsif' in the 'else', but this is a useful
8785 -- self-check in case caller and callee don't agree
8786 -- on whether BIPAlloc and so on should be passed.
8788 Make_Elsif_Part
(Loc
,
8792 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8794 Make_Integer_Literal
(Loc
,
8795 UI_From_Int
(BIP_Allocation_Form
'Pos
8796 (User_Storage_Pool
)))),
8798 Then_Statements
=> New_List
(
8800 Build_Heap_Or_Pool_Allocator
8801 (Temp_Id
=> Alloc_Obj_Id
,
8802 Temp_Typ
=> Acc_Typ
,
8803 Ret_Typ
=> Desig_Typ
,
8804 Alloc_Expr
=> Pool_Allocator
)))),
8806 -- Raise Program_Error if it's none of the above;
8807 -- this is a compiler bug.
8809 Else_Statements
=> New_List
(Guard_Except
));
8811 -- If a separate initialization assignment was created
8812 -- earlier, append that following the assignment of the
8813 -- implicit access formal to the access object, to ensure
8814 -- that the return object is initialized in that case. In
8815 -- this situation, the target of the assignment must be
8816 -- rewritten to denote a dereference of the access to the
8817 -- return object passed in by the caller.
8819 if Present
(Init_Stmt
) then
8820 Set_Name
(Init_Stmt
,
8821 Make_Explicit_Dereference
(Loc
,
8822 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
)));
8823 Set_Assignment_OK
(Name
(Init_Stmt
));
8825 Append_To
(Then_Statements
(Alloc_Stmt
), Init_Stmt
);
8829 Insert_Action
(N
, Alloc_Stmt
, Suppress
=> All_Checks
);
8831 -- From now on, the type of the return object is the
8834 if Desig_Typ
/= Typ
then
8835 Set_Etype
(Def_Id
, Desig_Typ
);
8836 Set_Actual_Subtype
(Def_Id
, Typ
);
8839 -- Remember the local access object for use in the
8840 -- dereference of the renaming created below.
8842 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8845 -- When the function's type is unconstrained and a run-time test
8846 -- is not needed, we nevertheless need to build the return using
8847 -- the return object's type.
8849 elsif not Is_Constrained
(Underlying_Type
(Etype
(Func_Id
))) then
8851 Acc_Typ
: Entity_Id
;
8852 Alloc_Obj_Decl
: Node_Id
;
8853 Alloc_Obj_Id
: Entity_Id
;
8854 Ptr_Typ_Decl
: Node_Id
;
8857 -- Create an access type designating the function's
8860 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8863 Make_Full_Type_Declaration
(Loc
,
8864 Defining_Identifier
=> Acc_Typ
,
8866 Make_Access_To_Object_Definition
(Loc
,
8867 All_Present
=> True,
8868 Subtype_Indication
=>
8869 New_Occurrence_Of
(Typ
, Loc
)));
8871 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8873 -- Create an access object initialized to the conversion
8874 -- of the implicit access value passed in by the caller.
8876 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8878 -- See the ??? comment a few lines above about the use of
8879 -- an unchecked conversion here.
8882 Make_Object_Declaration
(Loc
,
8883 Defining_Identifier
=> Alloc_Obj_Id
,
8884 Constant_Present
=> True,
8885 Object_Definition
=>
8886 New_Occurrence_Of
(Acc_Typ
, Loc
),
8888 Unchecked_Convert_To
8889 (Acc_Typ
, New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)));
8891 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8893 -- Remember the local access object for use in the
8894 -- dereference of the renaming created below.
8896 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8900 -- Initialize the object now that it has got its final subtype,
8901 -- but before rewriting it as a renaming.
8903 Initialize_Return_Object
8904 (Tag_Assign
, Adj_Call
, Expr_Q
, Init_Stmt
, Init_After
);
8906 -- Save the assignment statement when returning a controlled
8907 -- object. This reference is used later by the finalization
8908 -- machinery to mark the object as successfully initialized.
8910 if Present
(Init_Stmt
) and then Needs_Finalization
(Typ
) then
8911 Set_Last_Aggregate_Assignment
(Def_Id
, Init_Stmt
);
8914 -- Replace the return object declaration with a renaming of a
8915 -- dereference of the access value designating the return object.
8918 Make_Explicit_Dereference
(Loc
,
8919 Prefix
=> New_Occurrence_Of
(Obj_Acc_Formal
, Loc
));
8920 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8922 Rewrite_As_Renaming
:= True;
8925 -- If we can rename the initialization expression, we need to make sure
8926 -- that we use the proper type in the case of a return object that lives
8927 -- on the secondary stack (see other cases below for a similar handling)
8928 -- and that the tag is assigned in the case of any return object.
8930 elsif Rewrite_As_Renaming
then
8931 if Special_Ret_Obj
then
8933 Desig_Typ
: constant Entity_Id
:=
8934 (if Ekind
(Typ
) = E_Array_Subtype
8935 then Etype
(Func_Id
) else Typ
);
8938 -- From now on, the type of the return object is the
8941 if Desig_Typ
/= Typ
then
8942 Set_Etype
(Def_Id
, Desig_Typ
);
8943 Set_Actual_Subtype
(Def_Id
, Typ
);
8946 if Present
(Tag_Assign
) then
8947 Insert_Action_After
(Init_After
, Tag_Assign
);
8950 -- Ada 2005 (AI95-344): If the result type is class-wide,
8951 -- insert a check that the level of the return expression's
8952 -- underlying type is not deeper than the level of the master
8953 -- enclosing the function.
8955 -- AI12-043: The check is made immediately after the return
8956 -- object is created.
8958 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
8959 Apply_CW_Accessibility_Check
(Expr_Q
, Func_Id
);
8964 -- If this is the return object of a function returning on the secondary
8965 -- stack, convert the declaration to a renaming of the dereference of ah
8966 -- allocator for the secondary stack.
8968 -- Result : T [:= <expression>];
8972 -- type Txx is access all ...;
8973 -- Rxx : constant Txx :=
8974 -- new <expression-type>['(<expression>)][storage_pool =
8975 -- system__secondary_stack__ss_pool][procedure_to_call =
8976 -- system__secondary_stack__ss_allocate];
8978 -- Result : T renames Rxx.all;
8980 elsif Is_Secondary_Stack_Return_Object
(Def_Id
) then
8982 Desig_Typ
: constant Entity_Id
:=
8983 (if Ekind
(Typ
) = E_Array_Subtype
8984 then Etype
(Func_Id
) else Typ
);
8985 -- Ensure that the we use a fat pointer when allocating
8986 -- an unconstrained array on the heap. In this case the
8987 -- result object's type is a constrained array type even
8988 -- though the function's type is unconstrained.
8990 Acc_Typ
: Entity_Id
;
8991 Alloc_Obj_Decl
: Node_Id
;
8992 Alloc_Obj_Id
: Entity_Id
;
8993 Ptr_Type_Decl
: Node_Id
;
8996 -- Create an access type designating the function's
8999 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
9002 Make_Full_Type_Declaration
(Loc
,
9003 Defining_Identifier
=> Acc_Typ
,
9005 Make_Access_To_Object_Definition
(Loc
,
9006 All_Present
=> True,
9007 Subtype_Indication
=>
9008 New_Occurrence_Of
(Desig_Typ
, Loc
)));
9010 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
9012 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
9014 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
9017 Make_Object_Declaration
(Loc
,
9018 Defining_Identifier
=> Alloc_Obj_Id
,
9019 Constant_Present
=> True,
9020 Object_Definition
=>
9021 New_Occurrence_Of
(Acc_Typ
, Loc
),
9022 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
9024 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
9026 Set_Uses_Sec_Stack
(Func_Id
);
9027 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
9028 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
9030 -- From now on, the type of the return object is the
9033 if Desig_Typ
/= Typ
then
9034 Set_Etype
(Def_Id
, Desig_Typ
);
9035 Set_Actual_Subtype
(Def_Id
, Typ
);
9038 -- Initialize the object now that it has got its final subtype,
9039 -- but before rewriting it as a renaming.
9041 Initialize_Return_Object
9042 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
9044 -- Replace the return object declaration with a renaming of a
9045 -- dereference of the access value designating the return object.
9048 Make_Explicit_Dereference
(Loc
,
9049 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
9050 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
9052 Rewrite_As_Renaming
:= True;
9055 -- If this is the return object of a function returning a by-reference
9056 -- type, convert the declaration to a renaming of the dereference of ah
9057 -- allocator for the return stack.
9059 -- Result : T [:= <expression>];
9063 -- type Txx is access all ...;
9064 -- Rxx : constant Txx :=
9065 -- new <expression-type>['(<expression>)][storage_pool =
9066 -- system__return_stack__rs_pool][procedure_to_call =
9067 -- system__return_stack__rs_allocate];
9069 -- Result : T renames Rxx.all;
9071 elsif Back_End_Return_Slot
9072 and then Is_By_Reference_Return_Object
(Def_Id
)
9075 Acc_Typ
: Entity_Id
;
9076 Alloc_Obj_Decl
: Node_Id
;
9077 Alloc_Obj_Id
: Entity_Id
;
9078 Ptr_Type_Decl
: Node_Id
;
9081 -- Create an access type designating the function's
9084 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
9087 Make_Full_Type_Declaration
(Loc
,
9088 Defining_Identifier
=> Acc_Typ
,
9090 Make_Access_To_Object_Definition
(Loc
,
9091 All_Present
=> True,
9092 Subtype_Indication
=>
9093 New_Occurrence_Of
(Typ
, Loc
)));
9095 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
9097 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_RS_Pool
));
9099 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
9102 Make_Object_Declaration
(Loc
,
9103 Defining_Identifier
=> Alloc_Obj_Id
,
9104 Constant_Present
=> True,
9105 Object_Definition
=>
9106 New_Occurrence_Of
(Acc_Typ
, Loc
),
9107 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
9109 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
9111 -- Initialize the object now that it has got its final subtype,
9112 -- but before rewriting it as a renaming.
9114 Initialize_Return_Object
9115 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
9117 -- Replace the return object declaration with a renaming of a
9118 -- dereference of the access value designating the return object.
9121 Make_Explicit_Dereference
(Loc
,
9122 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
9123 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
9125 Rewrite_As_Renaming
:= True;
9129 -- Final transformation - turn the object declaration into a renaming
9130 -- if appropriate. If this is the completion of a deferred constant
9131 -- declaration, then this transformation generates what would be
9132 -- illegal code if written by hand, but that's OK.
9134 if Rewrite_As_Renaming
then
9136 Make_Object_Renaming_Declaration
(Loc
,
9137 Defining_Identifier
=> Def_Id
,
9138 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Def_Id
), Loc
),
9141 -- Keep original aspects
9143 Move_Aspects
(Original_Node
(N
), N
);
9145 -- We do not analyze this renaming declaration, because all its
9146 -- components have already been analyzed, and if we were to go
9147 -- ahead and analyze it, we would in effect be trying to generate
9148 -- another declaration of X, which won't do.
9150 Set_Renamed_Object
(Def_Id
, Expr_Q
);
9153 -- We do need to deal with debug issues for this renaming
9155 -- First, if entity comes from source, then mark it as needing
9156 -- debug information, even though it is defined by a generated
9157 -- renaming that does not come from source.
9159 Set_Debug_Info_Defining_Id
(N
);
9161 -- Now call the routine to generate debug info for the renaming
9163 Insert_Action
(N
, Debug_Renaming_Declaration
(N
));
9166 -- Exception on library entity not available
9169 when RE_Not_Available
=>
9171 end Expand_N_Object_Declaration
;
9173 ---------------------------------
9174 -- Expand_N_Subtype_Indication --
9175 ---------------------------------
9177 -- Add a check on the range of the subtype and deal with validity checking
9179 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
9180 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
9181 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9184 if Nkind
(Constraint
(N
)) = N_Range_Constraint
then
9185 Validity_Check_Range
(Range_Expression
(Constraint
(N
)));
9188 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
9190 if Nkind
(Parent
(N
)) in N_Constrained_Array_Definition | N_Slice
9191 and then Nkind
(Parent
(Parent
(N
))) not in
9192 N_Full_Type_Declaration | N_Object_Declaration
9194 Apply_Range_Check
(Ran
, Typ
);
9196 end Expand_N_Subtype_Indication
;
9198 ---------------------------
9199 -- Expand_N_Variant_Part --
9200 ---------------------------
9202 -- Note: this procedure no longer has any effect. It used to be that we
9203 -- would replace the choices in the last variant by a when others, and
9204 -- also expanded static predicates in variant choices here, but both of
9205 -- those activities were being done too early, since we can't check the
9206 -- choices until the statically predicated subtypes are frozen, which can
9207 -- happen as late as the free point of the record, and we can't change the
9208 -- last choice to an others before checking the choices, which is now done
9209 -- at the freeze point of the record.
9211 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
9214 end Expand_N_Variant_Part
;
9216 ---------------------------------
9217 -- Expand_Previous_Access_Type --
9218 ---------------------------------
9220 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
9221 Ptr_Typ
: Entity_Id
;
9224 -- Find all access types in the current scope whose designated type is
9225 -- Def_Id and build master renamings for them.
9227 Ptr_Typ
:= First_Entity
(Current_Scope
);
9228 while Present
(Ptr_Typ
) loop
9229 if Is_Access_Type
(Ptr_Typ
)
9230 and then Designated_Type
(Ptr_Typ
) = Def_Id
9231 and then No
(Master_Id
(Ptr_Typ
))
9233 -- Ensure that the designated type has a master
9235 Build_Master_Entity
(Def_Id
);
9237 -- Private and incomplete types complicate the insertion of master
9238 -- renamings because the access type may precede the full view of
9239 -- the designated type. For this reason, the master renamings are
9240 -- inserted relative to the designated type.
9242 Build_Master_Renaming
(Ptr_Typ
, Ins_Nod
=> Parent
(Def_Id
));
9245 Next_Entity
(Ptr_Typ
);
9247 end Expand_Previous_Access_Type
;
9249 -----------------------------
9250 -- Expand_Record_Extension --
9251 -----------------------------
9253 -- Add a field _parent at the beginning of the record extension. This is
9254 -- used to implement inheritance. Here are some examples of expansion:
9256 -- 1. no discriminants
9257 -- type T2 is new T1 with null record;
9259 -- type T2 is new T1 with record
9263 -- 2. renamed discriminants
9264 -- type T2 (B, C : Int) is new T1 (A => B) with record
9265 -- _Parent : T1 (A => B);
9269 -- 3. inherited discriminants
9270 -- type T2 is new T1 with record -- discriminant A inherited
9271 -- _Parent : T1 (A);
9275 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
9276 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
9277 Loc
: constant Source_Ptr
:= Sloc
(Def
);
9278 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
9279 Par_Subtype
: Entity_Id
;
9280 Comp_List
: Node_Id
;
9281 Comp_Decl
: Node_Id
;
9284 List_Constr
: constant List_Id
:= New_List
;
9287 -- Expand_Record_Extension is called directly from the semantics, so
9288 -- we must check to see whether expansion is active before proceeding,
9289 -- because this affects the visibility of selected components in bodies
9290 -- of instances. Within a generic we still need to set Parent_Subtype
9291 -- link because the visibility of inherited components will have to be
9292 -- verified in subsequent instances.
9294 if not Expander_Active
then
9295 if Inside_A_Generic
and then Ekind
(T
) = E_Record_Type
then
9296 Set_Parent_Subtype
(T
, Etype
(T
));
9301 -- This may be a derivation of an untagged private type whose full
9302 -- view is tagged, in which case the Derived_Type_Definition has no
9303 -- extension part. Build an empty one now.
9305 if No
(Rec_Ext_Part
) then
9307 Make_Record_Definition
(Loc
,
9309 Component_List
=> Empty
,
9310 Null_Present
=> True);
9312 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
9313 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
9316 Comp_List
:= Component_List
(Rec_Ext_Part
);
9318 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
9320 -- If the derived type inherits its discriminants the type of the
9321 -- _parent field must be constrained by the inherited discriminants
9323 if Has_Discriminants
(T
)
9324 and then Nkind
(Indic
) /= N_Subtype_Indication
9325 and then not Is_Constrained
(Entity
(Indic
))
9327 D
:= First_Discriminant
(T
);
9328 while Present
(D
) loop
9329 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
9330 Next_Discriminant
(D
);
9335 Make_Subtype_Indication
(Loc
,
9336 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Indic
), Loc
),
9338 Make_Index_Or_Discriminant_Constraint
(Loc
,
9339 Constraints
=> List_Constr
)),
9342 -- Otherwise the original subtype_indication is just what is needed
9345 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
9348 Set_Parent_Subtype
(T
, Par_Subtype
);
9351 Make_Component_Declaration
(Loc
,
9352 Defining_Identifier
=> Parent_N
,
9353 Component_Definition
=>
9354 Make_Component_Definition
(Loc
,
9355 Aliased_Present
=> False,
9356 Subtype_Indication
=> New_Occurrence_Of
(Par_Subtype
, Loc
)));
9358 if Null_Present
(Rec_Ext_Part
) then
9359 Set_Component_List
(Rec_Ext_Part
,
9360 Make_Component_List
(Loc
,
9361 Component_Items
=> New_List
(Comp_Decl
),
9362 Variant_Part
=> Empty
,
9363 Null_Present
=> False));
9364 Set_Null_Present
(Rec_Ext_Part
, False);
9366 elsif Null_Present
(Comp_List
)
9367 or else Is_Empty_List
(Component_Items
(Comp_List
))
9369 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9370 Set_Null_Present
(Comp_List
, False);
9373 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9376 Analyze
(Comp_Decl
);
9377 end Expand_Record_Extension
;
9379 ------------------------
9380 -- Expand_Tagged_Root --
9381 ------------------------
9383 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
9384 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
9385 Comp_List
: Node_Id
;
9386 Comp_Decl
: Node_Id
;
9387 Sloc_N
: Source_Ptr
;
9390 if Null_Present
(Def
) then
9391 Set_Component_List
(Def
,
9392 Make_Component_List
(Sloc
(Def
),
9393 Component_Items
=> Empty_List
,
9394 Variant_Part
=> Empty
,
9395 Null_Present
=> True));
9398 Comp_List
:= Component_List
(Def
);
9400 if Null_Present
(Comp_List
)
9401 or else Is_Empty_List
(Component_Items
(Comp_List
))
9403 Sloc_N
:= Sloc
(Comp_List
);
9405 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
9409 Make_Component_Declaration
(Sloc_N
,
9410 Defining_Identifier
=> First_Tag_Component
(T
),
9411 Component_Definition
=>
9412 Make_Component_Definition
(Sloc_N
,
9413 Aliased_Present
=> False,
9414 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RE_Tag
), Sloc_N
)));
9416 if Null_Present
(Comp_List
)
9417 or else Is_Empty_List
(Component_Items
(Comp_List
))
9419 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9420 Set_Null_Present
(Comp_List
, False);
9423 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9426 -- We don't Analyze the whole expansion because the tag component has
9427 -- already been analyzed previously. Here we just insure that the tree
9428 -- is coherent with the semantic decoration
9430 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
9433 when RE_Not_Available
=>
9435 end Expand_Tagged_Root
;
9437 ------------------------------
9438 -- Freeze_Stream_Operations --
9439 ------------------------------
9441 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
9442 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
9447 Stream_Op
: Entity_Id
;
9450 -- Primitive operations of tagged types are frozen when the dispatch
9451 -- table is constructed.
9453 if not Comes_From_Source
(Typ
) or else Is_Tagged_Type
(Typ
) then
9457 for J
in Names
'Range loop
9458 Stream_Op
:= TSS
(Typ
, Names
(J
));
9460 if Present
(Stream_Op
)
9461 and then Is_Subprogram
(Stream_Op
)
9462 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
9463 N_Subprogram_Declaration
9464 and then not Is_Frozen
(Stream_Op
)
9466 Append_Freeze_Actions
(Typ
, Freeze_Entity
(Stream_Op
, N
));
9469 end Freeze_Stream_Operations
;
9475 -- Full type declarations are expanded at the point at which the type is
9476 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
9477 -- declarations generated by the freezing (e.g. the procedure generated
9478 -- for initialization) are chained in the Actions field list of the freeze
9479 -- node using Append_Freeze_Actions.
9481 -- WARNING: This routine manages Ghost regions. Return statements must be
9482 -- replaced by gotos which jump to the end of the routine and restore the
9485 function Freeze_Type
(N
: Node_Id
) return Boolean is
9486 procedure Process_RACW_Types
(Typ
: Entity_Id
);
9487 -- Validate and generate stubs for all RACW types associated with type
9490 ------------------------
9491 -- Process_RACW_Types --
9492 ------------------------
9494 procedure Process_RACW_Types
(Typ
: Entity_Id
) is
9495 List
: constant Elist_Id
:= Access_Types_To_Process
(N
);
9497 Seen
: Boolean := False;
9500 if Present
(List
) then
9501 E
:= First_Elmt
(List
);
9502 while Present
(E
) loop
9503 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
9504 Validate_RACW_Primitives
(Node
(E
));
9512 -- If there are RACWs designating this type, make stubs now
9515 Remote_Types_Tagged_Full_View_Encountered
(Typ
);
9517 end Process_RACW_Types
;
9521 Def_Id
: constant Entity_Id
:= Entity
(N
);
9523 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
9524 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
9525 -- Save the Ghost-related attributes to restore on exit
9527 Result
: Boolean := False;
9529 -- Start of processing for Freeze_Type
9532 -- The type being frozen may be subject to pragma Ghost. Set the mode
9533 -- now to ensure that any nodes generated during freezing are properly
9536 Set_Ghost_Mode
(Def_Id
);
9538 -- Process any remote access-to-class-wide types designating the type
9541 Process_RACW_Types
(Def_Id
);
9543 -- Freeze processing for record types
9545 if Is_Record_Type
(Def_Id
) then
9546 if Ekind
(Def_Id
) = E_Record_Type
then
9547 Expand_Freeze_Record_Type
(N
);
9548 elsif Is_Class_Wide_Type
(Def_Id
) then
9549 Expand_Freeze_Class_Wide_Type
(N
);
9552 -- Freeze processing for array types
9554 elsif Is_Array_Type
(Def_Id
) then
9555 Expand_Freeze_Array_Type
(N
);
9557 -- Freeze processing for access types
9559 -- For pool-specific access types, find out the pool object used for
9560 -- this type, needs actual expansion of it in some cases. Here are the
9561 -- different cases :
9563 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
9564 -- ---> don't use any storage pool
9566 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
9568 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
9570 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9571 -- ---> Storage Pool is the specified one
9573 -- See GNAT Pool packages in the Run-Time for more details
9575 elsif Ekind
(Def_Id
) in E_Access_Type | E_General_Access_Type
then
9577 Loc
: constant Source_Ptr
:= Sloc
(N
);
9578 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
9580 Freeze_Action_Typ
: Entity_Id
;
9581 Pool_Object
: Entity_Id
;
9586 -- Rep Clause "for Def_Id'Storage_Size use 0;"
9587 -- ---> don't use any storage pool
9589 if No_Pool_Assigned
(Def_Id
) then
9594 -- Rep Clause : for Def_Id'Storage_Size use Expr.
9596 -- Def_Id__Pool : Stack_Bounded_Pool
9597 -- (Expr, DT'Size, DT'Alignment);
9599 elsif Has_Storage_Size_Clause
(Def_Id
) then
9605 -- For unconstrained composite types we give a size of zero
9606 -- so that the pool knows that it needs a special algorithm
9607 -- for variable size object allocation.
9609 if Is_Composite_Type
(Desig_Type
)
9610 and then not Is_Constrained
(Desig_Type
)
9612 DT_Size
:= Make_Integer_Literal
(Loc
, 0);
9613 DT_Align
:= Make_Integer_Literal
(Loc
, Maximum_Alignment
);
9617 Make_Attribute_Reference
(Loc
,
9618 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9619 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
9622 Make_Attribute_Reference
(Loc
,
9623 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9624 Attribute_Name
=> Name_Alignment
);
9628 Make_Defining_Identifier
(Loc
,
9629 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
9631 -- We put the code associated with the pools in the entity
9632 -- that has the later freeze node, usually the access type
9633 -- but it can also be the designated_type; because the pool
9634 -- code requires both those types to be frozen
9636 if Is_Frozen
(Desig_Type
)
9637 and then (No
(Freeze_Node
(Desig_Type
))
9638 or else Analyzed
(Freeze_Node
(Desig_Type
)))
9640 Freeze_Action_Typ
:= Def_Id
;
9642 -- A Taft amendment type cannot get the freeze actions
9643 -- since the full view is not there.
9645 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
9646 and then No
(Full_View
(Desig_Type
))
9648 Freeze_Action_Typ
:= Def_Id
;
9651 Freeze_Action_Typ
:= Desig_Type
;
9654 Append_Freeze_Action
(Freeze_Action_Typ
,
9655 Make_Object_Declaration
(Loc
,
9656 Defining_Identifier
=> Pool_Object
,
9657 Object_Definition
=>
9658 Make_Subtype_Indication
(Loc
,
9661 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
9664 Make_Index_Or_Discriminant_Constraint
(Loc
,
9665 Constraints
=> New_List
(
9667 -- First discriminant is the Pool Size
9670 Storage_Size_Variable
(Def_Id
), Loc
),
9672 -- Second discriminant is the element size
9676 -- Third discriminant is the alignment
9681 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
9685 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9686 -- ---> Storage Pool is the specified one
9688 -- When compiling in Ada 2012 mode, ensure that the accessibility
9689 -- level of the subpool access type is not deeper than that of the
9690 -- pool_with_subpools.
9692 elsif Ada_Version
>= Ada_2012
9693 and then Present
(Associated_Storage_Pool
(Def_Id
))
9694 and then RTU_Loaded
(System_Storage_Pools_Subpools
)
9697 Loc
: constant Source_Ptr
:= Sloc
(Def_Id
);
9698 Pool
: constant Entity_Id
:=
9699 Associated_Storage_Pool
(Def_Id
);
9702 -- It is known that the accessibility level of the access
9703 -- type is deeper than that of the pool.
9705 if Type_Access_Level
(Def_Id
)
9706 > Static_Accessibility_Level
(Pool
, Object_Decl_Level
)
9707 and then Is_Class_Wide_Type
(Etype
(Pool
))
9708 and then not Accessibility_Checks_Suppressed
(Def_Id
)
9709 and then not Accessibility_Checks_Suppressed
(Pool
)
9711 -- When the pool is of a class-wide type, it may or may
9712 -- not support subpools depending on the path of
9713 -- derivation. Generate:
9715 -- if Def_Id in RSPWS'Class then
9716 -- raise Program_Error;
9719 Append_Freeze_Action
(Def_Id
,
9720 Make_If_Statement
(Loc
,
9723 Left_Opnd
=> New_Occurrence_Of
(Pool
, Loc
),
9728 (RE_Root_Storage_Pool_With_Subpools
)),
9730 Then_Statements
=> New_List
(
9731 Make_Raise_Program_Error
(Loc
,
9732 Reason
=> PE_Accessibility_Check_Failed
))));
9737 -- For access-to-controlled types (including class-wide types and
9738 -- Taft-amendment types, which potentially have controlled
9739 -- components), expand the list controller object that will store
9740 -- the dynamically allocated objects. Don't do this transformation
9741 -- for expander-generated access types, except do it for types
9742 -- that are the full view of types derived from other private
9743 -- types and for access types used to implement indirect temps.
9744 -- Also suppress the list controller in the case of a designated
9745 -- type with convention Java, since this is used when binding to
9746 -- Java API specs, where there's no equivalent of a finalization
9747 -- list and we don't want to pull in the finalization support if
9750 if not Comes_From_Source
(Def_Id
)
9751 and then not Has_Private_Declaration
(Def_Id
)
9752 and then not Old_Attr_Util
.Indirect_Temps
9753 .Is_Access_Type_For_Indirect_Temp
(Def_Id
)
9757 -- An exception is made for types defined in the run-time because
9758 -- Ada.Tags.Tag itself is such a type and cannot afford this
9759 -- unnecessary overhead that would generates a loop in the
9760 -- expansion scheme. Another exception is if Restrictions
9761 -- (No_Finalization) is active, since then we know nothing is
9764 elsif Restriction_Active
(No_Finalization
)
9765 or else In_Runtime
(Def_Id
)
9769 -- Create a finalization collection for an access-to-controlled
9770 -- type or an access-to-incomplete type. It is assumed that the
9771 -- full view will be controlled.
9773 elsif Needs_Finalization
(Desig_Type
)
9774 or else (Is_Incomplete_Type
(Desig_Type
)
9775 and then No
(Full_View
(Desig_Type
)))
9777 Build_Finalization_Collection
(Def_Id
);
9779 -- Also create a finalization collection when the designated type
9780 -- contains a private component. It is assumed that the full view
9781 -- will be controlled.
9783 elsif Has_Private_Component
(Desig_Type
) then
9784 Build_Finalization_Collection
9786 For_Private
=> True,
9787 Context_Scope
=> Scope
(Def_Id
),
9788 Insertion_Node
=> Declaration_Node
(Desig_Type
));
9792 -- Freeze processing for enumeration types
9794 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
9796 -- We only have something to do if we have a non-standard
9797 -- representation (i.e. at least one literal whose pos value
9798 -- is not the same as its representation)
9800 if Has_Non_Standard_Rep
(Def_Id
) then
9801 Expand_Freeze_Enumeration_Type
(N
);
9804 -- Private types that are completed by a derivation from a private
9805 -- type have an internally generated full view, that needs to be
9806 -- frozen. This must be done explicitly because the two views share
9807 -- the freeze node, and the underlying full view is not visible when
9808 -- the freeze node is analyzed.
9810 elsif Is_Private_Type
(Def_Id
)
9811 and then Is_Derived_Type
(Def_Id
)
9812 and then Present
(Full_View
(Def_Id
))
9813 and then Is_Itype
(Full_View
(Def_Id
))
9814 and then Has_Private_Declaration
(Full_View
(Def_Id
))
9815 and then Freeze_Node
(Full_View
(Def_Id
)) = N
9817 Set_Entity
(N
, Full_View
(Def_Id
));
9818 Result
:= Freeze_Type
(N
);
9819 Set_Entity
(N
, Def_Id
);
9821 -- All other types require no expander action. There are such cases
9822 -- (e.g. task types and protected types). In such cases, the freeze
9823 -- nodes are there for use by Gigi.
9827 Freeze_Stream_Operations
(N
, Def_Id
);
9829 -- Generate the [spec and] body of the invariant procedure tasked with
9830 -- the runtime verification of all invariants that pertain to the type.
9831 -- This includes invariants on the partial and full view, inherited
9832 -- class-wide invariants from parent types or interfaces, and invariants
9833 -- on array elements or record components. But skip internal types.
9835 if Is_Itype
(Def_Id
) then
9838 elsif Is_Interface
(Def_Id
) then
9840 -- Interfaces are treated as the partial view of a private type in
9841 -- order to achieve uniformity with the general case. As a result, an
9842 -- interface receives only a "partial" invariant procedure which is
9845 if Has_Own_Invariants
(Def_Id
) then
9846 Build_Invariant_Procedure_Body
9848 Partial_Invariant
=> Is_Interface
(Def_Id
));
9851 -- Non-interface types
9853 -- Do not generate invariant procedure within other assertion
9854 -- subprograms, which may involve local declarations of local
9855 -- subtypes to which these checks do not apply.
9858 if Has_Invariants
(Def_Id
) then
9859 if not Predicate_Check_In_Scope
(Def_Id
)
9860 or else (Ekind
(Current_Scope
) = E_Function
9861 and then Is_Predicate_Function
(Current_Scope
))
9865 Build_Invariant_Procedure_Body
(Def_Id
);
9869 -- Generate the [spec and] body of the procedure tasked with the
9870 -- run-time verification of pragma Default_Initial_Condition's
9873 if Has_DIC
(Def_Id
) then
9874 Build_DIC_Procedure_Body
(Def_Id
);
9878 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9883 when RE_Not_Available
=>
9884 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9889 -------------------------
9890 -- Get_Simple_Init_Val --
9891 -------------------------
9893 function Get_Simple_Init_Val
9896 Size
: Uint
:= No_Uint
) return Node_Id
9898 IV_Attribute
: constant Boolean :=
9899 Nkind
(N
) = N_Attribute_Reference
9900 and then Attribute_Name
(N
) = Name_Invalid_Value
;
9902 Loc
: constant Source_Ptr
:= Sloc
(N
);
9904 procedure Extract_Subtype_Bounds
9905 (Lo_Bound
: out Uint
;
9906 Hi_Bound
: out Uint
);
9907 -- Inspect subtype Typ as well its ancestor subtypes and derived types
9908 -- to determine the best known information about the bounds of the type.
9909 -- The output parameters are set as follows:
9911 -- * Lo_Bound - Set to No_Unit when there is no information available,
9912 -- or to the known low bound.
9914 -- * Hi_Bound - Set to No_Unit when there is no information available,
9915 -- or to the known high bound.
9917 function Simple_Init_Array_Type
return Node_Id
;
9918 -- Build an expression to initialize array type Typ
9920 function Simple_Init_Defaulted_Type
return Node_Id
;
9921 -- Build an expression to initialize type Typ which is subject to
9922 -- aspect Default_Value.
9924 function Simple_Init_Initialize_Scalars_Type
9925 (Size_To_Use
: Uint
) return Node_Id
;
9926 -- Build an expression to initialize scalar type Typ which is subject to
9927 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
9929 function Simple_Init_Normalize_Scalars_Type
9930 (Size_To_Use
: Uint
) return Node_Id
;
9931 -- Build an expression to initialize scalar type Typ which is subject to
9932 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
9934 function Simple_Init_Private_Type
return Node_Id
;
9935 -- Build an expression to initialize private type Typ
9937 function Simple_Init_Scalar_Type
return Node_Id
;
9938 -- Build an expression to initialize scalar type Typ
9940 ----------------------------
9941 -- Extract_Subtype_Bounds --
9942 ----------------------------
9944 procedure Extract_Subtype_Bounds
9945 (Lo_Bound
: out Uint
;
9946 Hi_Bound
: out Uint
)
9956 Lo_Bound
:= No_Uint
;
9957 Hi_Bound
:= No_Uint
;
9959 -- Loop to climb ancestor subtypes and derived types
9963 if not Is_Discrete_Type
(ST1
) then
9967 Lo
:= Type_Low_Bound
(ST1
);
9968 Hi
:= Type_High_Bound
(ST1
);
9970 if Compile_Time_Known_Value
(Lo
) then
9971 Lo_Val
:= Expr_Value
(Lo
);
9973 if No
(Lo_Bound
) or else Lo_Bound
< Lo_Val
then
9978 if Compile_Time_Known_Value
(Hi
) then
9979 Hi_Val
:= Expr_Value
(Hi
);
9981 if No
(Hi_Bound
) or else Hi_Bound
> Hi_Val
then
9986 ST2
:= Ancestor_Subtype
(ST1
);
9992 exit when ST1
= ST2
;
9995 end Extract_Subtype_Bounds
;
9997 ----------------------------
9998 -- Simple_Init_Array_Type --
9999 ----------------------------
10001 function Simple_Init_Array_Type
return Node_Id
is
10002 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
10004 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
;
10005 -- Initialize a single array dimension with index constraint Index
10007 --------------------
10008 -- Simple_Init_Dimension --
10009 --------------------
10011 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
is
10013 -- Process the current dimension
10015 if Present
(Index
) then
10017 -- Build a suitable "others" aggregate for the next dimension,
10018 -- or initialize the component itself. Generate:
10023 Make_Aggregate
(Loc
,
10024 Component_Associations
=> New_List
(
10025 Make_Component_Association
(Loc
,
10026 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
10028 Simple_Init_Dimension
(Next_Index
(Index
)))));
10030 -- Otherwise all dimensions have been processed. Initialize the
10031 -- component itself.
10035 Get_Simple_Init_Val
10038 Size
=> Esize
(Comp_Typ
));
10040 end Simple_Init_Dimension
;
10042 -- Start of processing for Simple_Init_Array_Type
10045 return Simple_Init_Dimension
(First_Index
(Typ
));
10046 end Simple_Init_Array_Type
;
10048 --------------------------------
10049 -- Simple_Init_Defaulted_Type --
10050 --------------------------------
10052 function Simple_Init_Defaulted_Type
return Node_Id
is
10053 Subtyp
: Entity_Id
:= First_Subtype
(Typ
);
10056 -- When the first subtype is private, retrieve the expression of the
10057 -- Default_Value from the underlying type.
10059 if Is_Private_Type
(Subtyp
) then
10060 Subtyp
:= Full_View
(Subtyp
);
10063 -- Use the Sloc of the context node when constructing the initial
10064 -- value because the expression of Default_Value may come from a
10065 -- different unit. Updating the Sloc will result in accurate error
10073 (Source
=> Default_Aspect_Value
(Subtyp
),
10075 end Simple_Init_Defaulted_Type
;
10077 -----------------------------------------
10078 -- Simple_Init_Initialize_Scalars_Type --
10079 -----------------------------------------
10081 function Simple_Init_Initialize_Scalars_Type
10082 (Size_To_Use
: Uint
) return Node_Id
10084 Float_Typ
: Entity_Id
;
10087 Scal_Typ
: Scalar_Id
;
10090 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
10094 if Is_Floating_Point_Type
(Typ
) then
10095 Float_Typ
:= Root_Type
(Typ
);
10097 if Float_Typ
= Standard_Short_Float
then
10098 Scal_Typ
:= Name_Short_Float
;
10099 elsif Float_Typ
= Standard_Float
then
10100 Scal_Typ
:= Name_Float
;
10101 elsif Float_Typ
= Standard_Long_Float
then
10102 Scal_Typ
:= Name_Long_Float
;
10103 else pragma Assert
(Float_Typ
= Standard_Long_Long_Float
);
10104 Scal_Typ
:= Name_Long_Long_Float
;
10107 -- If zero is invalid, it is a convenient value to use that is for
10108 -- sure an appropriate invalid value in all situations.
10110 elsif Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
10111 return Make_Integer_Literal
(Loc
, 0);
10115 elsif Is_Unsigned_Type
(Typ
) then
10116 if Size_To_Use
<= 8 then
10117 Scal_Typ
:= Name_Unsigned_8
;
10118 elsif Size_To_Use
<= 16 then
10119 Scal_Typ
:= Name_Unsigned_16
;
10120 elsif Size_To_Use
<= 32 then
10121 Scal_Typ
:= Name_Unsigned_32
;
10122 elsif Size_To_Use
<= 64 then
10123 Scal_Typ
:= Name_Unsigned_64
;
10125 Scal_Typ
:= Name_Unsigned_128
;
10131 if Size_To_Use
<= 8 then
10132 Scal_Typ
:= Name_Signed_8
;
10133 elsif Size_To_Use
<= 16 then
10134 Scal_Typ
:= Name_Signed_16
;
10135 elsif Size_To_Use
<= 32 then
10136 Scal_Typ
:= Name_Signed_32
;
10137 elsif Size_To_Use
<= 64 then
10138 Scal_Typ
:= Name_Signed_64
;
10140 Scal_Typ
:= Name_Signed_128
;
10144 -- Use the values specified by pragma Initialize_Scalars or the ones
10145 -- provided by the binder. Higher precedence is given to the pragma.
10147 return Invalid_Scalar_Value
(Loc
, Scal_Typ
);
10148 end Simple_Init_Initialize_Scalars_Type
;
10150 ----------------------------------------
10151 -- Simple_Init_Normalize_Scalars_Type --
10152 ----------------------------------------
10154 function Simple_Init_Normalize_Scalars_Type
10155 (Size_To_Use
: Uint
) return Node_Id
10157 Signed_Size
: constant Uint
:= UI_Min
(Uint_63
, Size_To_Use
- 1);
10164 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
10166 -- If zero is invalid, it is a convenient value to use that is for
10167 -- sure an appropriate invalid value in all situations.
10169 if Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
10170 Expr
:= Make_Integer_Literal
(Loc
, 0);
10172 -- Cases where all one bits is the appropriate invalid value
10174 -- For modular types, all 1 bits is either invalid or valid. If it
10175 -- is valid, then there is nothing that can be done since there are
10176 -- no invalid values (we ruled out zero already).
10178 -- For signed integer types that have no negative values, either
10179 -- there is room for negative values, or there is not. If there
10180 -- is, then all 1-bits may be interpreted as minus one, which is
10181 -- certainly invalid. Alternatively it is treated as the largest
10182 -- positive value, in which case the observation for modular types
10185 -- For float types, all 1-bits is a NaN (not a number), which is
10186 -- certainly an appropriately invalid value.
10188 elsif Is_Enumeration_Type
(Typ
)
10189 or else Is_Floating_Point_Type
(Typ
)
10190 or else Is_Unsigned_Type
(Typ
)
10192 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Size_To_Use
- 1);
10194 -- Resolve as Long_Long_Long_Unsigned, because the largest number
10195 -- we can generate is out of range of universal integer.
10197 Analyze_And_Resolve
(Expr
, Standard_Long_Long_Long_Unsigned
);
10199 -- Case of signed types
10202 -- Normally we like to use the most negative number. The one
10203 -- exception is when this number is in the known subtype range and
10204 -- the largest positive number is not in the known subtype range.
10206 -- For this exceptional case, use largest positive value
10208 if Present
(Lo_Bound
) and then Present
(Hi_Bound
)
10209 and then Lo_Bound
<= (-(2 ** Signed_Size
))
10210 and then Hi_Bound
< 2 ** Signed_Size
10212 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Signed_Size
- 1);
10214 -- Normal case of largest negative value
10217 Expr
:= Make_Integer_Literal
(Loc
, -(2 ** Signed_Size
));
10222 end Simple_Init_Normalize_Scalars_Type
;
10224 ------------------------------
10225 -- Simple_Init_Private_Type --
10226 ------------------------------
10228 function Simple_Init_Private_Type
return Node_Id
is
10229 Under_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
10233 -- The availability of the underlying view must be checked by routine
10234 -- Needs_Simple_Initialization.
10236 pragma Assert
(Present
(Under_Typ
));
10238 Expr
:= Get_Simple_Init_Val
(Under_Typ
, N
, Size
);
10240 -- If the initial value is null or an aggregate, qualify it with the
10241 -- underlying type in order to provide a proper context.
10243 if Nkind
(Expr
) in N_Aggregate | N_Null
then
10245 Make_Qualified_Expression
(Loc
,
10246 Subtype_Mark
=> New_Occurrence_Of
(Under_Typ
, Loc
),
10247 Expression
=> Expr
);
10250 Expr
:= Unchecked_Convert_To
(Typ
, Expr
);
10252 -- Do not truncate the result when scalar types are involved and
10253 -- Initialize/Normalize_Scalars is in effect.
10255 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
10256 and then Is_Scalar_Type
(Under_Typ
)
10258 Set_No_Truncation
(Expr
);
10262 end Simple_Init_Private_Type
;
10264 -----------------------------
10265 -- Simple_Init_Scalar_Type --
10266 -----------------------------
10268 function Simple_Init_Scalar_Type
return Node_Id
is
10270 Size_To_Use
: Uint
;
10273 pragma Assert
(Init_Or_Norm_Scalars
or IV_Attribute
);
10275 -- Determine the size of the object. This is either the size provided
10276 -- by the caller, or the Esize of the scalar type.
10278 if No
(Size
) or else Size
<= Uint_0
then
10279 Size_To_Use
:= UI_Max
(Uint_1
, Esize
(Typ
));
10281 Size_To_Use
:= Size
;
10284 -- The maximum size to use is System_Max_Integer_Size bits. This
10285 -- will create values of type Long_Long_Long_Unsigned and the range
10286 -- must fit this type.
10288 if Present
(Size_To_Use
)
10289 and then Size_To_Use
> System_Max_Integer_Size
10291 Size_To_Use
:= UI_From_Int
(System_Max_Integer_Size
);
10294 if Normalize_Scalars
and then not IV_Attribute
then
10295 Expr
:= Simple_Init_Normalize_Scalars_Type
(Size_To_Use
);
10297 Expr
:= Simple_Init_Initialize_Scalars_Type
(Size_To_Use
);
10300 -- The final expression is obtained by doing an unchecked conversion
10301 -- of this result to the base type of the required subtype. Use the
10302 -- base type to prevent the unchecked conversion from chopping bits,
10303 -- and then we set Kill_Range_Check to preserve the "bad" value.
10305 Expr
:= Unchecked_Convert_To
(Base_Type
(Typ
), Expr
);
10307 -- Ensure that the expression is not truncated since the "bad" bits
10308 -- are desired, and also kill the range checks.
10310 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
10311 Set_Kill_Range_Check
(Expr
);
10312 Set_No_Truncation
(Expr
);
10316 end Simple_Init_Scalar_Type
;
10318 -- Start of processing for Get_Simple_Init_Val
10321 if Is_Private_Type
(Typ
) then
10322 return Simple_Init_Private_Type
;
10324 elsif Is_Scalar_Type
(Typ
) then
10325 if Has_Default_Aspect
(Typ
) then
10326 return Simple_Init_Defaulted_Type
;
10328 return Simple_Init_Scalar_Type
;
10331 -- Array type with Initialize or Normalize_Scalars
10333 elsif Is_Array_Type
(Typ
) then
10334 pragma Assert
(Init_Or_Norm_Scalars
);
10335 return Simple_Init_Array_Type
;
10337 -- Access type is initialized to null
10339 elsif Is_Access_Type
(Typ
) then
10340 return Make_Null
(Loc
);
10342 -- No other possibilities should arise, since we should only be calling
10343 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
10344 -- indicating one of the above cases held.
10347 raise Program_Error
;
10351 when RE_Not_Available
=>
10353 end Get_Simple_Init_Val
;
10355 ------------------------------
10356 -- Has_New_Non_Standard_Rep --
10357 ------------------------------
10359 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
10361 if not Is_Derived_Type
(T
) then
10362 return Has_Non_Standard_Rep
(T
)
10363 or else Has_Non_Standard_Rep
(Root_Type
(T
));
10365 -- If Has_Non_Standard_Rep is not set on the derived type, the
10366 -- representation is fully inherited.
10368 elsif not Has_Non_Standard_Rep
(T
) then
10372 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
10374 -- May need a more precise check here: the First_Rep_Item may be a
10375 -- stream attribute, which does not affect the representation of the
10379 end Has_New_Non_Standard_Rep
;
10381 ----------------------
10382 -- Inline_Init_Proc --
10383 ----------------------
10385 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean is
10387 -- The initialization proc of protected records is not worth inlining.
10388 -- In addition, when compiled for another unit for inlining purposes,
10389 -- it may make reference to entities that have not been elaborated yet.
10390 -- The initialization proc of records that need finalization contains
10391 -- a nested clean-up procedure that makes it impractical to inline as
10392 -- well, except for simple controlled types themselves. And similar
10393 -- considerations apply to task types.
10395 if Is_Concurrent_Type
(Typ
) then
10398 elsif Needs_Finalization
(Typ
) and then not Is_Controlled
(Typ
) then
10401 elsif Has_Task
(Typ
) then
10407 end Inline_Init_Proc
;
10413 function In_Runtime
(E
: Entity_Id
) return Boolean is
10418 while Scope
(S1
) /= Standard_Standard
loop
10422 return Is_RTU
(S1
, System
) or else Is_RTU
(S1
, Ada
);
10425 package body Initialization_Control
is
10427 ------------------------
10428 -- Requires_Late_Init --
10429 ------------------------
10431 function Requires_Late_Init
10433 Rec_Type
: Entity_Id
) return Boolean
10435 References_Current_Instance
: Boolean := False;
10436 Has_Access_Discriminant
: Boolean := False;
10437 Has_Internal_Call
: Boolean := False;
10439 function Find_Access_Discriminant
10440 (N
: Node_Id
) return Traverse_Result
;
10441 -- Look for a name denoting an access discriminant
10443 function Find_Current_Instance
10444 (N
: Node_Id
) return Traverse_Result
;
10445 -- Look for a reference to the current instance of the type
10447 function Find_Internal_Call
10448 (N
: Node_Id
) return Traverse_Result
;
10449 -- Look for an internal protected function call
10451 ------------------------------
10452 -- Find_Access_Discriminant --
10453 ------------------------------
10455 function Find_Access_Discriminant
10456 (N
: Node_Id
) return Traverse_Result
is
10458 if Is_Entity_Name
(N
)
10459 and then Denotes_Discriminant
(N
)
10460 and then Is_Access_Type
(Etype
(N
))
10462 Has_Access_Discriminant
:= True;
10467 end Find_Access_Discriminant
;
10469 ---------------------------
10470 -- Find_Current_Instance --
10471 ---------------------------
10473 function Find_Current_Instance
10474 (N
: Node_Id
) return Traverse_Result
is
10476 if Is_Entity_Name
(N
)
10477 and then Present
(Entity
(N
))
10478 and then Is_Current_Instance
(N
)
10480 References_Current_Instance
:= True;
10485 end Find_Current_Instance
;
10487 ------------------------
10488 -- Find_Internal_Call --
10489 ------------------------
10491 function Find_Internal_Call
(N
: Node_Id
) return Traverse_Result
is
10493 function Call_Scope
(N
: Node_Id
) return Entity_Id
;
10494 -- Return the scope enclosing a given call node N
10500 function Call_Scope
(N
: Node_Id
) return Entity_Id
is
10501 Nam
: constant Node_Id
:= Name
(N
);
10503 if Nkind
(Nam
) = N_Selected_Component
then
10504 return Scope
(Entity
(Prefix
(Nam
)));
10506 return Scope
(Entity
(Nam
));
10511 if Nkind
(N
) = N_Function_Call
10512 and then Call_Scope
(N
)
10513 = Corresponding_Concurrent_Type
(Rec_Type
)
10515 Has_Internal_Call
:= True;
10520 end Find_Internal_Call
;
10522 procedure Search_Access_Discriminant
is new
10523 Traverse_Proc
(Find_Access_Discriminant
);
10525 procedure Search_Current_Instance
is new
10526 Traverse_Proc
(Find_Current_Instance
);
10528 procedure Search_Internal_Call
is new
10529 Traverse_Proc
(Find_Internal_Call
);
10531 -- Start of processing for Requires_Late_Init
10534 -- A component of an object is said to require late initialization
10537 -- it has an access discriminant value constrained by a per-object
10540 if Has_Access_Constraint
(Defining_Identifier
(Decl
))
10541 and then No
(Expression
(Decl
))
10545 elsif Present
(Expression
(Decl
)) then
10547 -- it has an initialization expression that includes a name
10548 -- denoting an access discriminant;
10550 Search_Access_Discriminant
(Expression
(Decl
));
10552 if Has_Access_Discriminant
then
10556 -- or it has an initialization expression that includes a
10557 -- reference to the current instance of the type either by
10560 Search_Current_Instance
(Expression
(Decl
));
10562 if References_Current_Instance
then
10566 -- ...or implicitly as the target object of a call.
10568 if Is_Protected_Record_Type
(Rec_Type
) then
10569 Search_Internal_Call
(Expression
(Decl
));
10571 if Has_Internal_Call
then
10578 end Requires_Late_Init
;
10580 -----------------------------
10581 -- Has_Late_Init_Component --
10582 -----------------------------
10584 function Has_Late_Init_Component
10585 (Tagged_Rec_Type
: Entity_Id
) return Boolean
10587 Comp_Id
: Entity_Id
:=
10588 First_Component
(Implementation_Base_Type
(Tagged_Rec_Type
));
10590 while Present
(Comp_Id
) loop
10591 if Requires_Late_Init
(Decl
=> Parent
(Comp_Id
),
10592 Rec_Type
=> Tagged_Rec_Type
)
10594 return True; -- found a component that requires late init
10596 elsif Chars
(Comp_Id
) = Name_uParent
10597 and then Has_Late_Init_Component
(Etype
(Comp_Id
))
10599 return True; -- an ancestor type has a late init component
10602 Next_Component
(Comp_Id
);
10606 end Has_Late_Init_Component
;
10608 ------------------------
10609 -- Tag_Init_Condition --
10610 ------------------------
10612 function Tag_Init_Condition
10614 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10616 return Make_Op_Eq
(Loc
,
10617 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10618 Make_Mode_Literal
(Loc
, Full_Init
));
10619 end Tag_Init_Condition
;
10621 --------------------------
10622 -- Early_Init_Condition --
10623 --------------------------
10625 function Early_Init_Condition
10627 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10629 return Make_Op_Ne
(Loc
,
10630 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10631 Make_Mode_Literal
(Loc
, Late_Init_Only
));
10632 end Early_Init_Condition
;
10634 -------------------------
10635 -- Late_Init_Condition --
10636 -------------------------
10638 function Late_Init_Condition
10640 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10642 return Make_Op_Ne
(Loc
,
10643 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10644 Make_Mode_Literal
(Loc
, Early_Init_Only
));
10645 end Late_Init_Condition
;
10647 end Initialization_Control
;
10649 ----------------------------
10650 -- Initialization_Warning --
10651 ----------------------------
10653 procedure Initialization_Warning
(E
: Entity_Id
) is
10654 Warning_Needed
: Boolean;
10657 Warning_Needed
:= False;
10659 if Ekind
(Current_Scope
) = E_Package
10660 and then Static_Elaboration_Desired
(Current_Scope
)
10662 if Is_Type
(E
) then
10663 if Is_Record_Type
(E
) then
10664 if Has_Discriminants
(E
)
10665 or else Is_Limited_Type
(E
)
10666 or else Has_Non_Standard_Rep
(E
)
10668 Warning_Needed
:= True;
10671 -- Verify that at least one component has an initialization
10672 -- expression. No need for a warning on a type if all its
10673 -- components have no initialization.
10679 Comp
:= First_Component
(E
);
10680 while Present
(Comp
) loop
10682 (Nkind
(Parent
(Comp
)) = N_Component_Declaration
);
10684 if Present
(Expression
(Parent
(Comp
))) then
10685 Warning_Needed
:= True;
10689 Next_Component
(Comp
);
10694 if Warning_Needed
then
10696 ("objects of the type cannot be initialized statically "
10697 & "by default??", Parent
(E
));
10702 Error_Msg_N
("object cannot be initialized statically??", E
);
10705 end Initialization_Warning
;
10711 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
10713 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10714 Unc_Arr
: constant Boolean :=
10715 Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
);
10716 With_Prot
: constant Boolean :=
10717 Has_Protected
(Typ
)
10718 or else (Is_Record_Type
(Typ
)
10719 and then Is_Protected_Record_Type
(Typ
));
10720 With_Task
: constant Boolean :=
10721 not Global_No_Tasking
10724 or else (Is_Record_Type
(Typ
)
10725 and then Is_Task_Record_Type
(Typ
)));
10729 -- The first parameter is always _Init : [in] out Typ. Note that we need
10730 -- it to be in/out in the case of an unconstrained array, because of the
10731 -- need to have the bounds, and in the case of protected or task record
10732 -- value, because there are default record fields that may be referenced
10733 -- in the generated initialization routine.
10735 Formals
:= New_List
(
10736 Make_Parameter_Specification
(Loc
,
10737 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uInit
),
10738 In_Present
=> Unc_Arr
or else With_Prot
or else With_Task
,
10739 Out_Present
=> True,
10740 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
10742 -- For task record value, or type that contains tasks, add two more
10743 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
10744 -- We also add these parameters for the task record type case.
10747 Append_To
(Formals
,
10748 Make_Parameter_Specification
(Loc
,
10749 Defining_Identifier
=>
10750 Make_Defining_Identifier
(Loc
, Name_uMaster
),
10752 New_Occurrence_Of
(Standard_Integer
, Loc
)));
10754 Set_Has_Master_Entity
(Proc_Id
);
10756 -- Add _Chain (not done for sequential elaboration policy, see
10757 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
10759 if Partition_Elaboration_Policy
/= 'S' then
10760 Append_To
(Formals
,
10761 Make_Parameter_Specification
(Loc
,
10762 Defining_Identifier
=>
10763 Make_Defining_Identifier
(Loc
, Name_uChain
),
10764 In_Present
=> True,
10765 Out_Present
=> True,
10767 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
)));
10770 Append_To
(Formals
,
10771 Make_Parameter_Specification
(Loc
,
10772 Defining_Identifier
=>
10773 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
10774 In_Present
=> True,
10775 Parameter_Type
=> New_Occurrence_Of
(Standard_String
, Loc
)));
10778 -- Due to certain edge cases such as arrays with null-excluding
10779 -- components being built with the secondary stack it becomes necessary
10780 -- to add a formal to the Init_Proc which controls whether we raise
10781 -- Constraint_Errors on generated calls for internal object
10784 if Needs_Conditional_Null_Excluding_Check
(Typ
) then
10785 Append_To
(Formals
,
10786 Make_Parameter_Specification
(Loc
,
10787 Defining_Identifier
=>
10788 Make_Defining_Identifier
(Loc
,
10789 New_External_Name
(Chars
10790 (Component_Type
(Typ
)), "_skip_null_excluding_check")),
10791 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
10792 In_Present
=> True,
10794 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
10800 when RE_Not_Available
=>
10804 -------------------------
10805 -- Init_Secondary_Tags --
10806 -------------------------
10808 procedure Init_Secondary_Tags
10811 Init_Tags_List
: List_Id
;
10812 Stmts_List
: List_Id
;
10813 Fixed_Comps
: Boolean := True;
10814 Variable_Comps
: Boolean := True)
10816 Loc
: constant Source_Ptr
:= Sloc
(Target
);
10818 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
10819 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10821 procedure Initialize_Tag
10824 Tag_Comp
: Entity_Id
;
10825 Iface_Tag
: Node_Id
);
10826 -- Initialize the tag of the secondary dispatch table of Typ associated
10827 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10828 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
10829 -- of Typ CPP tagged type we generate code to inherit the contents of
10830 -- the dispatch table directly from the ancestor.
10832 --------------------
10833 -- Initialize_Tag --
10834 --------------------
10836 procedure Initialize_Tag
10839 Tag_Comp
: Entity_Id
;
10840 Iface_Tag
: Node_Id
)
10842 Comp_Typ
: Entity_Id
;
10843 Offset_To_Top_Comp
: Entity_Id
:= Empty
;
10846 -- Initialize pointer to secondary DT associated with the interface
10848 if not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
10849 Append_To
(Init_Tags_List
,
10850 Make_Assignment_Statement
(Loc
,
10852 Make_Selected_Component
(Loc
,
10853 Prefix
=> New_Copy_Tree
(Target
),
10854 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10856 New_Occurrence_Of
(Iface_Tag
, Loc
)));
10859 Comp_Typ
:= Scope
(Tag_Comp
);
10861 -- Initialize the entries of the table of interfaces. We generate a
10862 -- different call when the parent of the type has variable size
10865 if Comp_Typ
/= Etype
(Comp_Typ
)
10866 and then Is_Variable_Size_Record
(Etype
(Comp_Typ
))
10867 and then Chars
(Tag_Comp
) /= Name_uTag
10869 pragma Assert
(Present
(DT_Offset_To_Top_Func
(Tag_Comp
)));
10871 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
10872 -- configurable run-time environment.
10874 if not RTE_Available
(RE_Set_Dynamic_Offset_To_Top
) then
10876 ("variable size record with interface types", Typ
);
10881 -- Set_Dynamic_Offset_To_Top
10883 -- Prim_T => Typ'Tag,
10884 -- Interface_T => Iface'Tag,
10885 -- Offset_Value => n,
10886 -- Offset_Func => Fn'Unrestricted_Access)
10888 Append_To
(Stmts_List
,
10889 Make_Procedure_Call_Statement
(Loc
,
10891 New_Occurrence_Of
(RTE
(RE_Set_Dynamic_Offset_To_Top
), Loc
),
10892 Parameter_Associations
=> New_List
(
10893 Make_Attribute_Reference
(Loc
,
10894 Prefix
=> New_Copy_Tree
(Target
),
10895 Attribute_Name
=> Name_Address
),
10897 Unchecked_Convert_To
(RTE
(RE_Tag
),
10899 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10901 Unchecked_Convert_To
(RTE
(RE_Tag
),
10903 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
10906 Unchecked_Convert_To
10907 (RTE
(RE_Storage_Offset
),
10908 Make_Op_Minus
(Loc
,
10909 Make_Attribute_Reference
(Loc
,
10911 Make_Selected_Component
(Loc
,
10912 Prefix
=> New_Copy_Tree
(Target
),
10914 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10915 Attribute_Name
=> Name_Position
))),
10917 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Function_Ptr
),
10918 Make_Attribute_Reference
(Loc
,
10919 Prefix
=> New_Occurrence_Of
10920 (DT_Offset_To_Top_Func
(Tag_Comp
), Loc
),
10921 Attribute_Name
=> Name_Unrestricted_Access
)))));
10923 -- In this case the next component stores the value of the offset
10926 Offset_To_Top_Comp
:= Next_Entity
(Tag_Comp
);
10927 pragma Assert
(Present
(Offset_To_Top_Comp
));
10929 Append_To
(Init_Tags_List
,
10930 Make_Assignment_Statement
(Loc
,
10932 Make_Selected_Component
(Loc
,
10933 Prefix
=> New_Copy_Tree
(Target
),
10935 New_Occurrence_Of
(Offset_To_Top_Comp
, Loc
)),
10938 Make_Op_Minus
(Loc
,
10939 Make_Attribute_Reference
(Loc
,
10941 Make_Selected_Component
(Loc
,
10942 Prefix
=> New_Copy_Tree
(Target
),
10943 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10944 Attribute_Name
=> Name_Position
))));
10946 -- Normal case: No discriminants in the parent type
10949 -- Don't need to set any value if the offset-to-top field is
10950 -- statically set or if this interface shares the primary
10953 if not Building_Static_Secondary_DT
(Typ
)
10954 and then not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True)
10956 Append_To
(Stmts_List
,
10957 Build_Set_Static_Offset_To_Top
(Loc
,
10958 Iface_Tag
=> New_Occurrence_Of
(Iface_Tag
, Loc
),
10960 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10961 Make_Op_Minus
(Loc
,
10962 Make_Attribute_Reference
(Loc
,
10964 Make_Selected_Component
(Loc
,
10965 Prefix
=> New_Copy_Tree
(Target
),
10967 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10968 Attribute_Name
=> Name_Position
)))));
10972 -- Register_Interface_Offset
10973 -- (Prim_T => Typ'Tag,
10974 -- Interface_T => Iface'Tag,
10975 -- Is_Constant => True,
10976 -- Offset_Value => n,
10977 -- Offset_Func => null);
10979 if not Building_Static_Secondary_DT
(Typ
)
10980 and then RTE_Available
(RE_Register_Interface_Offset
)
10982 Append_To
(Stmts_List
,
10983 Make_Procedure_Call_Statement
(Loc
,
10986 (RTE
(RE_Register_Interface_Offset
), Loc
),
10987 Parameter_Associations
=> New_List
(
10988 Unchecked_Convert_To
(RTE
(RE_Tag
),
10990 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10992 Unchecked_Convert_To
(RTE
(RE_Tag
),
10994 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))), Loc
)),
10996 New_Occurrence_Of
(Standard_True
, Loc
),
10998 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10999 Make_Op_Minus
(Loc
,
11000 Make_Attribute_Reference
(Loc
,
11002 Make_Selected_Component
(Loc
,
11003 Prefix
=> New_Copy_Tree
(Target
),
11005 New_Occurrence_Of
(Tag_Comp
, Loc
)),
11006 Attribute_Name
=> Name_Position
))),
11008 Make_Null
(Loc
))));
11011 end Initialize_Tag
;
11015 Full_Typ
: Entity_Id
;
11016 Ifaces_List
: Elist_Id
;
11017 Ifaces_Comp_List
: Elist_Id
;
11018 Ifaces_Tag_List
: Elist_Id
;
11019 Iface_Elmt
: Elmt_Id
;
11020 Iface_Comp_Elmt
: Elmt_Id
;
11021 Iface_Tag_Elmt
: Elmt_Id
;
11022 Tag_Comp
: Node_Id
;
11023 In_Variable_Pos
: Boolean;
11025 -- Start of processing for Init_Secondary_Tags
11028 -- Handle private types
11030 if Present
(Full_View
(Typ
)) then
11031 Full_Typ
:= Full_View
(Typ
);
11036 Collect_Interfaces_Info
11037 (Full_Typ
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
11039 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
11040 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
11041 Iface_Tag_Elmt
:= First_Elmt
(Ifaces_Tag_List
);
11042 while Present
(Iface_Elmt
) loop
11043 Tag_Comp
:= Node
(Iface_Comp_Elmt
);
11045 -- Check if parent of record type has variable size components
11047 In_Variable_Pos
:= Scope
(Tag_Comp
) /= Etype
(Scope
(Tag_Comp
))
11048 and then Is_Variable_Size_Record
(Etype
(Scope
(Tag_Comp
)));
11050 -- If we are compiling under the CPP full ABI compatibility mode and
11051 -- the ancestor is a CPP_Pragma tagged type then we generate code to
11052 -- initialize the secondary tag components from tags that reference
11053 -- secondary tables filled with copy of parent slots.
11055 if Is_CPP_Class
(Root_Type
(Full_Typ
)) then
11057 -- Reject interface components located at variable offset in
11058 -- C++ derivations. This is currently unsupported.
11060 if not Fixed_Comps
and then In_Variable_Pos
then
11062 -- Locate the first dynamic component of the record. Done to
11063 -- improve the text of the warning.
11067 Comp_Typ
: Entity_Id
;
11070 Comp
:= First_Entity
(Typ
);
11071 while Present
(Comp
) loop
11072 Comp_Typ
:= Etype
(Comp
);
11074 if Ekind
(Comp
) /= E_Discriminant
11075 and then not Is_Tag
(Comp
)
11078 (Is_Record_Type
(Comp_Typ
)
11080 Is_Variable_Size_Record
(Base_Type
(Comp_Typ
)))
11082 (Is_Array_Type
(Comp_Typ
)
11083 and then Is_Variable_Size_Array
(Comp_Typ
));
11086 Next_Entity
(Comp
);
11089 pragma Assert
(Present
(Comp
));
11091 -- Move this check to sem???
11092 Error_Msg_Node_2
:= Comp
;
11094 ("parent type & with dynamic component & cannot be parent"
11095 & " of 'C'P'P derivation if new interfaces are present",
11096 Typ
, Scope
(Original_Record_Component
(Comp
)));
11099 Sloc
(Scope
(Original_Record_Component
(Comp
)));
11101 ("type derived from 'C'P'P type & defined #",
11102 Typ
, Scope
(Original_Record_Component
(Comp
)));
11104 -- Avoid duplicated warnings
11109 -- Initialize secondary tags
11114 Iface
=> Node
(Iface_Elmt
),
11115 Tag_Comp
=> Tag_Comp
,
11116 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
11119 -- Otherwise generate code to initialize the tag
11122 if (In_Variable_Pos
and then Variable_Comps
)
11123 or else (not In_Variable_Pos
and then Fixed_Comps
)
11127 Iface
=> Node
(Iface_Elmt
),
11128 Tag_Comp
=> Tag_Comp
,
11129 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
11133 Next_Elmt
(Iface_Elmt
);
11134 Next_Elmt
(Iface_Comp_Elmt
);
11135 Next_Elmt
(Iface_Tag_Elmt
);
11137 end Init_Secondary_Tags
;
11139 ----------------------------
11140 -- Is_Null_Statement_List --
11141 ----------------------------
11143 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean is
11147 -- We must skip SCIL nodes because they may have been added to the list
11148 -- by Insert_Actions.
11150 Stmt
:= First_Non_SCIL_Node
(Stmts
);
11151 while Present
(Stmt
) loop
11152 if Nkind
(Stmt
) = N_Case_Statement
then
11156 Alt
:= First
(Alternatives
(Stmt
));
11157 while Present
(Alt
) loop
11158 if not Is_Null_Statement_List
(Statements
(Alt
)) then
11166 elsif Nkind
(Stmt
) /= N_Null_Statement
then
11170 Stmt
:= Next_Non_SCIL_Node
(Stmt
);
11174 end Is_Null_Statement_List
;
11176 ----------------------------------------
11177 -- Make_Controlling_Function_Wrappers --
11178 ----------------------------------------
11180 procedure Make_Controlling_Function_Wrappers
11181 (Tag_Typ
: Entity_Id
;
11182 Decl_List
: out List_Id
;
11183 Body_List
: out List_Id
)
11185 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11187 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
;
11188 -- Returns a function specification with the same profile as Subp
11190 --------------------------------
11191 -- Make_Wrapper_Specification --
11192 --------------------------------
11194 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
is
11197 Make_Function_Specification
(Loc
,
11198 Defining_Unit_Name
=>
11199 Make_Defining_Identifier
(Loc
,
11200 Chars
=> Chars
(Subp
)),
11201 Parameter_Specifications
=>
11202 Copy_Parameter_List
(Subp
),
11203 Result_Definition
=>
11204 New_Occurrence_Of
(Etype
(Subp
), Loc
));
11205 end Make_Wrapper_Specification
;
11207 Prim_Elmt
: Elmt_Id
;
11209 Actual_List
: List_Id
;
11210 Formal
: Entity_Id
;
11211 Par_Formal
: Entity_Id
;
11212 Ext_Aggr
: Node_Id
;
11213 Formal_Node
: Node_Id
;
11214 Func_Body
: Node_Id
;
11215 Func_Decl
: Node_Id
;
11216 Func_Id
: Entity_Id
;
11218 -- Start of processing for Make_Controlling_Function_Wrappers
11221 Decl_List
:= New_List
;
11222 Body_List
:= New_List
;
11224 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11225 while Present
(Prim_Elmt
) loop
11226 Subp
:= Node
(Prim_Elmt
);
11228 -- If a primitive function with a controlling result of the type has
11229 -- not been overridden by the user, then we must create a wrapper
11230 -- function here that effectively overrides it and invokes the
11231 -- (non-abstract) parent function. This can only occur for a null
11232 -- extension. Note that functions with anonymous controlling access
11233 -- results don't qualify and must be overridden. We also exclude
11234 -- Input attributes, since each type will have its own version of
11235 -- Input constructed by the expander. The test for Comes_From_Source
11236 -- is needed to distinguish inherited operations from renamings
11237 -- (which also have Alias set). We exclude internal entities with
11238 -- Interface_Alias to avoid generating duplicated wrappers since
11239 -- the primitive which covers the interface is also available in
11240 -- the list of primitive operations.
11242 -- The function may be abstract, or require_Overriding may be set
11243 -- for it, because tests for null extensions may already have reset
11244 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
11245 -- set, functions that need wrappers are recognized by having an
11246 -- alias that returns the parent type.
11248 if Comes_From_Source
(Subp
)
11249 or else No
(Alias
(Subp
))
11250 or else Present
(Interface_Alias
(Subp
))
11251 or else Ekind
(Subp
) /= E_Function
11252 or else not Has_Controlling_Result
(Subp
)
11253 or else Is_Access_Type
(Etype
(Subp
))
11254 or else Is_Abstract_Subprogram
(Alias
(Subp
))
11255 or else Is_TSS
(Subp
, TSS_Stream_Input
)
11259 elsif Is_Abstract_Subprogram
(Subp
)
11260 or else Requires_Overriding
(Subp
)
11262 (Is_Null_Extension
(Etype
(Subp
))
11263 and then Etype
(Alias
(Subp
)) /= Etype
(Subp
))
11265 -- If there is a non-overloadable homonym in the current
11266 -- scope, the implicit declaration remains invisible.
11267 -- We check the current entity with the same name, or its
11268 -- homonym in case the derivation takes place after the
11269 -- hiding object declaration.
11271 if Present
(Current_Entity
(Subp
)) then
11273 Curr
: constant Entity_Id
:= Current_Entity
(Subp
);
11274 Prev
: constant Entity_Id
:= Homonym
(Curr
);
11276 if (Comes_From_Source
(Curr
)
11277 and then Scope
(Curr
) = Current_Scope
11278 and then not Is_Overloadable
(Curr
))
11281 and then Comes_From_Source
(Prev
)
11282 and then Scope
(Prev
) = Current_Scope
11283 and then not Is_Overloadable
(Prev
))
11291 Make_Subprogram_Declaration
(Loc
,
11292 Specification
=> Make_Wrapper_Specification
(Subp
));
11294 Append_To
(Decl_List
, Func_Decl
);
11296 -- Build a wrapper body that calls the parent function. The body
11297 -- contains a single return statement that returns an extension
11298 -- aggregate whose ancestor part is a call to the parent function,
11299 -- passing the formals as actuals (with any controlling arguments
11300 -- converted to the types of the corresponding formals of the
11301 -- parent function, which might be anonymous access types), and
11302 -- having a null extension.
11304 Formal
:= First_Formal
(Subp
);
11305 Par_Formal
:= First_Formal
(Alias
(Subp
));
11307 First
(Parameter_Specifications
(Specification
(Func_Decl
)));
11309 if Present
(Formal
) then
11310 Actual_List
:= New_List
;
11312 while Present
(Formal
) loop
11313 if Is_Controlling_Formal
(Formal
) then
11314 Append_To
(Actual_List
,
11315 Make_Type_Conversion
(Loc
,
11317 New_Occurrence_Of
(Etype
(Par_Formal
), Loc
),
11320 (Defining_Identifier
(Formal_Node
), Loc
)));
11325 (Defining_Identifier
(Formal_Node
), Loc
));
11328 Next_Formal
(Formal
);
11329 Next_Formal
(Par_Formal
);
11330 Next
(Formal_Node
);
11333 Actual_List
:= No_List
;
11337 Make_Extension_Aggregate
(Loc
,
11339 Make_Function_Call
(Loc
,
11341 New_Occurrence_Of
(Alias
(Subp
), Loc
),
11342 Parameter_Associations
=> Actual_List
),
11343 Null_Record_Present
=> True);
11345 -- GNATprove will use expression of an expression function as an
11346 -- implicit postcondition. GNAT will also benefit from expression
11347 -- function to avoid premature freezing, but would struggle if we
11348 -- added an expression function to freezing actions, so we create
11349 -- the expanded form directly.
11351 if GNATprove_Mode
then
11353 Make_Expression_Function
(Loc
,
11355 Make_Wrapper_Specification
(Subp
),
11356 Expression
=> Ext_Aggr
);
11359 Make_Subprogram_Body
(Loc
,
11361 Make_Wrapper_Specification
(Subp
),
11362 Declarations
=> Empty_List
,
11363 Handled_Statement_Sequence
=>
11364 Make_Handled_Sequence_Of_Statements
(Loc
,
11365 Statements
=> New_List
(
11366 Make_Simple_Return_Statement
(Loc
,
11367 Expression
=> Ext_Aggr
))));
11368 Set_Was_Expression_Function
(Func_Body
);
11371 Append_To
(Body_List
, Func_Body
);
11373 -- Replace the inherited function with the wrapper function in the
11374 -- primitive operations list. We add the minimum decoration needed
11375 -- to override interface primitives.
11377 Func_Id
:= Defining_Unit_Name
(Specification
(Func_Decl
));
11379 Mutate_Ekind
(Func_Id
, E_Function
);
11380 Set_Is_Wrapper
(Func_Id
);
11382 -- Corresponding_Spec will be set again to the same value during
11383 -- analysis, but we need this information earlier.
11384 -- Expand_N_Freeze_Entity needs to know whether a subprogram body
11385 -- is a wrapper's body in order to get check suppression right.
11387 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
11391 Next_Elmt
(Prim_Elmt
);
11393 end Make_Controlling_Function_Wrappers
;
11399 function Make_Eq_Body
11401 Eq_Name
: Name_Id
) return Node_Id
11403 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Typ
));
11405 Def
: constant Node_Id
:= Parent
(Typ
);
11406 Stmts
: constant List_Id
:= New_List
;
11407 Variant_Case
: Boolean := Has_Discriminants
(Typ
);
11408 Comps
: Node_Id
:= Empty
;
11409 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
11413 Predef_Spec_Or_Body
(Loc
,
11416 Profile
=> New_List
(
11417 Make_Parameter_Specification
(Loc
,
11418 Defining_Identifier
=>
11419 Make_Defining_Identifier
(Loc
, Name_X
),
11420 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
11422 Make_Parameter_Specification
(Loc
,
11423 Defining_Identifier
=>
11424 Make_Defining_Identifier
(Loc
, Name_Y
),
11425 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
11427 Ret_Type
=> Standard_Boolean
,
11430 if Variant_Case
then
11431 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
11432 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
11435 if Present
(Typ_Def
) then
11436 Comps
:= Component_List
(Typ_Def
);
11440 Present
(Comps
) and then Present
(Variant_Part
(Comps
));
11443 if Variant_Case
then
11445 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
11446 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
11448 Make_Simple_Return_Statement
(Loc
,
11449 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11453 Make_Simple_Return_Statement
(Loc
,
11455 Expand_Record_Equality
11458 Lhs
=> Make_Identifier
(Loc
, Name_X
),
11459 Rhs
=> Make_Identifier
(Loc
, Name_Y
))));
11462 Set_Handled_Statement_Sequence
11463 (Decl
, Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
11471 -- <Make_Eq_If shared components>
11474 -- when V1 => <Make_Eq_Case> on subcomponents
11476 -- when Vn => <Make_Eq_Case> on subcomponents
11479 function Make_Eq_Case
11482 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
11484 Loc
: constant Source_Ptr
:= Sloc
(E
);
11485 Result
: constant List_Id
:= New_List
;
11487 Alt_List
: List_Id
;
11489 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
;
11490 -- Given the discriminant that controls a given variant of an unchecked
11491 -- union, find the formal of the equality function that carries the
11492 -- inferred value of the discriminant.
11494 function External_Name
(E
: Entity_Id
) return Name_Id
;
11495 -- The value of a given discriminant is conveyed in the corresponding
11496 -- formal parameter of the equality routine. The name of this formal
11497 -- parameter carries a one-character suffix which is removed here.
11499 --------------------------
11500 -- Corresponding_Formal --
11501 --------------------------
11503 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
is
11504 Discr
: constant Entity_Id
:= Entity
(Name
(Variant_Part
(C
)));
11508 Elm
:= First_Elmt
(Discrs
);
11509 while Present
(Elm
) loop
11510 if Chars
(Discr
) = External_Name
(Node
(Elm
)) then
11517 -- A formal of the proper name must be found
11519 raise Program_Error
;
11520 end Corresponding_Formal
;
11522 -------------------
11523 -- External_Name --
11524 -------------------
11526 function External_Name
(E
: Entity_Id
) return Name_Id
is
11528 Get_Name_String
(Chars
(E
));
11529 Name_Len
:= Name_Len
- 1;
11533 -- Start of processing for Make_Eq_Case
11536 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
11538 if No
(Variant_Part
(CL
)) then
11542 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
11544 if No
(Variant
) then
11548 Alt_List
:= New_List
;
11549 while Present
(Variant
) loop
11550 Append_To
(Alt_List
,
11551 Make_Case_Statement_Alternative
(Loc
,
11552 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
11554 Make_Eq_Case
(E
, Component_List
(Variant
), Discrs
)));
11555 Next_Non_Pragma
(Variant
);
11558 -- If we have an Unchecked_Union, use one of the parameters of the
11559 -- enclosing equality routine that captures the discriminant, to use
11560 -- as the expression in the generated case statement.
11562 if Is_Unchecked_Union
(E
) then
11564 Make_Case_Statement
(Loc
,
11566 New_Occurrence_Of
(Corresponding_Formal
(CL
), Loc
),
11567 Alternatives
=> Alt_List
));
11571 Make_Case_Statement
(Loc
,
11573 Make_Selected_Component
(Loc
,
11574 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11575 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
11576 Alternatives
=> Alt_List
));
11597 -- or a null statement if the list L is empty
11599 -- Equality may be user-defined for a given component type, in which case
11600 -- a function call is constructed instead of an operator node. This is an
11601 -- Ada 2012 change in the composability of equality for untagged composite
11604 function Make_Eq_If
11606 L
: List_Id
) return Node_Id
11608 Loc
: constant Source_Ptr
:= Sloc
(E
);
11612 Field_Name
: Name_Id
;
11613 Next_Test
: Node_Id
;
11618 return Make_Null_Statement
(Loc
);
11623 C
:= First_Non_Pragma
(L
);
11624 while Present
(C
) loop
11625 Typ
:= Etype
(Defining_Identifier
(C
));
11626 Field_Name
:= Chars
(Defining_Identifier
(C
));
11628 -- The tags must not be compared: they are not part of the value.
11629 -- Ditto for parent interfaces because their equality operator is
11632 -- Note also that in the following, we use Make_Identifier for
11633 -- the component names. Use of New_Occurrence_Of to identify the
11634 -- components would be incorrect because the wrong entities for
11635 -- discriminants could be picked up in the private type case.
11637 if Field_Name
= Name_uParent
11638 and then Is_Interface
(Typ
)
11642 elsif Field_Name
/= Name_uTag
then
11644 Lhs
: constant Node_Id
:=
11645 Make_Selected_Component
(Loc
,
11646 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11647 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11649 Rhs
: constant Node_Id
:=
11650 Make_Selected_Component
(Loc
,
11651 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
11652 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11656 -- Build equality code with a user-defined operator, if
11657 -- available, and with the predefined "=" otherwise. For
11658 -- compatibility with older Ada versions, we also use the
11659 -- predefined operation if the component-type equality is
11660 -- abstract, rather than raising Program_Error.
11662 if Ada_Version
< Ada_2012
then
11663 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11666 Eq_Call
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
11668 if No
(Eq_Call
) then
11669 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11671 -- If a component has a defined abstract equality, its
11672 -- application raises Program_Error on that component
11673 -- and therefore on the current variant.
11675 elsif Nkind
(Eq_Call
) = N_Raise_Program_Error
then
11676 Set_Etype
(Eq_Call
, Standard_Boolean
);
11677 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11680 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11685 Evolve_Or_Else
(Cond
, Next_Test
);
11688 Next_Non_Pragma
(C
);
11692 return Make_Null_Statement
(Loc
);
11696 Make_Implicit_If_Statement
(E
,
11698 Then_Statements
=> New_List
(
11699 Make_Simple_Return_Statement
(Loc
,
11700 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
11705 -------------------
11706 -- Make_Neq_Body --
11707 -------------------
11709 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
is
11711 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean;
11712 -- Returns true if Prim is a renaming of an unresolved predefined
11713 -- inequality operation.
11715 --------------------------------
11716 -- Is_Predefined_Neq_Renaming --
11717 --------------------------------
11719 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean is
11721 return Chars
(Prim
) /= Name_Op_Ne
11722 and then Present
(Alias
(Prim
))
11723 and then Comes_From_Source
(Prim
)
11724 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11725 and then Chars
(Alias
(Prim
)) = Name_Op_Ne
;
11726 end Is_Predefined_Neq_Renaming
;
11730 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Tag_Typ
));
11732 Eq_Prim
: Entity_Id
;
11733 Left_Op
: Entity_Id
;
11734 Renaming_Prim
: Entity_Id
;
11735 Right_Op
: Entity_Id
;
11736 Target
: Entity_Id
;
11738 -- Start of processing for Make_Neq_Body
11741 -- For a call on a renaming of a dispatching subprogram that is
11742 -- overridden, if the overriding occurred before the renaming, then
11743 -- the body executed is that of the overriding declaration, even if the
11744 -- overriding declaration is not visible at the place of the renaming;
11745 -- otherwise, the inherited or predefined subprogram is called, see
11748 -- Stage 1: Search for a renaming of the inequality primitive and also
11749 -- search for an overriding of the equality primitive located before the
11750 -- renaming declaration.
11758 Renaming_Prim
:= Empty
;
11760 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11761 while Present
(Elmt
) loop
11762 Prim
:= Node
(Elmt
);
11764 if Is_User_Defined_Equality
(Prim
) and then No
(Alias
(Prim
)) then
11765 if No
(Renaming_Prim
) then
11766 pragma Assert
(No
(Eq_Prim
));
11770 elsif Is_Predefined_Neq_Renaming
(Prim
) then
11771 Renaming_Prim
:= Prim
;
11778 -- No further action needed if no renaming was found
11780 if No
(Renaming_Prim
) then
11784 -- Stage 2: Replace the renaming declaration by a subprogram declaration
11785 -- (required to add its body)
11787 Decl
:= Parent
(Parent
(Renaming_Prim
));
11789 Make_Subprogram_Declaration
(Loc
,
11790 Specification
=> Specification
(Decl
)));
11791 Set_Analyzed
(Decl
);
11793 -- Remove the decoration of intrinsic renaming subprogram
11795 Set_Is_Intrinsic_Subprogram
(Renaming_Prim
, False);
11796 Set_Convention
(Renaming_Prim
, Convention_Ada
);
11797 Set_Alias
(Renaming_Prim
, Empty
);
11798 Set_Has_Completion
(Renaming_Prim
, False);
11800 -- Stage 3: Build the corresponding body
11802 Left_Op
:= First_Formal
(Renaming_Prim
);
11803 Right_Op
:= Next_Formal
(Left_Op
);
11806 Predef_Spec_Or_Body
(Loc
,
11807 Tag_Typ
=> Tag_Typ
,
11808 Name
=> Chars
(Renaming_Prim
),
11809 Profile
=> New_List
(
11810 Make_Parameter_Specification
(Loc
,
11811 Defining_Identifier
=>
11812 Make_Defining_Identifier
(Loc
, Chars
(Left_Op
)),
11813 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11815 Make_Parameter_Specification
(Loc
,
11816 Defining_Identifier
=>
11817 Make_Defining_Identifier
(Loc
, Chars
(Right_Op
)),
11818 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11820 Ret_Type
=> Standard_Boolean
,
11823 -- If the overriding of the equality primitive occurred before the
11824 -- renaming, then generate:
11826 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11828 -- return not Oeq (X, Y);
11831 if Present
(Eq_Prim
) then
11834 -- Otherwise build a nested subprogram which performs the predefined
11835 -- evaluation of the equality operator. That is, generate:
11837 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11838 -- function Oeq (X : Y) return Boolean is
11840 -- <<body of default implementation>>
11843 -- return not Oeq (X, Y);
11848 Local_Subp
: Node_Id
;
11850 Local_Subp
:= Make_Eq_Body
(Tag_Typ
, Name_Op_Eq
);
11851 Set_Declarations
(Decl
, New_List
(Local_Subp
));
11852 Target
:= Defining_Entity
(Local_Subp
);
11856 Set_Handled_Statement_Sequence
11858 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
11859 Make_Simple_Return_Statement
(Loc
,
11862 Make_Function_Call
(Loc
,
11863 Name
=> New_Occurrence_Of
(Target
, Loc
),
11864 Parameter_Associations
=> New_List
(
11865 Make_Identifier
(Loc
, Chars
(Left_Op
)),
11866 Make_Identifier
(Loc
, Chars
(Right_Op
)))))))));
11871 -------------------------------
11872 -- Make_Null_Procedure_Specs --
11873 -------------------------------
11875 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
is
11876 Decl_List
: constant List_Id
:= New_List
;
11877 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11878 Formal
: Entity_Id
;
11879 New_Param_Spec
: Node_Id
;
11880 New_Spec
: Node_Id
;
11881 Parent_Subp
: Entity_Id
;
11882 Prim_Elmt
: Elmt_Id
;
11886 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11887 while Present
(Prim_Elmt
) loop
11888 Subp
:= Node
(Prim_Elmt
);
11890 -- If a null procedure inherited from an interface has not been
11891 -- overridden, then we build a null procedure declaration to
11892 -- override the inherited procedure.
11894 Parent_Subp
:= Alias
(Subp
);
11896 if Present
(Parent_Subp
)
11897 and then Is_Null_Interface_Primitive
(Parent_Subp
)
11899 -- The null procedure spec is copied from the inherited procedure,
11900 -- except for the IS NULL (which must be added) and the overriding
11901 -- indicators (which must be removed, if present).
11904 Copy_Subprogram_Spec
(Subprogram_Specification
(Subp
), Loc
);
11906 Set_Null_Present
(New_Spec
, True);
11907 Set_Must_Override
(New_Spec
, False);
11908 Set_Must_Not_Override
(New_Spec
, False);
11910 Formal
:= First_Formal
(Subp
);
11911 New_Param_Spec
:= First
(Parameter_Specifications
(New_Spec
));
11913 while Present
(Formal
) loop
11915 -- For controlling arguments we must change their parameter
11916 -- type to reference the tagged type (instead of the interface
11919 if Is_Controlling_Formal
(Formal
) then
11920 if Nkind
(Parameter_Type
(Parent
(Formal
))) = N_Identifier
11922 Set_Parameter_Type
(New_Param_Spec
,
11923 New_Occurrence_Of
(Tag_Typ
, Loc
));
11926 (Nkind
(Parameter_Type
(Parent
(Formal
))) =
11927 N_Access_Definition
);
11928 Set_Subtype_Mark
(Parameter_Type
(New_Param_Spec
),
11929 New_Occurrence_Of
(Tag_Typ
, Loc
));
11933 Next_Formal
(Formal
);
11934 Next
(New_Param_Spec
);
11937 Append_To
(Decl_List
,
11938 Make_Subprogram_Declaration
(Loc
,
11939 Specification
=> New_Spec
));
11942 Next_Elmt
(Prim_Elmt
);
11946 end Make_Null_Procedure_Specs
;
11948 ---------------------------------------
11949 -- Make_Predefined_Primitive_Eq_Spec --
11950 ---------------------------------------
11952 procedure Make_Predefined_Primitive_Eq_Spec
11953 (Tag_Typ
: Entity_Id
;
11954 Predef_List
: List_Id
;
11955 Renamed_Eq
: out Entity_Id
)
11957 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
11958 -- Returns true if Prim is a renaming of an unresolved predefined
11959 -- equality operation.
11961 -------------------------------
11962 -- Is_Predefined_Eq_Renaming --
11963 -------------------------------
11965 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
11967 return Chars
(Prim
) /= Name_Op_Eq
11968 and then Present
(Alias
(Prim
))
11969 and then Comes_From_Source
(Prim
)
11970 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11971 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
11972 end Is_Predefined_Eq_Renaming
;
11976 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11978 Eq_Name
: Name_Id
:= Name_Op_Eq
;
11979 Eq_Needed
: Boolean := True;
11983 Has_Predef_Eq_Renaming
: Boolean := False;
11984 -- Set to True if Tag_Typ has a primitive that renames the predefined
11985 -- equality operator. Used to implement (RM 8-5-4(8)).
11987 -- Start of processing for Make_Predefined_Primitive_Specs
11990 Renamed_Eq
:= Empty
;
11992 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11993 while Present
(Prim
) loop
11995 -- If a primitive is encountered that renames the predefined equality
11996 -- operator before reaching any explicit equality primitive, then we
11997 -- still need to create a predefined equality function, because calls
11998 -- to it can occur via the renaming. A new name is created for the
11999 -- equality to avoid conflicting with any user-defined equality.
12000 -- (Note that this doesn't account for renamings of equality nested
12001 -- within subpackages???)
12003 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
12004 Has_Predef_Eq_Renaming
:= True;
12005 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
12007 -- User-defined equality
12009 elsif Is_User_Defined_Equality
(Node
(Prim
)) then
12010 if No
(Alias
(Node
(Prim
)))
12011 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
12012 N_Subprogram_Renaming_Declaration
12014 Eq_Needed
:= False;
12017 -- If the parent is not an interface type and has an abstract
12018 -- equality function explicitly defined in the sources, then the
12019 -- inherited equality is abstract as well, and no body can be
12022 elsif not Is_Interface
(Etype
(Tag_Typ
))
12023 and then Present
(Alias
(Node
(Prim
)))
12024 and then Comes_From_Source
(Alias
(Node
(Prim
)))
12025 and then Is_Abstract_Subprogram
(Alias
(Node
(Prim
)))
12027 Eq_Needed
:= False;
12030 -- If the type has an equality function corresponding with a
12031 -- primitive defined in an interface type, the inherited equality
12032 -- is abstract as well, and no body can be created for it.
12034 elsif Present
(Alias
(Node
(Prim
)))
12035 and then Comes_From_Source
(Ultimate_Alias
(Node
(Prim
)))
12038 (Find_Dispatching_Type
(Ultimate_Alias
(Node
(Prim
))))
12040 Eq_Needed
:= False;
12048 -- If a renaming of predefined equality was found but there was no
12049 -- user-defined equality (so Eq_Needed is still true), then set the name
12050 -- back to Name_Op_Eq. But in the case where a user-defined equality was
12051 -- located after such a renaming, then the predefined equality function
12052 -- is still needed, so Eq_Needed must be set back to True.
12054 if Eq_Name
/= Name_Op_Eq
then
12056 Eq_Name
:= Name_Op_Eq
;
12063 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
12064 Tag_Typ
=> Tag_Typ
,
12066 Profile
=> New_List
(
12067 Make_Parameter_Specification
(Loc
,
12068 Defining_Identifier
=>
12069 Make_Defining_Identifier
(Loc
, Name_X
),
12070 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12072 Make_Parameter_Specification
(Loc
,
12073 Defining_Identifier
=>
12074 Make_Defining_Identifier
(Loc
, Name_Y
),
12075 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12076 Ret_Type
=> Standard_Boolean
);
12077 Append_To
(Predef_List
, Eq_Spec
);
12079 if Has_Predef_Eq_Renaming
then
12080 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
12082 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12083 while Present
(Prim
) loop
12085 -- Any renamings of equality that appeared before an overriding
12086 -- equality must be updated to refer to the entity for the
12087 -- predefined equality, otherwise calls via the renaming would
12088 -- get incorrectly resolved to call the user-defined equality
12091 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
12092 Set_Alias
(Node
(Prim
), Renamed_Eq
);
12094 -- Exit upon encountering a user-defined equality
12096 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
12097 and then No
(Alias
(Node
(Prim
)))
12106 end Make_Predefined_Primitive_Eq_Spec
;
12108 -------------------------------------
12109 -- Make_Predefined_Primitive_Specs --
12110 -------------------------------------
12112 procedure Make_Predefined_Primitive_Specs
12113 (Tag_Typ
: Entity_Id
;
12114 Predef_List
: out List_Id
;
12115 Renamed_Eq
: out Entity_Id
)
12117 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12118 Res
: constant List_Id
:= New_List
;
12123 Renamed_Eq
:= Empty
;
12127 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12128 Tag_Typ
=> Tag_Typ
,
12129 Name
=> Name_uSize
,
12130 Profile
=> New_List
(
12131 Make_Parameter_Specification
(Loc
,
12132 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12133 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12135 Ret_Type
=> Standard_Long_Long_Integer
));
12137 -- Spec of Put_Image
12139 if not No_Run_Time_Mode
12140 and then RTE_Available
(RE_Root_Buffer_Type
)
12142 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
12143 -- (like any tagged type) will be rejected. Given this, avoid
12144 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
12147 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12148 Tag_Typ
=> Tag_Typ
,
12149 Name
=> Make_TSS_Name
(Tag_Typ
, TSS_Put_Image
),
12150 Profile
=> Build_Put_Image_Profile
(Loc
, Tag_Typ
)));
12153 -- Specs for dispatching stream attributes
12156 Stream_Op_TSS_Names
:
12157 constant array (Positive range <>) of TSS_Name_Type
:=
12161 TSS_Stream_Output
);
12164 for Op
in Stream_Op_TSS_Names
'Range loop
12165 if Stream_Operation_OK
(Tag_Typ
, Stream_Op_TSS_Names
(Op
)) then
12167 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
,
12168 Stream_Op_TSS_Names
(Op
)));
12173 -- Spec of "=" is expanded if the type is not limited and if a user
12174 -- defined "=" was not already declared for the non-full view of a
12175 -- private extension.
12177 if not Is_Limited_Type
(Tag_Typ
) then
12178 Make_Predefined_Primitive_Eq_Spec
(Tag_Typ
, Res
, Renamed_Eq
);
12180 -- Spec for dispatching assignment
12182 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12183 Tag_Typ
=> Tag_Typ
,
12184 Name
=> Name_uAssign
,
12185 Profile
=> New_List
(
12186 Make_Parameter_Specification
(Loc
,
12187 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12188 Out_Present
=> True,
12189 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12191 Make_Parameter_Specification
(Loc
,
12192 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12193 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)))));
12196 -- Ada 2005: Generate declarations for the following primitive
12197 -- operations for limited interfaces and synchronized types that
12198 -- implement a limited interface.
12200 -- Disp_Asynchronous_Select
12201 -- Disp_Conditional_Select
12202 -- Disp_Get_Prim_Op_Kind
12203 -- Disp_Get_Task_Id
12205 -- Disp_Timed_Select
12207 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12209 if Ada_Version
>= Ada_2005
12210 and then not Restriction_Active
(No_Select_Statements
)
12211 and then RTE_Available
(RE_Select_Specific_Data
)
12213 -- These primitives are defined abstract in interface types
12215 if Is_Interface
(Tag_Typ
)
12216 and then Is_Limited_Record
(Tag_Typ
)
12219 Make_Abstract_Subprogram_Declaration
(Loc
,
12221 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
12224 Make_Abstract_Subprogram_Declaration
(Loc
,
12226 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
12229 Make_Abstract_Subprogram_Declaration
(Loc
,
12231 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
12234 Make_Abstract_Subprogram_Declaration
(Loc
,
12236 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12239 Make_Abstract_Subprogram_Declaration
(Loc
,
12241 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12244 Make_Abstract_Subprogram_Declaration
(Loc
,
12246 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12248 -- If ancestor is an interface type, declare non-abstract primitives
12249 -- to override the abstract primitives of the interface type.
12251 -- In VM targets we define these primitives in all root tagged types
12252 -- that are not interface types. Done because in VM targets we don't
12253 -- have secondary dispatch tables and any derivation of Tag_Typ may
12254 -- cover limited interfaces (which always have these primitives since
12255 -- they may be ancestors of synchronized interface types).
12257 elsif (not Is_Interface
(Tag_Typ
)
12258 and then Is_Interface
(Etype
(Tag_Typ
))
12259 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12261 (Is_Concurrent_Record_Type
(Tag_Typ
)
12262 and then Has_Interfaces
(Tag_Typ
))
12264 (not Tagged_Type_Expansion
12265 and then not Is_Interface
(Tag_Typ
)
12266 and then Tag_Typ
= Root_Type
(Tag_Typ
))
12269 Make_Subprogram_Declaration
(Loc
,
12271 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
12274 Make_Subprogram_Declaration
(Loc
,
12276 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
12279 Make_Subprogram_Declaration
(Loc
,
12281 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
12284 Make_Subprogram_Declaration
(Loc
,
12286 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12289 Make_Subprogram_Declaration
(Loc
,
12291 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12294 Make_Subprogram_Declaration
(Loc
,
12296 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12300 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
12301 -- regardless of whether they are controlled or may contain controlled
12304 -- Do not generate the routines if finalization is disabled
12306 if Restriction_Active
(No_Finalization
) then
12310 if not Is_Limited_Type
(Tag_Typ
) then
12311 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
12314 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
12317 Predef_List
:= Res
;
12318 end Make_Predefined_Primitive_Specs
;
12320 -------------------------
12321 -- Make_Tag_Assignment --
12322 -------------------------
12324 function Make_Tag_Assignment
(N
: Node_Id
) return Node_Id
is
12325 Loc
: constant Source_Ptr
:= Sloc
(N
);
12326 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
12327 Expr
: constant Node_Id
:= Expression
(N
);
12328 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
12329 Full_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
12332 -- This expansion activity is called during analysis
12334 if Is_Tagged_Type
(Typ
)
12335 and then not Is_Class_Wide_Type
(Typ
)
12336 and then not Is_CPP_Class
(Typ
)
12337 and then Tagged_Type_Expansion
12338 and then Nkind
(Unqualify
(Expr
)) /= N_Aggregate
12341 Make_Tag_Assignment_From_Type
12342 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Full_Typ
);
12347 end Make_Tag_Assignment
;
12349 ----------------------
12350 -- Predef_Deep_Spec --
12351 ----------------------
12353 function Predef_Deep_Spec
12355 Tag_Typ
: Entity_Id
;
12356 Name
: TSS_Name_Type
;
12357 For_Body
: Boolean := False) return Node_Id
12362 -- V : in out Tag_Typ
12364 Formals
:= New_List
(
12365 Make_Parameter_Specification
(Loc
,
12366 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
12367 In_Present
=> True,
12368 Out_Present
=> True,
12369 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)));
12371 -- F : Boolean := True
12373 if Name
= TSS_Deep_Adjust
12374 or else Name
= TSS_Deep_Finalize
12376 Append_To
(Formals
,
12377 Make_Parameter_Specification
(Loc
,
12378 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
12379 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12380 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12384 Predef_Spec_Or_Body
(Loc
,
12385 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12386 Tag_Typ
=> Tag_Typ
,
12387 Profile
=> Formals
,
12388 For_Body
=> For_Body
);
12391 when RE_Not_Available
=>
12393 end Predef_Deep_Spec
;
12395 -------------------------
12396 -- Predef_Spec_Or_Body --
12397 -------------------------
12399 function Predef_Spec_Or_Body
12401 Tag_Typ
: Entity_Id
;
12404 Ret_Type
: Entity_Id
:= Empty
;
12405 For_Body
: Boolean := False) return Node_Id
12407 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
12411 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
12413 -- The internal flag is set to mark these declarations because they have
12414 -- specific properties. First, they are primitives even if they are not
12415 -- defined in the type scope (the freezing point is not necessarily in
12416 -- the same scope). Second, the predefined equality can be overridden by
12417 -- a user-defined equality, no body will be generated in this case.
12419 Set_Is_Internal
(Id
);
12421 if not Debug_Generated_Code
then
12422 Set_Debug_Info_Off
(Id
);
12425 if No
(Ret_Type
) then
12427 Make_Procedure_Specification
(Loc
,
12428 Defining_Unit_Name
=> Id
,
12429 Parameter_Specifications
=> Profile
);
12432 Make_Function_Specification
(Loc
,
12433 Defining_Unit_Name
=> Id
,
12434 Parameter_Specifications
=> Profile
,
12435 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
12438 -- Declare an abstract subprogram for primitive subprograms of an
12439 -- interface type (except for "=").
12441 if Is_Interface
(Tag_Typ
) then
12442 if Name
/= Name_Op_Eq
then
12443 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12445 -- The equality function (if any) for an interface type is defined
12446 -- to be nonabstract, so we create an expression function for it that
12447 -- always returns False. Note that the function can never actually be
12448 -- invoked because interface types are abstract, so there aren't any
12449 -- objects of such types (and their equality operation will always
12453 return Make_Expression_Function
12454 (Loc
, Spec
, New_Occurrence_Of
(Standard_False
, Loc
));
12457 -- If body case, return empty subprogram body. Note that this is ill-
12458 -- formed, because there is not even a null statement, and certainly not
12459 -- a return in the function case. The caller is expected to do surgery
12460 -- on the body to add the appropriate stuff.
12462 elsif For_Body
then
12463 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
12465 -- For the case of an Input attribute predefined for an abstract type,
12466 -- generate an abstract specification. This will never be called, but we
12467 -- need the slot allocated in the dispatching table so that attributes
12468 -- typ'Class'Input and typ'Class'Output will work properly.
12470 elsif Is_TSS
(Name
, TSS_Stream_Input
)
12471 and then Is_Abstract_Type
(Tag_Typ
)
12473 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12475 -- Normal spec case, where we return a subprogram declaration
12478 return Make_Subprogram_Declaration
(Loc
, Spec
);
12480 end Predef_Spec_Or_Body
;
12482 -----------------------------
12483 -- Predef_Stream_Attr_Spec --
12484 -----------------------------
12486 function Predef_Stream_Attr_Spec
12488 Tag_Typ
: Entity_Id
;
12489 Name
: TSS_Name_Type
) return Node_Id
12491 Ret_Type
: Entity_Id
;
12494 if Name
= TSS_Stream_Input
then
12495 Ret_Type
:= Tag_Typ
;
12501 Predef_Spec_Or_Body
12503 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12504 Tag_Typ
=> Tag_Typ
,
12505 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
12506 Ret_Type
=> Ret_Type
,
12507 For_Body
=> False);
12508 end Predef_Stream_Attr_Spec
;
12510 ----------------------------------
12511 -- Predefined_Primitive_Eq_Body --
12512 ----------------------------------
12514 procedure Predefined_Primitive_Eq_Body
12515 (Tag_Typ
: Entity_Id
;
12516 Predef_List
: List_Id
;
12517 Renamed_Eq
: Entity_Id
)
12520 Eq_Needed
: Boolean;
12525 -- See if we have a predefined "=" operator
12527 if Present
(Renamed_Eq
) then
12529 Eq_Name
:= Chars
(Renamed_Eq
);
12531 -- If the parent is an interface type then it has defined all the
12532 -- predefined primitives abstract and we need to check if the type
12533 -- has some user defined "=" function which matches the profile of
12534 -- the Ada predefined equality operator to avoid generating it.
12536 elsif Is_Interface
(Etype
(Tag_Typ
)) then
12538 Eq_Name
:= Name_Op_Eq
;
12540 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12541 while Present
(Prim
) loop
12542 if Is_User_Defined_Equality
(Node
(Prim
))
12543 and then not Is_Internal
(Node
(Prim
))
12545 Eq_Needed
:= False;
12546 Eq_Name
:= No_Name
;
12554 Eq_Needed
:= False;
12555 Eq_Name
:= No_Name
;
12557 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12558 while Present
(Prim
) loop
12559 if Is_User_Defined_Equality
(Node
(Prim
))
12560 and then Is_Internal
(Node
(Prim
))
12563 Eq_Name
:= Name_Op_Eq
;
12571 -- If equality is needed, we will have its name
12573 pragma Assert
(Eq_Needed
= Present
(Eq_Name
));
12575 -- Body for equality
12578 Decl
:= Make_Eq_Body
(Tag_Typ
, Eq_Name
);
12579 Append_To
(Predef_List
, Decl
);
12582 -- Body for inequality (if required)
12584 Decl
:= Make_Neq_Body
(Tag_Typ
);
12586 if Present
(Decl
) then
12587 Append_To
(Predef_List
, Decl
);
12589 end Predefined_Primitive_Eq_Body
;
12591 ---------------------------------
12592 -- Predefined_Primitive_Bodies --
12593 ---------------------------------
12595 function Predefined_Primitive_Bodies
12596 (Tag_Typ
: Entity_Id
;
12597 Renamed_Eq
: Entity_Id
) return List_Id
12599 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12600 Res
: constant List_Id
:= New_List
;
12601 Adj_Call
: Node_Id
;
12603 Fin_Call
: Node_Id
;
12606 pragma Warnings
(Off
, Ent
);
12611 pragma Assert
(not Is_Interface
(Tag_Typ
));
12615 Decl
:= Predef_Spec_Or_Body
(Loc
,
12616 Tag_Typ
=> Tag_Typ
,
12617 Name
=> Name_uSize
,
12618 Profile
=> New_List
(
12619 Make_Parameter_Specification
(Loc
,
12620 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12621 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12623 Ret_Type
=> Standard_Long_Long_Integer
,
12626 Set_Handled_Statement_Sequence
(Decl
,
12627 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12628 Make_Simple_Return_Statement
(Loc
,
12630 Make_Attribute_Reference
(Loc
,
12631 Prefix
=> Make_Identifier
(Loc
, Name_X
),
12632 Attribute_Name
=> Name_Size
)))));
12634 Append_To
(Res
, Decl
);
12636 -- Body of Put_Image
12638 if No
(TSS
(Tag_Typ
, TSS_Put_Image
))
12639 and then not No_Run_Time_Mode
12640 and then RTE_Available
(RE_Root_Buffer_Type
)
12642 Build_Record_Put_Image_Procedure
(Tag_Typ
, Decl
, Ent
);
12643 Append_To
(Res
, Decl
);
12646 -- Bodies for Dispatching stream IO routines. We need these only for
12647 -- non-limited types (in the limited case there is no dispatching).
12648 -- We also skip them if dispatching or finalization are not available
12649 -- or if stream operations are prohibited by restriction No_Streams or
12650 -- from use of pragma/aspect No_Tagged_Streams.
12652 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Read
)
12653 and then No
(TSS
(Tag_Typ
, TSS_Stream_Read
))
12655 Build_Record_Read_Procedure
(Tag_Typ
, Decl
, Ent
);
12656 Append_To
(Res
, Decl
);
12659 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Write
)
12660 and then No
(TSS
(Tag_Typ
, TSS_Stream_Write
))
12662 Build_Record_Write_Procedure
(Tag_Typ
, Decl
, Ent
);
12663 Append_To
(Res
, Decl
);
12666 -- Skip body of _Input for the abstract case, since the corresponding
12667 -- spec is abstract (see Predef_Spec_Or_Body).
12669 if not Is_Abstract_Type
(Tag_Typ
)
12670 and then Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Input
)
12671 and then No
(TSS
(Tag_Typ
, TSS_Stream_Input
))
12673 Build_Record_Or_Elementary_Input_Function
(Tag_Typ
, Decl
, Ent
);
12674 Append_To
(Res
, Decl
);
12677 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Output
)
12678 and then No
(TSS
(Tag_Typ
, TSS_Stream_Output
))
12680 Build_Record_Or_Elementary_Output_Procedure
(Tag_Typ
, Decl
, Ent
);
12681 Append_To
(Res
, Decl
);
12684 -- Ada 2005: Generate bodies for the following primitive operations for
12685 -- limited interfaces and synchronized types that implement a limited
12688 -- disp_asynchronous_select
12689 -- disp_conditional_select
12690 -- disp_get_prim_op_kind
12691 -- disp_get_task_id
12692 -- disp_timed_select
12694 -- The interface versions will have null bodies
12696 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12698 -- In VM targets we define these primitives in all root tagged types
12699 -- that are not interface types. Done because in VM targets we don't
12700 -- have secondary dispatch tables and any derivation of Tag_Typ may
12701 -- cover limited interfaces (which always have these primitives since
12702 -- they may be ancestors of synchronized interface types).
12704 if Ada_Version
>= Ada_2005
12706 ((Is_Interface
(Etype
(Tag_Typ
))
12707 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12709 (Is_Concurrent_Record_Type
(Tag_Typ
)
12710 and then Has_Interfaces
(Tag_Typ
))
12712 (not Tagged_Type_Expansion
12713 and then Tag_Typ
= Root_Type
(Tag_Typ
)))
12714 and then not Restriction_Active
(No_Select_Statements
)
12715 and then RTE_Available
(RE_Select_Specific_Data
)
12717 Append_To
(Res
, Make_Disp_Asynchronous_Select_Body
(Tag_Typ
));
12718 Append_To
(Res
, Make_Disp_Conditional_Select_Body
(Tag_Typ
));
12719 Append_To
(Res
, Make_Disp_Get_Prim_Op_Kind_Body
(Tag_Typ
));
12720 Append_To
(Res
, Make_Disp_Get_Task_Id_Body
(Tag_Typ
));
12721 Append_To
(Res
, Make_Disp_Requeue_Body
(Tag_Typ
));
12722 Append_To
(Res
, Make_Disp_Timed_Select_Body
(Tag_Typ
));
12725 if not Is_Limited_Type
(Tag_Typ
) then
12726 -- Body for equality and inequality
12728 Predefined_Primitive_Eq_Body
(Tag_Typ
, Res
, Renamed_Eq
);
12730 -- Body for dispatching assignment
12733 Predef_Spec_Or_Body
(Loc
,
12734 Tag_Typ
=> Tag_Typ
,
12735 Name
=> Name_uAssign
,
12736 Profile
=> New_List
(
12737 Make_Parameter_Specification
(Loc
,
12738 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12739 Out_Present
=> True,
12740 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12742 Make_Parameter_Specification
(Loc
,
12743 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12744 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12747 Set_Handled_Statement_Sequence
(Decl
,
12748 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12749 Make_Assignment_Statement
(Loc
,
12750 Name
=> Make_Identifier
(Loc
, Name_X
),
12751 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
12753 Append_To
(Res
, Decl
);
12756 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
12757 -- tagged types which do not contain controlled components.
12759 -- Do not generate the routines if finalization is disabled
12761 if Restriction_Active
(No_Finalization
) then
12764 elsif not Has_Controlled_Component
(Tag_Typ
) then
12765 if not Is_Limited_Type
(Tag_Typ
) then
12767 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
12769 if Is_Controlled
(Tag_Typ
) then
12772 Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12776 if No
(Adj_Call
) then
12777 Adj_Call
:= Make_Null_Statement
(Loc
);
12780 Set_Handled_Statement_Sequence
(Decl
,
12781 Make_Handled_Sequence_Of_Statements
(Loc
,
12782 Statements
=> New_List
(Adj_Call
)));
12784 Append_To
(Res
, Decl
);
12788 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
12790 if Is_Controlled
(Tag_Typ
) then
12793 (Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12797 if No
(Fin_Call
) then
12798 Fin_Call
:= Make_Null_Statement
(Loc
);
12801 Set_Handled_Statement_Sequence
(Decl
,
12802 Make_Handled_Sequence_Of_Statements
(Loc
,
12803 Statements
=> New_List
(Fin_Call
)));
12805 Append_To
(Res
, Decl
);
12809 end Predefined_Primitive_Bodies
;
12811 ---------------------------------
12812 -- Predefined_Primitive_Freeze --
12813 ---------------------------------
12815 function Predefined_Primitive_Freeze
12816 (Tag_Typ
: Entity_Id
) return List_Id
12818 Res
: constant List_Id
:= New_List
;
12823 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12824 while Present
(Prim
) loop
12825 if Is_Predefined_Dispatching_Operation
(Node
(Prim
)) then
12826 Frnodes
:= Freeze_Entity
(Node
(Prim
), Tag_Typ
);
12828 if Present
(Frnodes
) then
12829 Append_List_To
(Res
, Frnodes
);
12837 end Predefined_Primitive_Freeze
;
12839 -------------------------
12840 -- Stream_Operation_OK --
12841 -------------------------
12843 function Stream_Operation_OK
12845 Operation
: TSS_Name_Type
) return Boolean
12847 Has_Predefined_Or_Specified_Stream_Attribute
: Boolean := False;
12850 -- Special case of a limited type extension: a default implementation
12851 -- of the stream attributes Read or Write exists if that attribute
12852 -- has been specified or is available for an ancestor type; a default
12853 -- implementation of the attribute Output (resp. Input) exists if the
12854 -- attribute has been specified or Write (resp. Read) is available for
12855 -- an ancestor type. The last condition only applies under Ada 2005.
12857 if Is_Limited_Type
(Typ
) and then Is_Tagged_Type
(Typ
) then
12858 if Operation
= TSS_Stream_Read
then
12859 Has_Predefined_Or_Specified_Stream_Attribute
:=
12860 Has_Specified_Stream_Read
(Typ
);
12862 elsif Operation
= TSS_Stream_Write
then
12863 Has_Predefined_Or_Specified_Stream_Attribute
:=
12864 Has_Specified_Stream_Write
(Typ
);
12866 elsif Operation
= TSS_Stream_Input
then
12867 Has_Predefined_Or_Specified_Stream_Attribute
:=
12868 Has_Specified_Stream_Input
(Typ
)
12870 (Ada_Version
>= Ada_2005
12871 and then Stream_Operation_OK
(Typ
, TSS_Stream_Read
));
12873 elsif Operation
= TSS_Stream_Output
then
12874 Has_Predefined_Or_Specified_Stream_Attribute
:=
12875 Has_Specified_Stream_Output
(Typ
)
12877 (Ada_Version
>= Ada_2005
12878 and then Stream_Operation_OK
(Typ
, TSS_Stream_Write
));
12881 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
12883 if not Has_Predefined_Or_Specified_Stream_Attribute
12884 and then Is_Derived_Type
(Typ
)
12885 and then (Operation
= TSS_Stream_Read
12886 or else Operation
= TSS_Stream_Write
)
12888 Has_Predefined_Or_Specified_Stream_Attribute
:=
12890 (Find_Inherited_TSS
(Base_Type
(Etype
(Typ
)), Operation
));
12894 -- If the type is not limited, or else is limited but the attribute is
12895 -- explicitly specified or is predefined for the type, then return True,
12896 -- unless other conditions prevail, such as restrictions prohibiting
12897 -- streams or dispatching operations. We also return True for limited
12898 -- interfaces, because they may be extended by nonlimited types and
12899 -- permit inheritance in this case (addresses cases where an abstract
12900 -- extension doesn't get 'Input declared, as per comments below, but
12901 -- 'Class'Input must still be allowed). Note that attempts to apply
12902 -- stream attributes to a limited interface or its class-wide type
12903 -- (or limited extensions thereof) will still get properly rejected
12904 -- by Check_Stream_Attribute.
12906 -- We exclude the Input operation from being a predefined subprogram in
12907 -- the case where the associated type is an abstract extension, because
12908 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
12909 -- we don't want an abstract version created because types derived from
12910 -- the abstract type may not even have Input available (for example if
12911 -- derived from a private view of the abstract type that doesn't have
12912 -- a visible Input).
12915 (not Is_Limited_Type
(Typ
)
12916 or else Is_Interface
(Typ
)
12917 or else Has_Predefined_Or_Specified_Stream_Attribute
)
12919 (Operation
/= TSS_Stream_Input
12920 or else not Is_Abstract_Type
(Typ
)
12921 or else not Is_Derived_Type
(Typ
))
12922 and then not Has_Unknown_Discriminants
(Typ
)
12923 and then not Is_Concurrent_Interface
(Typ
)
12924 and then not Restriction_Active
(No_Streams
)
12925 and then not Restriction_Active
(No_Dispatch
)
12926 and then No
(No_Tagged_Streams_Pragma
(Typ
))
12927 and then not No_Run_Time_Mode
12928 and then RTE_Available
(RE_Tag
)
12930 (not Restriction_Active
(No_Default_Stream_Attributes
)
12931 or else No
(Type_Without_Stream_Operation
(Typ
)))
12932 and then RTE_Available
(RE_Root_Stream_Type
);
12933 end Stream_Operation_OK
;