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
)
1897 Initialization_Warning
(T
);
1901 Comp
:= First_Component
(T
);
1903 -- A null record needs no warning
1909 while Present
(Comp
) loop
1911 -- Array components are acceptable if initialized by a positional
1912 -- aggregate with static components.
1914 if Is_Array_Type
(Etype
(Comp
)) then
1915 Comp_Type
:= Component_Type
(Etype
(Comp
));
1917 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1918 or else No
(Expression
(Parent
(Comp
)))
1919 or else Nkind
(Expression
(Parent
(Comp
))) /= N_Aggregate
1921 Initialization_Warning
(T
);
1924 elsif Is_Scalar_Type
(Component_Type
(Etype
(Comp
)))
1926 (not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1928 not Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
)))
1930 Initialization_Warning
(T
);
1934 not Static_Array_Aggregate
(Expression
(Parent
(Comp
)))
1936 Initialization_Warning
(T
);
1939 -- We need to return empty if the type has predicates because
1940 -- this would otherwise duplicate calls to the predicate
1941 -- function. If the type hasn't been frozen before being
1942 -- referenced in the current record, the extraneous call to
1943 -- the predicate function would be inserted somewhere before
1944 -- the predicate function is elaborated, which would result in
1947 elsif Has_Predicates
(Etype
(Comp
)) then
1951 elsif Is_Scalar_Type
(Etype
(Comp
)) then
1952 Comp_Type
:= Etype
(Comp
);
1954 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1955 or else No
(Expression
(Parent
(Comp
)))
1956 or else not Compile_Time_Known_Value
(Expression
(Parent
(Comp
)))
1957 or else not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1959 Compile_Time_Known_Value
(Type_High_Bound
(Comp_Type
))
1960 or else Has_Predicates
(Etype
(Comp
))
1962 Initialization_Warning
(T
);
1966 -- For now, other types are excluded
1969 Initialization_Warning
(T
);
1973 Next_Component
(Comp
);
1976 -- All components have static initialization. Build positional aggregate
1977 -- from the given expressions or defaults.
1979 Agg
:= Make_Aggregate
(Sloc
(T
), New_List
, New_List
);
1980 Set_Parent
(Agg
, Parent
(T
));
1982 Comp
:= First_Component
(T
);
1983 while Present
(Comp
) loop
1985 (New_Copy_Tree
(Expression
(Parent
(Comp
))), Expressions
(Agg
));
1986 Next_Component
(Comp
);
1989 Analyze_And_Resolve
(Agg
, T
);
1991 end Build_Equivalent_Record_Aggregate
;
1993 -------------------------------
1994 -- Build_Initialization_Call --
1995 -------------------------------
1997 -- References to a discriminant inside the record type declaration can
1998 -- appear either in the subtype_indication to constrain a record or an
1999 -- array, or as part of a larger expression given for the initial value
2000 -- of a component. In both of these cases N appears in the record
2001 -- initialization procedure and needs to be replaced by the formal
2002 -- parameter of the initialization procedure which corresponds to that
2005 -- In the example below, references to discriminants D1 and D2 in proc_1
2006 -- are replaced by references to formals with the same name
2009 -- A similar replacement is done for calls to any record initialization
2010 -- procedure for any components that are themselves of a record type.
2012 -- type R (D1, D2 : Integer) is record
2013 -- X : Integer := F * D1;
2014 -- Y : Integer := F * D2;
2017 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
2021 -- Out_2.X := F * D1;
2022 -- Out_2.Y := F * D2;
2025 function Build_Initialization_Call
2029 In_Init_Proc
: Boolean := False;
2030 Enclos_Type
: Entity_Id
:= Empty
;
2031 Target_Ref
: Node_Id
:= Empty
;
2032 Discr_Map
: Elist_Id
:= New_Elmt_List
;
2033 With_Default_Init
: Boolean := False;
2034 Constructor_Ref
: Node_Id
:= Empty
;
2035 Init_Control_Actual
: Entity_Id
:= Empty
) return List_Id
2037 Loc
: constant Source_Ptr
:= Sloc
(N
);
2038 Res
: constant List_Id
:= New_List
;
2040 Full_Type
: Entity_Id
;
2042 procedure Check_Predicated_Discriminant
2045 -- Discriminants whose subtypes have predicates are checked in two
2047 -- a) When an object is default-initialized and assertions are enabled
2048 -- we check that the value of the discriminant obeys the predicate.
2050 -- b) In all cases, if the discriminant controls a variant and the
2051 -- variant has no others_choice, Constraint_Error must be raised if
2052 -- the predicate is violated, because there is no variant covered
2053 -- by the illegal discriminant value.
2055 -----------------------------------
2056 -- Check_Predicated_Discriminant --
2057 -----------------------------------
2059 procedure Check_Predicated_Discriminant
2063 Typ
: constant Entity_Id
:= Etype
(Discr
);
2065 procedure Check_Missing_Others
(V
: Node_Id
);
2066 -- Check that a given variant and its nested variants have an others
2067 -- choice, and generate a constraint error raise when it does not.
2069 --------------------------
2070 -- Check_Missing_Others --
2071 --------------------------
2073 procedure Check_Missing_Others
(V
: Node_Id
) is
2079 Last_Var
:= Last_Non_Pragma
(Variants
(V
));
2080 Choice
:= First
(Discrete_Choices
(Last_Var
));
2082 -- An others_choice is added during expansion for gcc use, but
2083 -- does not cover the illegality.
2085 if Entity
(Name
(V
)) = Discr
then
2087 and then (Nkind
(Choice
) /= N_Others_Choice
2088 or else not Comes_From_Source
(Choice
))
2090 Check_Expression_Against_Static_Predicate
(Val
, Typ
);
2092 if not Is_Static_Expression
(Val
) then
2094 Make_Raise_Constraint_Error
(Loc
,
2097 Right_Opnd
=> Make_Predicate_Call
(Typ
, Val
)),
2098 Reason
=> CE_Invalid_Data
));
2103 -- Check whether some nested variant is ruled by the predicated
2106 Alt
:= First
(Variants
(V
));
2107 while Present
(Alt
) loop
2108 if Nkind
(Alt
) = N_Variant
2109 and then Present
(Variant_Part
(Component_List
(Alt
)))
2111 Check_Missing_Others
2112 (Variant_Part
(Component_List
(Alt
)));
2117 end Check_Missing_Others
;
2123 -- Start of processing for Check_Predicated_Discriminant
2126 if Ekind
(Base_Type
(Full_Type
)) = E_Record_Type
then
2127 Def
:= Type_Definition
(Parent
(Base_Type
(Full_Type
)));
2132 if Policy_In_Effect
(Name_Assert
) = Name_Check
2133 and then not Predicates_Ignored
(Etype
(Discr
))
2135 Prepend_To
(Res
, Make_Predicate_Check
(Typ
, Val
));
2138 -- If discriminant controls a variant, verify that predicate is
2139 -- obeyed or else an Others_Choice is present.
2141 if Nkind
(Def
) = N_Record_Definition
2142 and then Present
(Variant_Part
(Component_List
(Def
)))
2143 and then Policy_In_Effect
(Name_Assert
) = Name_Ignore
2145 Check_Missing_Others
(Variant_Part
(Component_List
(Def
)));
2147 end Check_Predicated_Discriminant
;
2157 First_Arg
: Node_Id
;
2158 Full_Init_Type
: Entity_Id
;
2159 Init_Call
: Node_Id
;
2160 Init_Type
: Entity_Id
;
2163 -- Start of processing for Build_Initialization_Call
2166 pragma Assert
(Constructor_Ref
= Empty
2167 or else Is_CPP_Constructor_Call
(Constructor_Ref
));
2169 if No
(Constructor_Ref
) then
2170 Proc
:= Base_Init_Proc
(Typ
);
2172 Proc
:= Base_Init_Proc
(Typ
, Entity
(Name
(Constructor_Ref
)));
2175 pragma Assert
(Present
(Proc
));
2176 Init_Type
:= Etype
(First_Formal
(Proc
));
2177 Full_Init_Type
:= Underlying_Type
(Init_Type
);
2179 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
2180 -- is active (in which case we make the call anyway, since in the
2181 -- actual compiled client it may be non null).
2183 if Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
then
2186 -- Nothing to do for an array of controlled components that have only
2187 -- the inherited Initialize primitive. This is a useful optimization
2190 elsif Is_Trivial_Subprogram
(Proc
)
2191 and then Is_Array_Type
(Full_Init_Type
)
2193 return New_List
(Make_Null_Statement
(Loc
));
2196 -- Use the [underlying] full view when dealing with a private type. This
2197 -- may require several steps depending on derivations.
2201 if Is_Private_Type
(Full_Type
) then
2202 if Present
(Full_View
(Full_Type
)) then
2203 Full_Type
:= Full_View
(Full_Type
);
2205 elsif Present
(Underlying_Full_View
(Full_Type
)) then
2206 Full_Type
:= Underlying_Full_View
(Full_Type
);
2208 -- When a private type acts as a generic actual and lacks a full
2209 -- view, use the base type.
2211 elsif Is_Generic_Actual_Type
(Full_Type
) then
2212 Full_Type
:= Base_Type
(Full_Type
);
2214 elsif Ekind
(Full_Type
) = E_Private_Subtype
2215 and then (not Has_Discriminants
(Full_Type
)
2216 or else No
(Discriminant_Constraint
(Full_Type
)))
2218 Full_Type
:= Etype
(Full_Type
);
2220 -- The loop has recovered the [underlying] full view, stop the
2227 -- The type is not private, nothing to do
2234 -- If Typ is derived, the procedure is the initialization procedure for
2235 -- the root type. Wrap the argument in an conversion to make it type
2236 -- honest. Actually it isn't quite type honest, because there can be
2237 -- conflicts of views in the private type case. That is why we set
2238 -- Conversion_OK in the conversion node.
2240 if (Is_Record_Type
(Typ
)
2241 or else Is_Array_Type
(Typ
)
2242 or else Is_Private_Type
(Typ
))
2243 and then Init_Type
/= Base_Type
(Typ
)
2245 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
2246 Set_Etype
(First_Arg
, Init_Type
);
2249 First_Arg
:= Id_Ref
;
2252 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
2254 -- In the tasks case, add _Master as the value of the _Master parameter
2255 -- and _Chain as the value of the _Chain parameter. At the outer level,
2256 -- these will be variables holding the corresponding values obtained
2257 -- from GNARL. At inner levels, they will be the parameters passed down
2258 -- through the outer routines.
2260 if Has_Task
(Full_Type
) then
2261 if Restriction_Active
(No_Task_Hierarchy
) then
2262 Append_To
(Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
2263 elsif Present
(Target_Ref
) then
2266 (Master_Id
(Base_Type
(Root_Type
(Etype
(Target_Ref
)))), Loc
));
2268 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
2271 -- Add _Chain (not done for sequential elaboration policy, see
2272 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2274 if Partition_Elaboration_Policy
/= 'S' then
2275 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2278 -- Ada 2005 (AI-287): In case of default initialized components
2279 -- with tasks, we generate a null string actual parameter.
2280 -- This is just a workaround that must be improved later???
2282 if With_Default_Init
then
2283 Append_To
(Args
, Make_String_Literal
(Loc
, Strval
=> ""));
2286 if Present
(Enclos_Type
) then
2287 A_Type
:= Enclos_Type
;
2289 elsif Present
(Target_Ref
)
2290 and then Nkind
(Target_Ref
) in N_Indexed_Component
2291 | N_Selected_Component
2293 A_Type
:= Etype
(Prefix
(Target_Ref
));
2296 A_Type
:= Full_Type
;
2300 Build_Task_Image_Decls
(Loc
,
2301 (if Present
(Target_Ref
) then Target_Ref
else Id_Ref
),
2304 Decl
:= Last
(Decls
);
2307 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
2308 Append_List
(Decls
, Res
);
2316 -- Handle the optionally generated formal *_skip_null_excluding_checks
2318 -- Look at the associated node for the object we are referencing and
2319 -- verify that we are expanding a call to an Init_Proc for an internally
2320 -- generated object declaration before passing True and skipping the
2323 if Needs_Conditional_Null_Excluding_Check
(Full_Init_Type
)
2324 and then Nkind
(Id_Ref
) in N_Has_Entity
2325 and then (Comes_From_Source
(Id_Ref
)
2326 or else (Present
(Associated_Node
(Id_Ref
))
2327 and then Comes_From_Source
2328 (Associated_Node
(Id_Ref
))))
2330 Append_To
(Args
, New_Occurrence_Of
(Standard_True
, Loc
));
2333 -- Add discriminant values if discriminants are present
2335 if Has_Discriminants
(Full_Init_Type
) then
2336 -- If an allocated object will be constrained by the default
2337 -- values for discriminants, then build a subtype with those
2338 -- defaults, and change the allocated subtype to that. Note
2339 -- that this happens in fewer cases in Ada 2005 (AI95-0363).
2341 if Nkind
(N
) = N_Allocator
2342 and then not Is_Constrained
(Full_Type
)
2345 (Discriminant_Default_Value
(First_Discriminant
(Full_Type
)))
2346 and then (Ada_Version
< Ada_2005
2347 or else not Object_Type_Has_Constrained_Partial_View
2348 (Full_Type
, Current_Scope
))
2350 Full_Type
:= Build_Default_Subtype
(Full_Type
, N
);
2351 Set_Expression
(N
, New_Occurrence_Of
(Full_Type
, Loc
));
2354 Discr
:= First_Discriminant
(Full_Init_Type
);
2355 while Present
(Discr
) loop
2357 -- If this is a discriminated concurrent type, the init_proc
2358 -- for the corresponding record is being called. Use that type
2359 -- directly to find the discriminant value, to handle properly
2360 -- intervening renamed discriminants.
2363 T
: Entity_Id
:= Full_Type
;
2366 if Is_Protected_Type
(T
) then
2367 T
:= Corresponding_Record_Type
(T
);
2371 Get_Discriminant_Value
(
2374 Discriminant_Constraint
(Full_Type
));
2377 -- If the target has access discriminants, and is constrained by
2378 -- an access to the enclosing construct, i.e. a current instance,
2379 -- replace the reference to the type by a reference to the object.
2381 if Nkind
(Arg
) = N_Attribute_Reference
2382 and then Is_Access_Type
(Etype
(Arg
))
2383 and then Is_Entity_Name
(Prefix
(Arg
))
2384 and then Is_Type
(Entity
(Prefix
(Arg
)))
2387 Make_Attribute_Reference
(Loc
,
2388 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
2389 Attribute_Name
=> Name_Unrestricted_Access
);
2391 elsif In_Init_Proc
then
2393 -- Replace any possible references to the discriminant in the
2394 -- call to the record initialization procedure with references
2395 -- to the appropriate formal parameter.
2397 if Nkind
(Arg
) = N_Identifier
2398 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2400 Arg
:= New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
);
2402 -- Otherwise make a copy of the default expression. Note that
2403 -- we use the current Sloc for this, because we do not want the
2404 -- call to appear to be at the declaration point. Within the
2405 -- expression, replace discriminants with their discriminals.
2409 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
2413 if Is_Constrained
(Full_Type
) then
2414 Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
2416 -- The constraints come from the discriminant default exps,
2417 -- they must be reevaluated, so we use New_Copy_Tree but we
2418 -- ensure the proper Sloc (for any embedded calls).
2419 -- In addition, if a predicate check is needed on the value
2420 -- of the discriminant, insert it ahead of the call.
2422 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
2425 if Has_Predicates
(Etype
(Discr
)) then
2426 Check_Predicated_Discriminant
(Arg
, Discr
);
2430 -- Ada 2005 (AI-287): In case of default initialized components,
2431 -- if the component is constrained with a discriminant of the
2432 -- enclosing type, we need to generate the corresponding selected
2433 -- component node to access the discriminant value. In other cases
2434 -- this is not required, either because we are inside the init
2435 -- proc and we use the corresponding formal, or else because the
2436 -- component is constrained by an expression.
2438 if With_Default_Init
2439 and then Nkind
(Id_Ref
) = N_Selected_Component
2440 and then Nkind
(Arg
) = N_Identifier
2441 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2444 Make_Selected_Component
(Loc
,
2445 Prefix
=> New_Copy_Tree
(Prefix
(Id_Ref
)),
2446 Selector_Name
=> Arg
));
2448 Append_To
(Args
, Arg
);
2451 Next_Discriminant
(Discr
);
2455 -- If this is a call to initialize the parent component of a derived
2456 -- tagged type, indicate that the tag should not be set in the parent.
2457 -- This is done via the actual parameter value for the Init_Control
2458 -- formal parameter, which is also used to deal with late initialization
2461 -- We pass in Full_Init_Except_Tag unless the caller tells us to do
2462 -- otherwise (by passing in a nonempty Init_Control_Actual parameter).
2464 if Is_Tagged_Type
(Full_Init_Type
)
2465 and then not Is_CPP_Class
(Full_Init_Type
)
2466 and then Nkind
(Id_Ref
) = N_Selected_Component
2467 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
2470 use Initialization_Control
;
2473 (if Present
(Init_Control_Actual
)
2474 then Init_Control_Actual
2475 else Make_Mode_Literal
(Loc
, Full_Init_Except_Tag
)));
2477 elsif Present
(Constructor_Ref
) then
2478 Append_List_To
(Args
,
2479 New_Copy_List
(Parameter_Associations
(Constructor_Ref
)));
2482 -- Pass the extra accessibility level parameter associated with the
2483 -- level of the object being initialized when required.
2485 if Is_Entity_Name
(Id_Ref
)
2486 and then Present
(Init_Proc_Level_Formal
(Proc
))
2489 Make_Parameter_Association
(Loc
,
2491 Make_Identifier
(Loc
, Name_uInit_Level
),
2492 Explicit_Actual_Parameter
=>
2493 Accessibility_Level
(Id_Ref
, Dynamic_Level
)));
2497 Make_Procedure_Call_Statement
(Loc
,
2498 Name
=> New_Occurrence_Of
(Proc
, Loc
),
2499 Parameter_Associations
=> Args
));
2501 if Needs_Finalization
(Typ
)
2502 and then Nkind
(Id_Ref
) = N_Selected_Component
2504 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
2507 (Obj_Ref
=> New_Copy_Tree
(First_Arg
),
2510 -- Guard against a missing [Deep_]Initialize when the type was not
2513 if Present
(Init_Call
) then
2514 Append_To
(Res
, Init_Call
);
2522 when RE_Not_Available
=>
2524 end Build_Initialization_Call
;
2526 ----------------------------
2527 -- Build_Record_Init_Proc --
2528 ----------------------------
2530 procedure Build_Record_Init_Proc
(N
: Node_Id
; Rec_Ent
: Entity_Id
) is
2531 Decls
: constant List_Id
:= New_List
;
2532 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
2533 Loc
: constant Source_Ptr
:= Sloc
(Rec_Ent
);
2535 Proc_Id
: Entity_Id
;
2536 Rec_Type
: Entity_Id
;
2538 Init_Control_Formal
: Entity_Id
:= Empty
; -- set in Build_Init_Statements
2539 Has_Late_Init_Comp
: Boolean := False; -- set in Build_Init_Statements
2541 function Build_Assignment
2543 Default
: Node_Id
) return List_Id
;
2544 -- Build an assignment statement that assigns the default expression to
2545 -- its corresponding record component if defined. The left-hand side of
2546 -- the assignment is marked Assignment_OK so that initialization of
2547 -- limited private records works correctly. This routine may also build
2548 -- an adjustment call if the component is controlled.
2550 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
2551 -- If the record has discriminants, add assignment statements to
2552 -- Statement_List to initialize the discriminant values from the
2553 -- arguments of the initialization procedure.
2555 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
2556 -- Build a list representing a sequence of statements which initialize
2557 -- components of the given component list. This may involve building
2558 -- case statements for the variant parts. Append any locally declared
2559 -- objects on list Decls.
2561 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
;
2562 -- Given an untagged type-derivation that declares discriminants, e.g.
2564 -- type R (R1, R2 : Integer) is record ... end record;
2565 -- type D (D1 : Integer) is new R (1, D1);
2567 -- we make the _init_proc of D be
2569 -- procedure _init_proc (X : D; D1 : Integer) is
2571 -- _init_proc (R (X), 1, D1);
2574 -- This function builds the call statement in this _init_proc.
2576 procedure Build_CPP_Init_Procedure
;
2577 -- Build the tree corresponding to the procedure specification and body
2578 -- of the IC procedure that initializes the C++ part of the dispatch
2579 -- table of an Ada tagged type that is a derivation of a CPP type.
2580 -- Install it as the CPP_Init TSS.
2582 procedure Build_Init_Procedure
;
2583 -- Build the tree corresponding to the procedure specification and body
2584 -- of the initialization procedure and install it as the _init TSS.
2586 procedure Build_Offset_To_Top_Functions
;
2587 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
2588 -- and body of Offset_To_Top, a function used in conjuction with types
2589 -- having secondary dispatch tables.
2591 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
2592 -- Add range checks to components of discriminated records. S is a
2593 -- subtype indication of a record component. Check_List is a list
2594 -- to which the check actions are appended.
2596 function Component_Needs_Simple_Initialization
2597 (T
: Entity_Id
) return Boolean;
2598 -- Determine if a component needs simple initialization, given its type
2599 -- T. This routine is the same as Needs_Simple_Initialization except for
2600 -- components of type Tag and Interface_Tag. These two access types do
2601 -- not require initialization since they are explicitly initialized by
2604 function Parent_Subtype_Renaming_Discrims
return Boolean;
2605 -- Returns True for base types N that rename discriminants, else False
2607 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
2608 -- Determine whether a record initialization procedure needs to be
2609 -- generated for the given record type.
2611 ----------------------
2612 -- Build_Assignment --
2613 ----------------------
2615 function Build_Assignment
2617 Default
: Node_Id
) return List_Id
2619 Default_Loc
: constant Source_Ptr
:= Sloc
(Default
);
2620 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
2630 Make_Selected_Component
(Default_Loc
,
2631 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2632 Selector_Name
=> New_Occurrence_Of
(Id
, Default_Loc
));
2633 Set_Assignment_OK
(Lhs
);
2635 -- Take copy of Default to ensure that later copies of this component
2636 -- declaration in derived types see the original tree, not a node
2637 -- rewritten during expansion of the init_proc. If the copy contains
2638 -- itypes, the scope of the new itypes is the init_proc being built.
2641 Map
: Elist_Id
:= No_Elist
;
2644 if Has_Late_Init_Comp
then
2645 -- Map the type to the _Init parameter in order to
2646 -- handle "current instance" references.
2648 Map
:= New_Elmt_List
2650 Elmt2
=> Defining_Identifier
(First
2651 (Parameter_Specifications
2652 (Parent
(Proc_Id
)))));
2654 -- If the type has an incomplete view, a current instance
2655 -- may have an incomplete type. In that case, it must also be
2656 -- replaced by the formal of the Init_Proc.
2658 if Nkind
(Parent
(Rec_Type
)) = N_Full_Type_Declaration
2659 and then Present
(Incomplete_View
(Parent
(Rec_Type
)))
2662 N
=> Incomplete_View
(Parent
(Rec_Type
)),
2665 N
=> Defining_Identifier
2667 (Parameter_Specifications
2668 (Parent
(Proc_Id
)))),
2673 Exp
:= New_Copy_Tree
(Default
, New_Scope
=> Proc_Id
, Map
=> Map
);
2677 Make_Assignment_Statement
(Loc
,
2679 Expression
=> Exp
));
2681 Set_No_Ctrl_Actions
(First
(Res
));
2683 Exp_Q
:= Unqualify
(Exp
);
2685 -- Adjust the tag if tagged (because of possible view conversions).
2686 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2687 -- tags are represented implicitly in objects, and when the record is
2688 -- initialized with a raise expression.
2690 if Is_Tagged_Type
(Typ
)
2691 and then Tagged_Type_Expansion
2692 and then Nkind
(Exp_Q
) /= N_Raise_Expression
2695 Make_Tag_Assignment_From_Type
2697 New_Copy_Tree
(Lhs
, New_Scope
=> Proc_Id
),
2698 Underlying_Type
(Typ
)));
2701 -- Adjust the component if controlled except if it is an aggregate
2702 -- that will be expanded inline.
2704 if Needs_Finalization
(Typ
)
2705 and then Nkind
(Exp_Q
) not in N_Aggregate | N_Extension_Aggregate
2706 and then not Is_Build_In_Place_Function_Call
(Exp
)
2710 (Obj_Ref
=> New_Copy_Tree
(Lhs
),
2713 -- Guard against a missing [Deep_]Adjust when the component type
2714 -- was not properly frozen.
2716 if Present
(Adj_Call
) then
2717 Append_To
(Res
, Adj_Call
);
2724 when RE_Not_Available
=>
2726 end Build_Assignment
;
2728 ------------------------------------
2729 -- Build_Discriminant_Assignments --
2730 ------------------------------------
2732 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
2733 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
2738 if Has_Discriminants
(Rec_Type
)
2739 and then not Is_Unchecked_Union
(Rec_Type
)
2741 D
:= First_Discriminant
(Rec_Type
);
2742 while Present
(D
) loop
2744 -- Don't generate the assignment for discriminants in derived
2745 -- tagged types if the discriminant is a renaming of some
2746 -- ancestor discriminant. This initialization will be done
2747 -- when initializing the _parent field of the derived record.
2750 and then Present
(Corresponding_Discriminant
(D
))
2756 Append_List_To
(Statement_List
,
2757 Build_Assignment
(D
,
2758 New_Occurrence_Of
(Discriminal
(D
), D_Loc
)));
2761 Next_Discriminant
(D
);
2764 end Build_Discriminant_Assignments
;
2766 --------------------------
2767 -- Build_Init_Call_Thru --
2768 --------------------------
2770 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
is
2771 Parent_Proc
: constant Entity_Id
:=
2772 Base_Init_Proc
(Etype
(Rec_Type
));
2774 Parent_Type
: constant Entity_Id
:=
2775 Etype
(First_Formal
(Parent_Proc
));
2777 Uparent_Type
: constant Entity_Id
:=
2778 Underlying_Type
(Parent_Type
);
2780 First_Discr_Param
: Node_Id
;
2784 First_Arg
: Node_Id
;
2785 Parent_Discr
: Entity_Id
;
2789 -- First argument (_Init) is the object to be initialized.
2790 -- ??? not sure where to get a reasonable Loc for First_Arg
2793 OK_Convert_To
(Parent_Type
,
2795 (Defining_Identifier
(First
(Parameters
)), Loc
));
2797 Set_Etype
(First_Arg
, Parent_Type
);
2799 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
2801 -- In the tasks case,
2802 -- add _Master as the value of the _Master parameter
2803 -- add _Chain as the value of the _Chain parameter.
2804 -- add _Task_Name as the value of the _Task_Name parameter.
2805 -- At the outer level, these will be variables holding the
2806 -- corresponding values obtained from GNARL or the expander.
2808 -- At inner levels, they will be the parameters passed down through
2809 -- the outer routines.
2811 First_Discr_Param
:= Next
(First
(Parameters
));
2813 if Has_Task
(Rec_Type
) then
2814 if Restriction_Active
(No_Task_Hierarchy
) then
2816 (Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
2818 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
2821 -- Add _Chain (not done for sequential elaboration policy, see
2822 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2824 if Partition_Elaboration_Policy
/= 'S' then
2825 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2828 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
2829 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
2832 -- Append discriminant values
2834 if Has_Discriminants
(Uparent_Type
) then
2835 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
2837 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
2838 while Present
(Parent_Discr
) loop
2840 -- Get the initial value for this discriminant
2841 -- ??? needs to be cleaned up to use parent_Discr_Constr
2845 Discr
: Entity_Id
:=
2846 First_Stored_Discriminant
(Uparent_Type
);
2848 Discr_Value
: Elmt_Id
:=
2849 First_Elmt
(Stored_Constraint
(Rec_Type
));
2852 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
2853 Next_Stored_Discriminant
(Discr
);
2854 Next_Elmt
(Discr_Value
);
2857 Arg
:= Node
(Discr_Value
);
2860 -- Append it to the list
2862 if Nkind
(Arg
) = N_Identifier
2863 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2866 New_Occurrence_Of
(Discriminal
(Entity
(Arg
)), Loc
));
2868 -- Case of access discriminants. We replace the reference
2869 -- to the type by a reference to the actual object.
2871 -- Is above comment right??? Use of New_Copy below seems mighty
2875 Append_To
(Args
, New_Copy
(Arg
));
2878 Next_Discriminant
(Parent_Discr
);
2884 Make_Procedure_Call_Statement
(Loc
,
2886 New_Occurrence_Of
(Parent_Proc
, Loc
),
2887 Parameter_Associations
=> Args
));
2890 end Build_Init_Call_Thru
;
2892 -----------------------------------
2893 -- Build_Offset_To_Top_Functions --
2894 -----------------------------------
2896 procedure Build_Offset_To_Top_Functions
is
2898 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
);
2900 -- function Fxx (O : Address) return Storage_Offset is
2901 -- type Acc is access all <Typ>;
2903 -- return Acc!(O).Iface_Comp'Position;
2906 ----------------------------------
2907 -- Build_Offset_To_Top_Function --
2908 ----------------------------------
2910 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
) is
2911 Body_Node
: Node_Id
;
2912 Func_Id
: Entity_Id
;
2913 Spec_Node
: Node_Id
;
2914 Acc_Type
: Entity_Id
;
2917 Func_Id
:= Make_Temporary
(Loc
, 'F');
2918 Set_DT_Offset_To_Top_Func
(Iface_Comp
, Func_Id
);
2921 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2923 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
2924 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
2925 Set_Parameter_Specifications
(Spec_Node
, New_List
(
2926 Make_Parameter_Specification
(Loc
,
2927 Defining_Identifier
=>
2928 Make_Defining_Identifier
(Loc
, Name_uO
),
2931 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))));
2932 Set_Result_Definition
(Spec_Node
,
2933 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
));
2936 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2938 -- return -O.Iface_Comp'Position;
2941 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2942 Set_Specification
(Body_Node
, Spec_Node
);
2944 Acc_Type
:= Make_Temporary
(Loc
, 'T');
2945 Set_Declarations
(Body_Node
, New_List
(
2946 Make_Full_Type_Declaration
(Loc
,
2947 Defining_Identifier
=> Acc_Type
,
2949 Make_Access_To_Object_Definition
(Loc
,
2950 All_Present
=> True,
2951 Null_Exclusion_Present
=> False,
2952 Constant_Present
=> False,
2953 Subtype_Indication
=>
2954 New_Occurrence_Of
(Rec_Type
, Loc
)))));
2956 Set_Handled_Statement_Sequence
(Body_Node
,
2957 Make_Handled_Sequence_Of_Statements
(Loc
,
2958 Statements
=> New_List
(
2959 Make_Simple_Return_Statement
(Loc
,
2962 Make_Attribute_Reference
(Loc
,
2964 Make_Selected_Component
(Loc
,
2966 Make_Explicit_Dereference
(Loc
,
2967 Unchecked_Convert_To
(Acc_Type
,
2968 Make_Identifier
(Loc
, Name_uO
))),
2970 New_Occurrence_Of
(Iface_Comp
, Loc
)),
2971 Attribute_Name
=> Name_Position
))))));
2973 Mutate_Ekind
(Func_Id
, E_Function
);
2974 Set_Mechanism
(Func_Id
, Default_Mechanism
);
2975 Set_Is_Internal
(Func_Id
, True);
2977 if not Debug_Generated_Code
then
2978 Set_Debug_Info_Off
(Func_Id
);
2981 Analyze
(Body_Node
);
2983 Append_Freeze_Action
(Rec_Type
, Body_Node
);
2984 end Build_Offset_To_Top_Function
;
2988 Iface_Comp
: Node_Id
;
2989 Iface_Comp_Elmt
: Elmt_Id
;
2990 Ifaces_Comp_List
: Elist_Id
;
2992 -- Start of processing for Build_Offset_To_Top_Functions
2995 -- Offset_To_Top_Functions are built only for derivations of types
2996 -- with discriminants that cover interface types.
2997 -- Nothing is needed either in case of virtual targets, since
2998 -- interfaces are handled directly by the target.
3000 if not Is_Tagged_Type
(Rec_Type
)
3001 or else Etype
(Rec_Type
) = Rec_Type
3002 or else not Has_Discriminants
(Etype
(Rec_Type
))
3003 or else not Tagged_Type_Expansion
3008 Collect_Interface_Components
(Rec_Type
, Ifaces_Comp_List
);
3010 -- For each interface type with secondary dispatch table we generate
3011 -- the Offset_To_Top_Functions (required to displace the pointer in
3012 -- interface conversions)
3014 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
3015 while Present
(Iface_Comp_Elmt
) loop
3016 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
3017 pragma Assert
(Is_Interface
(Related_Type
(Iface_Comp
)));
3019 -- If the interface is a parent of Rec_Type it shares the primary
3020 -- dispatch table and hence there is no need to build the function
3022 if not Is_Ancestor
(Related_Type
(Iface_Comp
), Rec_Type
,
3023 Use_Full_View
=> True)
3025 Build_Offset_To_Top_Function
(Iface_Comp
);
3028 Next_Elmt
(Iface_Comp_Elmt
);
3030 end Build_Offset_To_Top_Functions
;
3032 ------------------------------
3033 -- Build_CPP_Init_Procedure --
3034 ------------------------------
3036 procedure Build_CPP_Init_Procedure
is
3037 Body_Node
: Node_Id
;
3038 Body_Stmts
: List_Id
;
3039 Flag_Id
: Entity_Id
;
3040 Handled_Stmt_Node
: Node_Id
;
3041 Init_Tags_List
: List_Id
;
3042 Proc_Id
: Entity_Id
;
3043 Proc_Spec_Node
: Node_Id
;
3046 -- Check cases requiring no IC routine
3048 if not Is_CPP_Class
(Root_Type
(Rec_Type
))
3049 or else Is_CPP_Class
(Rec_Type
)
3050 or else CPP_Num_Prims
(Rec_Type
) = 0
3051 or else not Tagged_Type_Expansion
3052 or else No_Run_Time_Mode
3059 -- Flag : Boolean := False;
3061 -- procedure Typ_IC is
3064 -- Copy C++ dispatch table slots from parent
3065 -- Update C++ slots of overridden primitives
3069 Flag_Id
:= Make_Temporary
(Loc
, 'F');
3071 Append_Freeze_Action
(Rec_Type
,
3072 Make_Object_Declaration
(Loc
,
3073 Defining_Identifier
=> Flag_Id
,
3074 Object_Definition
=>
3075 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3077 New_Occurrence_Of
(Standard_True
, Loc
)));
3079 Body_Stmts
:= New_List
;
3080 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
3082 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
3085 Make_Defining_Identifier
(Loc
,
3086 Chars
=> Make_TSS_Name
(Rec_Type
, TSS_CPP_Init_Proc
));
3088 Mutate_Ekind
(Proc_Id
, E_Procedure
);
3089 Set_Is_Internal
(Proc_Id
);
3091 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
3093 Set_Parameter_Specifications
(Proc_Spec_Node
, New_List
);
3094 Set_Specification
(Body_Node
, Proc_Spec_Node
);
3095 Set_Declarations
(Body_Node
, New_List
);
3097 Init_Tags_List
:= Build_Inherit_CPP_Prims
(Rec_Type
);
3099 Append_To
(Init_Tags_List
,
3100 Make_Assignment_Statement
(Loc
,
3102 New_Occurrence_Of
(Flag_Id
, Loc
),
3104 New_Occurrence_Of
(Standard_False
, Loc
)));
3106 Append_To
(Body_Stmts
,
3107 Make_If_Statement
(Loc
,
3108 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
3109 Then_Statements
=> Init_Tags_List
));
3111 Handled_Stmt_Node
:=
3112 New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
3113 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
3114 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
3115 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
3117 if not Debug_Generated_Code
then
3118 Set_Debug_Info_Off
(Proc_Id
);
3121 -- Associate CPP_Init_Proc with type
3123 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3124 end Build_CPP_Init_Procedure
;
3126 --------------------------
3127 -- Build_Init_Procedure --
3128 --------------------------
3130 procedure Build_Init_Procedure
is
3131 Body_Stmts
: List_Id
;
3132 Body_Node
: Node_Id
;
3133 Handled_Stmt_Node
: Node_Id
;
3134 Init_Tags_List
: List_Id
;
3135 Parameters
: List_Id
;
3136 Proc_Spec_Node
: Node_Id
;
3137 Record_Extension_Node
: Node_Id
;
3139 use Initialization_Control
;
3141 Body_Stmts
:= New_List
;
3142 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
3143 Mutate_Ekind
(Proc_Id
, E_Procedure
);
3145 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
3146 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
3148 Parameters
:= Init_Formals
(Rec_Type
, Proc_Id
);
3149 Append_List_To
(Parameters
,
3150 Build_Discriminant_Formals
(Rec_Type
, True));
3152 -- For tagged types, we add a parameter to indicate what
3153 -- portion of the object's initialization is to be performed.
3154 -- This is used for two purposes:
3155 -- 1) When a type extension's initialization procedure calls
3156 -- the initialization procedure of the parent type, we do
3157 -- not want the parent to initialize the Tag component;
3158 -- it has been set already.
3159 -- 2) If an ancestor type has at least one component that requires
3160 -- late initialization, then we need to be able to initialize
3161 -- those components separately after initializing any other
3164 if Is_Tagged_Type
(Rec_Type
) then
3165 Init_Control_Formal
:= Make_Temporary
(Loc
, 'P');
3167 Append_To
(Parameters
,
3168 Make_Parameter_Specification
(Loc
,
3169 Defining_Identifier
=> Init_Control_Formal
,
3171 New_Occurrence_Of
(Standard_Natural
, Loc
),
3172 Expression
=> Make_Mode_Literal
(Loc
, Full_Init
)));
3175 -- Create an extra accessibility parameter to capture the level of
3176 -- the object being initialized when its type is a limited record.
3178 if Is_Limited_Record
(Rec_Type
) then
3179 Append_To
(Parameters
,
3180 Make_Parameter_Specification
(Loc
,
3181 Defining_Identifier
=> Make_Defining_Identifier
3182 (Loc
, Name_uInit_Level
),
3184 New_Occurrence_Of
(Standard_Natural
, Loc
),
3186 Make_Integer_Literal
3187 (Loc
, Scope_Depth
(Standard_Standard
))));
3190 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
3191 Set_Specification
(Body_Node
, Proc_Spec_Node
);
3192 Set_Declarations
(Body_Node
, Decls
);
3194 -- N is a Derived_Type_Definition that renames the parameters of the
3195 -- ancestor type. We initialize it by expanding our discriminants and
3196 -- call the ancestor _init_proc with a type-converted object.
3198 if Parent_Subtype_Renaming_Discrims
then
3199 Append_List_To
(Body_Stmts
, Build_Init_Call_Thru
(Parameters
));
3201 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
3202 Build_Discriminant_Assignments
(Body_Stmts
);
3204 if not Null_Present
(Type_Definition
(N
)) then
3205 Append_List_To
(Body_Stmts
,
3206 Build_Init_Statements
(Component_List
(Type_Definition
(N
))));
3209 -- N is a Derived_Type_Definition with a possible non-empty
3210 -- extension. The initialization of a type extension consists in the
3211 -- initialization of the components in the extension.
3214 Build_Discriminant_Assignments
(Body_Stmts
);
3216 Record_Extension_Node
:=
3217 Record_Extension_Part
(Type_Definition
(N
));
3219 if not Null_Present
(Record_Extension_Node
) then
3221 Stmts
: constant List_Id
:=
3222 Build_Init_Statements
(
3223 Component_List
(Record_Extension_Node
));
3226 -- The parent field must be initialized first because the
3227 -- offset of the new discriminants may depend on it. This is
3228 -- not needed if the parent is an interface type because in
3229 -- such case the initialization of the _parent field was not
3232 if not Is_Interface
(Etype
(Rec_Ent
)) then
3234 Parent_IP
: constant Name_Id
:=
3235 Make_Init_Proc_Name
(Etype
(Rec_Ent
));
3236 Stmt
: Node_Id
:= First
(Stmts
);
3237 IP_Call
: Node_Id
:= Empty
;
3239 -- Look for a call to the parent IP associated with
3240 -- the record extension.
3241 -- The call will be inside not one but two
3242 -- if-statements (with the same condition). Testing
3243 -- the same Early_Init condition twice might seem
3244 -- redundant. However, as soon as we exit this loop,
3245 -- we are going to hoist the inner if-statement out
3246 -- of the outer one; the "redundant" test was built
3247 -- in anticipation of this hoisting.
3249 while Present
(Stmt
) loop
3250 if Nkind
(Stmt
) = N_If_Statement
then
3252 Then_Stmt1
: Node_Id
:=
3253 First
(Then_Statements
(Stmt
));
3254 Then_Stmt2
: Node_Id
;
3256 while Present
(Then_Stmt1
) loop
3257 if Nkind
(Then_Stmt1
) = N_If_Statement
then
3259 First
(Then_Statements
(Then_Stmt1
));
3261 if Nkind
(Then_Stmt2
) =
3262 N_Procedure_Call_Statement
3263 and then Chars
(Name
(Then_Stmt2
)) =
3266 -- IP_Call is a call wrapped in an
3268 IP_Call
:= Then_Stmt1
;
3280 -- If found then move it to the beginning of the
3281 -- statements of this IP routine
3283 if Present
(IP_Call
) then
3285 Prepend_List_To
(Body_Stmts
, New_List
(IP_Call
));
3290 Append_List_To
(Body_Stmts
, Stmts
);
3295 -- Add here the assignment to instantiate the Tag
3297 -- The assignment corresponds to the code:
3299 -- _Init._Tag := Typ'Tag;
3301 -- Suppress the tag assignment when not Tagged_Type_Expansion because
3302 -- tags are represented implicitly in objects. It is also suppressed
3303 -- in case of CPP_Class types because in this case the tag is
3304 -- initialized in the C++ side.
3306 if Is_Tagged_Type
(Rec_Type
)
3307 and then Tagged_Type_Expansion
3308 and then not No_Run_Time_Mode
3310 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
3311 -- the actual object and invoke the IP of the parent (in this
3312 -- order). The tag must be initialized before the call to the IP
3313 -- of the parent and the assignments to other components because
3314 -- the initial value of the components may depend on the tag (eg.
3315 -- through a dispatching operation on an access to the current
3316 -- type). The tag assignment is not done when initializing the
3317 -- parent component of a type extension, because in that case the
3318 -- tag is set in the extension.
3320 if not Is_CPP_Class
(Root_Type
(Rec_Type
)) then
3322 -- Initialize the primary tag component
3324 Init_Tags_List
:= New_List
(
3325 Make_Tag_Assignment_From_Type
3326 (Loc
, Make_Identifier
(Loc
, Name_uInit
), Rec_Type
));
3328 -- Ada 2005 (AI-251): Initialize the secondary tags components
3329 -- located at fixed positions (tags whose position depends on
3330 -- variable size components are initialized later ---see below)
3332 if Ada_Version
>= Ada_2005
3333 and then not Is_Interface
(Rec_Type
)
3334 and then Has_Interfaces
(Rec_Type
)
3337 Elab_Sec_DT_Stmts_List
: constant List_Id
:= New_List
;
3338 Elab_List
: List_Id
:= New_List
;
3343 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3344 Init_Tags_List
=> Init_Tags_List
,
3345 Stmts_List
=> Elab_Sec_DT_Stmts_List
,
3346 Fixed_Comps
=> True,
3347 Variable_Comps
=> False);
3349 Elab_List
:= New_List
(
3350 Make_If_Statement
(Loc
,
3352 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
3353 Then_Statements
=> Init_Tags_List
));
3355 if Elab_Flag_Needed
(Rec_Type
) then
3356 Append_To
(Elab_Sec_DT_Stmts_List
,
3357 Make_Assignment_Statement
(Loc
,
3360 (Access_Disp_Table_Elab_Flag
(Rec_Type
),
3363 New_Occurrence_Of
(Standard_False
, Loc
)));
3365 Append_To
(Elab_List
,
3366 Make_If_Statement
(Loc
,
3369 (Access_Disp_Table_Elab_Flag
(Rec_Type
), Loc
),
3370 Then_Statements
=> Elab_Sec_DT_Stmts_List
));
3373 Prepend_List_To
(Body_Stmts
, Elab_List
);
3376 Prepend_To
(Body_Stmts
,
3377 Make_If_Statement
(Loc
,
3379 Tag_Init_Condition
(Loc
, Init_Control_Formal
),
3380 Then_Statements
=> Init_Tags_List
));
3383 -- Case 2: CPP type. The imported C++ constructor takes care of
3384 -- tags initialization. No action needed here because the IP
3385 -- is built by Set_CPP_Constructors; in this case the IP is a
3386 -- wrapper that invokes the C++ constructor and copies the C++
3387 -- tags locally. Done to inherit the C++ slots in Ada derivations
3390 elsif Is_CPP_Class
(Rec_Type
) then
3391 pragma Assert
(False);
3394 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
3395 -- type derivations. Derivations of imported C++ classes add a
3396 -- complication, because we cannot inhibit tag setting in the
3397 -- constructor for the parent. Hence we initialize the tag after
3398 -- the call to the parent IP (that is, in reverse order compared
3399 -- with pure Ada hierarchies ---see comment on case 1).
3402 -- Initialize the primary tag
3404 Init_Tags_List
:= New_List
(
3405 Make_Tag_Assignment_From_Type
3406 (Loc
, Make_Identifier
(Loc
, Name_uInit
), Rec_Type
));
3408 -- Ada 2005 (AI-251): Initialize the secondary tags components
3409 -- located at fixed positions (tags whose position depends on
3410 -- variable size components are initialized later ---see below)
3412 if Ada_Version
>= Ada_2005
3413 and then not Is_Interface
(Rec_Type
)
3414 and then Has_Interfaces
(Rec_Type
)
3418 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3419 Init_Tags_List
=> Init_Tags_List
,
3420 Stmts_List
=> Init_Tags_List
,
3421 Fixed_Comps
=> True,
3422 Variable_Comps
=> False);
3425 -- Initialize the tag component after invocation of parent IP.
3428 -- parent_IP(_init.parent); // Invokes the C++ constructor
3429 -- [ typIC; ] // Inherit C++ slots from parent
3436 -- Search for the call to the IP of the parent. We assume
3437 -- that the first init_proc call is for the parent.
3438 -- It is wrapped in an "if Early_Init_Condition"
3441 Ins_Nod
:= First
(Body_Stmts
);
3442 while Present
(Next
(Ins_Nod
))
3444 (Nkind
(Ins_Nod
) /= N_If_Statement
3445 or else Nkind
(First
(Then_Statements
(Ins_Nod
)))
3446 /= N_Procedure_Call_Statement
3447 or else not Is_Init_Proc
3448 (Name
(First
(Then_Statements
3454 -- The IC routine copies the inherited slots of the C+ part
3455 -- of the dispatch table from the parent and updates the
3456 -- overridden C++ slots.
3458 if CPP_Num_Prims
(Rec_Type
) > 0 then
3460 Init_DT
: Entity_Id
;
3464 Init_DT
:= CPP_Init_Proc
(Rec_Type
);
3465 pragma Assert
(Present
(Init_DT
));
3468 Make_Procedure_Call_Statement
(Loc
,
3469 New_Occurrence_Of
(Init_DT
, Loc
));
3470 Insert_After
(Ins_Nod
, New_Nod
);
3472 -- Update location of init tag statements
3478 Insert_List_After
(Ins_Nod
, Init_Tags_List
);
3482 -- Ada 2005 (AI-251): Initialize the secondary tag components
3483 -- located at variable positions. We delay the generation of this
3484 -- code until here because the value of the attribute 'Position
3485 -- applied to variable size components of the parent type that
3486 -- depend on discriminants is only safely read at runtime after
3487 -- the parent components have been initialized.
3489 if Ada_Version
>= Ada_2005
3490 and then not Is_Interface
(Rec_Type
)
3491 and then Has_Interfaces
(Rec_Type
)
3492 and then Has_Discriminants
(Etype
(Rec_Type
))
3493 and then Is_Variable_Size_Record
(Etype
(Rec_Type
))
3495 Init_Tags_List
:= New_List
;
3499 Target
=> Make_Identifier
(Loc
, Name_uInit
),
3500 Init_Tags_List
=> Init_Tags_List
,
3501 Stmts_List
=> Init_Tags_List
,
3502 Fixed_Comps
=> False,
3503 Variable_Comps
=> True);
3505 Append_List_To
(Body_Stmts
, Init_Tags_List
);
3509 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
3510 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
3513 -- Deep_Finalize (_init, C1, ..., CN);
3517 and then Needs_Finalization
(Rec_Type
)
3518 and then not Is_Abstract_Type
(Rec_Type
)
3519 and then not Restriction_Active
(No_Exception_Propagation
)
3526 -- Create a local version of Deep_Finalize which has indication
3527 -- of partial initialization state.
3530 Make_Defining_Identifier
(Loc
,
3531 Chars
=> New_External_Name
(Name_uFinalizer
));
3533 Append_To
(Decls
, Make_Local_Deep_Finalize
(Rec_Type
, DF_Id
));
3536 Make_Procedure_Call_Statement
(Loc
,
3537 Name
=> New_Occurrence_Of
(DF_Id
, Loc
),
3538 Parameter_Associations
=> New_List
(
3539 Make_Identifier
(Loc
, Name_uInit
),
3540 New_Occurrence_Of
(Standard_False
, Loc
)));
3542 -- Do not emit warnings related to the elaboration order when a
3543 -- controlled object is declared before the body of Finalize is
3546 if Legacy_Elaboration_Checks
then
3547 Set_No_Elaboration_Check
(DF_Call
);
3550 Set_Exception_Handlers
(Handled_Stmt_Node
, New_List
(
3551 Make_Exception_Handler
(Loc
,
3552 Exception_Choices
=> New_List
(
3553 Make_Others_Choice
(Loc
)),
3554 Statements
=> New_List
(
3556 Make_Raise_Statement
(Loc
)))));
3559 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
3562 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
3564 if not Debug_Generated_Code
then
3565 Set_Debug_Info_Off
(Proc_Id
);
3568 -- Associate Init_Proc with type, and determine if the procedure
3569 -- is null (happens because of the Initialize_Scalars pragma case,
3570 -- where we have to generate a null procedure in case it is called
3571 -- by a client with Initialize_Scalars set). Such procedures have
3572 -- to be generated, but do not have to be called, so we mark them
3573 -- as null to suppress the call. Kill also warnings for the _Init
3574 -- out parameter, which is left entirely uninitialized.
3576 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3578 if Is_Null_Statement_List
(Body_Stmts
) then
3579 Set_Is_Null_Init_Proc
(Proc_Id
);
3580 Set_Warnings_Off
(Defining_Identifier
(First
(Parameters
)));
3582 end Build_Init_Procedure
;
3584 ---------------------------
3585 -- Build_Init_Statements --
3586 ---------------------------
3588 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
3589 Checks
: constant List_Id
:= New_List
;
3590 Actions
: List_Id
:= No_List
;
3591 Counter_Id
: Entity_Id
:= Empty
;
3592 Comp_Loc
: Source_Ptr
;
3595 Parent_Stmts
: List_Id
;
3596 Parent_Id
: Entity_Id
:= Empty
;
3597 Stmts
, Late_Stmts
: List_Id
:= Empty_List
;
3600 procedure Increment_Counter
3601 (Loc
: Source_Ptr
; Late
: Boolean := False);
3602 -- Generate an "increment by one" statement for the current counter
3603 -- and append it to the appropriate statement list.
3605 procedure Make_Counter
(Loc
: Source_Ptr
);
3606 -- Create a new counter for the current component list. The routine
3607 -- creates a new defining Id, adds an object declaration and sets
3608 -- the Id generator for the next variant.
3610 -----------------------
3611 -- Increment_Counter --
3612 -----------------------
3614 procedure Increment_Counter
3615 (Loc
: Source_Ptr
; Late
: Boolean := False) is
3618 -- Counter := Counter + 1;
3620 Append_To
((if Late
then Late_Stmts
else Stmts
),
3621 Make_Assignment_Statement
(Loc
,
3622 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3625 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3626 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
3627 end Increment_Counter
;
3633 procedure Make_Counter
(Loc
: Source_Ptr
) is
3635 -- Increment the Id generator
3637 Counter
:= Counter
+ 1;
3639 -- Create the entity and declaration
3642 Make_Defining_Identifier
(Loc
,
3643 Chars
=> New_External_Name
('C', Counter
));
3646 -- Cnn : Integer := 0;
3649 Make_Object_Declaration
(Loc
,
3650 Defining_Identifier
=> Counter_Id
,
3651 Object_Definition
=>
3652 New_Occurrence_Of
(Standard_Integer
, Loc
),
3654 Make_Integer_Literal
(Loc
, 0)));
3657 -- Start of processing for Build_Init_Statements
3660 if Null_Present
(Comp_List
) then
3661 return New_List
(Make_Null_Statement
(Loc
));
3664 Parent_Stmts
:= New_List
;
3667 -- Loop through visible declarations of task types and protected
3668 -- types moving any expanded code from the spec to the body of the
3671 if Is_Concurrent_Record_Type
(Rec_Type
) then
3673 Decl
: constant Node_Id
:=
3674 Parent
(Corresponding_Concurrent_Type
(Rec_Type
));
3680 if Is_Task_Record_Type
(Rec_Type
) then
3681 Def
:= Task_Definition
(Decl
);
3683 Def
:= Protected_Definition
(Decl
);
3686 if Present
(Def
) then
3687 N1
:= First
(Visible_Declarations
(Def
));
3688 while Present
(N1
) loop
3692 if Nkind
(N2
) in N_Statement_Other_Than_Procedure_Call
3693 or else Nkind
(N2
) in N_Raise_xxx_Error
3694 or else Nkind
(N2
) = N_Procedure_Call_Statement
3697 New_Copy_Tree
(N2
, New_Scope
=> Proc_Id
));
3698 Rewrite
(N2
, Make_Null_Statement
(Sloc
(N2
)));
3706 -- Loop through components, skipping pragmas, in 2 steps. The first
3707 -- step deals with regular components. The second step deals with
3708 -- components that require late initialization.
3710 -- First pass : regular components
3712 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
3713 while Present
(Decl
) loop
3714 Comp_Loc
:= Sloc
(Decl
);
3716 (Subtype_Indication
(Component_Definition
(Decl
)), Checks
);
3718 Id
:= Defining_Identifier
(Decl
);
3720 -- Obtain the corresponding mutably tagged type's parent subtype
3721 -- to handle default initialization.
3723 Typ
:= Get_Corresponding_Tagged_Type_If_Present
(Etype
(Id
));
3725 -- Leave any processing of component requiring late initialization
3726 -- for the second pass.
3728 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
) then
3729 if not Has_Late_Init_Comp
then
3730 Late_Stmts
:= New_List
;
3732 Has_Late_Init_Comp
:= True;
3734 -- Regular component cases
3737 -- In the context of the init proc, references to discriminants
3738 -- resolve to denote the discriminals: this is where we can
3739 -- freeze discriminant dependent component subtypes.
3741 if not Is_Frozen
(Typ
) then
3742 Append_List_To
(Stmts
, Freeze_Entity
(Typ
, N
));
3745 -- Explicit initialization
3747 if Present
(Expression
(Decl
)) then
3748 if Is_CPP_Constructor_Call
(Expression
(Decl
)) then
3750 Build_Initialization_Call
3753 Make_Selected_Component
(Comp_Loc
,
3755 Make_Identifier
(Comp_Loc
, Name_uInit
),
3757 New_Occurrence_Of
(Id
, Comp_Loc
)),
3759 In_Init_Proc
=> True,
3760 Enclos_Type
=> Rec_Type
,
3761 Discr_Map
=> Discr_Map
,
3762 Constructor_Ref
=> Expression
(Decl
));
3764 Actions
:= Build_Assignment
(Id
, Expression
(Decl
));
3767 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3768 -- components are filled in with the corresponding rep-item
3769 -- expression of the concurrent type (if any).
3771 elsif Ekind
(Scope
(Id
)) = E_Record_Type
3772 and then Present
(Corresponding_Concurrent_Type
(Scope
(Id
)))
3773 and then Chars
(Id
) in Name_uCPU
3774 | Name_uDispatching_Domain
3776 | Name_uSecondary_Stack_Size
3781 pragma Warnings
(Off
, Nam
);
3785 if Chars
(Id
) = Name_uCPU
then
3788 elsif Chars
(Id
) = Name_uDispatching_Domain
then
3789 Nam
:= Name_Dispatching_Domain
;
3791 elsif Chars
(Id
) = Name_uPriority
then
3792 Nam
:= Name_Priority
;
3794 elsif Chars
(Id
) = Name_uSecondary_Stack_Size
then
3795 Nam
:= Name_Secondary_Stack_Size
;
3798 -- Get the Rep Item (aspect specification, attribute
3799 -- definition clause or pragma) of the corresponding
3804 (Corresponding_Concurrent_Type
(Scope
(Id
)),
3806 Check_Parents
=> False);
3808 if Present
(Ritem
) then
3812 if Nkind
(Ritem
) = N_Pragma
then
3815 (First
(Pragma_Argument_Associations
(Ritem
)));
3817 -- Conversion for Priority expression
3819 if Nam
= Name_Priority
then
3820 if Pragma_Name
(Ritem
) = Name_Priority
3821 and then not GNAT_Mode
3823 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3826 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3830 -- Aspect/Attribute definition clause case
3833 Exp
:= Expression
(Ritem
);
3835 -- Conversion for Priority expression
3837 if Nam
= Name_Priority
then
3838 if Chars
(Ritem
) = Name_Priority
3839 and then not GNAT_Mode
3841 Exp
:= Convert_To
(RTE
(RE_Priority
), Exp
);
3844 Convert_To
(RTE
(RE_Any_Priority
), Exp
);
3849 -- Conversion for Dispatching_Domain value
3851 if Nam
= Name_Dispatching_Domain
then
3853 Unchecked_Convert_To
3854 (RTE
(RE_Dispatching_Domain_Access
), Exp
);
3856 -- Conversion for Secondary_Stack_Size value
3858 elsif Nam
= Name_Secondary_Stack_Size
then
3859 Exp
:= Convert_To
(RTE
(RE_Size_Type
), Exp
);
3862 Actions
:= Build_Assignment
(Id
, Exp
);
3864 -- Nothing needed if no Rep Item
3871 -- Composite component with its own Init_Proc
3873 elsif not Is_Interface
(Typ
)
3874 and then Has_Non_Null_Base_Init_Proc
(Typ
)
3877 use Initialization_Control
;
3878 Init_Control_Actual
: Node_Id
:= Empty
;
3879 Is_Parent
: constant Boolean := Chars
(Id
) = Name_uParent
;
3880 Init_Call_Stmts
: List_Id
;
3882 if Is_Parent
and then Has_Late_Init_Component
(Etype
(Id
))
3884 Init_Control_Actual
:=
3885 Make_Mode_Literal
(Comp_Loc
, Early_Init_Only
);
3886 -- Parent_Id used later in second call to parent's
3887 -- init proc to initialize late-init components.
3892 Build_Initialization_Call
3894 Make_Selected_Component
(Comp_Loc
,
3896 Make_Identifier
(Comp_Loc
, Name_uInit
),
3897 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
3899 In_Init_Proc
=> True,
3900 Enclos_Type
=> Rec_Type
,
3901 Discr_Map
=> Discr_Map
,
3902 Init_Control_Actual
=> Init_Control_Actual
);
3905 -- This is tricky. At first it looks like
3906 -- we are going to end up with nested
3907 -- if-statements with the same condition:
3908 -- if Early_Init_Condition then
3909 -- if Early_Init_Condition then
3910 -- Parent_TypeIP (...);
3913 -- But later we will hoist the inner if-statement
3914 -- out of the outer one; we do this because the
3915 -- init-proc call for the _Parent component of a type
3916 -- extension has to precede any other initialization.
3918 New_List
(Make_If_Statement
(Loc
,
3920 Early_Init_Condition
(Loc
, Init_Control_Formal
),
3921 Then_Statements
=> Init_Call_Stmts
));
3923 Actions
:= Init_Call_Stmts
;
3927 Clean_Task_Names
(Typ
, Proc_Id
);
3929 -- Simple initialization. If the Esize is not yet set, we pass
3930 -- Uint_0 as expected by Get_Simple_Init_Val.
3932 elsif Component_Needs_Simple_Initialization
(Typ
) then
3941 (if Known_Esize
(Id
) then Esize
(Id
)
3944 -- Nothing needed for this case
3950 -- When the component's type has a Default_Initial_Condition,
3951 -- and the component is default initialized, then check the
3955 and then No
(Expression
(Decl
))
3956 and then Present
(DIC_Procedure
(Typ
))
3957 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
3959 -- The DICs of ancestors are checked as part of the type's
3962 and then Chars
(Id
) /= Name_uParent
3964 -- In GNATprove mode, the component DICs are checked by other
3965 -- means. They should not be added to the record type DIC
3966 -- procedure, so that the procedure can be used to check the
3967 -- record type invariants or DICs if any.
3969 and then not GNATprove_Mode
3971 Append_New_To
(Actions
,
3974 Make_Selected_Component
(Comp_Loc
,
3976 Make_Identifier
(Comp_Loc
, Name_uInit
),
3978 New_Occurrence_Of
(Id
, Comp_Loc
)),
3982 if Present
(Checks
) then
3983 if Chars
(Id
) = Name_uParent
then
3984 Append_List_To
(Parent_Stmts
, Checks
);
3986 Append_List_To
(Stmts
, Checks
);
3990 if Present
(Actions
) then
3991 if Chars
(Id
) = Name_uParent
then
3992 Append_List_To
(Parent_Stmts
, Actions
);
3994 Append_List_To
(Stmts
, Actions
);
3996 -- Preserve initialization state in the current counter
3998 if Needs_Finalization
(Typ
) then
3999 if No
(Counter_Id
) then
4000 Make_Counter
(Comp_Loc
);
4003 Increment_Counter
(Comp_Loc
);
4009 Next_Non_Pragma
(Decl
);
4012 -- The parent field must be initialized first because variable
4013 -- size components of the parent affect the location of all the
4016 Prepend_List_To
(Stmts
, Parent_Stmts
);
4018 -- Set up tasks and protected object support. This needs to be done
4019 -- before any component with a per-object access discriminant
4020 -- constraint, or any variant part (which may contain such
4021 -- components) is initialized, because the initialization of these
4022 -- components may reference the enclosing concurrent object.
4024 -- For a task record type, add the task create call and calls to bind
4025 -- any interrupt (signal) entries.
4027 if Is_Task_Record_Type
(Rec_Type
) then
4029 -- In the case of the restricted run time the ATCB has already
4030 -- been preallocated.
4032 if Restricted_Profile
then
4034 Make_Assignment_Statement
(Loc
,
4036 Make_Selected_Component
(Loc
,
4037 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
4038 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
4040 Make_Attribute_Reference
(Loc
,
4042 Make_Selected_Component
(Loc
,
4043 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
4044 Selector_Name
=> Make_Identifier
(Loc
, Name_uATCB
)),
4045 Attribute_Name
=> Name_Unchecked_Access
)));
4048 Append_To
(Stmts
, Make_Task_Create_Call
(Rec_Type
));
4051 Task_Type
: constant Entity_Id
:=
4052 Corresponding_Concurrent_Type
(Rec_Type
);
4053 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
4054 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
4055 Decl_Loc
: Source_Ptr
;
4060 if Present
(Task_Def
) then
4061 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
4062 while Present
(Vis_Decl
) loop
4063 Decl_Loc
:= Sloc
(Vis_Decl
);
4065 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
4066 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
4069 Ent
:= Entity
(Name
(Vis_Decl
));
4071 if Ekind
(Ent
) = E_Entry
then
4073 Make_Procedure_Call_Statement
(Decl_Loc
,
4075 New_Occurrence_Of
(RTE
(
4076 RE_Bind_Interrupt_To_Entry
), Decl_Loc
),
4077 Parameter_Associations
=> New_List
(
4078 Make_Selected_Component
(Decl_Loc
,
4080 Make_Identifier
(Decl_Loc
, Name_uInit
),
4083 (Decl_Loc
, Name_uTask_Id
)),
4084 Entry_Index_Expression
4085 (Decl_Loc
, Ent
, Empty
, Task_Type
),
4086 Expression
(Vis_Decl
))));
4096 -- For a protected type, add statements generated by
4097 -- Make_Initialize_Protection.
4099 elsif Is_Protected_Record_Type
(Rec_Type
) then
4100 Append_List_To
(Stmts
,
4101 Make_Initialize_Protection
(Rec_Type
));
4104 -- Second pass: components that require late initialization
4106 if Present
(Parent_Id
) then
4108 Parent_Loc
: constant Source_Ptr
:= Sloc
(Parent
(Parent_Id
));
4109 use Initialization_Control
;
4111 -- We are building the init proc for a type extension.
4112 -- Call the parent type's init proc a second time, this
4113 -- time to initialize the parent's components that require
4114 -- late initialization.
4116 Append_List_To
(Late_Stmts
,
4117 Build_Initialization_Call
4118 (N
=> Parent
(Parent_Id
),
4120 Make_Selected_Component
(Parent_Loc
,
4121 Prefix
=> Make_Identifier
4122 (Parent_Loc
, Name_uInit
),
4123 Selector_Name
=> New_Occurrence_Of
(Parent_Id
,
4125 Typ
=> Etype
(Parent_Id
),
4126 In_Init_Proc
=> True,
4127 Enclos_Type
=> Rec_Type
,
4128 Discr_Map
=> Discr_Map
,
4129 Init_Control_Actual
=> Make_Mode_Literal
4130 (Parent_Loc
, Late_Init_Only
)));
4134 if Has_Late_Init_Comp
then
4135 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
4136 while Present
(Decl
) loop
4137 Comp_Loc
:= Sloc
(Decl
);
4138 Id
:= Defining_Identifier
(Decl
);
4140 -- Obtain the corresponding mutably tagged type's parent
4141 -- subtype to handle default initialization.
4143 Typ
:= Get_Corresponding_Tagged_Type_If_Present
(Etype
(Id
));
4145 if Initialization_Control
.Requires_Late_Init
(Decl
, Rec_Type
)
4147 if Present
(Expression
(Decl
)) then
4148 Append_List_To
(Late_Stmts
,
4149 Build_Assignment
(Id
, Expression
(Decl
)));
4151 elsif Has_Non_Null_Base_Init_Proc
(Typ
) then
4152 Append_List_To
(Late_Stmts
,
4153 Build_Initialization_Call
(Decl
,
4154 Make_Selected_Component
(Comp_Loc
,
4156 Make_Identifier
(Comp_Loc
, Name_uInit
),
4157 Selector_Name
=> New_Occurrence_Of
(Id
, Comp_Loc
)),
4159 In_Init_Proc
=> True,
4160 Enclos_Type
=> Rec_Type
,
4161 Discr_Map
=> Discr_Map
));
4163 Clean_Task_Names
(Typ
, Proc_Id
);
4165 -- Preserve initialization state in the current counter
4167 if Needs_Finalization
(Typ
) then
4168 if No
(Counter_Id
) then
4169 Make_Counter
(Comp_Loc
);
4172 Increment_Counter
(Comp_Loc
, Late
=> True);
4174 elsif Component_Needs_Simple_Initialization
(Typ
) then
4175 Append_List_To
(Late_Stmts
,
4182 Size
=> Esize
(Id
))));
4186 Next_Non_Pragma
(Decl
);
4190 -- Process the variant part (incorrectly ignoring late
4191 -- initialization requirements for components therein).
4193 if Present
(Variant_Part
(Comp_List
)) then
4195 Variant_Alts
: constant List_Id
:= New_List
;
4196 Var_Loc
: Source_Ptr
:= No_Location
;
4201 First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
4202 while Present
(Variant
) loop
4203 Var_Loc
:= Sloc
(Variant
);
4204 Append_To
(Variant_Alts
,
4205 Make_Case_Statement_Alternative
(Var_Loc
,
4207 New_Copy_List
(Discrete_Choices
(Variant
)),
4209 Build_Init_Statements
(Component_List
(Variant
))));
4210 Next_Non_Pragma
(Variant
);
4213 -- The expression of the case statement which is a reference
4214 -- to one of the discriminants is replaced by the appropriate
4215 -- formal parameter of the initialization procedure.
4218 Make_Case_Statement
(Var_Loc
,
4220 New_Occurrence_Of
(Discriminal
(
4221 Entity
(Name
(Variant_Part
(Comp_List
)))), Var_Loc
),
4222 Alternatives
=> Variant_Alts
));
4226 if No
(Init_Control_Formal
) then
4227 Append_List_To
(Stmts
, Late_Stmts
);
4229 -- If no initializations were generated for component declarations
4230 -- and included in Stmts, then append a null statement to Stmts
4231 -- to make it a valid Ada tree.
4233 if Is_Empty_List
(Stmts
) then
4234 Append
(Make_Null_Statement
(Loc
), Stmts
);
4240 use Initialization_Control
;
4242 If_Early
: constant Node_Id
:=
4243 (if Is_Empty_List
(Stmts
) then
4244 Make_Null_Statement
(Loc
)
4246 Make_If_Statement
(Loc
,
4248 Early_Init_Condition
(Loc
, Init_Control_Formal
),
4249 Then_Statements
=> Stmts
));
4250 If_Late
: constant Node_Id
:=
4251 (if Is_Empty_List
(Late_Stmts
) then
4252 Make_Null_Statement
(Loc
)
4254 Make_If_Statement
(Loc
,
4256 Late_Init_Condition
(Loc
, Init_Control_Formal
),
4257 Then_Statements
=> Late_Stmts
));
4259 return New_List
(If_Early
, If_Late
);
4263 when RE_Not_Available
=>
4265 end Build_Init_Statements
;
4267 -------------------------
4268 -- Build_Record_Checks --
4269 -------------------------
4271 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
4272 Subtype_Mark_Id
: Entity_Id
;
4274 procedure Constrain_Array
4276 Check_List
: List_Id
);
4277 -- Apply a list of index constraints to an unconstrained array type.
4278 -- The first parameter is the entity for the resulting subtype.
4279 -- Check_List is a list to which the check actions are appended.
4281 ---------------------
4282 -- Constrain_Array --
4283 ---------------------
4285 procedure Constrain_Array
4287 Check_List
: List_Id
)
4289 C
: constant Node_Id
:= Constraint
(SI
);
4290 Number_Of_Constraints
: Nat
:= 0;
4294 procedure Constrain_Index
4297 Check_List
: List_Id
);
4298 -- Process an index constraint in a constrained array declaration.
4299 -- The constraint can be either a subtype name or a range with or
4300 -- without an explicit subtype mark. Index is the corresponding
4301 -- index of the unconstrained array. S is the range expression.
4302 -- Check_List is a list to which the check actions are appended.
4304 ---------------------
4305 -- Constrain_Index --
4306 ---------------------
4308 procedure Constrain_Index
4311 Check_List
: List_Id
)
4313 T
: constant Entity_Id
:= Etype
(Index
);
4316 if Nkind
(S
) = N_Range
then
4317 Process_Range_Expr_In_Decl
(S
, T
, Check_List
=> Check_List
);
4319 end Constrain_Index
;
4321 -- Start of processing for Constrain_Array
4324 T
:= Entity
(Subtype_Mark
(SI
));
4326 if Is_Access_Type
(T
) then
4327 T
:= Designated_Type
(T
);
4330 S
:= First
(Constraints
(C
));
4331 while Present
(S
) loop
4332 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
4336 -- In either case, the index constraint must provide a discrete
4337 -- range for each index of the array type and the type of each
4338 -- discrete range must be the same as that of the corresponding
4339 -- index. (RM 3.6.1)
4341 S
:= First
(Constraints
(C
));
4342 Index
:= First_Index
(T
);
4345 -- Apply constraints to each index type
4347 for J
in 1 .. Number_Of_Constraints
loop
4348 Constrain_Index
(Index
, S
, Check_List
);
4352 end Constrain_Array
;
4354 -- Start of processing for Build_Record_Checks
4357 if Nkind
(S
) = N_Subtype_Indication
then
4358 Find_Type
(Subtype_Mark
(S
));
4359 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
4361 -- Remaining processing depends on type
4363 case Ekind
(Subtype_Mark_Id
) is
4365 Constrain_Array
(S
, Check_List
);
4371 end Build_Record_Checks
;
4373 -------------------------------------------
4374 -- Component_Needs_Simple_Initialization --
4375 -------------------------------------------
4377 function Component_Needs_Simple_Initialization
4378 (T
: Entity_Id
) return Boolean
4382 Needs_Simple_Initialization
(T
)
4383 and then not Is_RTE
(T
, RE_Tag
)
4385 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
4387 and then not Is_RTE
(T
, RE_Interface_Tag
);
4388 end Component_Needs_Simple_Initialization
;
4390 --------------------------------------
4391 -- Parent_Subtype_Renaming_Discrims --
4392 --------------------------------------
4394 function Parent_Subtype_Renaming_Discrims
return Boolean is
4399 if Base_Type
(Rec_Ent
) /= Rec_Ent
then
4403 if Etype
(Rec_Ent
) = Rec_Ent
4404 or else not Has_Discriminants
(Rec_Ent
)
4405 or else Is_Constrained
(Rec_Ent
)
4406 or else Is_Tagged_Type
(Rec_Ent
)
4411 -- If there are no explicit stored discriminants we have inherited
4412 -- the root type discriminants so far, so no renamings occurred.
4414 if First_Discriminant
(Rec_Ent
) =
4415 First_Stored_Discriminant
(Rec_Ent
)
4420 -- Check if we have done some trivial renaming of the parent
4421 -- discriminants, i.e. something like
4423 -- type DT (X1, X2: int) is new PT (X1, X2);
4425 De
:= First_Discriminant
(Rec_Ent
);
4426 Dp
:= First_Discriminant
(Etype
(Rec_Ent
));
4427 while Present
(De
) loop
4428 pragma Assert
(Present
(Dp
));
4430 if Corresponding_Discriminant
(De
) /= Dp
then
4434 Next_Discriminant
(De
);
4435 Next_Discriminant
(Dp
);
4438 return Present
(Dp
);
4439 end Parent_Subtype_Renaming_Discrims
;
4441 ------------------------
4442 -- Requires_Init_Proc --
4443 ------------------------
4445 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
4446 Comp_Decl
: Node_Id
;
4451 -- Definitely do not need one if specifically suppressed
4453 if Initialization_Suppressed
(Rec_Id
) then
4457 -- If it is a type derived from a type with unknown discriminants,
4458 -- we cannot build an initialization procedure for it.
4460 if Has_Unknown_Discriminants
(Rec_Id
)
4461 or else Has_Unknown_Discriminants
(Etype
(Rec_Id
))
4466 -- Otherwise we need to generate an initialization procedure if
4467 -- Is_CPP_Class is False and at least one of the following applies:
4469 -- 1. Discriminants are present, since they need to be initialized
4470 -- with the appropriate discriminant constraint expressions.
4471 -- However, the discriminant of an unchecked union does not
4472 -- count, since the discriminant is not present.
4474 -- 2. The type is a tagged type, since the implicit Tag component
4475 -- needs to be initialized with a pointer to the dispatch table.
4477 -- 3. The type contains tasks
4479 -- 4. One or more components has an initial value
4481 -- 5. One or more components is for a type which itself requires
4482 -- an initialization procedure.
4484 -- 6. One or more components is a type that requires simple
4485 -- initialization (see Needs_Simple_Initialization), except
4486 -- that types Tag and Interface_Tag are excluded, since fields
4487 -- of these types are initialized by other means.
4489 -- 7. The type is the record type built for a task type (since at
4490 -- the very least, Create_Task must be called)
4492 -- 8. The type is the record type built for a protected type (since
4493 -- at least Initialize_Protection must be called)
4495 -- 9. The type is marked as a public entity. The reason we add this
4496 -- case (even if none of the above apply) is to properly handle
4497 -- Initialize_Scalars. If a package is compiled without an IS
4498 -- pragma, and the client is compiled with an IS pragma, then
4499 -- the client will think an initialization procedure is present
4500 -- and call it, when in fact no such procedure is required, but
4501 -- since the call is generated, there had better be a routine
4502 -- at the other end of the call, even if it does nothing).
4504 -- Note: the reason we exclude the CPP_Class case is because in this
4505 -- case the initialization is performed by the C++ constructors, and
4506 -- the IP is built by Set_CPP_Constructors.
4508 if Is_CPP_Class
(Rec_Id
) then
4511 elsif Is_Interface
(Rec_Id
) then
4514 elsif (Has_Discriminants
(Rec_Id
)
4515 and then not Is_Unchecked_Union
(Rec_Id
))
4516 or else Is_Tagged_Type
(Rec_Id
)
4517 or else Is_Concurrent_Record_Type
(Rec_Id
)
4518 or else Has_Task
(Rec_Id
)
4523 Id
:= First_Component
(Rec_Id
);
4524 while Present
(Id
) loop
4525 Comp_Decl
:= Parent
(Id
);
4528 if Present
(Expression
(Comp_Decl
))
4529 or else Has_Non_Null_Base_Init_Proc
(Typ
)
4530 or else Component_Needs_Simple_Initialization
(Typ
)
4535 Next_Component
(Id
);
4538 -- As explained above, a record initialization procedure is needed
4539 -- for public types in case Initialize_Scalars applies to a client.
4540 -- However, such a procedure is not needed in the case where either
4541 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
4542 -- applies. No_Initialize_Scalars excludes the possibility of using
4543 -- Initialize_Scalars in any partition, and No_Default_Initialization
4544 -- implies that no initialization should ever be done for objects of
4545 -- the type, so is incompatible with Initialize_Scalars.
4547 if not Restriction_Active
(No_Initialize_Scalars
)
4548 and then not Restriction_Active
(No_Default_Initialization
)
4549 and then Is_Public
(Rec_Id
)
4555 end Requires_Init_Proc
;
4557 -- Start of processing for Build_Record_Init_Proc
4560 Rec_Type
:= Defining_Identifier
(N
);
4562 -- This may be full declaration of a private type, in which case
4563 -- the visible entity is a record, and the private entity has been
4564 -- exchanged with it in the private part of the current package.
4565 -- The initialization procedure is built for the record type, which
4566 -- is retrievable from the private entity.
4568 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
4569 Rec_Type
:= Underlying_Type
(Rec_Type
);
4572 -- If we have a variant record with restriction No_Implicit_Conditionals
4573 -- in effect, then we skip building the procedure. This is safe because
4574 -- if we can see the restriction, so can any caller, calls to initialize
4575 -- such records are not allowed for variant records if this restriction
4578 if Has_Variant_Part
(Rec_Type
)
4579 and then Restriction_Active
(No_Implicit_Conditionals
)
4584 -- If there are discriminants, build the discriminant map to replace
4585 -- discriminants by their discriminals in complex bound expressions.
4586 -- These only arise for the corresponding records of synchronized types.
4588 if Is_Concurrent_Record_Type
(Rec_Type
)
4589 and then Has_Discriminants
(Rec_Type
)
4594 Disc
:= First_Discriminant
(Rec_Type
);
4595 while Present
(Disc
) loop
4596 Append_Elmt
(Disc
, Discr_Map
);
4597 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
4598 Next_Discriminant
(Disc
);
4603 -- Derived types that have no type extension can use the initialization
4604 -- procedure of their parent and do not need a procedure of their own.
4605 -- This is only correct if there are no representation clauses for the
4606 -- type or its parent, and if the parent has in fact been frozen so
4607 -- that its initialization procedure exists.
4609 if Is_Derived_Type
(Rec_Type
)
4610 and then not Is_Tagged_Type
(Rec_Type
)
4611 and then not Is_Unchecked_Union
(Rec_Type
)
4612 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
4613 and then not Parent_Subtype_Renaming_Discrims
4614 and then Present
(Base_Init_Proc
(Etype
(Rec_Type
)))
4616 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
4618 -- Otherwise if we need an initialization procedure, then build one,
4619 -- mark it as public and inlinable and as having a completion.
4621 elsif Requires_Init_Proc
(Rec_Type
)
4622 or else Is_Unchecked_Union
(Rec_Type
)
4625 Make_Defining_Identifier
(Loc
,
4626 Chars
=> Make_Init_Proc_Name
(Rec_Type
));
4628 -- If No_Default_Initialization restriction is active, then we don't
4629 -- want to build an init_proc, but we need to mark that an init_proc
4630 -- would be needed if this restriction was not active (so that we can
4631 -- detect attempts to call it), so set a dummy init_proc in place.
4633 if Restriction_Active
(No_Default_Initialization
) then
4634 Set_Init_Proc
(Rec_Type
, Proc_Id
);
4638 Build_Offset_To_Top_Functions
;
4639 Build_CPP_Init_Procedure
;
4640 Build_Init_Procedure
;
4642 Set_Is_Public
(Proc_Id
, Is_Public
(Rec_Ent
));
4643 Set_Is_Internal
(Proc_Id
);
4644 Set_Has_Completion
(Proc_Id
);
4646 if not Debug_Generated_Code
then
4647 Set_Debug_Info_Off
(Proc_Id
);
4650 Set_Is_Inlined
(Proc_Id
, Inline_Init_Proc
(Rec_Type
));
4652 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4653 -- needed and may generate early references to non frozen types
4654 -- since we expand aggregate much more systematically.
4656 if Modify_Tree_For_C
then
4661 Agg
: constant Node_Id
:=
4662 Build_Equivalent_Record_Aggregate
(Rec_Type
);
4664 procedure Collect_Itypes
(Comp
: Node_Id
);
4665 -- Generate references to itypes in the aggregate, because
4666 -- the first use of the aggregate may be in a nested scope.
4668 --------------------
4669 -- Collect_Itypes --
4670 --------------------
4672 procedure Collect_Itypes
(Comp
: Node_Id
) is
4675 Typ
: constant Entity_Id
:= Etype
(Comp
);
4678 if Is_Array_Type
(Typ
) and then Is_Itype
(Typ
) then
4679 Ref
:= Make_Itype_Reference
(Loc
);
4680 Set_Itype
(Ref
, Typ
);
4681 Append_Freeze_Action
(Rec_Type
, Ref
);
4683 Ref
:= Make_Itype_Reference
(Loc
);
4684 Set_Itype
(Ref
, Etype
(First_Index
(Typ
)));
4685 Append_Freeze_Action
(Rec_Type
, Ref
);
4687 -- Recurse on nested arrays
4689 Sub_Aggr
:= First
(Expressions
(Comp
));
4690 while Present
(Sub_Aggr
) loop
4691 Collect_Itypes
(Sub_Aggr
);
4698 -- If there is a static initialization aggregate for the type,
4699 -- generate itype references for the types of its (sub)components,
4700 -- to prevent out-of-scope errors in the resulting tree.
4701 -- The aggregate may have been rewritten as a Raise node, in which
4702 -- case there are no relevant itypes.
4704 if Present
(Agg
) and then Nkind
(Agg
) = N_Aggregate
then
4705 Set_Static_Initialization
(Proc_Id
, Agg
);
4710 Comp
:= First
(Component_Associations
(Agg
));
4711 while Present
(Comp
) loop
4712 Collect_Itypes
(Expression
(Comp
));
4719 end Build_Record_Init_Proc
;
4721 ----------------------------
4722 -- Build_Slice_Assignment --
4723 ----------------------------
4725 -- Generates the following subprogram:
4727 -- procedure array_typeSA
4728 -- (Source, Target : Array_Type,
4729 -- Left_Lo, Left_Hi : Index;
4730 -- Right_Lo, Right_Hi : Index;
4737 -- if Left_Hi < Left_Lo then
4750 -- Target (Li1) := Source (Ri1);
4753 -- exit when Li1 = Left_Lo;
4754 -- Li1 := Index'pred (Li1);
4755 -- Ri1 := Index'pred (Ri1);
4757 -- exit when Li1 = Left_Hi;
4758 -- Li1 := Index'succ (Li1);
4759 -- Ri1 := Index'succ (Ri1);
4762 -- end array_typeSA;
4764 procedure Build_Slice_Assignment
(Typ
: Entity_Id
) is
4765 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4766 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
4768 Larray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4769 Rarray
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4770 Left_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4771 Left_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4772 Right_Lo
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4773 Right_Hi
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4774 Rev
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
4775 -- Formal parameters of procedure
4777 Proc_Name
: constant Entity_Id
:=
4778 Make_Defining_Identifier
(Loc
,
4779 Chars
=> Make_TSS_Name
(Typ
, TSS_Slice_Assign
));
4781 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
4782 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4783 -- Subscripts for left and right sides
4790 -- Build declarations for indexes
4795 Make_Object_Declaration
(Loc
,
4796 Defining_Identifier
=> Lnn
,
4797 Object_Definition
=>
4798 New_Occurrence_Of
(Index
, Loc
)));
4801 Make_Object_Declaration
(Loc
,
4802 Defining_Identifier
=> Rnn
,
4803 Object_Definition
=>
4804 New_Occurrence_Of
(Index
, Loc
)));
4808 -- Build test for empty slice case
4811 Make_If_Statement
(Loc
,
4814 Left_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
),
4815 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
)),
4816 Then_Statements
=> New_List
(Make_Simple_Return_Statement
(Loc
))));
4818 -- Build initializations for indexes
4821 F_Init
: constant List_Id
:= New_List
;
4822 B_Init
: constant List_Id
:= New_List
;
4826 Make_Assignment_Statement
(Loc
,
4827 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4828 Expression
=> New_Occurrence_Of
(Left_Lo
, Loc
)));
4831 Make_Assignment_Statement
(Loc
,
4832 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4833 Expression
=> New_Occurrence_Of
(Right_Lo
, Loc
)));
4836 Make_Assignment_Statement
(Loc
,
4837 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4838 Expression
=> New_Occurrence_Of
(Left_Hi
, Loc
)));
4841 Make_Assignment_Statement
(Loc
,
4842 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4843 Expression
=> New_Occurrence_Of
(Right_Hi
, Loc
)));
4846 Make_If_Statement
(Loc
,
4847 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4848 Then_Statements
=> B_Init
,
4849 Else_Statements
=> F_Init
));
4852 -- Now construct the assignment statement
4855 Make_Loop_Statement
(Loc
,
4856 Statements
=> New_List
(
4857 Make_Assignment_Statement
(Loc
,
4859 Make_Indexed_Component
(Loc
,
4860 Prefix
=> New_Occurrence_Of
(Larray
, Loc
),
4861 Expressions
=> New_List
(New_Occurrence_Of
(Lnn
, Loc
))),
4863 Make_Indexed_Component
(Loc
,
4864 Prefix
=> New_Occurrence_Of
(Rarray
, Loc
),
4865 Expressions
=> New_List
(New_Occurrence_Of
(Rnn
, Loc
))))),
4866 End_Label
=> Empty
);
4868 -- Build the exit condition and increment/decrement statements
4871 F_Ass
: constant List_Id
:= New_List
;
4872 B_Ass
: constant List_Id
:= New_List
;
4876 Make_Exit_Statement
(Loc
,
4879 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4880 Right_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
))));
4883 Make_Assignment_Statement
(Loc
,
4884 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4886 Make_Attribute_Reference
(Loc
,
4888 New_Occurrence_Of
(Index
, Loc
),
4889 Attribute_Name
=> Name_Succ
,
4890 Expressions
=> New_List
(
4891 New_Occurrence_Of
(Lnn
, Loc
)))));
4894 Make_Assignment_Statement
(Loc
,
4895 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4897 Make_Attribute_Reference
(Loc
,
4899 New_Occurrence_Of
(Index
, Loc
),
4900 Attribute_Name
=> Name_Succ
,
4901 Expressions
=> New_List
(
4902 New_Occurrence_Of
(Rnn
, Loc
)))));
4905 Make_Exit_Statement
(Loc
,
4908 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4909 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
))));
4912 Make_Assignment_Statement
(Loc
,
4913 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4915 Make_Attribute_Reference
(Loc
,
4917 New_Occurrence_Of
(Index
, Loc
),
4918 Attribute_Name
=> Name_Pred
,
4919 Expressions
=> New_List
(
4920 New_Occurrence_Of
(Lnn
, Loc
)))));
4923 Make_Assignment_Statement
(Loc
,
4924 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
4926 Make_Attribute_Reference
(Loc
,
4928 New_Occurrence_Of
(Index
, Loc
),
4929 Attribute_Name
=> Name_Pred
,
4930 Expressions
=> New_List
(
4931 New_Occurrence_Of
(Rnn
, Loc
)))));
4933 Append_To
(Statements
(Loops
),
4934 Make_If_Statement
(Loc
,
4935 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
4936 Then_Statements
=> B_Ass
,
4937 Else_Statements
=> F_Ass
));
4940 Append_To
(Stats
, Loops
);
4947 Formals
:= New_List
(
4948 Make_Parameter_Specification
(Loc
,
4949 Defining_Identifier
=> Larray
,
4950 Out_Present
=> True,
4952 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4954 Make_Parameter_Specification
(Loc
,
4955 Defining_Identifier
=> Rarray
,
4957 New_Occurrence_Of
(Base_Type
(Typ
), Loc
)),
4959 Make_Parameter_Specification
(Loc
,
4960 Defining_Identifier
=> Left_Lo
,
4962 New_Occurrence_Of
(Index
, Loc
)),
4964 Make_Parameter_Specification
(Loc
,
4965 Defining_Identifier
=> Left_Hi
,
4967 New_Occurrence_Of
(Index
, Loc
)),
4969 Make_Parameter_Specification
(Loc
,
4970 Defining_Identifier
=> Right_Lo
,
4972 New_Occurrence_Of
(Index
, Loc
)),
4974 Make_Parameter_Specification
(Loc
,
4975 Defining_Identifier
=> Right_Hi
,
4977 New_Occurrence_Of
(Index
, Loc
)));
4980 Make_Parameter_Specification
(Loc
,
4981 Defining_Identifier
=> Rev
,
4983 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
4986 Make_Procedure_Specification
(Loc
,
4987 Defining_Unit_Name
=> Proc_Name
,
4988 Parameter_Specifications
=> Formals
);
4991 Make_Subprogram_Body
(Loc
,
4992 Specification
=> Spec
,
4993 Declarations
=> Decls
,
4994 Handled_Statement_Sequence
=>
4995 Make_Handled_Sequence_Of_Statements
(Loc
,
4996 Statements
=> Stats
)));
4999 Set_TSS
(Typ
, Proc_Name
);
5000 Set_Is_Pure
(Proc_Name
);
5001 end Build_Slice_Assignment
;
5003 ------------------------------------
5004 -- Build_Untagged_Record_Equality --
5005 ------------------------------------
5007 procedure Build_Untagged_Record_Equality
(Typ
: Entity_Id
) is
5014 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
;
5015 -- Check whether the type T has a user-defined primitive equality. If so
5016 -- return it, else return Empty. If true for a component of Typ, we have
5017 -- to build the primitive equality for it.
5019 ---------------------
5020 -- User_Defined_Eq --
5021 ---------------------
5023 function User_Defined_Eq
(T
: Entity_Id
) return Entity_Id
is
5024 Op
: constant Entity_Id
:= TSS
(T
, TSS_Composite_Equality
);
5027 if Present
(Op
) then
5030 return Get_User_Defined_Equality
(T
);
5032 end User_Defined_Eq
;
5034 -- Start of processing for Build_Untagged_Record_Equality
5037 -- If a record component has a primitive equality operation, we must
5038 -- build the corresponding one for the current type.
5041 Comp
:= First_Component
(Typ
);
5042 while Present
(Comp
) loop
5043 if Is_Record_Type
(Etype
(Comp
))
5044 and then Present
(User_Defined_Eq
(Etype
(Comp
)))
5050 Next_Component
(Comp
);
5053 -- If there is a user-defined equality for the type, we do not create
5054 -- the implicit one.
5056 Eq_Op
:= Get_User_Defined_Equality
(Typ
);
5057 if Present
(Eq_Op
) then
5058 if Comes_From_Source
(Eq_Op
) then
5065 -- If the type is derived, inherit the operation, if present, from the
5066 -- parent type. It may have been declared after the type derivation. If
5067 -- the parent type itself is derived, it may have inherited an operation
5068 -- that has itself been overridden, so update its alias and related
5069 -- flags. Ditto for inequality.
5071 if No
(Eq_Op
) and then Is_Derived_Type
(Typ
) then
5072 Eq_Op
:= Get_User_Defined_Equality
(Etype
(Typ
));
5073 if Present
(Eq_Op
) then
5074 Copy_TSS
(Eq_Op
, Typ
);
5078 Op
: constant Entity_Id
:= User_Defined_Eq
(Typ
);
5079 NE_Op
: constant Entity_Id
:= Next_Entity
(Eq_Op
);
5082 if Present
(Op
) then
5083 Set_Alias
(Op
, Eq_Op
);
5084 Set_Is_Abstract_Subprogram
5085 (Op
, Is_Abstract_Subprogram
(Eq_Op
));
5087 if Chars
(Next_Entity
(Op
)) = Name_Op_Ne
then
5088 Set_Is_Abstract_Subprogram
5089 (Next_Entity
(Op
), Is_Abstract_Subprogram
(NE_Op
));
5096 -- If not inherited and not user-defined, build body as for a type with
5097 -- components of record type (i.e. a type for which "=" composes when
5098 -- used as a component in an outer composite type).
5102 Make_Eq_Body
(Typ
, Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
5103 Op
:= Defining_Entity
(Decl
);
5107 if Is_Library_Level_Entity
(Typ
) then
5111 end Build_Untagged_Record_Equality
;
5113 -----------------------------------
5114 -- Build_Variant_Record_Equality --
5115 -----------------------------------
5119 -- function <<Body_Id>> (Left, Right : T) return Boolean is
5120 -- [ X : T renames Left; ]
5121 -- [ Y : T renames Right; ]
5122 -- -- The above renamings are generated only if the parameters of
5123 -- -- this built function (which are passed by the caller) are not
5124 -- -- named 'X' and 'Y'; these names are required to reuse several
5125 -- -- expander routines when generating this body.
5128 -- -- Compare discriminants
5130 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
5134 -- -- Compare components
5136 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
5140 -- -- Compare variant part
5144 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
5149 -- if X.Cn /= Y.Cn or else ... then
5157 function Build_Variant_Record_Equality
5159 Spec_Id
: Entity_Id
;
5160 Body_Id
: Entity_Id
;
5161 Param_Specs
: List_Id
) return Node_Id
5163 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5164 Def
: constant Node_Id
:= Parent
(Typ
);
5165 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
5166 Left
: constant Entity_Id
:= Defining_Identifier
(First
(Param_Specs
));
5167 Right
: constant Entity_Id
:=
5168 Defining_Identifier
(Next
(First
(Param_Specs
)));
5169 Decls
: constant List_Id
:= New_List
;
5170 Stmts
: constant List_Id
:= New_List
;
5172 Subp_Body
: Node_Id
;
5175 pragma Assert
(not Is_Tagged_Type
(Typ
));
5177 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
5178 -- the name of the formals must be X and Y; otherwise we generate two
5179 -- renaming declarations for such purpose.
5181 if Chars
(Left
) /= Name_X
then
5183 Make_Object_Renaming_Declaration
(Loc
,
5184 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5185 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5186 Name
=> Make_Identifier
(Loc
, Chars
(Left
))));
5189 if Chars
(Right
) /= Name_Y
then
5191 Make_Object_Renaming_Declaration
(Loc
,
5192 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
5193 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5194 Name
=> Make_Identifier
(Loc
, Chars
(Right
))));
5197 -- Unchecked_Unions require additional machinery to support equality.
5198 -- Two extra parameters (A and B) are added to the equality function
5199 -- parameter list for each discriminant of the type, in order to
5200 -- capture the inferred values of the discriminants in equality calls.
5201 -- The names of the parameters match the names of the corresponding
5202 -- discriminant, with an added suffix.
5204 if Is_Unchecked_Union
(Typ
) then
5206 Right_Formal
: constant Entity_Id
:=
5207 (if Present
(Spec_Id
) then Last_Formal
(Spec_Id
) else Right
);
5208 Scop
: constant Entity_Id
:=
5209 (if Present
(Spec_Id
) then Spec_Id
else Body_Id
);
5211 procedure Decorate_Extra_Formal
(F
, F_Typ
: Entity_Id
);
5212 -- Decorate extra formal F with type F_Typ
5214 ---------------------------
5215 -- Decorate_Extra_Formal --
5216 ---------------------------
5218 procedure Decorate_Extra_Formal
(F
, F_Typ
: Entity_Id
) is
5220 Mutate_Ekind
(F
, E_In_Parameter
);
5221 Set_Etype
(F
, F_Typ
);
5222 Set_Scope
(F
, Scop
);
5223 Set_Mechanism
(F
, By_Copy
);
5224 end Decorate_Extra_Formal
;
5229 Discr_Type
: Entity_Id
;
5230 Last_Extra
: Entity_Id
:= Empty
;
5231 New_Discrs
: Elist_Id
;
5234 Mutate_Ekind
(Body_Id
, E_Subprogram_Body
);
5235 New_Discrs
:= New_Elmt_List
;
5237 Discr
:= First_Discriminant
(Typ
);
5238 while Present
(Discr
) loop
5239 Discr_Type
:= Etype
(Discr
);
5241 -- Add the new parameters as extra formals
5244 Make_Defining_Identifier
(Loc
,
5245 Chars
=> New_External_Name
(Chars
(Discr
), 'A'));
5247 Decorate_Extra_Formal
(A
, Discr_Type
);
5249 if Present
(Last_Extra
) then
5250 Set_Extra_Formal
(Last_Extra
, A
);
5252 Set_Extra_Formal
(Right_Formal
, A
);
5253 Set_Extra_Formals
(Scop
, A
);
5256 Append_Elmt
(A
, New_Discrs
);
5259 Make_Defining_Identifier
(Loc
,
5260 Chars
=> New_External_Name
(Chars
(Discr
), 'B'));
5262 Decorate_Extra_Formal
(B
, Discr_Type
);
5264 Set_Extra_Formal
(A
, B
);
5267 -- Generate the following code to compare each of the inferred
5275 Make_If_Statement
(Loc
,
5278 Left_Opnd
=> New_Occurrence_Of
(A
, Loc
),
5279 Right_Opnd
=> New_Occurrence_Of
(B
, Loc
)),
5280 Then_Statements
=> New_List
(
5281 Make_Simple_Return_Statement
(Loc
,
5283 New_Occurrence_Of
(Standard_False
, Loc
)))));
5285 Next_Discriminant
(Discr
);
5288 -- Generate component-by-component comparison. Note that we must
5289 -- propagate the inferred discriminants formals to act as the case
5290 -- statement switch. Their value is added when an equality call on
5291 -- unchecked unions is expanded.
5293 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
, New_Discrs
));
5296 -- Normal case (not unchecked union)
5300 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
5301 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
5305 Make_Simple_Return_Statement
(Loc
,
5306 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
5309 Make_Subprogram_Body
(Loc
,
5311 Make_Function_Specification
(Loc
,
5312 Defining_Unit_Name
=> Body_Id
,
5313 Parameter_Specifications
=> Param_Specs
,
5314 Result_Definition
=>
5315 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
5316 Declarations
=> Decls
,
5317 Handled_Statement_Sequence
=>
5318 Make_Handled_Sequence_Of_Statements
(Loc
,
5319 Statements
=> Stmts
));
5322 end Build_Variant_Record_Equality
;
5324 -----------------------------
5325 -- Check_Stream_Attributes --
5326 -----------------------------
5328 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
5330 Par_Read
: constant Boolean :=
5331 Stream_Attribute_Available
(Typ
, TSS_Stream_Read
)
5332 and then not Has_Specified_Stream_Read
(Typ
);
5333 Par_Write
: constant Boolean :=
5334 Stream_Attribute_Available
(Typ
, TSS_Stream_Write
)
5335 and then not Has_Specified_Stream_Write
(Typ
);
5337 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
);
5338 -- Check that Comp has a user-specified Nam stream attribute
5344 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
) is
5346 -- Move this check to sem???
5348 if not Stream_Attribute_Available
(Etype
(Comp
), TSS_Nam
) then
5349 Error_Msg_Name_1
:= Nam
;
5351 ("|component& in limited extension must have% attribute", Comp
);
5355 -- Start of processing for Check_Stream_Attributes
5358 if Par_Read
or else Par_Write
then
5359 Comp
:= First_Component
(Typ
);
5360 while Present
(Comp
) loop
5361 if Comes_From_Source
(Comp
)
5362 and then Original_Record_Component
(Comp
) = Comp
5363 and then Is_Limited_Type
(Etype
(Comp
))
5366 Check_Attr
(Name_Read
, TSS_Stream_Read
);
5370 Check_Attr
(Name_Write
, TSS_Stream_Write
);
5374 Next_Component
(Comp
);
5377 end Check_Stream_Attributes
;
5379 ----------------------
5380 -- Clean_Task_Names --
5381 ----------------------
5383 procedure Clean_Task_Names
5385 Proc_Id
: Entity_Id
)
5389 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
5390 and then not Global_Discard_Names
5391 and then Tagged_Type_Expansion
5393 Set_Uses_Sec_Stack
(Proc_Id
);
5395 end Clean_Task_Names
;
5397 -------------------------------
5398 -- Copy_Discr_Checking_Funcs --
5399 -------------------------------
5401 procedure Copy_Discr_Checking_Funcs
(N
: Node_Id
) is
5402 Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
5403 Comp
: Entity_Id
:= First_Component
(Typ
);
5404 Old_Comp
: Entity_Id
:= First_Component
5405 (Base_Type
(Underlying_Type
(Etype
(Typ
))));
5407 while Present
(Comp
) loop
5408 if Chars
(Comp
) = Chars
(Old_Comp
) then
5409 Set_Discriminant_Checking_Func
5410 (Comp
, Discriminant_Checking_Func
(Old_Comp
));
5413 Next_Component
(Old_Comp
);
5414 Next_Component
(Comp
);
5416 end Copy_Discr_Checking_Funcs
;
5418 ------------------------------
5419 -- Expand_Freeze_Array_Type --
5420 ------------------------------
5422 procedure Expand_Freeze_Array_Type
(N
: Node_Id
) is
5423 Typ
: constant Entity_Id
:= Entity
(N
);
5424 Base
: constant Entity_Id
:= Base_Type
(Typ
);
5426 -- Obtain the corresponding mutably tagged type if necessary
5428 Comp_Typ
: constant Entity_Id
:=
5429 Get_Corresponding_Mutably_Tagged_Type_If_Present
5430 (Component_Type
(Typ
));
5433 if not Is_Bit_Packed_Array
(Typ
) then
5435 -- If the component contains tasks, so does the array type. This may
5436 -- not be indicated in the array type because the component may have
5437 -- been a private type at the point of definition. Same if component
5438 -- type is controlled or contains protected objects.
5440 Propagate_Concurrent_Flags
(Base
, Comp_Typ
);
5441 Set_Has_Controlled_Component
5442 (Base
, Has_Controlled_Component
(Comp_Typ
)
5443 or else Is_Controlled
(Comp_Typ
));
5445 if No
(Init_Proc
(Base
)) then
5447 -- If this is an anonymous array created for a declaration with
5448 -- an initial value, its init_proc will never be called. The
5449 -- initial value itself may have been expanded into assignments,
5450 -- in which case the object declaration is carries the
5451 -- No_Initialization flag.
5454 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
5455 N_Object_Declaration
5457 (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
5458 or else No_Initialization
(Associated_Node_For_Itype
(Base
)))
5462 -- We do not need an init proc for string or wide [wide] string,
5463 -- since the only time these need initialization in normalize or
5464 -- initialize scalars mode, and these types are treated specially
5465 -- and do not need initialization procedures.
5467 elsif Is_Standard_String_Type
(Base
) then
5470 -- Otherwise we have to build an init proc for the subtype
5473 Build_Array_Init_Proc
(Base
, N
);
5477 if Typ
= Base
and then Has_Controlled_Component
(Base
) then
5478 Build_Controlling_Procs
(Base
);
5480 if not Is_Limited_Type
(Comp_Typ
)
5481 and then Number_Dimensions
(Typ
) = 1
5483 Build_Slice_Assignment
(Typ
);
5487 -- For packed case, default initialization, except if the component type
5488 -- is itself a packed structure with an initialization procedure, or
5489 -- initialize/normalize scalars active, and we have a base type, or the
5490 -- type is public, because in that case a client might specify
5491 -- Normalize_Scalars and there better be a public Init_Proc for it.
5493 elsif (Present
(Init_Proc
(Component_Type
(Base
)))
5494 and then No
(Base_Init_Proc
(Base
)))
5495 or else (Init_Or_Norm_Scalars
and then Base
= Typ
)
5496 or else Is_Public
(Typ
)
5498 Build_Array_Init_Proc
(Base
, N
);
5500 end Expand_Freeze_Array_Type
;
5502 -----------------------------------
5503 -- Expand_Freeze_Class_Wide_Type --
5504 -----------------------------------
5506 procedure Expand_Freeze_Class_Wide_Type
(N
: Node_Id
) is
5507 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean;
5508 -- Given a type, determine whether it is derived from a C or C++ root
5510 ---------------------
5511 -- Is_C_Derivation --
5512 ---------------------
5514 function Is_C_Derivation
(Typ
: Entity_Id
) return Boolean is
5521 or else Convention
(T
) = Convention_C
5522 or else Convention
(T
) = Convention_CPP
5527 exit when T
= Etype
(T
);
5533 end Is_C_Derivation
;
5537 Typ
: constant Entity_Id
:= Entity
(N
);
5538 Root
: constant Entity_Id
:= Root_Type
(Typ
);
5540 -- Start of processing for Expand_Freeze_Class_Wide_Type
5543 -- Certain run-time configurations and targets do not provide support
5544 -- for controlled types.
5546 if Restriction_Active
(No_Finalization
) then
5549 -- Do not create TSS routine Finalize_Address when dispatching calls are
5550 -- disabled since the core of the routine is a dispatching call.
5552 elsif Restriction_Active
(No_Dispatching_Calls
) then
5555 -- Do not create TSS routine Finalize_Address for concurrent class-wide
5556 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
5557 -- non-Ada side will handle their destruction.
5559 -- Concurrent Ada types are functionally represented by an associated
5560 -- "corresponding record type" (typenameV), which owns the actual TSS
5561 -- finalize bodies for the type (and technically class-wide type).
5563 elsif Is_Concurrent_Type
(Root
)
5564 or else Is_C_Derivation
(Root
)
5565 or else Convention
(Typ
) = Convention_CPP
5569 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
5570 -- mode since the routine contains an Unchecked_Conversion.
5572 elsif CodePeer_Mode
then
5576 -- Create the body of TSS primitive Finalize_Address. This automatically
5577 -- sets the TSS entry for the class-wide type.
5579 if No
(Finalize_Address
(Typ
)) then
5580 Make_Finalize_Address_Body
(Typ
);
5582 end Expand_Freeze_Class_Wide_Type
;
5584 ------------------------------------
5585 -- Expand_Freeze_Enumeration_Type --
5586 ------------------------------------
5588 procedure Expand_Freeze_Enumeration_Type
(N
: Node_Id
) is
5589 Typ
: constant Entity_Id
:= Entity
(N
);
5590 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5595 Is_Contiguous
: Boolean;
5596 Index_Typ
: Entity_Id
;
5604 pragma Warnings
(Off
, Func
);
5607 -- Various optimizations possible if given representation is contiguous
5609 Is_Contiguous
:= True;
5611 Ent
:= First_Literal
(Typ
);
5612 Last_Repval
:= Enumeration_Rep
(Ent
);
5616 while Present
(Ent
) loop
5617 if Enumeration_Rep
(Ent
) - Last_Repval
/= 1 then
5618 Is_Contiguous
:= False;
5620 Last_Repval
:= Enumeration_Rep
(Ent
);
5627 if Is_Contiguous
then
5628 Set_Has_Contiguous_Rep
(Typ
);
5630 -- Now build a subtype declaration
5632 -- subtype typI is new Natural range 0 .. num - 1
5635 Make_Defining_Identifier
(Loc
,
5636 Chars
=> New_External_Name
(Chars
(Typ
), 'I'));
5638 Append_Freeze_Action
(Typ
,
5639 Make_Subtype_Declaration
(Loc
,
5640 Defining_Identifier
=> Index_Typ
,
5641 Subtype_Indication
=>
5642 Make_Subtype_Indication
(Loc
,
5644 New_Occurrence_Of
(Standard_Natural
, Loc
),
5646 Make_Range_Constraint
(Loc
,
5650 Make_Integer_Literal
(Loc
, 0),
5652 Make_Integer_Literal
(Loc
, Num
- 1))))));
5654 Set_Enum_Pos_To_Rep
(Typ
, Index_Typ
);
5657 -- Build list of literal references
5660 Ent
:= First_Literal
(Typ
);
5661 while Present
(Ent
) loop
5662 Append_To
(Lst
, New_Occurrence_Of
(Ent
, Sloc
(Ent
)));
5666 -- Now build an array declaration
5668 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5669 -- (v, v, v, v, v, ....)
5672 Make_Defining_Identifier
(Loc
,
5673 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
5675 Append_Freeze_Action
(Typ
,
5676 Make_Object_Declaration
(Loc
,
5677 Defining_Identifier
=> Arr
,
5678 Constant_Present
=> True,
5680 Object_Definition
=>
5681 Make_Constrained_Array_Definition
(Loc
,
5682 Discrete_Subtype_Definitions
=> New_List
(
5683 Make_Subtype_Indication
(Loc
,
5685 New_Occurrence_Of
(Standard_Natural
, Loc
),
5687 Make_Range_Constraint
(Loc
,
5691 Make_Integer_Literal
(Loc
, 0),
5693 Make_Integer_Literal
(Loc
, Num
- 1))))),
5695 Component_Definition
=>
5696 Make_Component_Definition
(Loc
,
5697 Aliased_Present
=> False,
5698 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))),
5701 Make_Aggregate
(Loc
,
5702 Expressions
=> Lst
)));
5704 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
5707 -- Now we build the function that converts representation values to
5708 -- position values. This function has the form:
5710 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5713 -- when enum-lit'Enum_Rep => return posval;
5714 -- when enum-lit'Enum_Rep => return posval;
5717 -- [raise Constraint_Error when F "invalid data"]
5722 -- Note: the F parameter determines whether the others case (no valid
5723 -- representation) raises Constraint_Error or returns a unique value
5724 -- of minus one. The latter case is used, e.g. in 'Valid code.
5726 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5727 -- the code generator making inappropriate assumptions about the range
5728 -- of the values in the case where the value is invalid. ityp is a
5729 -- signed or unsigned integer type of appropriate width.
5731 -- Note: if exceptions are not supported, then we suppress the raise
5732 -- and return -1 unconditionally (this is an erroneous program in any
5733 -- case and there is no obligation to raise Constraint_Error here). We
5734 -- also do this if pragma Restrictions (No_Exceptions) is active.
5736 -- Is this right??? What about No_Exception_Propagation???
5738 -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly
5739 -- because it might have been inherited from the parent type.
5741 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
5742 Set_Is_Unsigned_Type
(Typ
, False);
5745 Ityp
:= Integer_Type_For
(Esize
(Typ
), Is_Unsigned_Type
(Typ
));
5747 -- The body of the function is a case statement. First collect case
5748 -- alternatives, or optimize the contiguous case.
5752 -- If representation is contiguous, Pos is computed by subtracting
5753 -- the representation of the first literal.
5755 if Is_Contiguous
then
5756 Ent
:= First_Literal
(Typ
);
5758 if Enumeration_Rep
(Ent
) = Last_Repval
then
5760 -- Another special case: for a single literal, Pos is zero
5762 Pos_Expr
:= Make_Integer_Literal
(Loc
, Uint_0
);
5766 Convert_To
(Standard_Integer
,
5767 Make_Op_Subtract
(Loc
,
5769 Unchecked_Convert_To
5770 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5772 Make_Integer_Literal
(Loc
,
5773 Intval
=> Enumeration_Rep
(First_Literal
(Typ
)))));
5777 Make_Case_Statement_Alternative
(Loc
,
5778 Discrete_Choices
=> New_List
(
5779 Make_Range
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5781 Make_Integer_Literal
(Loc
,
5782 Intval
=> Enumeration_Rep
(Ent
)),
5784 Make_Integer_Literal
(Loc
, Intval
=> Last_Repval
))),
5786 Statements
=> New_List
(
5787 Make_Simple_Return_Statement
(Loc
,
5788 Expression
=> Pos_Expr
))));
5791 Ent
:= First_Literal
(Typ
);
5792 while Present
(Ent
) loop
5794 Make_Case_Statement_Alternative
(Loc
,
5795 Discrete_Choices
=> New_List
(
5796 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5797 Intval
=> Enumeration_Rep
(Ent
))),
5799 Statements
=> New_List
(
5800 Make_Simple_Return_Statement
(Loc
,
5802 Make_Integer_Literal
(Loc
,
5803 Intval
=> Enumeration_Pos
(Ent
))))));
5809 -- In normal mode, add the others clause with the test.
5810 -- If Predicates_Ignored is True, validity checks do not apply to
5813 if not No_Exception_Handlers_Set
5814 and then not Predicates_Ignored
(Typ
)
5817 Make_Case_Statement_Alternative
(Loc
,
5818 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5819 Statements
=> New_List
(
5820 Make_Raise_Constraint_Error
(Loc
,
5821 Condition
=> Make_Identifier
(Loc
, Name_uF
),
5822 Reason
=> CE_Invalid_Data
),
5823 Make_Simple_Return_Statement
(Loc
,
5824 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5826 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5827 -- active then return -1 (we cannot usefully raise Constraint_Error in
5828 -- this case). See description above for further details.
5832 Make_Case_Statement_Alternative
(Loc
,
5833 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5834 Statements
=> New_List
(
5835 Make_Simple_Return_Statement
(Loc
,
5836 Expression
=> Make_Integer_Literal
(Loc
, -1)))));
5839 -- Now we can build the function body
5842 Make_Defining_Identifier
(Loc
, Make_TSS_Name
(Typ
, TSS_Rep_To_Pos
));
5845 Make_Subprogram_Body
(Loc
,
5847 Make_Function_Specification
(Loc
,
5848 Defining_Unit_Name
=> Fent
,
5849 Parameter_Specifications
=> New_List
(
5850 Make_Parameter_Specification
(Loc
,
5851 Defining_Identifier
=>
5852 Make_Defining_Identifier
(Loc
, Name_uA
),
5853 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
5854 Make_Parameter_Specification
(Loc
,
5855 Defining_Identifier
=>
5856 Make_Defining_Identifier
(Loc
, Name_uF
),
5858 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
5860 Result_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
5862 Declarations
=> Empty_List
,
5864 Handled_Statement_Sequence
=>
5865 Make_Handled_Sequence_Of_Statements
(Loc
,
5866 Statements
=> New_List
(
5867 Make_Case_Statement
(Loc
,
5869 Unchecked_Convert_To
5870 (Ityp
, Make_Identifier
(Loc
, Name_uA
)),
5871 Alternatives
=> Lst
))));
5873 Set_TSS
(Typ
, Fent
);
5875 -- Set Pure flag (it will be reset if the current context is not Pure).
5876 -- We also pretend there was a pragma Pure_Function so that for purposes
5877 -- of optimization and constant-folding, we will consider the function
5878 -- Pure even if we are not in a Pure context).
5881 Set_Has_Pragma_Pure_Function
(Fent
);
5883 -- Unless we are in -gnatD mode, where we are debugging generated code,
5884 -- this is an internal entity for which we don't need debug info.
5886 if not Debug_Generated_Code
then
5887 Set_Debug_Info_Off
(Fent
);
5890 Set_Is_Inlined
(Fent
);
5893 when RE_Not_Available
=>
5895 end Expand_Freeze_Enumeration_Type
;
5897 -------------------------------
5898 -- Expand_Freeze_Record_Type --
5899 -------------------------------
5901 procedure Expand_Freeze_Record_Type
(N
: Node_Id
) is
5903 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
);
5904 -- Create internal subprograms of Typ primitives that have class-wide
5905 -- preconditions or postconditions; they are invoked by the caller to
5906 -- evaluate the conditions.
5908 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
5909 -- Create an equality function for the untagged variant record Typ and
5910 -- attach it to the TSS list.
5912 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
);
5913 -- Register dispatch-table wrappers in the dispatch table of Typ
5915 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
);
5916 -- Check extra formals of dispatching primitives of tagged type Typ.
5917 -- Used in pragma Debug.
5919 ---------------------------------------
5920 -- Build_Class_Condition_Subprograms --
5921 ---------------------------------------
5923 procedure Build_Class_Condition_Subprograms
(Typ
: Entity_Id
) is
5924 Prim_List
: constant Elist_Id
:= Primitive_Operations
(Typ
);
5925 Prim_Elmt
: Elmt_Id
:= First_Elmt
(Prim_List
);
5929 while Present
(Prim_Elmt
) loop
5930 Prim
:= Node
(Prim_Elmt
);
5932 -- Primitive with class-wide preconditions
5934 if Comes_From_Source
(Prim
)
5935 and then Has_Significant_Contract
(Prim
)
5937 (Present
(Class_Preconditions
(Prim
))
5938 or else Present
(Ignored_Class_Preconditions
(Prim
)))
5940 if Expander_Active
then
5941 Make_Class_Precondition_Subps
(Prim
);
5944 -- Wrapper of a primitive that has or inherits class-wide
5947 elsif Is_Primitive_Wrapper
(Prim
)
5949 (Present
(Nearest_Class_Condition_Subprogram
5951 Kind
=> Class_Precondition
))
5953 Present
(Nearest_Class_Condition_Subprogram
5955 Kind
=> Ignored_Class_Precondition
)))
5957 if Expander_Active
then
5958 Make_Class_Precondition_Subps
(Prim
);
5962 Next_Elmt
(Prim_Elmt
);
5964 end Build_Class_Condition_Subprograms
;
5966 -----------------------------------
5967 -- Build_Variant_Record_Equality --
5968 -----------------------------------
5970 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
5971 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5972 F
: constant Entity_Id
:=
5973 Make_Defining_Identifier
(Loc
,
5974 Chars
=> Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
5976 -- For a variant record with restriction No_Implicit_Conditionals
5977 -- in effect we skip building the procedure. This is safe because
5978 -- if we can see the restriction, so can any caller, and calls to
5979 -- equality test routines are not allowed for variant records if
5980 -- this restriction is active.
5982 if Restriction_Active
(No_Implicit_Conditionals
) then
5986 -- Derived Unchecked_Union types no longer inherit the equality
5987 -- function of their parent.
5989 if Is_Derived_Type
(Typ
)
5990 and then not Is_Unchecked_Union
(Typ
)
5991 and then not Has_New_Non_Standard_Rep
(Typ
)
5994 Parent_Eq
: constant Entity_Id
:=
5995 TSS
(Root_Type
(Typ
), TSS_Composite_Equality
);
5997 if Present
(Parent_Eq
) then
5998 Copy_TSS
(Parent_Eq
, Typ
);
6005 Build_Variant_Record_Equality
6009 Param_Specs
=> New_List
(
6010 Make_Parameter_Specification
(Loc
,
6011 Defining_Identifier
=>
6012 Make_Defining_Identifier
(Loc
, Name_X
),
6013 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
6015 Make_Parameter_Specification
(Loc
,
6016 Defining_Identifier
=>
6017 Make_Defining_Identifier
(Loc
, Name_Y
),
6018 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))));
6023 if not Debug_Generated_Code
then
6024 Set_Debug_Info_Off
(F
);
6026 end Build_Variant_Record_Equality
;
6028 --------------------------------------
6029 -- Register_Dispatch_Table_Wrappers --
6030 --------------------------------------
6032 procedure Register_Dispatch_Table_Wrappers
(Typ
: Entity_Id
) is
6033 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
6037 while Present
(Elmt
) loop
6038 Subp
:= Node
(Elmt
);
6040 if Is_Dispatch_Table_Wrapper
(Subp
) then
6041 Append_Freeze_Actions
(Typ
,
6042 Register_Primitive
(Sloc
(Subp
), Subp
));
6047 end Register_Dispatch_Table_Wrappers
;
6049 ----------------------------------------
6050 -- Validate_Tagged_Type_Extra_Formals --
6051 ----------------------------------------
6053 procedure Validate_Tagged_Type_Extra_Formals
(Typ
: Entity_Id
) is
6054 Ovr_Subp
: Entity_Id
;
6059 pragma Assert
(not Is_Class_Wide_Type
(Typ
));
6061 -- No check required if expansion is not active since we never
6062 -- generate extra formals in such case.
6064 if not Expander_Active
then
6068 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6069 while Present
(Elmt
) loop
6070 Subp
:= Node
(Elmt
);
6072 -- Extra formals of a dispatching primitive must match:
6074 -- 1) The extra formals of its covered interface primitive
6076 if Present
(Interface_Alias
(Subp
)) then
6078 (Extra_Formals_Match_OK
6079 (E
=> Interface_Alias
(Subp
),
6080 Ref_E
=> Alias
(Subp
)));
6083 -- 2) The extra formals of its renamed primitive
6085 if Present
(Alias
(Subp
)) then
6087 (Extra_Formals_Match_OK
6089 Ref_E
=> Ultimate_Alias
(Subp
)));
6092 -- 3) The extra formals of its overridden primitive
6094 if Present
(Overridden_Operation
(Subp
)) then
6095 Ovr_Subp
:= Overridden_Operation
(Subp
);
6097 -- Handle controlling function wrapper
6099 if Is_Wrapper
(Subp
)
6100 and then Ultimate_Alias
(Ovr_Subp
) = Subp
6102 if Present
(Overridden_Operation
(Ovr_Subp
)) then
6104 (Extra_Formals_Match_OK
6106 Ref_E
=> Overridden_Operation
(Ovr_Subp
)));
6111 (Extra_Formals_Match_OK
6113 Ref_E
=> Ovr_Subp
));
6119 end Validate_Tagged_Type_Extra_Formals
;
6123 Typ
: constant Node_Id
:= Entity
(N
);
6124 Typ_Decl
: constant Node_Id
:= Parent
(Typ
);
6127 Comp_Typ
: Entity_Id
;
6128 Predef_List
: List_Id
;
6130 Wrapper_Decl_List
: List_Id
;
6131 Wrapper_Body_List
: List_Id
:= No_List
;
6133 Renamed_Eq
: Node_Id
:= Empty
;
6134 -- Defining unit name for the predefined equality function in the case
6135 -- where the type has a primitive operation that is a renaming of
6136 -- predefined equality (but only if there is also an overriding
6137 -- user-defined equality function). Used to pass this entity from
6138 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
6140 -- Start of processing for Expand_Freeze_Record_Type
6143 -- Build discriminant checking functions if not a derived type (for
6144 -- derived types that are not tagged types, always use the discriminant
6145 -- checking functions of the parent type). However, for untagged types
6146 -- the derivation may have taken place before the parent was frozen, so
6147 -- we copy explicitly the discriminant checking functions from the
6148 -- parent into the components of the derived type.
6150 Build_Or_Copy_Discr_Checking_Funcs
(Typ_Decl
);
6152 if Is_Derived_Type
(Typ
)
6153 and then Is_Limited_Type
(Typ
)
6154 and then Is_Tagged_Type
(Typ
)
6156 Check_Stream_Attributes
(Typ
);
6159 -- Update task, protected, and controlled component flags, because some
6160 -- of the component types may have been private at the point of the
6161 -- record declaration. Detect anonymous access-to-controlled components.
6163 Comp
:= First_Component
(Typ
);
6164 while Present
(Comp
) loop
6165 Comp_Typ
:= Etype
(Comp
);
6167 Propagate_Concurrent_Flags
(Typ
, Comp_Typ
);
6169 -- Do not set Has_Controlled_Component on a class-wide equivalent
6170 -- type. See Make_CW_Equivalent_Type.
6172 if not Is_Class_Wide_Equivalent_Type
(Typ
)
6174 (Has_Controlled_Component
(Comp_Typ
)
6175 or else (Chars
(Comp
) /= Name_uParent
6176 and then Is_Controlled
(Comp_Typ
)))
6178 Set_Has_Controlled_Component
(Typ
);
6181 Next_Component
(Comp
);
6184 -- Handle constructors of untagged CPP_Class types
6186 if not Is_Tagged_Type
(Typ
) and then Is_CPP_Class
(Typ
) then
6187 Set_CPP_Constructors
(Typ
);
6190 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
6191 -- for regular tagged types as well as for Ada types deriving from a C++
6192 -- Class, but not for tagged types directly corresponding to C++ classes
6193 -- In the later case we assume that it is created in the C++ side and we
6196 if Is_Tagged_Type
(Typ
) then
6198 -- Add the _Tag component
6200 if Underlying_Type
(Etype
(Typ
)) = Typ
then
6201 Expand_Tagged_Root
(Typ
);
6204 if Is_CPP_Class
(Typ
) then
6205 Set_All_DT_Position
(Typ
);
6207 -- Create the tag entities with a minimum decoration
6209 if Tagged_Type_Expansion
then
6210 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
6213 Set_CPP_Constructors
(Typ
);
6216 if not Building_Static_DT
(Typ
) then
6218 -- Usually inherited primitives are not delayed but the first
6219 -- Ada extension of a CPP_Class is an exception since the
6220 -- address of the inherited subprogram has to be inserted in
6221 -- the new Ada Dispatch Table and this is a freezing action.
6223 -- Similarly, if this is an inherited operation whose parent is
6224 -- not frozen yet, it is not in the DT of the parent, and we
6225 -- generate an explicit freeze node for the inherited operation
6226 -- so it is properly inserted in the DT of the current type.
6233 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6234 while Present
(Elmt
) loop
6235 Subp
:= Node
(Elmt
);
6237 if Present
(Alias
(Subp
)) then
6238 if Is_CPP_Class
(Etype
(Typ
)) then
6239 Set_Has_Delayed_Freeze
(Subp
);
6241 elsif Has_Delayed_Freeze
(Alias
(Subp
))
6242 and then not Is_Frozen
(Alias
(Subp
))
6244 Set_Is_Frozen
(Subp
, False);
6245 Set_Has_Delayed_Freeze
(Subp
);
6254 -- Unfreeze momentarily the type to add the predefined primitives
6255 -- operations. The reason we unfreeze is so that these predefined
6256 -- operations will indeed end up as primitive operations (which
6257 -- must be before the freeze point).
6259 Set_Is_Frozen
(Typ
, False);
6261 -- Do not add the spec of predefined primitives in case of
6262 -- CPP tagged type derivations that have convention CPP.
6264 if Is_CPP_Class
(Root_Type
(Typ
))
6265 and then Convention
(Typ
) = Convention_CPP
6269 -- Do not add the spec of the predefined primitives if we are
6270 -- compiling under restriction No_Dispatching_Calls.
6272 elsif not Restriction_Active
(No_Dispatching_Calls
) then
6273 Make_Predefined_Primitive_Specs
(Typ
, Predef_List
, Renamed_Eq
);
6274 Insert_List_Before_And_Analyze
(N
, Predef_List
);
6277 -- Ada 2005 (AI-391): For a nonabstract null extension, create
6278 -- wrapper functions for each nonoverridden inherited function
6279 -- with a controlling result of the type. The wrapper for such
6280 -- a function returns an extension aggregate that invokes the
6283 if Ada_Version
>= Ada_2005
6284 and then not Is_Abstract_Type
(Typ
)
6285 and then Is_Null_Extension
(Typ
)
6287 Make_Controlling_Function_Wrappers
6288 (Typ
, Wrapper_Decl_List
, Wrapper_Body_List
);
6289 Insert_List_Before_And_Analyze
(N
, Wrapper_Decl_List
);
6292 -- Ada 2005 (AI-251): For a nonabstract type extension, build
6293 -- null procedure declarations for each set of homographic null
6294 -- procedures that are inherited from interface types but not
6295 -- overridden. This is done to ensure that the dispatch table
6296 -- entry associated with such null primitives are properly filled.
6298 if Ada_Version
>= Ada_2005
6299 and then Etype
(Typ
) /= Typ
6300 and then not Is_Abstract_Type
(Typ
)
6301 and then Has_Interfaces
(Typ
)
6303 Insert_Actions
(N
, Make_Null_Procedure_Specs
(Typ
));
6306 Set_Is_Frozen
(Typ
);
6308 if not Is_Derived_Type
(Typ
)
6309 or else Is_Tagged_Type
(Etype
(Typ
))
6311 Set_All_DT_Position
(Typ
);
6313 -- If this is a type derived from an untagged private type whose
6314 -- full view is tagged, the type is marked tagged for layout
6315 -- reasons, but it has no dispatch table.
6317 elsif Is_Derived_Type
(Typ
)
6318 and then Is_Private_Type
(Etype
(Typ
))
6319 and then not Is_Tagged_Type
(Etype
(Typ
))
6324 -- Create and decorate the tags. Suppress their creation when
6325 -- not Tagged_Type_Expansion because the dispatching mechanism is
6326 -- handled internally by the virtual target.
6328 if Tagged_Type_Expansion
then
6329 Append_Freeze_Actions
(Typ
, Make_Tags
(Typ
));
6331 -- Generate dispatch table of locally defined tagged type.
6332 -- Dispatch tables of library level tagged types are built
6333 -- later (see Build_Static_Dispatch_Tables).
6335 if not Building_Static_DT
(Typ
) then
6336 Append_Freeze_Actions
(Typ
, Make_DT
(Typ
));
6338 -- Register dispatch table wrappers in the dispatch table.
6339 -- It could not be done when these wrappers were built
6340 -- because, at that stage, the dispatch table was not
6343 Register_Dispatch_Table_Wrappers
(Typ
);
6347 -- If the type has unknown discriminants, propagate dispatching
6348 -- information to its underlying record view, which does not get
6349 -- its own dispatch table.
6351 if Is_Derived_Type
(Typ
)
6352 and then Has_Unknown_Discriminants
(Typ
)
6353 and then Present
(Underlying_Record_View
(Typ
))
6356 Rep
: constant Entity_Id
:= Underlying_Record_View
(Typ
);
6358 Set_Access_Disp_Table
6359 (Rep
, Access_Disp_Table
(Typ
));
6360 Set_Dispatch_Table_Wrappers
6361 (Rep
, Dispatch_Table_Wrappers
(Typ
));
6362 Set_Direct_Primitive_Operations
6363 (Rep
, Direct_Primitive_Operations
(Typ
));
6367 -- Make sure that the primitives Initialize, Adjust and Finalize
6368 -- are Frozen before other TSS subprograms. We don't want them
6371 if Is_Controlled
(Typ
) then
6372 if not Is_Limited_Type
(Typ
) then
6373 Append_Freeze_Actions
(Typ
,
6374 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Adjust
), Typ
));
6377 Append_Freeze_Actions
(Typ
,
6378 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Initialize
), Typ
));
6380 Append_Freeze_Actions
(Typ
,
6381 Freeze_Entity
(Find_Prim_Op
(Typ
, Name_Finalize
), Typ
));
6384 -- Freeze rest of primitive operations. There is no need to handle
6385 -- the predefined primitives if we are compiling under restriction
6386 -- No_Dispatching_Calls.
6388 if not Restriction_Active
(No_Dispatching_Calls
) then
6389 Append_Freeze_Actions
(Typ
, Predefined_Primitive_Freeze
(Typ
));
6393 -- In the untagged case, ever since Ada 83 an equality function must
6394 -- be provided for variant records that are not unchecked unions.
6396 elsif Has_Discriminants
(Typ
)
6397 and then not Is_Limited_Type
(Typ
)
6398 and then Present
(Component_List
(Type_Definition
(Typ_Decl
)))
6400 Present
(Variant_Part
(Component_List
(Type_Definition
(Typ_Decl
))))
6402 Build_Variant_Record_Equality
(Typ
);
6404 -- In Ada 2012 the equality function composes, and thus must be built
6405 -- explicitly just as for tagged records.
6407 -- This is done unconditionally to ensure that tools can be linked
6408 -- properly with user programs compiled with older language versions.
6409 -- In addition, this is needed because "=" composes for bounded strings
6410 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
6412 elsif Comes_From_Source
(Typ
)
6413 and then Convention
(Typ
) = Convention_Ada
6414 and then not Is_Limited_Type
(Typ
)
6416 Build_Untagged_Record_Equality
(Typ
);
6419 -- Before building the record initialization procedure, if we are
6420 -- dealing with a concurrent record value type, then we must go through
6421 -- the discriminants, exchanging discriminals between the concurrent
6422 -- type and the concurrent record value type. See the section "Handling
6423 -- of Discriminants" in the Einfo spec for details.
6425 if Is_Concurrent_Record_Type
(Typ
) and then Has_Discriminants
(Typ
) then
6427 Ctyp
: constant Entity_Id
:=
6428 Corresponding_Concurrent_Type
(Typ
);
6429 Conc_Discr
: Entity_Id
;
6430 Rec_Discr
: Entity_Id
;
6434 Conc_Discr
:= First_Discriminant
(Ctyp
);
6435 Rec_Discr
:= First_Discriminant
(Typ
);
6436 while Present
(Conc_Discr
) loop
6437 Temp
:= Discriminal
(Conc_Discr
);
6438 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
6439 Set_Discriminal
(Rec_Discr
, Temp
);
6441 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
6442 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
6444 Next_Discriminant
(Conc_Discr
);
6445 Next_Discriminant
(Rec_Discr
);
6450 if Has_Controlled_Component
(Typ
) then
6451 Build_Controlling_Procs
(Typ
);
6454 Adjust_Discriminants
(Typ
);
6456 -- Do not need init for interfaces on virtual targets since they're
6459 if not Is_Mutably_Tagged_CW_Equivalent_Type
(Typ
)
6460 and then (Tagged_Type_Expansion
or else not Is_Interface
(Typ
))
6462 Build_Record_Init_Proc
(Typ_Decl
, Typ
);
6465 -- For tagged type that are not interfaces, build bodies of primitive
6466 -- operations. Note: do this after building the record initialization
6467 -- procedure, since the primitive operations may need the initialization
6468 -- routine. There is no need to add predefined primitives of interfaces
6469 -- because all their predefined primitives are abstract.
6471 if Is_Tagged_Type
(Typ
) and then not Is_Interface
(Typ
) then
6473 -- Do not add the body of predefined primitives in case of CPP tagged
6474 -- type derivations that have convention CPP.
6476 if Is_CPP_Class
(Root_Type
(Typ
))
6477 and then Convention
(Typ
) = Convention_CPP
6482 -- Create the body of TSS primitive Finalize_Address. This must
6483 -- be done before the bodies of all predefined primitives are
6484 -- created. If Typ is limited, Stream_Input and Stream_Read may
6485 -- produce build-in-place allocations and for those the expander
6486 -- needs Finalize_Address.
6488 Make_Finalize_Address_Body
(Typ
);
6490 -- Do not add the body of the predefined primitives if we are
6491 -- compiling under restriction No_Dispatching_Calls.
6493 if not Restriction_Active
(No_Dispatching_Calls
) then
6494 -- Create the body of the class-wide type's TSS primitive
6495 -- Finalize_Address. This must be done before any class-wide
6496 -- precondition functions are created.
6498 Make_Finalize_Address_Body
(Class_Wide_Type
(Typ
));
6500 Predef_List
:= Predefined_Primitive_Bodies
(Typ
, Renamed_Eq
);
6501 Append_Freeze_Actions
(Typ
, Predef_List
);
6505 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
6506 -- inherited functions, then add their bodies to the freeze actions.
6508 Append_Freeze_Actions
(Typ
, Wrapper_Body_List
);
6510 -- Create body of an interface type's class-wide type's TSS primitive
6511 -- Finalize_Address.
6513 elsif Is_Tagged_Type
(Typ
)
6514 and then Is_Interface
(Typ
)
6515 and then not Restriction_Active
(No_Dispatching_Calls
)
6517 Make_Finalize_Address_Body
(Class_Wide_Type
(Typ
));
6520 -- Create extra formals for the primitive operations of the type.
6521 -- This must be done before analyzing the body of the initialization
6522 -- procedure, because a self-referential type might call one of these
6523 -- primitives in the body of the init_proc itself.
6525 -- This is not needed:
6526 -- 1) If expansion is disabled, because extra formals are only added
6527 -- when we are generating code.
6529 -- 2) For types with foreign convention since primitives with foreign
6530 -- convention don't have extra formals and AI95-117 requires that
6531 -- all primitives of a tagged type inherit the convention.
6534 and then Is_Tagged_Type
(Typ
)
6535 and then not Has_Foreign_Convention
(Typ
)
6542 -- Add extra formals to primitive operations
6544 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6545 while Present
(Elmt
) loop
6546 Create_Extra_Formals
(Node
(Elmt
));
6550 -- Add extra formals to renamings of primitive operations. The
6551 -- addition of extra formals is done in two steps to minimize
6552 -- the compile time required for this action; the evaluation of
6553 -- Find_Dispatching_Type() and Contains() is only done here for
6554 -- renamings that are not primitive operations.
6556 E
:= First_Entity
(Scope
(Typ
));
6557 while Present
(E
) loop
6558 if Is_Dispatching_Operation
(E
)
6559 and then Present
(Alias
(E
))
6560 and then Find_Dispatching_Type
(E
) = Typ
6561 and then not Contains
(Primitive_Operations
(Typ
), E
)
6563 Create_Extra_Formals
(E
);
6569 pragma Debug
(Validate_Tagged_Type_Extra_Formals
(Typ
));
6573 -- Build internal subprograms of primitives with class-wide
6574 -- pre/postconditions.
6576 if Is_Tagged_Type
(Typ
) then
6577 Build_Class_Condition_Subprograms
(Typ
);
6579 end Expand_Freeze_Record_Type
;
6581 ------------------------------------
6582 -- Expand_N_Full_Type_Declaration --
6583 ------------------------------------
6585 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
6586 procedure Build_Master
(Ptr_Typ
: Entity_Id
);
6587 -- Create the master associated with Ptr_Typ
6593 procedure Build_Master
(Ptr_Typ
: Entity_Id
) is
6594 Desig_Typ
: Entity_Id
:= Designated_Type
(Ptr_Typ
);
6597 -- If the designated type is an incomplete view coming from a
6598 -- limited-with'ed package, we need to use the nonlimited view in
6599 -- case it has tasks.
6601 if Is_Incomplete_Type
(Desig_Typ
)
6602 and then Present
(Non_Limited_View
(Desig_Typ
))
6604 Desig_Typ
:= Non_Limited_View
(Desig_Typ
);
6607 -- Anonymous access types are created for the components of the
6608 -- record parameter for an entry declaration. No master is created
6611 if Has_Task
(Desig_Typ
) then
6612 Build_Master_Entity
(Ptr_Typ
);
6613 Build_Master_Renaming
(Ptr_Typ
);
6615 -- Create a class-wide master because a Master_Id must be generated
6616 -- for access-to-limited-class-wide types whose root may be extended
6617 -- with task components.
6619 -- Note: This code covers access-to-limited-interfaces because they
6620 -- can be used to reference tasks implementing them.
6622 -- Suppress the master creation for access types created for entry
6623 -- formal parameters (parameter block component types). Seems like
6624 -- suppression should be more general for compiler-generated types,
6625 -- but testing Comes_From_Source may be too general in this case
6626 -- (affects some test output)???
6628 elsif not Is_Param_Block_Component_Type
(Ptr_Typ
)
6629 and then Is_Limited_Class_Wide_Type
(Desig_Typ
)
6631 Build_Class_Wide_Master
(Ptr_Typ
);
6635 -- Local declarations
6637 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6638 B_Id
: constant Entity_Id
:= Base_Type
(Def_Id
);
6642 -- Start of processing for Expand_N_Full_Type_Declaration
6645 if Is_Access_Type
(Def_Id
) then
6646 Build_Master
(Def_Id
);
6648 if Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
6649 Expand_Access_Protected_Subprogram_Type
(N
);
6652 -- Array of anonymous access-to-task pointers
6654 elsif Ada_Version
>= Ada_2005
6655 and then Is_Array_Type
(Def_Id
)
6656 and then Is_Access_Type
(Component_Type
(Def_Id
))
6657 and then Ekind
(Component_Type
(Def_Id
)) = E_Anonymous_Access_Type
6659 Build_Master
(Component_Type
(Def_Id
));
6661 elsif Has_Task
(Def_Id
) then
6662 Expand_Previous_Access_Type
(Def_Id
);
6664 -- Check the components of a record type or array of records for
6665 -- anonymous access-to-task pointers.
6667 elsif Ada_Version
>= Ada_2005
6668 and then (Is_Record_Type
(Def_Id
)
6670 (Is_Array_Type
(Def_Id
)
6671 and then Is_Record_Type
(Component_Type
(Def_Id
))))
6676 M_Id
: Entity_Id
:= Empty
;
6680 if Is_Array_Type
(Def_Id
) then
6681 Comp
:= First_Entity
(Component_Type
(Def_Id
));
6683 Comp
:= First_Entity
(Def_Id
);
6686 -- Examine all components looking for anonymous access-to-task
6690 while Present
(Comp
) loop
6691 Typ
:= Etype
(Comp
);
6693 if Ekind
(Typ
) = E_Anonymous_Access_Type
6694 and then Might_Have_Tasks
6695 (Available_View
(Designated_Type
(Typ
)))
6696 and then No
(Master_Id
(Typ
))
6698 -- Ensure that the record or array type have a _master
6701 Build_Master_Entity
(Def_Id
);
6702 Build_Master_Renaming
(Typ
);
6703 M_Id
:= Master_Id
(Typ
);
6707 -- Reuse the same master to service any additional types
6710 pragma Assert
(Present
(M_Id
));
6711 Set_Master_Id
(Typ
, M_Id
);
6720 -- Handle mutably tagged types by replacing their declarations with
6721 -- their class-wide equivalent types.
6726 if Is_Array_Type
(Def_Id
) then
6727 Comp
:= First_Entity
(Component_Type
(Def_Id
));
6729 Comp
:= First_Entity
(Def_Id
);
6732 while Present
(Comp
) loop
6733 if Ekind
(Etype
(Comp
)) /= E_Void
6734 and then Is_Mutably_Tagged_Type
(Etype
(Comp
))
6737 (Comp
, Class_Wide_Equivalent_Type
(Etype
(Comp
)));
6743 Par_Id
:= Etype
(B_Id
);
6745 -- The parent type is private then we need to inherit any TSS operations
6746 -- from the full view.
6748 if Is_Private_Type
(Par_Id
)
6749 and then Present
(Full_View
(Par_Id
))
6751 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
6754 if Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
6755 and then not Is_Tagged_Type
(Def_Id
)
6756 and then Present
(Freeze_Node
(Par_Id
))
6757 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
6759 Ensure_Freeze_Node
(B_Id
);
6760 FN
:= Freeze_Node
(B_Id
);
6762 if No
(TSS_Elist
(FN
)) then
6763 Set_TSS_Elist
(FN
, New_Elmt_List
);
6767 T_E
: constant Elist_Id
:= TSS_Elist
(FN
);
6771 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
6772 while Present
(Elmt
) loop
6773 if Chars
(Node
(Elmt
)) /= Name_uInit
then
6774 Append_Elmt
(Node
(Elmt
), T_E
);
6780 -- If the derived type itself is private with a full view, then
6781 -- associate the full view with the inherited TSS_Elist as well.
6783 if Is_Private_Type
(B_Id
)
6784 and then Present
(Full_View
(B_Id
))
6786 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
6788 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
6792 end Expand_N_Full_Type_Declaration
;
6794 ---------------------------------
6795 -- Expand_N_Object_Declaration --
6796 ---------------------------------
6798 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
6799 Loc
: constant Source_Ptr
:= Sloc
(N
);
6800 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6801 Expr
: constant Node_Id
:= Expression
(N
);
6802 Obj_Def
: constant Node_Id
:= Object_Definition
(N
);
6803 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
6804 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
6805 Next_N
: constant Node_Id
:= Next
(N
);
6807 Special_Ret_Obj
: constant Boolean := Is_Special_Return_Object
(Def_Id
);
6808 -- If this is a special return object, it will be allocated differently
6809 -- and ultimately rewritten as a renaming, so initialization activities
6810 -- need to be deferred until after that is done.
6812 Func_Id
: constant Entity_Id
:=
6813 (if Special_Ret_Obj
then Return_Applies_To
(Scope
(Def_Id
)) else Empty
);
6814 -- The function if this is a special return object, otherwise Empty
6816 function Build_Heap_Or_Pool_Allocator
6817 (Temp_Id
: Entity_Id
;
6818 Temp_Typ
: Entity_Id
;
6819 Ret_Typ
: Entity_Id
;
6820 Alloc_Expr
: Node_Id
) return Node_Id
;
6821 -- Create the statements necessary to allocate a return object on the
6822 -- heap or user-defined storage pool. The object may need finalization
6823 -- actions depending on the return type.
6825 -- * Controlled case
6827 -- if BIPcollection = null then
6828 -- Temp_Id := <Alloc_Expr>;
6831 -- type Ptr_Typ is access Ret_Typ;
6832 -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all;
6836 -- procedure Allocate (...) is
6838 -- System.Storage_Pools.Subpools.Allocate_Any (...);
6841 -- Local := <Alloc_Expr>;
6842 -- Temp_Id := Temp_Typ (Local);
6846 -- * Non-controlled case
6848 -- Temp_Id := <Alloc_Expr>;
6850 -- Temp_Id is the temporary which is used to reference the internally
6851 -- created object in all allocation forms. Temp_Typ is the type of the
6852 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
6853 -- type of Func_Id. Alloc_Expr is the actual allocator.
6855 function BIP_Function_Call_Id
return Entity_Id
;
6856 -- If the object initialization expression is a call to a build-in-place
6857 -- function, return the id of the called function; otherwise return
6860 procedure Count_Default_Sized_Task_Stacks
6862 Pri_Stacks
: out Int
;
6863 Sec_Stacks
: out Int
);
6864 -- Count the number of default-sized primary and secondary task stacks
6865 -- required for task objects contained within type Typ. If the number of
6866 -- task objects contained within the type is not known at compile time
6867 -- the procedure will return the stack counts of zero.
6869 procedure Default_Initialize_Object
(After
: Node_Id
);
6870 -- Generate all default initialization actions for object Def_Id. Any
6871 -- new code is inserted after node After.
6873 procedure Initialize_Return_Object
6874 (Tag_Assign
: Node_Id
;
6877 Init_Stmt
: Node_Id
;
6879 -- Generate all initialization actions for return object Def_Id. Any
6880 -- new code is inserted after node After.
6882 function Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean;
6883 -- If we are not at library level and the object declaration originally
6884 -- appears in the form:
6886 -- Obj : Typ := Func (...);
6888 -- and has been rewritten as the dereference of a captured reference
6889 -- to the function result built either on the primary or the secondary
6890 -- stack, then the declaration can be rewritten as the renaming of this
6893 -- type Ann is access all Typ;
6894 -- Rnn : constant Axx := Func (...)'reference;
6895 -- Obj : Typ renames Rnn.all;
6897 -- This will avoid making an extra copy and, in the case where Typ needs
6898 -- finalization, a pair of calls to the Adjust and Finalize primitives,
6899 -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
6900 -- has components that themselves need finalization.
6902 -- However, in the case of a special return object, we need to make sure
6903 -- that the object Rnn is recognized by the Is_Related_To_Func_Return
6904 -- predicate; otherwise, if it is of a type that needs finalization,
6905 -- then Requires_Cleanup_Actions would return true because of this and
6906 -- Build_Finalizer would finalize it prematurely because of this (see
6907 -- also Expand_Simple_Function_Return for the same test in the case of
6908 -- a simple return).
6910 -- Finally, in the case of a special return object, we also need to make
6911 -- sure that the two functions return on the same stack, otherwise we
6912 -- would create a dangling reference.
6914 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
;
6915 -- Make an allocator for a return object initialized with Expr
6917 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean;
6918 -- Return True if N denotes an entity with OK_To_Rename set
6920 ----------------------------------
6921 -- Build_Heap_Or_Pool_Allocator --
6922 ----------------------------------
6924 function Build_Heap_Or_Pool_Allocator
6925 (Temp_Id
: Entity_Id
;
6926 Temp_Typ
: Entity_Id
;
6927 Ret_Typ
: Entity_Id
;
6928 Alloc_Expr
: Node_Id
) return Node_Id
6931 pragma Assert
(Is_Build_In_Place_Function
(Func_Id
));
6933 -- Processing for objects that require finalization actions
6935 if Needs_Finalization
(Ret_Typ
) then
6937 Decls
: constant List_Id
:= New_List
;
6938 Fin_Coll_Id
: constant Entity_Id
:=
6939 Build_In_Place_Formal
(Func_Id
, BIP_Collection
);
6940 Orig_Expr
: constant Node_Id
:= New_Copy_Tree
(Alloc_Expr
);
6941 Stmts
: constant List_Id
:= New_List
;
6942 Local_Id
: Entity_Id
;
6943 Pool_Id
: Entity_Id
;
6944 Ptr_Typ
: Entity_Id
;
6948 -- Pool_Id renames BIPstoragepool.all;
6950 -- This formal is not added on ZFP as those targets do not
6953 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
6954 Pool_Id
:= Make_Temporary
(Loc
, 'P');
6957 Make_Object_Renaming_Declaration
(Loc
,
6958 Defining_Identifier
=> Pool_Id
,
6960 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
6962 Make_Explicit_Dereference
(Loc
,
6964 (Build_In_Place_Formal
6965 (Func_Id
, BIP_Storage_Pool
), Loc
))));
6970 -- Create an access type which uses the storage pool of the
6971 -- caller. This additional type is necessary because the
6972 -- finalization collection cannot be associated with the type
6973 -- of the temporary. Otherwise the secondary stack allocation
6977 -- type Ptr_Typ is access Ret_Typ;
6979 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
6982 Make_Full_Type_Declaration
(Loc
,
6983 Defining_Identifier
=> Ptr_Typ
,
6985 Make_Access_To_Object_Definition
(Loc
,
6986 Subtype_Indication
=>
6987 New_Occurrence_Of
(Ret_Typ
, Loc
))));
6989 -- Perform minor decoration in order to set the collection and
6990 -- the storage pool attributes.
6992 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
6993 Set_Finalization_Collection
(Ptr_Typ
, Fin_Coll_Id
);
6994 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
6996 -- Create the temporary, generate:
6997 -- Local_Id : Ptr_Typ;
6999 Local_Id
:= Make_Temporary
(Loc
, 'T');
7002 Make_Object_Declaration
(Loc
,
7003 Defining_Identifier
=> Local_Id
,
7004 Object_Definition
=>
7005 New_Occurrence_Of
(Ptr_Typ
, Loc
)));
7006 Set_No_Initialization
(Last
(Decls
));
7008 -- Allocate the object, generate:
7009 -- Local_Id := <Alloc_Expr>;
7012 Make_Assignment_Statement
(Loc
,
7013 Name
=> New_Occurrence_Of
(Local_Id
, Loc
),
7014 Expression
=> Alloc_Expr
));
7017 -- Temp_Id := Temp_Typ (Local_Id);
7020 Make_Assignment_Statement
(Loc
,
7021 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
7023 Unchecked_Convert_To
(Temp_Typ
,
7024 New_Occurrence_Of
(Local_Id
, Loc
))));
7026 -- Wrap the allocation in a block to make it conditioned by the
7027 -- presence of the caller's collection at run time.
7030 -- if BIPcollection = null then
7031 -- Temp_Id := <Orig_Expr>;
7041 Make_If_Statement
(Loc
,
7044 Left_Opnd
=> New_Occurrence_Of
(Fin_Coll_Id
, Loc
),
7045 Right_Opnd
=> Make_Null
(Loc
)),
7047 Then_Statements
=> New_List
(
7048 Make_Assignment_Statement
(Loc
,
7049 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
7050 Expression
=> Orig_Expr
)),
7052 Else_Statements
=> New_List
(
7053 Make_Block_Statement
(Loc
,
7054 Declarations
=> Decls
,
7055 Handled_Statement_Sequence
=>
7056 Make_Handled_Sequence_Of_Statements
(Loc
,
7057 Statements
=> Stmts
))));
7060 -- For all other cases, generate:
7061 -- Temp_Id := <Alloc_Expr>;
7065 Make_Assignment_Statement
(Loc
,
7066 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
7067 Expression
=> Alloc_Expr
);
7069 end Build_Heap_Or_Pool_Allocator
;
7071 --------------------------
7072 -- BIP_Function_Call_Id --
7073 --------------------------
7075 function BIP_Function_Call_Id
return Entity_Id
is
7077 function Func_Call_Id
(Function_Call
: Node_Id
) return Entity_Id
;
7078 -- Return the id of the called function.
7080 function Func_Call_Id
(Function_Call
: Node_Id
) return Entity_Id
is
7081 Call_Node
: constant Node_Id
:= Unqual_Conv
(Function_Call
);
7084 if Is_Entity_Name
(Name
(Call_Node
)) then
7085 return Entity
(Name
(Call_Node
));
7087 elsif Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
7088 return Etype
(Name
(Call_Node
));
7091 pragma Assert
(Nkind
(Name
(Call_Node
)) = N_Selected_Component
);
7092 return Etype
(Entity
(Selector_Name
(Name
(Call_Node
))));
7096 -- Local declarations
7098 BIP_Func_Call
: Node_Id
;
7099 Expr_Q
: constant Node_Id
:= Unqual_Conv
(Expr
);
7101 -- Start of processing for BIP_Function_Call_Id
7104 if Is_Build_In_Place_Function_Call
(Expr_Q
) then
7105 return Func_Call_Id
(Expr_Q
);
7108 BIP_Func_Call
:= Unqual_BIP_Iface_Function_Call
(Expr_Q
);
7110 if Present
(BIP_Func_Call
) then
7112 -- In the case of an explicitly dereferenced call, return the
7115 if Nkind
(Name
(BIP_Func_Call
)) = N_Explicit_Dereference
then
7116 return Etype
(Name
(BIP_Func_Call
));
7118 pragma Assert
(Is_Entity_Name
(Name
(BIP_Func_Call
)));
7119 return Entity
(Name
(BIP_Func_Call
));
7122 elsif Nkind
(Expr_Q
) = N_Reference
7123 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7125 return Func_Call_Id
(Prefix
(Expr_Q
));
7130 end BIP_Function_Call_Id
;
7132 -------------------------------------
7133 -- Count_Default_Sized_Task_Stacks --
7134 -------------------------------------
7136 procedure Count_Default_Sized_Task_Stacks
7138 Pri_Stacks
: out Int
;
7139 Sec_Stacks
: out Int
)
7141 Component
: Entity_Id
;
7144 -- To calculate the number of default-sized task stacks required for
7145 -- an object of Typ, a depth-first recursive traversal of the AST
7146 -- from the Typ entity node is undertaken. Only type nodes containing
7147 -- task objects are visited.
7152 if not Has_Task
(Typ
) then
7160 -- A task type is found marking the bottom of the descent. If
7161 -- the type has no representation aspect for the corresponding
7162 -- stack then that stack is using the default size.
7164 if Present
(Get_Rep_Item
(Typ
, Name_Storage_Size
)) then
7170 if Present
(Get_Rep_Item
(Typ
, Name_Secondary_Stack_Size
)) then
7176 when E_Array_Subtype
7179 -- First find the number of default stacks contained within an
7182 Count_Default_Sized_Task_Stacks
7183 (Component_Type
(Typ
),
7187 -- Then multiply the result by the size of the array
7190 Quantity
: constant Nat
:= Number_Of_Elements_In_Array
(Typ
);
7191 -- Number_Of_Elements_In_Array is non-trival, consequently
7192 -- its result is captured as an optimization.
7195 Pri_Stacks
:= Pri_Stacks
* Quantity
;
7196 Sec_Stacks
:= Sec_Stacks
* Quantity
;
7199 when E_Protected_Subtype
7204 Component
:= First_Component
(Typ
);
7206 -- Recursively descend each component of the composite type
7207 -- looking for tasks.
7209 while Present
(Component
) loop
7215 Count_Default_Sized_Task_Stacks
(Etype
(Component
), P
, S
);
7216 Pri_Stacks
:= Pri_Stacks
+ P
;
7217 Sec_Stacks
:= Sec_Stacks
+ S
;
7220 Next_Component
(Component
);
7223 when E_Limited_Private_Subtype
7224 | E_Limited_Private_Type
7225 | E_Record_Subtype_With_Private
7226 | E_Record_Type_With_Private
7228 -- Switch to the full view of the private type to continue
7231 Count_Default_Sized_Task_Stacks
7232 (Full_View
(Typ
), Pri_Stacks
, Sec_Stacks
);
7234 -- Other types should not contain tasks
7237 raise Program_Error
;
7239 end Count_Default_Sized_Task_Stacks
;
7241 -------------------------------
7242 -- Default_Initialize_Object --
7243 -------------------------------
7245 procedure Default_Initialize_Object
(After
: Node_Id
) is
7246 Init_Expr
: Node_Id
;
7247 Init_Stmts
: List_Id
;
7250 -- Nothing to do if the object has an initialization expression or
7251 -- need not be initialized.
7253 if Has_Init_Expression
(N
) or else No_Initialization
(N
) then
7256 -- Default initialization is suppressed for objects that are already
7257 -- known to be imported (i.e. whose declaration specifies the Import
7258 -- aspect). Note that for objects with a pragma Import, we generate
7259 -- initialization here, and then remove it downstream when processing
7260 -- the pragma. It is also suppressed for variables for which a pragma
7261 -- Suppress_Initialization has been explicitly given
7263 elsif Is_Imported
(Def_Id
)
7264 or else Suppress_Initialization
(Def_Id
)
7268 -- Nothing to do if the object being initialized is of a task type
7269 -- and restriction No_Tasking is in effect, because this is a direct
7270 -- violation of the restriction.
7272 elsif Is_Task_Type
(Base_Typ
)
7273 and then Restriction_Active
(No_Tasking
)
7278 -- First try a simple initialization; if it succeeds, then we just
7279 -- set the value as the expression of the declaration and let the
7280 -- code generator do the rest.
7282 Init_Expr
:= Build_Default_Simple_Initialization
(N
, Typ
, Def_Id
);
7284 if Present
(Init_Expr
) then
7285 Set_Expression
(N
, Init_Expr
);
7286 Analyze_And_Resolve
(Init_Expr
, Typ
);
7290 -- Or else build the fully-fledged initialization if need be
7292 if Is_Mutably_Tagged_Type
(Typ
) then
7294 Build_Default_Initialization
(N
, Etype
(Typ
), Def_Id
);
7296 Init_Stmts
:= Build_Default_Initialization
(N
, Typ
, Def_Id
);
7299 -- Insert the whole initialization sequence into the tree. If the
7300 -- object has a delayed freeze, as will be the case when it has
7301 -- aspect specifications, the initialization sequence is part of
7302 -- the freeze actions.
7304 if Present
(Init_Stmts
) then
7305 if Has_Delayed_Freeze
(Def_Id
) then
7306 Append_Freeze_Actions
(Def_Id
, Init_Stmts
);
7308 Insert_Actions_After
(After
, Init_Stmts
);
7311 end Default_Initialize_Object
;
7313 ------------------------------
7314 -- Initialize_Return_Object --
7315 ------------------------------
7317 procedure Initialize_Return_Object
7318 (Tag_Assign
: Node_Id
;
7321 Init_Stmt
: Node_Id
;
7325 if Present
(Tag_Assign
) then
7326 Insert_Action_After
(After
, Tag_Assign
);
7329 if Present
(Adj_Call
) then
7330 Insert_Action_After
(After
, Adj_Call
);
7334 Default_Initialize_Object
(After
);
7336 elsif Is_Delayed_Aggregate
(Expr
)
7337 and then not No_Initialization
(N
)
7339 Convert_Aggr_In_Object_Decl
(N
);
7341 elsif Present
(Init_Stmt
) then
7342 Insert_Action_After
(After
, Init_Stmt
);
7343 Set_Expression
(N
, Empty
);
7345 end Initialize_Return_Object
;
7347 --------------------------------
7348 -- Is_Renamable_Function_Call --
7349 --------------------------------
7351 function Is_Renamable_Function_Call
(Expr
: Node_Id
) return Boolean is
7353 return not Is_Library_Level_Entity
(Def_Id
)
7354 and then Is_Captured_Function_Call
(Expr
)
7355 and then (not Special_Ret_Obj
7357 (Is_Related_To_Func_Return
(Entity
(Prefix
(Expr
)))
7358 and then Needs_Secondary_Stack
(Etype
(Expr
)) =
7359 Needs_Secondary_Stack
(Etype
(Func_Id
))));
7360 end Is_Renamable_Function_Call
;
7362 -------------------------------
7363 -- Make_Allocator_For_Return --
7364 -------------------------------
7366 function Make_Allocator_For_Return
(Expr
: Node_Id
) return Node_Id
is
7368 Alloc_Expr
: Entity_Id
;
7369 Alloc_Typ
: Entity_Id
;
7372 -- If the return object's declaration does not include an expression,
7373 -- then we use its subtype for the allocation. Likewise in the case
7374 -- of a degenerate expression like a raise expression.
7377 or else Nkind
(Original_Node
(Expr
)) = N_Raise_Expression
7381 -- If the return object's declaration includes an expression, then
7382 -- there are two cases: either the nominal subtype of the object is
7383 -- definite and we can use it for the allocation directly, or it is
7384 -- not and Analyze_Object_Declaration should have built an actual
7385 -- subtype from the expression.
7387 -- However, there are exceptions in the latter case for interfaces
7388 -- (see Analyze_Object_Declaration), as well as class-wide types and
7389 -- types with unknown discriminants if they are additionally limited
7390 -- (see Expand_Subtype_From_Expr), so we must cope with them.
7392 elsif Is_Interface
(Typ
) then
7393 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7395 -- For interfaces, we use the type of the expression, except if
7396 -- we need to put back a conversion that we have removed earlier
7397 -- in the processing.
7399 if Is_Class_Wide_Type
(Etype
(Expr
)) then
7402 Alloc_Typ
:= Etype
(Expr
);
7405 elsif Is_Class_Wide_Type
(Typ
) then
7407 -- For class-wide types, we have to make sure that we use the
7408 -- dynamic type of the expression for the allocation, either by
7409 -- means of its (static) subtype or through the actual subtype.
7411 if Has_Tag_Of_Type
(Expr
) then
7412 Alloc_Typ
:= Etype
(Expr
);
7414 else pragma Assert
(Ekind
(Typ
) = E_Class_Wide_Subtype
7415 and then Present
(Equivalent_Type
(Typ
)));
7420 else pragma Assert
(Is_Definite_Subtype
(Typ
)
7421 or else (Has_Unknown_Discriminants
(Typ
)
7422 and then Is_Inherently_Limited_Type
(Typ
)));
7427 -- If the return object's declaration includes an expression and the
7428 -- declaration isn't marked as No_Initialization, then we generate an
7429 -- allocator with a qualified expression. Although this is necessary
7430 -- only in the case where the result type is an interface (or class-
7431 -- wide interface), we do it in all cases for the sake of consistency
7432 -- instead of subsequently generating a separate assignment.
7435 and then not Is_Delayed_Aggregate
(Expr
)
7436 and then not No_Initialization
(N
)
7438 -- Ada 2005 (AI95-344): If the result type is class-wide, insert
7439 -- a check that the level of the return expression's underlying
7440 -- type is not deeper than the level of the master enclosing the
7443 -- AI12-043: The check is made immediately after the return object
7446 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
7447 Apply_CW_Accessibility_Check
(Expr
, Func_Id
);
7450 Alloc_Expr
:= New_Copy_Tree
(Expr
);
7452 if Etype
(Alloc_Expr
) /= Alloc_Typ
then
7453 Alloc_Expr
:= Convert_To
(Alloc_Typ
, Alloc_Expr
);
7457 Make_Allocator
(Loc
,
7459 Make_Qualified_Expression
(Loc
,
7461 New_Occurrence_Of
(Alloc_Typ
, Loc
),
7462 Expression
=> Alloc_Expr
));
7466 Make_Allocator
(Loc
,
7467 Expression
=> New_Occurrence_Of
(Alloc_Typ
, Loc
));
7469 -- If the return object requires default initialization, then it
7470 -- will happen later following the elaboration of the renaming.
7471 -- If we don't turn it off here, then the object will be default
7472 -- initialized twice.
7474 Set_No_Initialization
(Alloc
);
7477 -- Set the flag indicating that the allocator is made for a special
7478 -- return object. This is used to bypass various legality checks as
7479 -- well as to make sure that the result is not adjusted twice.
7481 Set_For_Special_Return_Object
(Alloc
);
7484 end Make_Allocator_For_Return
;
7486 ----------------------
7487 -- OK_To_Rename_Ref --
7488 ----------------------
7490 function OK_To_Rename_Ref
(N
: Node_Id
) return Boolean is
7492 return Is_Entity_Name
(N
)
7493 and then Ekind
(Entity
(N
)) = E_Variable
7494 and then OK_To_Rename
(Entity
(N
));
7495 end OK_To_Rename_Ref
;
7499 Adj_Call
: Node_Id
:= Empty
;
7500 Expr_Q
: Node_Id
:= Empty
;
7501 Tag_Assign
: Node_Id
:= Empty
;
7503 Init_After
: Node_Id
:= N
;
7504 -- Node after which the initialization actions are to be inserted. This
7505 -- is normally N, except for the case of a shared passive variable, in
7506 -- which case the init proc call must be inserted only after the bodies
7507 -- of the shared variable procedures have been seen.
7509 Has_BIP_Init_Expr
: Boolean := False;
7510 -- Whether the object is initialized with a BIP function call
7512 Rewrite_As_Renaming
: Boolean := False;
7513 -- Whether to turn the declaration into a renaming at the end
7515 -- Start of processing for Expand_N_Object_Declaration
7518 -- Don't do anything for deferred constants. All proper actions will be
7519 -- expanded during the full declaration.
7521 if No
(Expr
) and Constant_Present
(N
) then
7525 -- The type of the object cannot be abstract. This is diagnosed at the
7526 -- point the object is frozen, which happens after the declaration is
7527 -- fully expanded, so simply return now.
7529 if Is_Abstract_Type
(Typ
) then
7533 -- No action needed for the internal imported dummy object added by
7534 -- Make_DT to compute the offset of the components that reference
7535 -- secondary dispatch tables; required to avoid never-ending loop
7536 -- processing this internal object declaration.
7538 if Tagged_Type_Expansion
7539 and then Is_Internal
(Def_Id
)
7540 and then Is_Imported
(Def_Id
)
7541 and then Related_Type
(Def_Id
) = Implementation_Base_Type
(Typ
)
7546 -- Make shared memory routines for shared passive variable
7548 if Is_Shared_Passive
(Def_Id
) then
7549 Init_After
:= Make_Shared_Var_Procs
(N
);
7552 -- Determine whether the object is initialized with a BIP function call
7554 if Present
(Expr
) then
7555 Expr_Q
:= Unqualify
(Expr
);
7557 Has_BIP_Init_Expr
:=
7558 Is_Build_In_Place_Function_Call
(Expr_Q
)
7559 or else Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
))
7560 or else (Nkind
(Expr_Q
) = N_Reference
7562 Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
)));
7565 -- If tasks are being declared, make sure we have an activation chain
7566 -- defined for the tasks (has no effect if we already have one), and
7567 -- also that a Master variable is established (and that the appropriate
7568 -- enclosing construct is established as a task master).
7571 or else Might_Have_Tasks
(Typ
)
7572 or else (Has_BIP_Init_Expr
7573 and then Needs_BIP_Task_Actuals
(BIP_Function_Call_Id
))
7575 Build_Activation_Chain_Entity
(N
);
7577 if Has_Task
(Typ
) then
7578 Build_Master_Entity
(Def_Id
);
7580 -- Handle objects initialized with BIP function calls
7582 elsif Has_BIP_Init_Expr
then
7583 Build_Master_Entity
(Def_Id
);
7587 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
7588 -- restrictions are active then default-sized secondary stacks are
7589 -- generated by the binder and allocated by SS_Init. To provide the
7590 -- binder the number of stacks to generate, the number of default-sized
7591 -- stacks required for task objects contained within the object
7592 -- declaration N is calculated here as it is at this point where
7593 -- unconstrained types become constrained. The result is stored in the
7594 -- enclosing unit's Unit_Record.
7596 -- Note if N is an array object declaration that has an initialization
7597 -- expression, a second object declaration for the initialization
7598 -- expression is created by the compiler. To prevent double counting
7599 -- of the stacks in this scenario, the stacks of the first array are
7602 if Might_Have_Tasks
(Typ
)
7603 and then not Restriction_Active
(No_Secondary_Stack
)
7604 and then (Restriction_Active
(No_Implicit_Heap_Allocations
)
7605 or else Restriction_Active
(No_Implicit_Task_Allocations
))
7606 and then not (Is_Array_Type
(Typ
) and then Has_Init_Expression
(N
))
7609 PS_Count
, SS_Count
: Int
;
7611 Count_Default_Sized_Task_Stacks
(Typ
, PS_Count
, SS_Count
);
7612 Increment_Primary_Stack_Count
(PS_Count
);
7613 Increment_Sec_Stack_Count
(SS_Count
);
7617 -- Default initialization required, and no expression present
7620 -- If we have a type with a variant part, the initialization proc
7621 -- will contain implicit tests of the discriminant values, which
7622 -- counts as a violation of the restriction No_Implicit_Conditionals.
7624 if Has_Variant_Part
(Typ
) then
7629 Check_Restriction
(Msg
, No_Implicit_Conditionals
, Obj_Def
);
7633 ("\initialization of variant record tests discriminants",
7640 -- For the default initialization case, if we have a private type
7641 -- with invariants, and invariant checks are enabled, then insert an
7642 -- invariant check after the object declaration. Note that it is OK
7643 -- to clobber the object with an invalid value since if the exception
7644 -- is raised, then the object will go out of scope. In the case where
7645 -- an array object is initialized with an aggregate, the expression
7646 -- is removed. Check flag Has_Init_Expression to avoid generating a
7647 -- junk invariant check and flag No_Initialization to avoid checking
7648 -- an uninitialized object such as a compiler temporary used for an
7651 if Has_Invariants
(Base_Typ
)
7652 and then Present
(Invariant_Procedure
(Base_Typ
))
7653 and then not Has_Init_Expression
(N
)
7654 and then not No_Initialization
(N
)
7656 -- If entity has an address clause or aspect, make invariant
7657 -- call into a freeze action for the explicit freeze node for
7658 -- object. Otherwise insert invariant check after declaration.
7660 if Present
(Following_Address_Clause
(N
))
7661 or else Has_Aspect
(Def_Id
, Aspect_Address
)
7663 Ensure_Freeze_Node
(Def_Id
);
7664 Set_Has_Delayed_Freeze
(Def_Id
);
7665 Set_Is_Frozen
(Def_Id
, False);
7667 if not Partial_View_Has_Unknown_Discr
(Typ
) then
7668 Append_Freeze_Action
(Def_Id
,
7669 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7672 elsif not Partial_View_Has_Unknown_Discr
(Typ
) then
7674 Make_Invariant_Call
(New_Occurrence_Of
(Def_Id
, Loc
)));
7678 if not Special_Ret_Obj
then
7679 Default_Initialize_Object
(Init_After
);
7681 -- Check whether an access object has been initialized above
7683 if Is_Access_Type
(Typ
) and then Present
(Expression
(N
)) then
7684 if Known_Non_Null
(Expression
(N
)) then
7685 Set_Is_Known_Non_Null
(Def_Id
);
7686 elsif Known_Null
(Expression
(N
)) then
7687 Set_Is_Known_Null
(Def_Id
);
7692 -- Generate attribute for Persistent_BSS if needed
7694 if Persistent_BSS_Mode
7695 and then Comes_From_Source
(N
)
7696 and then Is_Potentially_Persistent_Type
(Typ
)
7697 and then not Has_Init_Expression
(N
)
7698 and then Is_Library_Level_Entity
(Def_Id
)
7704 Make_Linker_Section_Pragma
7705 (Def_Id
, Sloc
(N
), ".persistent.bss");
7706 Insert_After
(N
, Prag
);
7711 -- Explicit initialization present
7714 -- Obtain actual expression from qualified expression
7716 Expr_Q
:= Unqualify
(Expr
);
7718 -- When we have the appropriate type of aggregate in the expression
7719 -- (it has been determined during analysis of the aggregate by
7720 -- setting the delay flag), let's perform in place assignment and
7721 -- thus avoid creating a temporary.
7723 if Is_Delayed_Aggregate
(Expr_Q
) then
7725 -- An aggregate that must be built in place is not resolved and
7726 -- expanded until the enclosing construct is expanded. This will
7727 -- happen when the aggregate is limited and the declared object
7728 -- has a following address clause; it happens also when generating
7729 -- C code for an aggregate that has an alignment or address clause
7730 -- (see Analyze_Object_Declaration). Resolution is done without
7731 -- expansion because it will take place when the declaration
7732 -- itself is expanded.
7734 if (Is_Limited_Type
(Typ
) or else Modify_Tree_For_C
)
7735 and then not Analyzed
(Expr
)
7737 Expander_Mode_Save_And_Set
(False);
7738 Resolve
(Expr
, Typ
);
7739 Expander_Mode_Restore
;
7742 -- For a special return object, the transformation must wait until
7743 -- after the object is turned into an allocator.
7745 if not Special_Ret_Obj
then
7746 Convert_Aggr_In_Object_Decl
(N
);
7749 -- If the initialization expression is a conditional expression whose
7750 -- expansion has been delayed, assign it explicitly to the object but
7751 -- only after analyzing it again and expanding it.
7753 elsif Is_Delayed_Conditional_Expression
(Expr_Q
) then
7754 -- For a special return object, the transformation must wait until
7755 -- after the object is turned into an allocator, and will be done
7756 -- during the expansion of the allocator.
7758 if not Special_Ret_Obj
then
7760 Assign
: constant Node_Id
:=
7761 Make_Assignment_Statement
(Loc
,
7762 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
7763 Expression
=> Relocate_Node
(Expr
));
7766 Set_Assignment_OK
(Name
(Assign
));
7767 Set_Analyzed
(Expression
(Assign
), False);
7768 Set_No_Finalize_Actions
(Assign
);
7769 Insert_Action_After
(Init_After
, Assign
);
7771 -- Save the assignment statement when declaring a controlled
7772 -- object. This reference is used later by the finalization
7773 -- machinery to mark the object as successfully initialized
7775 if Needs_Finalization
(Typ
) then
7776 Set_Last_Aggregate_Assignment
(Def_Id
, Assign
);
7779 Set_Expression
(N
, Empty
);
7780 Set_No_Initialization
(N
);
7784 -- Ada 2005 (AI-318-02): If the initialization expression is a call
7785 -- to a build-in-place function, then access to the declared object
7786 -- must be passed to the function. Currently we limit such functions
7787 -- to those with constrained limited result subtypes, but eventually
7788 -- plan to expand the allowed forms of functions that are treated as
7791 elsif Is_Build_In_Place_Function_Call
(Expr_Q
) then
7792 Make_Build_In_Place_Call_In_Object_Declaration
(N
, Expr_Q
);
7794 -- The previous call expands the expression initializing the
7795 -- built-in-place object into further code that will be analyzed
7796 -- later. No further expansion needed here.
7800 -- This is the same as the previous 'elsif', except that the call has
7801 -- been transformed by other expansion activities into something like
7802 -- F(...)'Reference.
7804 elsif Nkind
(Expr_Q
) = N_Reference
7805 and then Is_Build_In_Place_Function_Call
(Prefix
(Expr_Q
))
7806 and then not Is_Expanded_Build_In_Place_Call
7807 (Unqual_Conv
(Prefix
(Expr_Q
)))
7809 Make_Build_In_Place_Call_In_Anonymous_Context
(Prefix
(Expr_Q
));
7811 -- The previous call expands the expression initializing the
7812 -- built-in-place object into further code that will be analyzed
7813 -- later. No further expansion needed here.
7817 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7818 -- expressions containing a build-in-place function call whose
7819 -- returned object covers interface types, and Expr_Q has calls to
7820 -- Ada.Tags.Displace to displace the pointer to the returned build-
7821 -- in-place object to reference the secondary dispatch table of a
7822 -- covered interface type.
7824 elsif Present
(Unqual_BIP_Iface_Function_Call
(Expr_Q
)) then
7825 Make_Build_In_Place_Iface_Call_In_Object_Declaration
(N
, Expr_Q
);
7827 -- The previous call expands the expression initializing the
7828 -- built-in-place object into further code that will be analyzed
7829 -- later. No further expansion needed here.
7833 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7834 -- class-wide interface object to ensure that we copy the full
7835 -- object, unless we are targetting a VM where interfaces are handled
7836 -- by VM itself. Note that if the root type of Typ is an ancestor of
7837 -- Expr's type, both types share the same dispatch table and there is
7838 -- no need to displace the pointer.
7840 elsif Is_Interface
(Typ
)
7842 -- Avoid never-ending recursion because if Equivalent_Type is set
7843 -- then we've done it already and must not do it again.
7846 (Nkind
(Obj_Def
) = N_Identifier
7847 and then Present
(Equivalent_Type
(Entity
(Obj_Def
))))
7849 pragma Assert
(Is_Class_Wide_Type
(Typ
));
7851 -- If the original node of the expression was a conversion
7852 -- to this specific class-wide interface type then restore
7853 -- the original node because we must copy the object before
7854 -- displacing the pointer to reference the secondary tag
7855 -- component. This code must be kept synchronized with the
7856 -- expansion done by routine Expand_Interface_Conversion
7858 if not Comes_From_Source
(Expr
)
7859 and then Nkind
(Expr
) = N_Explicit_Dereference
7860 and then Nkind
(Original_Node
(Expr
)) = N_Type_Conversion
7861 and then Etype
(Original_Node
(Expr
)) = Typ
7863 Rewrite
(Expr
, Original_Node
(Expression
(N
)));
7866 -- Avoid expansion of redundant interface conversion
7868 if Nkind
(Expr
) = N_Type_Conversion
7869 and then Etype
(Expr
) = Typ
7871 Expr_Q
:= Expression
(Expr
);
7876 -- We may use a renaming if the initialization expression is a
7877 -- captured function call that meets a few conditions.
7879 Rewrite_As_Renaming
:= Is_Renamable_Function_Call
(Expr_Q
);
7881 -- If the object is a special return object, then bypass special
7882 -- treatment of class-wide interface initialization below. In this
7883 -- case, the expansion of the return object will take care of this
7884 -- initialization via the expansion of the allocator.
7886 if Special_Ret_Obj
and then not Rewrite_As_Renaming
then
7888 -- If the type needs finalization and is not inherently
7889 -- limited, then the target is adjusted after the copy
7890 -- and attached to the finalization list.
7892 if Needs_Finalization
(Typ
)
7893 and then not Is_Inherently_Limited_Type
(Typ
)
7897 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
7901 -- Renaming an expression of the object's type is immediate
7903 elsif Rewrite_As_Renaming
7904 and then Base_Type
(Etype
(Expr_Q
)) = Base_Type
(Typ
)
7908 elsif Tagged_Type_Expansion
then
7910 Iface
: constant Entity_Id
:= Root_Type
(Typ
);
7912 Expr_Typ
: Entity_Id
;
7915 Ptr_Obj_Decl
: Node_Id
;
7916 Ptr_Obj_Id
: Entity_Id
;
7920 Expr_Typ
:= Base_Type
(Etype
(Expr_Q
));
7921 if Is_Class_Wide_Type
(Expr_Typ
) then
7922 Expr_Typ
:= Root_Type
(Expr_Typ
);
7925 -- Rename limited objects since they cannot be copied
7927 if Is_Limited_Record
(Expr_Typ
) then
7928 Rewrite_As_Renaming
:= True;
7931 Obj_Id
:= Make_Temporary
(Loc
, 'D', Expr_Q
);
7934 -- IW : I'Class := Expr;
7936 -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
7937 -- type Ityp is not null access I'Class;
7938 -- Rnn : constant Ityp :=
7939 -- Ityp!(Displace (Dnn'Address, I'Tag));
7940 -- IW : I'Class renames Rnn.all;
7942 if Rewrite_As_Renaming
then
7944 Make_Explicit_Dereference
(Loc
,
7945 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7946 Make_Attribute_Reference
(Loc
,
7947 Prefix
=> Relocate_Node
(Expr_Q
),
7948 Attribute_Name
=> Name_Address
)));
7950 -- Suppress junk access checks on RE_Tag_Ptr
7953 Make_Object_Renaming_Declaration
(Loc
,
7954 Defining_Identifier
=> Obj_Id
,
7956 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7958 Suppress
=> Access_Check
);
7960 -- Dynamically reference the tag associated with the
7964 Make_Function_Call
(Loc
,
7965 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
7966 Parameter_Associations
=> New_List
(
7967 Make_Attribute_Reference
(Loc
,
7968 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
7969 Attribute_Name
=> Name_Address
),
7971 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
7975 -- IW : I'Class := Expr;
7977 -- Dnn : Typ := Expr;
7978 -- type Ityp is not null access I'Class;
7979 -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
7980 -- IW : I'Class renames Rnn.all;
7982 elsif Has_Tag_Of_Type
(Expr_Q
)
7983 and then Interface_Present_In_Ancestor
(Expr_Typ
, Typ
)
7984 and then (Expr_Typ
= Etype
(Expr_Typ
)
7986 Is_Variable_Size_Record
(Etype
(Expr_Typ
)))
7989 Make_Object_Declaration
(Loc
,
7990 Defining_Identifier
=> Obj_Id
,
7991 Object_Definition
=>
7992 New_Occurrence_Of
(Expr_Typ
, Loc
),
7993 Expression
=> Relocate_Node
(Expr_Q
)));
7995 -- Statically reference the tag associated with the
7999 Make_Selected_Component
(Loc
,
8000 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
8003 (Find_Interface_Tag
(Expr_Typ
, Iface
), Loc
));
8006 -- IW : I'Class := Expr;
8008 -- type Equiv_Record is record ... end record;
8009 -- implicit subtype CW is <Class_Wide_Subtype>;
8010 -- Dnn : CW := CW!(Expr);
8011 -- type Ityp is not null access I'Class;
8012 -- Rnn : constant Ityp :=
8013 -- Ityp!(Displace (Dnn'Address, I'Tag));
8014 -- IW : I'Class renames Rnn.all;
8017 -- Generate the equivalent record type and update the
8018 -- subtype indication to reference it.
8020 Expand_Subtype_From_Expr
8023 Subtype_Indic
=> Obj_Def
,
8026 -- For interface types we use 'Address which displaces
8027 -- the pointer to the base of the object (if required).
8029 if Is_Interface
(Etype
(Expr_Q
)) then
8031 Unchecked_Convert_To
(Etype
(Obj_Def
),
8032 Make_Explicit_Dereference
(Loc
,
8033 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
8034 Make_Attribute_Reference
(Loc
,
8035 Prefix
=> Relocate_Node
(Expr_Q
),
8036 Attribute_Name
=> Name_Address
))));
8038 -- For other types, no displacement is needed
8041 New_Expr
:= Relocate_Node
(Expr_Q
);
8044 -- Suppress junk access checks on RE_Tag_Ptr
8047 Make_Object_Declaration
(Loc
,
8048 Defining_Identifier
=> Obj_Id
,
8049 Object_Definition
=>
8050 New_Occurrence_Of
(Etype
(Obj_Def
), Loc
),
8051 Expression
=> New_Expr
),
8052 Suppress
=> Access_Check
);
8054 -- Dynamically reference the tag associated with the
8058 Make_Function_Call
(Loc
,
8059 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
8060 Parameter_Associations
=> New_List
(
8061 Make_Attribute_Reference
(Loc
,
8062 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
8063 Attribute_Name
=> Name_Address
),
8065 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
8069 -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
8070 -- to do the final conversion, but we insert an intermediate
8071 -- temporary before the dereference so that we can process
8072 -- the expansion as part of the analysis of the declaration
8073 -- of this temporary, and then rewrite manually the original
8074 -- object as the simple renaming of this dereference.
8076 Tag_Comp
:= Convert_Tag_To_Interface
(Typ
, Tag_Comp
);
8077 pragma Assert
(Nkind
(Tag_Comp
) = N_Explicit_Dereference
8079 Nkind
(Prefix
(Tag_Comp
)) = N_Unchecked_Type_Conversion
);
8081 Ptr_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8084 Make_Object_Declaration
(Loc
,
8085 Defining_Identifier
=> Ptr_Obj_Id
,
8086 Constant_Present
=> True,
8087 Object_Definition
=>
8089 (Entity
(Subtype_Mark
(Prefix
(Tag_Comp
))), Loc
),
8090 Expression
=> Prefix
(Tag_Comp
));
8092 Insert_Action
(N
, Ptr_Obj_Decl
, Suppress
=> All_Checks
);
8094 Set_Prefix
(Tag_Comp
, New_Occurrence_Of
(Ptr_Obj_Id
, Loc
));
8096 Set_Etype
(Expr_Q
, Typ
);
8097 Set_Parent
(Expr_Q
, N
);
8099 Rewrite_As_Renaming
:= True;
8106 -- Common case of explicit object initialization
8109 -- Small optimization: if the expression is a function call and
8110 -- the object is stand-alone, not declared at library level and of
8111 -- a class-wide type, then we capture the result of the call into
8112 -- a temporary, with the benefit that, if the result's type does
8113 -- not need finalization, nothing will be finalized and, if it
8114 -- does, the temporary only will be finalized by means of a direct
8115 -- call to the Finalize primitive if the result's type is not a
8116 -- class-wide type; whereas, in both cases, the stand-alone object
8117 -- itself would be finalized by means of a dispatching call to the
8118 -- Deep_Finalize routine.
8120 if Nkind
(Expr_Q
) = N_Function_Call
8121 and then not Special_Ret_Obj
8122 and then not Is_Library_Level_Entity
(Def_Id
)
8123 and then Is_Class_Wide_Type
(Typ
)
8125 Remove_Side_Effects
(Expr_Q
);
8128 -- In most cases, we must check that the initial value meets any
8129 -- constraint imposed by the declared type. However, there is one
8130 -- very important exception to this rule. If the entity has an
8131 -- unconstrained nominal subtype, then it acquired its constraints
8132 -- from the expression in the first place, and not only does this
8133 -- mean that the constraint check is not needed, but an attempt to
8134 -- perform the constraint check can cause order of elaboration
8137 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
8139 -- If this is an allocator for an aggregate that has been
8140 -- allocated in place, delay checks until assignments are
8141 -- made, because the discriminants are not initialized.
8143 if Nkind
(Expr
) = N_Allocator
8144 and then No_Initialization
(Expr
)
8148 -- Otherwise apply a constraint check now if no prev error
8150 elsif Nkind
(Expr
) /= N_Error
then
8151 Apply_Constraint_Check
(Expr
, Typ
);
8153 -- Deal with possible range check
8155 if Do_Range_Check
(Expr
) then
8157 -- If assignment checks are suppressed, turn off flag
8159 if Suppress_Assignment_Checks
(N
) then
8160 Set_Do_Range_Check
(Expr
, False);
8162 -- Otherwise generate the range check
8165 Generate_Range_Check
8166 (Expr
, Typ
, CE_Range_Check_Failed
);
8172 -- For tagged types, when an init value is given, the tag has to
8173 -- be re-initialized separately in order to avoid the propagation
8174 -- of a wrong tag coming from a view conversion unless the type
8175 -- is class wide (in this case the tag comes from the init value).
8176 -- Suppress the tag assignment when not Tagged_Type_Expansion
8177 -- because tags are represented implicitly in objects. Ditto for
8178 -- types that are CPP_CLASS, and for initializations that are
8179 -- aggregates, because they have to have the right tag.
8181 -- The re-assignment of the tag has to be done even if the object
8182 -- is a constant. The assignment must be analyzed after the
8183 -- declaration. If an address clause follows, this is handled as
8184 -- part of the freeze actions for the object, otherwise insert
8185 -- tag assignment here.
8187 Tag_Assign
:= Make_Tag_Assignment
(N
);
8189 if Present
(Tag_Assign
) then
8190 if Present
(Following_Address_Clause
(N
)) then
8191 Ensure_Freeze_Node
(Def_Id
);
8192 elsif not Special_Ret_Obj
then
8193 Insert_Action_After
(Init_After
, Tag_Assign
);
8196 -- Handle C++ constructor calls. Note that we do not check that
8197 -- Typ is a tagged type since the equivalent Ada type of a C++
8198 -- class that has no virtual methods is an untagged limited
8201 elsif Is_CPP_Constructor_Call
(Expr
) then
8203 Id_Ref
: constant Node_Id
:= New_Occurrence_Of
(Def_Id
, Loc
);
8206 -- The call to the initialization procedure does NOT freeze
8207 -- the object being initialized.
8209 Set_Must_Not_Freeze
(Id_Ref
);
8210 Set_Assignment_OK
(Id_Ref
);
8212 Insert_Actions_After
(Init_After
,
8213 Build_Initialization_Call
(N
, Id_Ref
, Typ
,
8214 Constructor_Ref
=> Expr
));
8216 -- We remove here the original call to the constructor
8217 -- to avoid its management in the backend
8219 Set_Expression
(N
, Empty
);
8223 -- Handle initialization of limited tagged types
8225 elsif Is_Tagged_Type
(Typ
)
8226 and then Is_Class_Wide_Type
(Typ
)
8227 and then Is_Limited_Record
(Typ
)
8228 and then not Is_Limited_Interface
(Typ
)
8230 -- Given that the type is limited we cannot perform a copy. If
8231 -- Expr_Q is the reference to a variable we mark the variable
8232 -- as OK_To_Rename to expand this declaration into a renaming
8233 -- declaration (see below).
8235 if Is_Entity_Name
(Expr_Q
) then
8236 Set_OK_To_Rename
(Entity
(Expr_Q
));
8238 -- If we cannot convert the expression into a renaming we must
8239 -- consider it an internal error because the backend does not
8240 -- have support to handle it. But avoid crashing on a raise
8241 -- expression or conditional expression.
8243 elsif Nkind
(Original_Node
(Expr_Q
)) not in
8244 N_Raise_Expression | N_If_Expression | N_Case_Expression
8246 raise Program_Error
;
8249 -- For discrete types, set the Is_Known_Valid flag if the
8250 -- initializing value is known to be valid. Only do this for
8251 -- source assignments, since otherwise we can end up turning
8252 -- on the known valid flag prematurely from inserted code.
8254 elsif Comes_From_Source
(N
)
8255 and then Is_Discrete_Type
(Typ
)
8256 and then Expr_Known_Valid
(Expr
)
8257 and then Safe_To_Capture_Value
(N
, Def_Id
)
8259 Set_Is_Known_Valid
(Def_Id
);
8261 -- For access types, set the Is_Known_Non_Null flag if the
8262 -- initializing value is known to be non-null. We can also
8263 -- set Can_Never_Be_Null if this is a constant.
8265 elsif Is_Access_Type
(Typ
) and then Known_Non_Null
(Expr
) then
8266 Set_Is_Known_Non_Null
(Def_Id
, True);
8268 if Constant_Present
(N
) then
8269 Set_Can_Never_Be_Null
(Def_Id
);
8273 -- If validity checking on copies, validate initial expression.
8274 -- But skip this if declaration is for a generic type, since it
8275 -- makes no sense to validate generic types. Not clear if this
8276 -- can happen for legal programs, but it definitely can arise
8277 -- from previous instantiation errors.
8279 if Validity_Checks_On
8280 and then Comes_From_Source
(N
)
8281 and then Validity_Check_Copies
8282 and then not Is_Generic_Type
(Typ
)
8284 Ensure_Valid
(Expr
);
8286 if Safe_To_Capture_Value
(N
, Def_Id
) then
8287 Set_Is_Known_Valid
(Def_Id
);
8291 -- Now determine whether we will use a renaming
8293 Rewrite_As_Renaming
:=
8295 -- The declaration cannot be rewritten if it has got constraints
8297 Is_Entity_Name
(Original_Node
(Obj_Def
))
8299 -- If we have "X : S := ...;", and S is a constrained array
8300 -- subtype, then we cannot rename, because renamings ignore
8301 -- the constraints of S, so that would change the semantics
8302 -- (sliding would not occur on the initial value). This is
8303 -- only a problem for source objects though, the others have
8304 -- the correct bounds.
8306 and then not (Comes_From_Source
(Obj_Def
)
8307 and then Is_Array_Type
(Typ
)
8308 and then Is_Constrained
(Typ
))
8310 -- Moreover, if we have "X : aliased S := "...;" and S is an
8311 -- unconstrained array type, then we can rename only if the
8312 -- initialization expression has an unconstrained subtype too,
8313 -- because the bounds must be present within X.
8315 and then not (Is_Constr_Array_Subt_With_Bounds
(Typ
)
8316 and then Is_Constrained
(Etype
(Expr_Q
)))
8318 -- We may use a renaming if the initialization expression is a
8319 -- captured function call that meets a few conditions.
8322 (Is_Renamable_Function_Call
(Expr_Q
)
8324 -- Or else if it is a variable with OK_To_Rename set
8326 or else (OK_To_Rename_Ref
(Expr_Q
)
8327 and then not Special_Ret_Obj
)
8329 -- Or else if it is a slice of such a variable
8331 or else (Nkind
(Expr_Q
) = N_Slice
8332 and then OK_To_Rename_Ref
(Prefix
(Expr_Q
))
8333 and then not Special_Ret_Obj
));
8335 -- If the type needs finalization and is not inherently limited,
8336 -- then the target is adjusted after the copy and attached to the
8337 -- finalization list. However, no adjustment is needed in the case
8338 -- where the object has been initialized by a call to a function
8339 -- returning on the primary stack (see Expand_Ctrl_Function_Call)
8340 -- since no copy occurred, given that the type is by-reference.
8341 -- Similarly, no adjustment is needed if we are going to rewrite
8342 -- the object declaration into a renaming declaration.
8344 if Needs_Finalization
(Typ
)
8345 and then not Is_Inherently_Limited_Type
(Typ
)
8346 and then Nkind
(Expr_Q
) /= N_Function_Call
8347 and then not Rewrite_As_Renaming
8351 Obj_Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
8354 if Present
(Adj_Call
) and then not Special_Ret_Obj
then
8355 Insert_Action_After
(Init_After
, Adj_Call
);
8360 -- Cases where the back end cannot handle the initialization
8361 -- directly. In such cases, we expand an assignment that will
8362 -- be appropriately handled by Expand_N_Assignment_Statement.
8364 -- The exclusion of the unconstrained case is wrong, but for now it
8365 -- is too much trouble ???
8367 if (Is_Possibly_Unaligned_Slice
(Expr
)
8368 or else (Is_Possibly_Unaligned_Object
(Expr
)
8369 and then not Represented_As_Scalar
(Etype
(Expr
))))
8370 and then not (Is_Array_Type
(Etype
(Expr
))
8371 and then not Is_Constrained
(Etype
(Expr
)))
8374 Stat
: constant Node_Id
:=
8375 Make_Assignment_Statement
(Loc
,
8376 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8377 Expression
=> Relocate_Node
(Expr
));
8379 Set_Assignment_OK
(Name
(Stat
));
8380 Set_No_Ctrl_Actions
(Stat
);
8381 Insert_Action_After
(Init_After
, Stat
);
8382 Set_Expression
(N
, Empty
);
8383 Set_No_Initialization
(N
);
8388 if Nkind
(Obj_Def
) = N_Access_Definition
8389 and then not Is_Local_Anonymous_Access
(Typ
)
8391 -- An Ada 2012 stand-alone object of an anonymous access type
8394 Loc
: constant Source_Ptr
:= Sloc
(N
);
8396 Level
: constant Entity_Id
:=
8397 Make_Defining_Identifier
(Sloc
(N
),
8399 New_External_Name
(Chars
(Def_Id
), Suffix
=> "L"));
8401 Level_Decl
: Node_Id
;
8402 Level_Expr
: Node_Id
;
8405 Mutate_Ekind
(Level
, Ekind
(Def_Id
));
8406 Set_Etype
(Level
, Standard_Natural
);
8407 Set_Scope
(Level
, Scope
(Def_Id
));
8409 -- Set accessibility level of null
8413 Make_Integer_Literal
8414 (Loc
, Scope_Depth
(Standard_Standard
));
8416 -- When the expression of the object is a function which returns
8417 -- an anonymous access type the master of the call is the object
8418 -- being initialized instead of the type.
8420 elsif Nkind
(Expr
) = N_Function_Call
8421 and then Ekind
(Etype
(Name
(Expr
))) = E_Anonymous_Access_Type
8423 Level_Expr
:= Accessibility_Level
8424 (Def_Id
, Object_Decl_Level
);
8429 Level_Expr
:= Accessibility_Level
(Expr
, Dynamic_Level
);
8433 Make_Object_Declaration
(Loc
,
8434 Defining_Identifier
=> Level
,
8435 Object_Definition
=>
8436 New_Occurrence_Of
(Standard_Natural
, Loc
),
8437 Expression
=> Level_Expr
,
8438 Constant_Present
=> Constant_Present
(N
),
8439 Has_Init_Expression
=> True);
8441 Insert_Action_After
(Init_After
, Level_Decl
);
8443 Set_Extra_Accessibility
(Def_Id
, Level
);
8447 -- If the object is default initialized and its type is subject to
8448 -- pragma Default_Initial_Condition, add a runtime check to verify
8449 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
8451 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
8453 -- Note that the check is generated for source objects only
8455 if Comes_From_Source
(Def_Id
)
8456 and then Has_DIC
(Typ
)
8457 and then Present
(DIC_Procedure
(Typ
))
8458 and then not Has_Null_Body
(DIC_Procedure
(Typ
))
8459 and then not Has_Init_Expression
(N
)
8461 and then not Is_Imported
(Def_Id
)
8464 DIC_Call
: constant Node_Id
:=
8466 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Typ
);
8468 if Present
(Next_N
) then
8469 Insert_Before_And_Analyze
(Next_N
, DIC_Call
);
8471 -- The object declaration is the last node in a declarative or a
8475 Append_To
(List_Containing
(N
), DIC_Call
);
8481 -- If this is the return object of a build-in-place function, locate the
8482 -- implicit BIPaccess parameter designating the caller-supplied return
8483 -- object and convert the declaration to a renaming of a dereference of
8484 -- this parameter. If the declaration includes an expression, add an
8485 -- assignment statement to ensure the return object gets initialized.
8487 -- Result : T [:= <expression>];
8491 -- Result : T renames BIPaccess.all;
8492 -- [Result := <expression>;]
8494 -- in the constrained case, or to
8496 -- type Txx is access all ...;
8497 -- Rxx : Txx := null;
8499 -- if BIPalloc = 1 then
8500 -- Rxx := BIPaccess;
8501 -- Rxx.all := <expression>;
8502 -- elsif BIPalloc = 2 then
8503 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8504 -- system__secondary_stack__ss_pool][procedure_to_call =
8505 -- system__secondary_stack__ss_allocate];
8506 -- elsif BIPalloc = 3 then
8507 -- Rxx := new <expression-type>'(<expression>)
8508 -- elsif BIPalloc = 4 then
8509 -- Pxx : system__storage_pools__root_storage_pool renames
8510 -- BIPstoragepool.all;
8511 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8512 -- Pxx][procedure_to_call =
8513 -- system__storage_pools__allocate_any];
8515 -- [program_error "build in place mismatch"]
8518 -- Result : T renames Rxx.all;
8520 -- in the unconstrained case.
8522 if Is_Build_In_Place_Return_Object
(Def_Id
) then
8524 Init_Stmt
: Node_Id
;
8525 Obj_Acc_Formal
: Entity_Id
;
8528 -- Retrieve the implicit access parameter passed by the caller
8531 Build_In_Place_Formal
(Func_Id
, BIP_Object_Access
);
8533 -- If the return object's declaration includes an expression
8534 -- and the declaration isn't marked as No_Initialization, then
8535 -- we need to generate an assignment to the object and insert
8536 -- it after the declaration before rewriting it as a renaming
8537 -- (otherwise we'll lose the initialization). The case where
8538 -- the result type is an interface (or class-wide interface)
8539 -- is also excluded because the context of the function call
8540 -- must be unconstrained, so the initialization will always
8541 -- be done as part of an allocator evaluation (storage pool
8542 -- or secondary stack), never to a constrained target object
8543 -- passed in by the caller. Besides the assignment being
8544 -- unneeded in this case, it avoids problems with trying to
8545 -- generate a dispatching assignment when the return expression
8546 -- is a nonlimited descendant of a limited interface (the
8547 -- interface has no assignment operation).
8550 and then not Is_Delayed_Aggregate
(Expr_Q
)
8551 and then not No_Initialization
(N
)
8552 and then not Is_Interface
(Typ
)
8554 if Is_Class_Wide_Type
(Typ
)
8555 and then not Is_Class_Wide_Type
(Etype
(Expr_Q
))
8558 Make_Assignment_Statement
(Loc
,
8559 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8561 Make_Type_Conversion
(Loc
,
8563 New_Occurrence_Of
(Typ
, Loc
),
8564 Expression
=> New_Copy_Tree
(Expr_Q
)));
8568 Make_Assignment_Statement
(Loc
,
8569 Name
=> New_Occurrence_Of
(Def_Id
, Loc
),
8570 Expression
=> New_Copy_Tree
(Expr_Q
));
8573 Set_Assignment_OK
(Name
(Init_Stmt
));
8574 Set_No_Ctrl_Actions
(Init_Stmt
);
8580 -- When the function's subtype is unconstrained, a run-time
8581 -- test may be needed to decide the form of allocation to use
8582 -- for the return object. The function has an implicit formal
8583 -- parameter indicating this. If the BIP_Alloc_Form formal has
8584 -- the value one, then the caller has passed access to an
8585 -- existing object for use as the return object. If the value
8586 -- is two, then the return object must be allocated on the
8587 -- secondary stack. If the value is three, then the return
8588 -- object must be allocated on the heap. Otherwise, the object
8589 -- must be allocated in a storage pool. We generate an if
8590 -- statement to test the BIP_Alloc_Form formal and initialize
8591 -- a local access value appropriately.
8593 if Needs_BIP_Alloc_Form
(Func_Id
) then
8595 Desig_Typ
: constant Entity_Id
:=
8596 (if Ekind
(Typ
) = E_Array_Subtype
8597 then Etype
(Func_Id
) else Typ
);
8598 -- Ensure that the we use a fat pointer when allocating
8599 -- an unconstrained array on the heap. In this case the
8600 -- result object's type is a constrained array type even
8601 -- though the function's type is unconstrained.
8603 Obj_Alloc_Formal
: constant Entity_Id
:=
8604 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
8605 Pool_Id
: constant Entity_Id
:=
8606 Make_Temporary
(Loc
, 'P');
8608 Acc_Typ
: Entity_Id
;
8609 Alloc_Obj_Decl
: Node_Id
;
8610 Alloc_Obj_Id
: Entity_Id
;
8611 Alloc_Stmt
: Node_Id
;
8612 Guard_Except
: Node_Id
;
8613 Heap_Allocator
: Node_Id
;
8614 Pool_Allocator
: Node_Id
;
8615 Pool_Decl
: Node_Id
;
8616 Ptr_Typ_Decl
: Node_Id
;
8617 SS_Allocator
: Node_Id
;
8620 -- Create an access type designating the function's
8623 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8626 Make_Full_Type_Declaration
(Loc
,
8627 Defining_Identifier
=> Acc_Typ
,
8629 Make_Access_To_Object_Definition
(Loc
,
8630 All_Present
=> True,
8631 Subtype_Indication
=>
8632 New_Occurrence_Of
(Desig_Typ
, Loc
)));
8634 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8636 -- Create an access object that will be initialized to an
8637 -- access value denoting the return object, either coming
8638 -- from an implicit access value passed in by the caller
8639 -- or from the result of an allocator.
8641 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8644 Make_Object_Declaration
(Loc
,
8645 Defining_Identifier
=> Alloc_Obj_Id
,
8646 Object_Definition
=>
8647 New_Occurrence_Of
(Acc_Typ
, Loc
));
8649 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8651 -- First create the Heap_Allocator
8653 Heap_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8655 -- The Pool_Allocator is just like the Heap_Allocator,
8656 -- except we set Storage_Pool and Procedure_To_Call so
8657 -- it will use the user-defined storage pool.
8659 Pool_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8661 -- Do not generate the renaming of the build-in-place
8662 -- pool parameter on ZFP because the parameter is not
8663 -- created in the first place.
8665 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
8667 Make_Object_Renaming_Declaration
(Loc
,
8668 Defining_Identifier
=> Pool_Id
,
8671 (RTE
(RE_Root_Storage_Pool
), Loc
),
8673 Make_Explicit_Dereference
(Loc
,
8675 (Build_In_Place_Formal
8676 (Func_Id
, BIP_Storage_Pool
), Loc
)));
8677 Set_Storage_Pool
(Pool_Allocator
, Pool_Id
);
8678 Set_Procedure_To_Call
8679 (Pool_Allocator
, RTE
(RE_Allocate_Any
));
8681 Pool_Decl
:= Make_Null_Statement
(Loc
);
8684 -- If the No_Allocators restriction is active, then only
8685 -- an allocator for secondary stack allocation is needed.
8686 -- It's OK for such allocators to have Comes_From_Source
8687 -- set to False, because gigi knows not to flag them as
8688 -- being a violation of No_Implicit_Heap_Allocations.
8690 if Restriction_Active
(No_Allocators
) then
8691 SS_Allocator
:= Heap_Allocator
;
8692 Heap_Allocator
:= Make_Null
(Loc
);
8693 Pool_Allocator
:= Make_Null
(Loc
);
8695 -- Otherwise the heap and pool allocators may be needed,
8696 -- so we make another allocator for secondary stack
8700 SS_Allocator
:= Make_Allocator_For_Return
(Expr_Q
);
8702 -- The heap and pool allocators are marked as
8703 -- Comes_From_Source since they correspond to an
8704 -- explicit user-written allocator (that is, it will
8705 -- only be executed on behalf of callers that call the
8706 -- function as initialization for such an allocator).
8707 -- Prevents errors when No_Implicit_Heap_Allocations
8710 Set_Comes_From_Source
(Heap_Allocator
, True);
8711 Set_Comes_From_Source
(Pool_Allocator
, True);
8714 -- The allocator is returned on the secondary stack
8716 Check_Restriction
(No_Secondary_Stack
, N
);
8717 Set_Storage_Pool
(SS_Allocator
, RTE
(RE_SS_Pool
));
8718 Set_Procedure_To_Call
8719 (SS_Allocator
, RTE
(RE_SS_Allocate
));
8721 -- The allocator is returned on the secondary stack,
8722 -- so indicate that the function return, as well as
8723 -- all blocks that encloses the allocator, must not
8724 -- release it. The flags must be set now because
8725 -- the decision to use the secondary stack is done
8726 -- very late in the course of expanding the return
8727 -- statement, past the point where these flags are
8730 Set_Uses_Sec_Stack
(Func_Id
);
8731 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
8732 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
8734 -- Guard against poor expansion on the caller side by
8735 -- using a raise statement to catch out-of-range values
8736 -- of formal parameter BIP_Alloc_Form.
8738 if Exceptions_OK
then
8740 Make_Raise_Program_Error
(Loc
,
8741 Reason
=> PE_Build_In_Place_Mismatch
);
8743 Guard_Except
:= Make_Null_Statement
(Loc
);
8746 -- Create an if statement to test the BIP_Alloc_Form
8747 -- formal and initialize the access object to either the
8748 -- BIP_Object_Access formal (BIP_Alloc_Form =
8749 -- Caller_Allocation), the result of allocating the
8750 -- object in the secondary stack (BIP_Alloc_Form =
8751 -- Secondary_Stack), or else an allocator to create the
8752 -- return object in the heap or user-defined pool
8753 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
8755 -- ??? An unchecked type conversion must be made in the
8756 -- case of assigning the access object formal to the
8757 -- local access object, because a normal conversion would
8758 -- be illegal in some cases (such as converting access-
8759 -- to-unconstrained to access-to-constrained), but the
8760 -- the unchecked conversion will presumably fail to work
8761 -- right in just such cases. It's not clear at all how to
8765 Make_If_Statement
(Loc
,
8769 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8771 Make_Integer_Literal
(Loc
,
8772 UI_From_Int
(BIP_Allocation_Form
'Pos
8773 (Caller_Allocation
)))),
8775 Then_Statements
=> New_List
(
8776 Make_Assignment_Statement
(Loc
,
8778 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8780 Unchecked_Convert_To
8782 New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)))),
8784 Elsif_Parts
=> New_List
(
8785 Make_Elsif_Part
(Loc
,
8789 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8791 Make_Integer_Literal
(Loc
,
8792 UI_From_Int
(BIP_Allocation_Form
'Pos
8793 (Secondary_Stack
)))),
8795 Then_Statements
=> New_List
(
8796 Make_Assignment_Statement
(Loc
,
8798 New_Occurrence_Of
(Alloc_Obj_Id
, Loc
),
8799 Expression
=> SS_Allocator
))),
8801 Make_Elsif_Part
(Loc
,
8805 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8807 Make_Integer_Literal
(Loc
,
8808 UI_From_Int
(BIP_Allocation_Form
'Pos
8811 Then_Statements
=> New_List
(
8812 Build_Heap_Or_Pool_Allocator
8813 (Temp_Id
=> Alloc_Obj_Id
,
8814 Temp_Typ
=> Acc_Typ
,
8815 Ret_Typ
=> Desig_Typ
,
8816 Alloc_Expr
=> Heap_Allocator
))),
8818 -- ??? If all is well, we can put the following
8819 -- 'elsif' in the 'else', but this is a useful
8820 -- self-check in case caller and callee don't agree
8821 -- on whether BIPAlloc and so on should be passed.
8823 Make_Elsif_Part
(Loc
,
8827 New_Occurrence_Of
(Obj_Alloc_Formal
, Loc
),
8829 Make_Integer_Literal
(Loc
,
8830 UI_From_Int
(BIP_Allocation_Form
'Pos
8831 (User_Storage_Pool
)))),
8833 Then_Statements
=> New_List
(
8835 Build_Heap_Or_Pool_Allocator
8836 (Temp_Id
=> Alloc_Obj_Id
,
8837 Temp_Typ
=> Acc_Typ
,
8838 Ret_Typ
=> Desig_Typ
,
8839 Alloc_Expr
=> Pool_Allocator
)))),
8841 -- Raise Program_Error if it's none of the above;
8842 -- this is a compiler bug.
8844 Else_Statements
=> New_List
(Guard_Except
));
8846 -- If a separate initialization assignment was created
8847 -- earlier, append that following the assignment of the
8848 -- implicit access formal to the access object, to ensure
8849 -- that the return object is initialized in that case. In
8850 -- this situation, the target of the assignment must be
8851 -- rewritten to denote a dereference of the access to the
8852 -- return object passed in by the caller.
8854 if Present
(Init_Stmt
) then
8855 Set_Name
(Init_Stmt
,
8856 Make_Explicit_Dereference
(Loc
,
8857 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
)));
8858 Set_Assignment_OK
(Name
(Init_Stmt
));
8860 Append_To
(Then_Statements
(Alloc_Stmt
), Init_Stmt
);
8864 Insert_Action
(N
, Alloc_Stmt
, Suppress
=> All_Checks
);
8866 -- From now on, the type of the return object is the
8869 if Desig_Typ
/= Typ
then
8870 Set_Etype
(Def_Id
, Desig_Typ
);
8871 Set_Actual_Subtype
(Def_Id
, Typ
);
8874 -- Remember the local access object for use in the
8875 -- dereference of the renaming created below.
8877 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8880 -- When the function's type is unconstrained and a run-time test
8881 -- is not needed, we nevertheless need to build the return using
8882 -- the return object's type.
8884 elsif not Is_Constrained
(Underlying_Type
(Etype
(Func_Id
))) then
8886 Acc_Typ
: Entity_Id
;
8887 Alloc_Obj_Decl
: Node_Id
;
8888 Alloc_Obj_Id
: Entity_Id
;
8889 Ptr_Typ_Decl
: Node_Id
;
8892 -- Create an access type designating the function's
8895 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
8898 Make_Full_Type_Declaration
(Loc
,
8899 Defining_Identifier
=> Acc_Typ
,
8901 Make_Access_To_Object_Definition
(Loc
,
8902 All_Present
=> True,
8903 Subtype_Indication
=>
8904 New_Occurrence_Of
(Typ
, Loc
)));
8906 Insert_Action
(N
, Ptr_Typ_Decl
, Suppress
=> All_Checks
);
8908 -- Create an access object initialized to the conversion
8909 -- of the implicit access value passed in by the caller.
8911 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
8913 -- See the ??? comment a few lines above about the use of
8914 -- an unchecked conversion here.
8917 Make_Object_Declaration
(Loc
,
8918 Defining_Identifier
=> Alloc_Obj_Id
,
8919 Constant_Present
=> True,
8920 Object_Definition
=>
8921 New_Occurrence_Of
(Acc_Typ
, Loc
),
8923 Unchecked_Convert_To
8924 (Acc_Typ
, New_Occurrence_Of
(Obj_Acc_Formal
, Loc
)));
8926 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
8928 -- Remember the local access object for use in the
8929 -- dereference of the renaming created below.
8931 Obj_Acc_Formal
:= Alloc_Obj_Id
;
8935 -- Initialize the object now that it has got its final subtype,
8936 -- but before rewriting it as a renaming.
8938 Initialize_Return_Object
8939 (Tag_Assign
, Adj_Call
, Expr_Q
, Init_Stmt
, Init_After
);
8941 -- Save the assignment statement when returning a controlled
8942 -- object. This reference is used later by the finalization
8943 -- machinery to mark the object as successfully initialized.
8945 if Present
(Init_Stmt
) and then Needs_Finalization
(Typ
) then
8946 Set_Last_Aggregate_Assignment
(Def_Id
, Init_Stmt
);
8949 -- Replace the return object declaration with a renaming of a
8950 -- dereference of the access value designating the return object.
8953 Make_Explicit_Dereference
(Loc
,
8954 Prefix
=> New_Occurrence_Of
(Obj_Acc_Formal
, Loc
));
8955 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
8957 Rewrite_As_Renaming
:= True;
8960 -- If we can rename the initialization expression, we need to make sure
8961 -- that we use the proper type in the case of a return object that lives
8962 -- on the secondary stack (see other cases below for a similar handling)
8963 -- and that the tag is assigned in the case of any return object.
8965 elsif Rewrite_As_Renaming
then
8966 if Special_Ret_Obj
then
8968 Desig_Typ
: constant Entity_Id
:=
8969 (if Ekind
(Typ
) = E_Array_Subtype
8970 then Etype
(Func_Id
) else Typ
);
8973 -- From now on, the type of the return object is the
8976 if Desig_Typ
/= Typ
then
8977 Set_Etype
(Def_Id
, Desig_Typ
);
8978 Set_Actual_Subtype
(Def_Id
, Typ
);
8981 if Present
(Tag_Assign
) then
8982 Insert_Action_After
(Init_After
, Tag_Assign
);
8985 -- Ada 2005 (AI95-344): If the result type is class-wide,
8986 -- insert a check that the level of the return expression's
8987 -- underlying type is not deeper than the level of the master
8988 -- enclosing the function.
8990 -- AI12-043: The check is made immediately after the return
8991 -- object is created.
8993 if Is_Class_Wide_Type
(Etype
(Func_Id
)) then
8994 Apply_CW_Accessibility_Check
(Expr_Q
, Func_Id
);
8999 -- If this is the return object of a function returning on the secondary
9000 -- stack, convert the declaration to a renaming of the dereference of ah
9001 -- allocator for the secondary stack.
9003 -- Result : T [:= <expression>];
9007 -- type Txx is access all ...;
9008 -- Rxx : constant Txx :=
9009 -- new <expression-type>['(<expression>)][storage_pool =
9010 -- system__secondary_stack__ss_pool][procedure_to_call =
9011 -- system__secondary_stack__ss_allocate];
9013 -- Result : T renames Rxx.all;
9015 elsif Is_Secondary_Stack_Return_Object
(Def_Id
) then
9017 Desig_Typ
: constant Entity_Id
:=
9018 (if Ekind
(Typ
) = E_Array_Subtype
9019 then Etype
(Func_Id
) else Typ
);
9020 -- Ensure that the we use a fat pointer when allocating
9021 -- an unconstrained array on the heap. In this case the
9022 -- result object's type is a constrained array type even
9023 -- though the function's type is unconstrained.
9025 Acc_Typ
: Entity_Id
;
9026 Alloc_Obj_Decl
: Node_Id
;
9027 Alloc_Obj_Id
: Entity_Id
;
9028 Ptr_Type_Decl
: Node_Id
;
9031 -- Create an access type designating the function's
9034 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
9037 Make_Full_Type_Declaration
(Loc
,
9038 Defining_Identifier
=> Acc_Typ
,
9040 Make_Access_To_Object_Definition
(Loc
,
9041 All_Present
=> True,
9042 Subtype_Indication
=>
9043 New_Occurrence_Of
(Desig_Typ
, Loc
)));
9045 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
9047 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
9049 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
9052 Make_Object_Declaration
(Loc
,
9053 Defining_Identifier
=> Alloc_Obj_Id
,
9054 Constant_Present
=> True,
9055 Object_Definition
=>
9056 New_Occurrence_Of
(Acc_Typ
, Loc
),
9057 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
9059 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
9061 Set_Uses_Sec_Stack
(Func_Id
);
9062 Set_Uses_Sec_Stack
(Scope
(Def_Id
));
9063 Set_Sec_Stack_Needed_For_Return
(Scope
(Def_Id
));
9065 -- From now on, the type of the return object is the
9068 if Desig_Typ
/= Typ
then
9069 Set_Etype
(Def_Id
, Desig_Typ
);
9070 Set_Actual_Subtype
(Def_Id
, Typ
);
9073 -- Initialize the object now that it has got its final subtype,
9074 -- but before rewriting it as a renaming.
9076 Initialize_Return_Object
9077 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
9079 -- Replace the return object declaration with a renaming of a
9080 -- dereference of the access value designating the return object.
9083 Make_Explicit_Dereference
(Loc
,
9084 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
9085 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
9087 Rewrite_As_Renaming
:= True;
9090 -- If this is the return object of a function returning a by-reference
9091 -- type, convert the declaration to a renaming of the dereference of ah
9092 -- allocator for the return stack.
9094 -- Result : T [:= <expression>];
9098 -- type Txx is access all ...;
9099 -- Rxx : constant Txx :=
9100 -- new <expression-type>['(<expression>)][storage_pool =
9101 -- system__return_stack__rs_pool][procedure_to_call =
9102 -- system__return_stack__rs_allocate];
9104 -- Result : T renames Rxx.all;
9106 elsif Back_End_Return_Slot
9107 and then Is_By_Reference_Return_Object
(Def_Id
)
9110 Acc_Typ
: Entity_Id
;
9111 Alloc_Obj_Decl
: Node_Id
;
9112 Alloc_Obj_Id
: Entity_Id
;
9113 Ptr_Type_Decl
: Node_Id
;
9116 -- Create an access type designating the function's
9119 Acc_Typ
:= Make_Temporary
(Loc
, 'A');
9122 Make_Full_Type_Declaration
(Loc
,
9123 Defining_Identifier
=> Acc_Typ
,
9125 Make_Access_To_Object_Definition
(Loc
,
9126 All_Present
=> True,
9127 Subtype_Indication
=>
9128 New_Occurrence_Of
(Typ
, Loc
)));
9130 Insert_Action
(N
, Ptr_Type_Decl
, Suppress
=> All_Checks
);
9132 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_RS_Pool
));
9134 Alloc_Obj_Id
:= Make_Temporary
(Loc
, 'R');
9137 Make_Object_Declaration
(Loc
,
9138 Defining_Identifier
=> Alloc_Obj_Id
,
9139 Constant_Present
=> True,
9140 Object_Definition
=>
9141 New_Occurrence_Of
(Acc_Typ
, Loc
),
9142 Expression
=> Make_Allocator_For_Return
(Expr_Q
));
9144 Insert_Action
(N
, Alloc_Obj_Decl
, Suppress
=> All_Checks
);
9146 -- Initialize the object now that it has got its final subtype,
9147 -- but before rewriting it as a renaming.
9149 Initialize_Return_Object
9150 (Tag_Assign
, Adj_Call
, Expr_Q
, Empty
, Init_After
);
9152 -- Replace the return object declaration with a renaming of a
9153 -- dereference of the access value designating the return object.
9156 Make_Explicit_Dereference
(Loc
,
9157 Prefix
=> New_Occurrence_Of
(Alloc_Obj_Id
, Loc
));
9158 Set_Etype
(Expr_Q
, Etype
(Def_Id
));
9160 Rewrite_As_Renaming
:= True;
9164 -- Final transformation - turn the object declaration into a renaming
9165 -- if appropriate. If this is the completion of a deferred constant
9166 -- declaration, then this transformation generates what would be
9167 -- illegal code if written by hand, but that's OK.
9169 if Rewrite_As_Renaming
then
9171 Make_Object_Renaming_Declaration
(Loc
,
9172 Defining_Identifier
=> Def_Id
,
9173 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Def_Id
), Loc
),
9176 -- Keep original aspects
9178 Move_Aspects
(Original_Node
(N
), N
);
9180 -- We do not analyze this renaming declaration, because all its
9181 -- components have already been analyzed, and if we were to go
9182 -- ahead and analyze it, we would in effect be trying to generate
9183 -- another declaration of X, which won't do.
9185 Set_Renamed_Object
(Def_Id
, Expr_Q
);
9188 -- We do need to deal with debug issues for this renaming
9190 -- First, if entity comes from source, then mark it as needing
9191 -- debug information, even though it is defined by a generated
9192 -- renaming that does not come from source.
9194 Set_Debug_Info_Defining_Id
(N
);
9196 -- Now call the routine to generate debug info for the renaming
9198 Insert_Action
(N
, Debug_Renaming_Declaration
(N
));
9201 -- Exception on library entity not available
9204 when RE_Not_Available
=>
9206 end Expand_N_Object_Declaration
;
9208 ---------------------------------
9209 -- Expand_N_Subtype_Indication --
9210 ---------------------------------
9212 -- Add a check on the range of the subtype and deal with validity checking
9214 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
9215 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
9216 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9219 if Nkind
(Constraint
(N
)) = N_Range_Constraint
then
9220 Validity_Check_Range
(Range_Expression
(Constraint
(N
)));
9223 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
9225 if Nkind
(Parent
(N
)) in N_Constrained_Array_Definition | N_Slice
9226 and then Nkind
(Parent
(Parent
(N
))) not in
9227 N_Full_Type_Declaration | N_Object_Declaration
9229 Apply_Range_Check
(Ran
, Typ
);
9231 end Expand_N_Subtype_Indication
;
9233 ---------------------------
9234 -- Expand_N_Variant_Part --
9235 ---------------------------
9237 -- Note: this procedure no longer has any effect. It used to be that we
9238 -- would replace the choices in the last variant by a when others, and
9239 -- also expanded static predicates in variant choices here, but both of
9240 -- those activities were being done too early, since we can't check the
9241 -- choices until the statically predicated subtypes are frozen, which can
9242 -- happen as late as the free point of the record, and we can't change the
9243 -- last choice to an others before checking the choices, which is now done
9244 -- at the freeze point of the record.
9246 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
9249 end Expand_N_Variant_Part
;
9251 ---------------------------------
9252 -- Expand_Previous_Access_Type --
9253 ---------------------------------
9255 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
9256 Ptr_Typ
: Entity_Id
;
9259 -- Find all access types in the current scope whose designated type is
9260 -- Def_Id and build master renamings for them.
9262 Ptr_Typ
:= First_Entity
(Current_Scope
);
9263 while Present
(Ptr_Typ
) loop
9264 if Is_Access_Type
(Ptr_Typ
)
9265 and then Designated_Type
(Ptr_Typ
) = Def_Id
9266 and then No
(Master_Id
(Ptr_Typ
))
9268 -- Ensure that the designated type has a master
9270 Build_Master_Entity
(Def_Id
);
9272 -- Private and incomplete types complicate the insertion of master
9273 -- renamings because the access type may precede the full view of
9274 -- the designated type. For this reason, the master renamings are
9275 -- inserted relative to the designated type.
9277 Build_Master_Renaming
(Ptr_Typ
, Ins_Nod
=> Parent
(Def_Id
));
9280 Next_Entity
(Ptr_Typ
);
9282 end Expand_Previous_Access_Type
;
9284 -----------------------------
9285 -- Expand_Record_Extension --
9286 -----------------------------
9288 -- Add a field _parent at the beginning of the record extension. This is
9289 -- used to implement inheritance. Here are some examples of expansion:
9291 -- 1. no discriminants
9292 -- type T2 is new T1 with null record;
9294 -- type T2 is new T1 with record
9298 -- 2. renamed discriminants
9299 -- type T2 (B, C : Int) is new T1 (A => B) with record
9300 -- _Parent : T1 (A => B);
9304 -- 3. inherited discriminants
9305 -- type T2 is new T1 with record -- discriminant A inherited
9306 -- _Parent : T1 (A);
9310 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
9311 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
9312 Loc
: constant Source_Ptr
:= Sloc
(Def
);
9313 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
9314 Par_Subtype
: Entity_Id
;
9315 Comp_List
: Node_Id
;
9316 Comp_Decl
: Node_Id
;
9319 List_Constr
: constant List_Id
:= New_List
;
9322 -- Expand_Record_Extension is called directly from the semantics, so
9323 -- we must check to see whether expansion is active before proceeding,
9324 -- because this affects the visibility of selected components in bodies
9325 -- of instances. Within a generic we still need to set Parent_Subtype
9326 -- link because the visibility of inherited components will have to be
9327 -- verified in subsequent instances.
9329 if not Expander_Active
then
9330 if Inside_A_Generic
and then Ekind
(T
) = E_Record_Type
then
9331 Set_Parent_Subtype
(T
, Etype
(T
));
9336 -- This may be a derivation of an untagged private type whose full
9337 -- view is tagged, in which case the Derived_Type_Definition has no
9338 -- extension part. Build an empty one now.
9340 if No
(Rec_Ext_Part
) then
9342 Make_Record_Definition
(Loc
,
9344 Component_List
=> Empty
,
9345 Null_Present
=> True);
9347 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
9348 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
9351 Comp_List
:= Component_List
(Rec_Ext_Part
);
9353 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
9355 -- If the derived type inherits its discriminants the type of the
9356 -- _parent field must be constrained by the inherited discriminants
9358 if Has_Discriminants
(T
)
9359 and then Nkind
(Indic
) /= N_Subtype_Indication
9360 and then not Is_Constrained
(Entity
(Indic
))
9362 D
:= First_Discriminant
(T
);
9363 while Present
(D
) loop
9364 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
9365 Next_Discriminant
(D
);
9370 Make_Subtype_Indication
(Loc
,
9371 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Indic
), Loc
),
9373 Make_Index_Or_Discriminant_Constraint
(Loc
,
9374 Constraints
=> List_Constr
)),
9377 -- Otherwise the original subtype_indication is just what is needed
9380 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
9383 Set_Parent_Subtype
(T
, Par_Subtype
);
9386 Make_Component_Declaration
(Loc
,
9387 Defining_Identifier
=> Parent_N
,
9388 Component_Definition
=>
9389 Make_Component_Definition
(Loc
,
9390 Aliased_Present
=> False,
9391 Subtype_Indication
=> New_Occurrence_Of
(Par_Subtype
, Loc
)));
9393 if Null_Present
(Rec_Ext_Part
) then
9394 Set_Component_List
(Rec_Ext_Part
,
9395 Make_Component_List
(Loc
,
9396 Component_Items
=> New_List
(Comp_Decl
),
9397 Variant_Part
=> Empty
,
9398 Null_Present
=> False));
9399 Set_Null_Present
(Rec_Ext_Part
, False);
9401 elsif Null_Present
(Comp_List
)
9402 or else Is_Empty_List
(Component_Items
(Comp_List
))
9404 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9405 Set_Null_Present
(Comp_List
, False);
9408 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9411 Analyze
(Comp_Decl
);
9412 end Expand_Record_Extension
;
9414 ------------------------
9415 -- Expand_Tagged_Root --
9416 ------------------------
9418 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
9419 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
9420 Comp_List
: Node_Id
;
9421 Comp_Decl
: Node_Id
;
9422 Sloc_N
: Source_Ptr
;
9425 if Null_Present
(Def
) then
9426 Set_Component_List
(Def
,
9427 Make_Component_List
(Sloc
(Def
),
9428 Component_Items
=> Empty_List
,
9429 Variant_Part
=> Empty
,
9430 Null_Present
=> True));
9433 Comp_List
:= Component_List
(Def
);
9435 if Null_Present
(Comp_List
)
9436 or else Is_Empty_List
(Component_Items
(Comp_List
))
9438 Sloc_N
:= Sloc
(Comp_List
);
9440 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
9444 Make_Component_Declaration
(Sloc_N
,
9445 Defining_Identifier
=> First_Tag_Component
(T
),
9446 Component_Definition
=>
9447 Make_Component_Definition
(Sloc_N
,
9448 Aliased_Present
=> False,
9449 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RE_Tag
), Sloc_N
)));
9451 if Null_Present
(Comp_List
)
9452 or else Is_Empty_List
(Component_Items
(Comp_List
))
9454 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
9455 Set_Null_Present
(Comp_List
, False);
9458 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
9461 -- We don't Analyze the whole expansion because the tag component has
9462 -- already been analyzed previously. Here we just insure that the tree
9463 -- is coherent with the semantic decoration
9465 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
9468 when RE_Not_Available
=>
9470 end Expand_Tagged_Root
;
9472 ------------------------------
9473 -- Freeze_Stream_Operations --
9474 ------------------------------
9476 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
9477 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
9482 Stream_Op
: Entity_Id
;
9485 -- Primitive operations of tagged types are frozen when the dispatch
9486 -- table is constructed.
9488 if not Comes_From_Source
(Typ
) or else Is_Tagged_Type
(Typ
) then
9492 for J
in Names
'Range loop
9493 Stream_Op
:= TSS
(Typ
, Names
(J
));
9495 if Present
(Stream_Op
)
9496 and then Is_Subprogram
(Stream_Op
)
9497 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
9498 N_Subprogram_Declaration
9499 and then not Is_Frozen
(Stream_Op
)
9501 Append_Freeze_Actions
(Typ
, Freeze_Entity
(Stream_Op
, N
));
9504 end Freeze_Stream_Operations
;
9510 -- Full type declarations are expanded at the point at which the type is
9511 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
9512 -- declarations generated by the freezing (e.g. the procedure generated
9513 -- for initialization) are chained in the Actions field list of the freeze
9514 -- node using Append_Freeze_Actions.
9516 -- WARNING: This routine manages Ghost regions. Return statements must be
9517 -- replaced by gotos which jump to the end of the routine and restore the
9520 function Freeze_Type
(N
: Node_Id
) return Boolean is
9521 procedure Process_RACW_Types
(Typ
: Entity_Id
);
9522 -- Validate and generate stubs for all RACW types associated with type
9525 ------------------------
9526 -- Process_RACW_Types --
9527 ------------------------
9529 procedure Process_RACW_Types
(Typ
: Entity_Id
) is
9530 List
: constant Elist_Id
:= Access_Types_To_Process
(N
);
9532 Seen
: Boolean := False;
9535 if Present
(List
) then
9536 E
:= First_Elmt
(List
);
9537 while Present
(E
) loop
9538 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
9539 Validate_RACW_Primitives
(Node
(E
));
9547 -- If there are RACWs designating this type, make stubs now
9550 Remote_Types_Tagged_Full_View_Encountered
(Typ
);
9552 end Process_RACW_Types
;
9556 Def_Id
: constant Entity_Id
:= Entity
(N
);
9558 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
9559 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
9560 -- Save the Ghost-related attributes to restore on exit
9562 Result
: Boolean := False;
9564 -- Start of processing for Freeze_Type
9567 -- The type being frozen may be subject to pragma Ghost. Set the mode
9568 -- now to ensure that any nodes generated during freezing are properly
9571 Set_Ghost_Mode
(Def_Id
);
9573 -- Process any remote access-to-class-wide types designating the type
9576 Process_RACW_Types
(Def_Id
);
9578 -- Freeze processing for record types
9580 if Is_Record_Type
(Def_Id
) then
9581 if Ekind
(Def_Id
) = E_Record_Type
then
9582 Expand_Freeze_Record_Type
(N
);
9583 elsif Is_Class_Wide_Type
(Def_Id
) then
9584 Expand_Freeze_Class_Wide_Type
(N
);
9587 -- Freeze processing for array types
9589 elsif Is_Array_Type
(Def_Id
) then
9590 Expand_Freeze_Array_Type
(N
);
9592 -- Freeze processing for access types
9594 -- For pool-specific access types, find out the pool object used for
9595 -- this type, needs actual expansion of it in some cases. Here are the
9596 -- different cases :
9598 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
9599 -- ---> don't use any storage pool
9601 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
9603 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
9605 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9606 -- ---> Storage Pool is the specified one
9608 -- See GNAT Pool packages in the Run-Time for more details
9610 elsif Ekind
(Def_Id
) in E_Access_Type | E_General_Access_Type
then
9612 Loc
: constant Source_Ptr
:= Sloc
(N
);
9613 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
9615 Freeze_Action_Typ
: Entity_Id
;
9616 Pool_Object
: Entity_Id
;
9621 -- Rep Clause "for Def_Id'Storage_Size use 0;"
9622 -- ---> don't use any storage pool
9624 if No_Pool_Assigned
(Def_Id
) then
9629 -- Rep Clause : for Def_Id'Storage_Size use Expr.
9631 -- Def_Id__Pool : Stack_Bounded_Pool
9632 -- (Expr, DT'Size, DT'Alignment);
9634 elsif Has_Storage_Size_Clause
(Def_Id
) then
9640 -- For unconstrained composite types we give a size of zero
9641 -- so that the pool knows that it needs a special algorithm
9642 -- for variable size object allocation.
9644 if Is_Composite_Type
(Desig_Type
)
9645 and then not Is_Constrained
(Desig_Type
)
9647 DT_Size
:= Make_Integer_Literal
(Loc
, 0);
9648 DT_Align
:= Make_Integer_Literal
(Loc
, Maximum_Alignment
);
9652 Make_Attribute_Reference
(Loc
,
9653 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9654 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
9657 Make_Attribute_Reference
(Loc
,
9658 Prefix
=> New_Occurrence_Of
(Desig_Type
, Loc
),
9659 Attribute_Name
=> Name_Alignment
);
9663 Make_Defining_Identifier
(Loc
,
9664 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
9666 -- We put the code associated with the pools in the entity
9667 -- that has the later freeze node, usually the access type
9668 -- but it can also be the designated_type; because the pool
9669 -- code requires both those types to be frozen
9671 if Is_Frozen
(Desig_Type
)
9672 and then (No
(Freeze_Node
(Desig_Type
))
9673 or else Analyzed
(Freeze_Node
(Desig_Type
)))
9675 Freeze_Action_Typ
:= Def_Id
;
9677 -- A Taft amendment type cannot get the freeze actions
9678 -- since the full view is not there.
9680 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
9681 and then No
(Full_View
(Desig_Type
))
9683 Freeze_Action_Typ
:= Def_Id
;
9686 Freeze_Action_Typ
:= Desig_Type
;
9689 Append_Freeze_Action
(Freeze_Action_Typ
,
9690 Make_Object_Declaration
(Loc
,
9691 Defining_Identifier
=> Pool_Object
,
9692 Object_Definition
=>
9693 Make_Subtype_Indication
(Loc
,
9696 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
9699 Make_Index_Or_Discriminant_Constraint
(Loc
,
9700 Constraints
=> New_List
(
9702 -- First discriminant is the Pool Size
9705 Storage_Size_Variable
(Def_Id
), Loc
),
9707 -- Second discriminant is the element size
9711 -- Third discriminant is the alignment
9716 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
9720 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9721 -- ---> Storage Pool is the specified one
9723 -- When compiling in Ada 2012 mode, ensure that the accessibility
9724 -- level of the subpool access type is not deeper than that of the
9725 -- pool_with_subpools.
9727 elsif Ada_Version
>= Ada_2012
9728 and then Present
(Associated_Storage_Pool
(Def_Id
))
9729 and then RTU_Loaded
(System_Storage_Pools_Subpools
)
9732 Loc
: constant Source_Ptr
:= Sloc
(Def_Id
);
9733 Pool
: constant Entity_Id
:=
9734 Associated_Storage_Pool
(Def_Id
);
9737 -- It is known that the accessibility level of the access
9738 -- type is deeper than that of the pool.
9740 if Type_Access_Level
(Def_Id
)
9741 > Static_Accessibility_Level
(Pool
, Object_Decl_Level
)
9742 and then Is_Class_Wide_Type
(Etype
(Pool
))
9743 and then not Accessibility_Checks_Suppressed
(Def_Id
)
9744 and then not Accessibility_Checks_Suppressed
(Pool
)
9746 -- When the pool is of a class-wide type, it may or may
9747 -- not support subpools depending on the path of
9748 -- derivation. Generate:
9750 -- if Def_Id in RSPWS'Class then
9751 -- raise Program_Error;
9754 Append_Freeze_Action
(Def_Id
,
9755 Make_If_Statement
(Loc
,
9758 Left_Opnd
=> New_Occurrence_Of
(Pool
, Loc
),
9763 (RE_Root_Storage_Pool_With_Subpools
)),
9765 Then_Statements
=> New_List
(
9766 Make_Raise_Program_Error
(Loc
,
9767 Reason
=> PE_Accessibility_Check_Failed
))));
9772 -- For access-to-controlled types (including class-wide types and
9773 -- Taft-amendment types, which potentially have controlled
9774 -- components), expand the list controller object that will store
9775 -- the dynamically allocated objects. Don't do this transformation
9776 -- for expander-generated access types, except do it for types
9777 -- that are the full view of types derived from other private
9778 -- types and for access types used to implement indirect temps.
9779 -- Also suppress the list controller in the case of a designated
9780 -- type with convention Java, since this is used when binding to
9781 -- Java API specs, where there's no equivalent of a finalization
9782 -- list and we don't want to pull in the finalization support if
9785 if not Comes_From_Source
(Def_Id
)
9786 and then not Has_Private_Declaration
(Def_Id
)
9787 and then not Old_Attr_Util
.Indirect_Temps
9788 .Is_Access_Type_For_Indirect_Temp
(Def_Id
)
9792 -- An exception is made for types defined in the run-time because
9793 -- Ada.Tags.Tag itself is such a type and cannot afford this
9794 -- unnecessary overhead that would generates a loop in the
9795 -- expansion scheme. Another exception is if Restrictions
9796 -- (No_Finalization) is active, since then we know nothing is
9799 elsif Restriction_Active
(No_Finalization
)
9800 or else In_Runtime
(Def_Id
)
9804 -- Create a finalization collection for an access-to-controlled
9805 -- type or an access-to-incomplete type. It is assumed that the
9806 -- full view will be controlled.
9808 elsif Needs_Finalization
(Desig_Type
)
9809 or else (Is_Incomplete_Type
(Desig_Type
)
9810 and then No
(Full_View
(Desig_Type
)))
9812 Build_Finalization_Collection
(Def_Id
);
9814 -- Also create a finalization collection when the designated type
9815 -- contains a private component. It is assumed that the full view
9816 -- will be controlled.
9818 elsif Has_Private_Component
(Desig_Type
) then
9819 Build_Finalization_Collection
9821 For_Private
=> True,
9822 Context_Scope
=> Scope
(Def_Id
),
9823 Insertion_Node
=> Declaration_Node
(Desig_Type
));
9827 -- Freeze processing for enumeration types
9829 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
9831 -- We only have something to do if we have a non-standard
9832 -- representation (i.e. at least one literal whose pos value
9833 -- is not the same as its representation)
9835 if Has_Non_Standard_Rep
(Def_Id
) then
9836 Expand_Freeze_Enumeration_Type
(N
);
9839 -- Private types that are completed by a derivation from a private
9840 -- type have an internally generated full view, that needs to be
9841 -- frozen. This must be done explicitly because the two views share
9842 -- the freeze node, and the underlying full view is not visible when
9843 -- the freeze node is analyzed.
9845 elsif Is_Private_Type
(Def_Id
)
9846 and then Is_Derived_Type
(Def_Id
)
9847 and then Present
(Full_View
(Def_Id
))
9848 and then Is_Itype
(Full_View
(Def_Id
))
9849 and then Has_Private_Declaration
(Full_View
(Def_Id
))
9850 and then Freeze_Node
(Full_View
(Def_Id
)) = N
9852 Set_Entity
(N
, Full_View
(Def_Id
));
9853 Result
:= Freeze_Type
(N
);
9854 Set_Entity
(N
, Def_Id
);
9856 -- All other types require no expander action. There are such cases
9857 -- (e.g. task types and protected types). In such cases, the freeze
9858 -- nodes are there for use by Gigi.
9862 Freeze_Stream_Operations
(N
, Def_Id
);
9864 -- Generate the [spec and] body of the invariant procedure tasked with
9865 -- the runtime verification of all invariants that pertain to the type.
9866 -- This includes invariants on the partial and full view, inherited
9867 -- class-wide invariants from parent types or interfaces, and invariants
9868 -- on array elements or record components. But skip internal types.
9870 if Is_Itype
(Def_Id
) then
9873 elsif Is_Interface
(Def_Id
) then
9875 -- Interfaces are treated as the partial view of a private type in
9876 -- order to achieve uniformity with the general case. As a result, an
9877 -- interface receives only a "partial" invariant procedure which is
9880 if Has_Own_Invariants
(Def_Id
) then
9881 Build_Invariant_Procedure_Body
9883 Partial_Invariant
=> Is_Interface
(Def_Id
));
9886 -- Non-interface types
9888 -- Do not generate invariant procedure within other assertion
9889 -- subprograms, which may involve local declarations of local
9890 -- subtypes to which these checks do not apply.
9893 if Has_Invariants
(Def_Id
) then
9894 if not Predicate_Check_In_Scope
(Def_Id
)
9895 or else (Ekind
(Current_Scope
) = E_Function
9896 and then Is_Predicate_Function
(Current_Scope
))
9900 Build_Invariant_Procedure_Body
(Def_Id
);
9904 -- Generate the [spec and] body of the procedure tasked with the
9905 -- run-time verification of pragma Default_Initial_Condition's
9908 if Has_DIC
(Def_Id
) then
9909 Build_DIC_Procedure_Body
(Def_Id
);
9913 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9918 when RE_Not_Available
=>
9919 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
9924 -------------------------
9925 -- Get_Simple_Init_Val --
9926 -------------------------
9928 function Get_Simple_Init_Val
9931 Size
: Uint
:= No_Uint
) return Node_Id
9933 IV_Attribute
: constant Boolean :=
9934 Nkind
(N
) = N_Attribute_Reference
9935 and then Attribute_Name
(N
) = Name_Invalid_Value
;
9937 Loc
: constant Source_Ptr
:= Sloc
(N
);
9939 procedure Extract_Subtype_Bounds
9940 (Lo_Bound
: out Uint
;
9941 Hi_Bound
: out Uint
);
9942 -- Inspect subtype Typ as well its ancestor subtypes and derived types
9943 -- to determine the best known information about the bounds of the type.
9944 -- The output parameters are set as follows:
9946 -- * Lo_Bound - Set to No_Unit when there is no information available,
9947 -- or to the known low bound.
9949 -- * Hi_Bound - Set to No_Unit when there is no information available,
9950 -- or to the known high bound.
9952 function Simple_Init_Array_Type
return Node_Id
;
9953 -- Build an expression to initialize array type Typ
9955 function Simple_Init_Defaulted_Type
return Node_Id
;
9956 -- Build an expression to initialize type Typ which is subject to
9957 -- aspect Default_Value.
9959 function Simple_Init_Initialize_Scalars_Type
9960 (Size_To_Use
: Uint
) return Node_Id
;
9961 -- Build an expression to initialize scalar type Typ which is subject to
9962 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
9964 function Simple_Init_Normalize_Scalars_Type
9965 (Size_To_Use
: Uint
) return Node_Id
;
9966 -- Build an expression to initialize scalar type Typ which is subject to
9967 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
9969 function Simple_Init_Private_Type
return Node_Id
;
9970 -- Build an expression to initialize private type Typ
9972 function Simple_Init_Scalar_Type
return Node_Id
;
9973 -- Build an expression to initialize scalar type Typ
9975 ----------------------------
9976 -- Extract_Subtype_Bounds --
9977 ----------------------------
9979 procedure Extract_Subtype_Bounds
9980 (Lo_Bound
: out Uint
;
9981 Hi_Bound
: out Uint
)
9991 Lo_Bound
:= No_Uint
;
9992 Hi_Bound
:= No_Uint
;
9994 -- Loop to climb ancestor subtypes and derived types
9998 if not Is_Discrete_Type
(ST1
) then
10002 Lo
:= Type_Low_Bound
(ST1
);
10003 Hi
:= Type_High_Bound
(ST1
);
10005 if Compile_Time_Known_Value
(Lo
) then
10006 Lo_Val
:= Expr_Value
(Lo
);
10008 if No
(Lo_Bound
) or else Lo_Bound
< Lo_Val
then
10009 Lo_Bound
:= Lo_Val
;
10013 if Compile_Time_Known_Value
(Hi
) then
10014 Hi_Val
:= Expr_Value
(Hi
);
10016 if No
(Hi_Bound
) or else Hi_Bound
> Hi_Val
then
10017 Hi_Bound
:= Hi_Val
;
10021 ST2
:= Ancestor_Subtype
(ST1
);
10024 ST2
:= Etype
(ST1
);
10027 exit when ST1
= ST2
;
10030 end Extract_Subtype_Bounds
;
10032 ----------------------------
10033 -- Simple_Init_Array_Type --
10034 ----------------------------
10036 function Simple_Init_Array_Type
return Node_Id
is
10037 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
10039 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
;
10040 -- Initialize a single array dimension with index constraint Index
10042 --------------------
10043 -- Simple_Init_Dimension --
10044 --------------------
10046 function Simple_Init_Dimension
(Index
: Node_Id
) return Node_Id
is
10048 -- Process the current dimension
10050 if Present
(Index
) then
10052 -- Build a suitable "others" aggregate for the next dimension,
10053 -- or initialize the component itself. Generate:
10058 Make_Aggregate
(Loc
,
10059 Component_Associations
=> New_List
(
10060 Make_Component_Association
(Loc
,
10061 Choices
=> New_List
(Make_Others_Choice
(Loc
)),
10063 Simple_Init_Dimension
(Next_Index
(Index
)))));
10065 -- Otherwise all dimensions have been processed. Initialize the
10066 -- component itself.
10070 Get_Simple_Init_Val
10073 Size
=> Esize
(Comp_Typ
));
10075 end Simple_Init_Dimension
;
10077 -- Start of processing for Simple_Init_Array_Type
10080 return Simple_Init_Dimension
(First_Index
(Typ
));
10081 end Simple_Init_Array_Type
;
10083 --------------------------------
10084 -- Simple_Init_Defaulted_Type --
10085 --------------------------------
10087 function Simple_Init_Defaulted_Type
return Node_Id
is
10088 Subtyp
: Entity_Id
:= First_Subtype
(Typ
);
10091 -- When the first subtype is private, retrieve the expression of the
10092 -- Default_Value from the underlying type.
10094 if Is_Private_Type
(Subtyp
) then
10095 Subtyp
:= Full_View
(Subtyp
);
10098 -- Use the Sloc of the context node when constructing the initial
10099 -- value because the expression of Default_Value may come from a
10100 -- different unit. Updating the Sloc will result in accurate error
10108 (Source
=> Default_Aspect_Value
(Subtyp
),
10110 end Simple_Init_Defaulted_Type
;
10112 -----------------------------------------
10113 -- Simple_Init_Initialize_Scalars_Type --
10114 -----------------------------------------
10116 function Simple_Init_Initialize_Scalars_Type
10117 (Size_To_Use
: Uint
) return Node_Id
10119 Float_Typ
: Entity_Id
;
10122 Scal_Typ
: Scalar_Id
;
10125 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
10129 if Is_Floating_Point_Type
(Typ
) then
10130 Float_Typ
:= Root_Type
(Typ
);
10132 if Float_Typ
= Standard_Short_Float
then
10133 Scal_Typ
:= Name_Short_Float
;
10134 elsif Float_Typ
= Standard_Float
then
10135 Scal_Typ
:= Name_Float
;
10136 elsif Float_Typ
= Standard_Long_Float
then
10137 Scal_Typ
:= Name_Long_Float
;
10138 else pragma Assert
(Float_Typ
= Standard_Long_Long_Float
);
10139 Scal_Typ
:= Name_Long_Long_Float
;
10142 -- If zero is invalid, it is a convenient value to use that is for
10143 -- sure an appropriate invalid value in all situations.
10145 elsif Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
10146 return Make_Integer_Literal
(Loc
, 0);
10150 elsif Is_Unsigned_Type
(Typ
) then
10151 if Size_To_Use
<= 8 then
10152 Scal_Typ
:= Name_Unsigned_8
;
10153 elsif Size_To_Use
<= 16 then
10154 Scal_Typ
:= Name_Unsigned_16
;
10155 elsif Size_To_Use
<= 32 then
10156 Scal_Typ
:= Name_Unsigned_32
;
10157 elsif Size_To_Use
<= 64 then
10158 Scal_Typ
:= Name_Unsigned_64
;
10160 Scal_Typ
:= Name_Unsigned_128
;
10166 if Size_To_Use
<= 8 then
10167 Scal_Typ
:= Name_Signed_8
;
10168 elsif Size_To_Use
<= 16 then
10169 Scal_Typ
:= Name_Signed_16
;
10170 elsif Size_To_Use
<= 32 then
10171 Scal_Typ
:= Name_Signed_32
;
10172 elsif Size_To_Use
<= 64 then
10173 Scal_Typ
:= Name_Signed_64
;
10175 Scal_Typ
:= Name_Signed_128
;
10179 -- Use the values specified by pragma Initialize_Scalars or the ones
10180 -- provided by the binder. Higher precedence is given to the pragma.
10182 return Invalid_Scalar_Value
(Loc
, Scal_Typ
);
10183 end Simple_Init_Initialize_Scalars_Type
;
10185 ----------------------------------------
10186 -- Simple_Init_Normalize_Scalars_Type --
10187 ----------------------------------------
10189 function Simple_Init_Normalize_Scalars_Type
10190 (Size_To_Use
: Uint
) return Node_Id
10192 Signed_Size
: constant Uint
:= UI_Min
(Uint_63
, Size_To_Use
- 1);
10199 Extract_Subtype_Bounds
(Lo_Bound
, Hi_Bound
);
10201 -- If zero is invalid, it is a convenient value to use that is for
10202 -- sure an appropriate invalid value in all situations.
10204 if Present
(Lo_Bound
) and then Lo_Bound
> Uint_0
then
10205 Expr
:= Make_Integer_Literal
(Loc
, 0);
10207 -- Cases where all one bits is the appropriate invalid value
10209 -- For modular types, all 1 bits is either invalid or valid. If it
10210 -- is valid, then there is nothing that can be done since there are
10211 -- no invalid values (we ruled out zero already).
10213 -- For signed integer types that have no negative values, either
10214 -- there is room for negative values, or there is not. If there
10215 -- is, then all 1-bits may be interpreted as minus one, which is
10216 -- certainly invalid. Alternatively it is treated as the largest
10217 -- positive value, in which case the observation for modular types
10220 -- For float types, all 1-bits is a NaN (not a number), which is
10221 -- certainly an appropriately invalid value.
10223 elsif Is_Enumeration_Type
(Typ
)
10224 or else Is_Floating_Point_Type
(Typ
)
10225 or else Is_Unsigned_Type
(Typ
)
10227 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Size_To_Use
- 1);
10229 -- Resolve as Long_Long_Long_Unsigned, because the largest number
10230 -- we can generate is out of range of universal integer.
10232 Analyze_And_Resolve
(Expr
, Standard_Long_Long_Long_Unsigned
);
10234 -- Case of signed types
10237 -- Normally we like to use the most negative number. The one
10238 -- exception is when this number is in the known subtype range and
10239 -- the largest positive number is not in the known subtype range.
10241 -- For this exceptional case, use largest positive value
10243 if Present
(Lo_Bound
) and then Present
(Hi_Bound
)
10244 and then Lo_Bound
<= (-(2 ** Signed_Size
))
10245 and then Hi_Bound
< 2 ** Signed_Size
10247 Expr
:= Make_Integer_Literal
(Loc
, 2 ** Signed_Size
- 1);
10249 -- Normal case of largest negative value
10252 Expr
:= Make_Integer_Literal
(Loc
, -(2 ** Signed_Size
));
10257 end Simple_Init_Normalize_Scalars_Type
;
10259 ------------------------------
10260 -- Simple_Init_Private_Type --
10261 ------------------------------
10263 function Simple_Init_Private_Type
return Node_Id
is
10264 Under_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
10268 -- The availability of the underlying view must be checked by routine
10269 -- Needs_Simple_Initialization.
10271 pragma Assert
(Present
(Under_Typ
));
10273 Expr
:= Get_Simple_Init_Val
(Under_Typ
, N
, Size
);
10275 -- If the initial value is null or an aggregate, qualify it with the
10276 -- underlying type in order to provide a proper context.
10278 if Nkind
(Expr
) in N_Aggregate | N_Null
then
10280 Make_Qualified_Expression
(Loc
,
10281 Subtype_Mark
=> New_Occurrence_Of
(Under_Typ
, Loc
),
10282 Expression
=> Expr
);
10285 Expr
:= Unchecked_Convert_To
(Typ
, Expr
);
10287 -- Do not truncate the result when scalar types are involved and
10288 -- Initialize/Normalize_Scalars is in effect.
10290 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
10291 and then Is_Scalar_Type
(Under_Typ
)
10293 Set_No_Truncation
(Expr
);
10297 end Simple_Init_Private_Type
;
10299 -----------------------------
10300 -- Simple_Init_Scalar_Type --
10301 -----------------------------
10303 function Simple_Init_Scalar_Type
return Node_Id
is
10305 Size_To_Use
: Uint
;
10308 pragma Assert
(Init_Or_Norm_Scalars
or IV_Attribute
);
10310 -- Determine the size of the object. This is either the size provided
10311 -- by the caller, or the Esize of the scalar type.
10313 if No
(Size
) or else Size
<= Uint_0
then
10314 Size_To_Use
:= UI_Max
(Uint_1
, Esize
(Typ
));
10316 Size_To_Use
:= Size
;
10319 -- The maximum size to use is System_Max_Integer_Size bits. This
10320 -- will create values of type Long_Long_Long_Unsigned and the range
10321 -- must fit this type.
10323 if Present
(Size_To_Use
)
10324 and then Size_To_Use
> System_Max_Integer_Size
10326 Size_To_Use
:= UI_From_Int
(System_Max_Integer_Size
);
10329 if Normalize_Scalars
and then not IV_Attribute
then
10330 Expr
:= Simple_Init_Normalize_Scalars_Type
(Size_To_Use
);
10332 Expr
:= Simple_Init_Initialize_Scalars_Type
(Size_To_Use
);
10335 -- The final expression is obtained by doing an unchecked conversion
10336 -- of this result to the base type of the required subtype. Use the
10337 -- base type to prevent the unchecked conversion from chopping bits,
10338 -- and then we set Kill_Range_Check to preserve the "bad" value.
10340 Expr
:= Unchecked_Convert_To
(Base_Type
(Typ
), Expr
);
10342 -- Ensure that the expression is not truncated since the "bad" bits
10343 -- are desired, and also kill the range checks.
10345 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
10346 Set_Kill_Range_Check
(Expr
);
10347 Set_No_Truncation
(Expr
);
10351 end Simple_Init_Scalar_Type
;
10353 -- Start of processing for Get_Simple_Init_Val
10356 if Is_Private_Type
(Typ
) then
10357 return Simple_Init_Private_Type
;
10359 elsif Is_Scalar_Type
(Typ
) then
10360 if Has_Default_Aspect
(Typ
) then
10361 return Simple_Init_Defaulted_Type
;
10363 return Simple_Init_Scalar_Type
;
10366 -- Array type with Initialize or Normalize_Scalars
10368 elsif Is_Array_Type
(Typ
) then
10369 pragma Assert
(Init_Or_Norm_Scalars
);
10370 return Simple_Init_Array_Type
;
10372 -- Access type is initialized to null
10374 elsif Is_Access_Type
(Typ
) then
10375 return Make_Null
(Loc
);
10377 -- No other possibilities should arise, since we should only be calling
10378 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
10379 -- indicating one of the above cases held.
10382 raise Program_Error
;
10386 when RE_Not_Available
=>
10388 end Get_Simple_Init_Val
;
10390 ------------------------------
10391 -- Has_New_Non_Standard_Rep --
10392 ------------------------------
10394 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
10396 if not Is_Derived_Type
(T
) then
10397 return Has_Non_Standard_Rep
(T
)
10398 or else Has_Non_Standard_Rep
(Root_Type
(T
));
10400 -- If Has_Non_Standard_Rep is not set on the derived type, the
10401 -- representation is fully inherited.
10403 elsif not Has_Non_Standard_Rep
(T
) then
10407 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
10409 -- May need a more precise check here: the First_Rep_Item may be a
10410 -- stream attribute, which does not affect the representation of the
10414 end Has_New_Non_Standard_Rep
;
10416 ----------------------
10417 -- Inline_Init_Proc --
10418 ----------------------
10420 function Inline_Init_Proc
(Typ
: Entity_Id
) return Boolean is
10422 -- The initialization proc of protected records is not worth inlining.
10423 -- In addition, when compiled for another unit for inlining purposes,
10424 -- it may make reference to entities that have not been elaborated yet.
10425 -- The initialization proc of records that need finalization contains
10426 -- a nested clean-up procedure that makes it impractical to inline as
10427 -- well, except for simple controlled types themselves. And similar
10428 -- considerations apply to task types.
10430 if Is_Concurrent_Type
(Typ
) then
10433 elsif Needs_Finalization
(Typ
) and then not Is_Controlled
(Typ
) then
10436 elsif Has_Task
(Typ
) then
10442 end Inline_Init_Proc
;
10448 function In_Runtime
(E
: Entity_Id
) return Boolean is
10453 while Scope
(S1
) /= Standard_Standard
loop
10457 return Is_RTU
(S1
, System
) or else Is_RTU
(S1
, Ada
);
10460 package body Initialization_Control
is
10462 ------------------------
10463 -- Requires_Late_Init --
10464 ------------------------
10466 function Requires_Late_Init
10468 Rec_Type
: Entity_Id
) return Boolean
10470 References_Current_Instance
: Boolean := False;
10471 Has_Access_Discriminant
: Boolean := False;
10472 Has_Internal_Call
: Boolean := False;
10474 function Find_Access_Discriminant
10475 (N
: Node_Id
) return Traverse_Result
;
10476 -- Look for a name denoting an access discriminant
10478 function Find_Current_Instance
10479 (N
: Node_Id
) return Traverse_Result
;
10480 -- Look for a reference to the current instance of the type
10482 function Find_Internal_Call
10483 (N
: Node_Id
) return Traverse_Result
;
10484 -- Look for an internal protected function call
10486 ------------------------------
10487 -- Find_Access_Discriminant --
10488 ------------------------------
10490 function Find_Access_Discriminant
10491 (N
: Node_Id
) return Traverse_Result
is
10493 if Is_Entity_Name
(N
)
10494 and then Denotes_Discriminant
(N
)
10495 and then Is_Access_Type
(Etype
(N
))
10497 Has_Access_Discriminant
:= True;
10502 end Find_Access_Discriminant
;
10504 ---------------------------
10505 -- Find_Current_Instance --
10506 ---------------------------
10508 function Find_Current_Instance
10509 (N
: Node_Id
) return Traverse_Result
is
10511 if Is_Entity_Name
(N
)
10512 and then Present
(Entity
(N
))
10513 and then Is_Current_Instance
(N
)
10515 References_Current_Instance
:= True;
10520 end Find_Current_Instance
;
10522 ------------------------
10523 -- Find_Internal_Call --
10524 ------------------------
10526 function Find_Internal_Call
(N
: Node_Id
) return Traverse_Result
is
10528 function Call_Scope
(N
: Node_Id
) return Entity_Id
;
10529 -- Return the scope enclosing a given call node N
10535 function Call_Scope
(N
: Node_Id
) return Entity_Id
is
10536 Nam
: constant Node_Id
:= Name
(N
);
10538 if Nkind
(Nam
) = N_Selected_Component
then
10539 return Scope
(Entity
(Prefix
(Nam
)));
10541 return Scope
(Entity
(Nam
));
10546 if Nkind
(N
) = N_Function_Call
10547 and then Call_Scope
(N
)
10548 = Corresponding_Concurrent_Type
(Rec_Type
)
10550 Has_Internal_Call
:= True;
10555 end Find_Internal_Call
;
10557 procedure Search_Access_Discriminant
is new
10558 Traverse_Proc
(Find_Access_Discriminant
);
10560 procedure Search_Current_Instance
is new
10561 Traverse_Proc
(Find_Current_Instance
);
10563 procedure Search_Internal_Call
is new
10564 Traverse_Proc
(Find_Internal_Call
);
10566 -- Start of processing for Requires_Late_Init
10569 -- A component of an object is said to require late initialization
10572 -- it has an access discriminant value constrained by a per-object
10575 if Has_Access_Constraint
(Defining_Identifier
(Decl
))
10576 and then No
(Expression
(Decl
))
10580 elsif Present
(Expression
(Decl
)) then
10582 -- it has an initialization expression that includes a name
10583 -- denoting an access discriminant;
10585 Search_Access_Discriminant
(Expression
(Decl
));
10587 if Has_Access_Discriminant
then
10591 -- or it has an initialization expression that includes a
10592 -- reference to the current instance of the type either by
10595 Search_Current_Instance
(Expression
(Decl
));
10597 if References_Current_Instance
then
10601 -- ...or implicitly as the target object of a call.
10603 if Is_Protected_Record_Type
(Rec_Type
) then
10604 Search_Internal_Call
(Expression
(Decl
));
10606 if Has_Internal_Call
then
10613 end Requires_Late_Init
;
10615 -----------------------------
10616 -- Has_Late_Init_Component --
10617 -----------------------------
10619 function Has_Late_Init_Component
10620 (Tagged_Rec_Type
: Entity_Id
) return Boolean
10622 Comp_Id
: Entity_Id
:=
10623 First_Component
(Implementation_Base_Type
(Tagged_Rec_Type
));
10625 while Present
(Comp_Id
) loop
10626 if Requires_Late_Init
(Decl
=> Parent
(Comp_Id
),
10627 Rec_Type
=> Tagged_Rec_Type
)
10629 return True; -- found a component that requires late init
10631 elsif Chars
(Comp_Id
) = Name_uParent
10632 and then Has_Late_Init_Component
(Etype
(Comp_Id
))
10634 return True; -- an ancestor type has a late init component
10637 Next_Component
(Comp_Id
);
10641 end Has_Late_Init_Component
;
10643 ------------------------
10644 -- Tag_Init_Condition --
10645 ------------------------
10647 function Tag_Init_Condition
10649 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10651 return Make_Op_Eq
(Loc
,
10652 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10653 Make_Mode_Literal
(Loc
, Full_Init
));
10654 end Tag_Init_Condition
;
10656 --------------------------
10657 -- Early_Init_Condition --
10658 --------------------------
10660 function Early_Init_Condition
10662 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10664 return Make_Op_Ne
(Loc
,
10665 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10666 Make_Mode_Literal
(Loc
, Late_Init_Only
));
10667 end Early_Init_Condition
;
10669 -------------------------
10670 -- Late_Init_Condition --
10671 -------------------------
10673 function Late_Init_Condition
10675 Init_Control_Formal
: Entity_Id
) return Node_Id
is
10677 return Make_Op_Ne
(Loc
,
10678 New_Occurrence_Of
(Init_Control_Formal
, Loc
),
10679 Make_Mode_Literal
(Loc
, Early_Init_Only
));
10680 end Late_Init_Condition
;
10682 end Initialization_Control
;
10684 ----------------------------
10685 -- Initialization_Warning --
10686 ----------------------------
10688 procedure Initialization_Warning
(E
: Entity_Id
) is
10689 Warning_Needed
: Boolean;
10692 Warning_Needed
:= False;
10694 if Ekind
(Current_Scope
) = E_Package
10695 and then Static_Elaboration_Desired
(Current_Scope
)
10697 if Is_Type
(E
) then
10698 if Is_Record_Type
(E
) then
10699 if Has_Discriminants
(E
)
10700 or else Is_Limited_Type
(E
)
10701 or else Has_Non_Standard_Rep
(E
)
10703 Warning_Needed
:= True;
10706 -- Verify that at least one component has an initialization
10707 -- expression. No need for a warning on a type if all its
10708 -- components have no initialization.
10714 Comp
:= First_Component
(E
);
10715 while Present
(Comp
) loop
10717 (Nkind
(Parent
(Comp
)) = N_Component_Declaration
);
10719 if Present
(Expression
(Parent
(Comp
))) then
10720 Warning_Needed
:= True;
10724 Next_Component
(Comp
);
10729 if Warning_Needed
then
10731 ("objects of the type cannot be initialized statically "
10732 & "by default??", Parent
(E
));
10737 Error_Msg_N
("object cannot be initialized statically??", E
);
10740 end Initialization_Warning
;
10746 function Init_Formals
(Typ
: Entity_Id
; Proc_Id
: Entity_Id
) return List_Id
10748 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
10749 Unc_Arr
: constant Boolean :=
10750 Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
);
10751 With_Prot
: constant Boolean :=
10752 Has_Protected
(Typ
)
10753 or else (Is_Record_Type
(Typ
)
10754 and then Is_Protected_Record_Type
(Typ
));
10755 With_Task
: constant Boolean :=
10756 not Global_No_Tasking
10759 or else (Is_Record_Type
(Typ
)
10760 and then Is_Task_Record_Type
(Typ
)));
10764 -- The first parameter is always _Init : [in] out Typ. Note that we need
10765 -- it to be in/out in the case of an unconstrained array, because of the
10766 -- need to have the bounds, and in the case of protected or task record
10767 -- value, because there are default record fields that may be referenced
10768 -- in the generated initialization routine.
10770 Formals
:= New_List
(
10771 Make_Parameter_Specification
(Loc
,
10772 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uInit
),
10773 In_Present
=> Unc_Arr
or else With_Prot
or else With_Task
,
10774 Out_Present
=> True,
10775 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
10777 -- For task record value, or type that contains tasks, add two more
10778 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
10779 -- We also add these parameters for the task record type case.
10782 Append_To
(Formals
,
10783 Make_Parameter_Specification
(Loc
,
10784 Defining_Identifier
=>
10785 Make_Defining_Identifier
(Loc
, Name_uMaster
),
10787 New_Occurrence_Of
(Standard_Integer
, Loc
)));
10789 Set_Has_Master_Entity
(Proc_Id
);
10791 -- Add _Chain (not done for sequential elaboration policy, see
10792 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
10794 if Partition_Elaboration_Policy
/= 'S' then
10795 Append_To
(Formals
,
10796 Make_Parameter_Specification
(Loc
,
10797 Defining_Identifier
=>
10798 Make_Defining_Identifier
(Loc
, Name_uChain
),
10799 In_Present
=> True,
10800 Out_Present
=> True,
10802 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
)));
10805 Append_To
(Formals
,
10806 Make_Parameter_Specification
(Loc
,
10807 Defining_Identifier
=>
10808 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
10809 In_Present
=> True,
10810 Parameter_Type
=> New_Occurrence_Of
(Standard_String
, Loc
)));
10813 -- Due to certain edge cases such as arrays with null-excluding
10814 -- components being built with the secondary stack it becomes necessary
10815 -- to add a formal to the Init_Proc which controls whether we raise
10816 -- Constraint_Errors on generated calls for internal object
10819 if Needs_Conditional_Null_Excluding_Check
(Typ
) then
10820 Append_To
(Formals
,
10821 Make_Parameter_Specification
(Loc
,
10822 Defining_Identifier
=>
10823 Make_Defining_Identifier
(Loc
,
10824 New_External_Name
(Chars
10825 (Component_Type
(Typ
)), "_skip_null_excluding_check")),
10826 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
10827 In_Present
=> True,
10829 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
10835 when RE_Not_Available
=>
10839 -------------------------
10840 -- Init_Secondary_Tags --
10841 -------------------------
10843 procedure Init_Secondary_Tags
10846 Init_Tags_List
: List_Id
;
10847 Stmts_List
: List_Id
;
10848 Fixed_Comps
: Boolean := True;
10849 Variable_Comps
: Boolean := True)
10851 Loc
: constant Source_Ptr
:= Sloc
(Target
);
10853 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
10854 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10856 procedure Initialize_Tag
10859 Tag_Comp
: Entity_Id
;
10860 Iface_Tag
: Node_Id
);
10861 -- Initialize the tag of the secondary dispatch table of Typ associated
10862 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10863 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
10864 -- of Typ CPP tagged type we generate code to inherit the contents of
10865 -- the dispatch table directly from the ancestor.
10867 --------------------
10868 -- Initialize_Tag --
10869 --------------------
10871 procedure Initialize_Tag
10874 Tag_Comp
: Entity_Id
;
10875 Iface_Tag
: Node_Id
)
10877 Comp_Typ
: Entity_Id
;
10878 Offset_To_Top_Comp
: Entity_Id
:= Empty
;
10881 -- Initialize pointer to secondary DT associated with the interface
10883 if not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
10884 Append_To
(Init_Tags_List
,
10885 Make_Assignment_Statement
(Loc
,
10887 Make_Selected_Component
(Loc
,
10888 Prefix
=> New_Copy_Tree
(Target
),
10889 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10891 New_Occurrence_Of
(Iface_Tag
, Loc
)));
10894 Comp_Typ
:= Scope
(Tag_Comp
);
10896 -- Initialize the entries of the table of interfaces. We generate a
10897 -- different call when the parent of the type has variable size
10900 if Comp_Typ
/= Etype
(Comp_Typ
)
10901 and then Is_Variable_Size_Record
(Etype
(Comp_Typ
))
10902 and then Chars
(Tag_Comp
) /= Name_uTag
10904 pragma Assert
(Present
(DT_Offset_To_Top_Func
(Tag_Comp
)));
10906 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
10907 -- configurable run-time environment.
10909 if not RTE_Available
(RE_Set_Dynamic_Offset_To_Top
) then
10911 ("variable size record with interface types", Typ
);
10916 -- Set_Dynamic_Offset_To_Top
10918 -- Prim_T => Typ'Tag,
10919 -- Interface_T => Iface'Tag,
10920 -- Offset_Value => n,
10921 -- Offset_Func => Fn'Unrestricted_Access)
10923 Append_To
(Stmts_List
,
10924 Make_Procedure_Call_Statement
(Loc
,
10926 New_Occurrence_Of
(RTE
(RE_Set_Dynamic_Offset_To_Top
), Loc
),
10927 Parameter_Associations
=> New_List
(
10928 Make_Attribute_Reference
(Loc
,
10929 Prefix
=> New_Copy_Tree
(Target
),
10930 Attribute_Name
=> Name_Address
),
10932 Unchecked_Convert_To
(RTE
(RE_Tag
),
10934 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
10936 Unchecked_Convert_To
(RTE
(RE_Tag
),
10938 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
10941 Unchecked_Convert_To
10942 (RTE
(RE_Storage_Offset
),
10943 Make_Op_Minus
(Loc
,
10944 Make_Attribute_Reference
(Loc
,
10946 Make_Selected_Component
(Loc
,
10947 Prefix
=> New_Copy_Tree
(Target
),
10949 New_Occurrence_Of
(Tag_Comp
, Loc
)),
10950 Attribute_Name
=> Name_Position
))),
10952 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Function_Ptr
),
10953 Make_Attribute_Reference
(Loc
,
10954 Prefix
=> New_Occurrence_Of
10955 (DT_Offset_To_Top_Func
(Tag_Comp
), Loc
),
10956 Attribute_Name
=> Name_Unrestricted_Access
)))));
10958 -- In this case the next component stores the value of the offset
10961 Offset_To_Top_Comp
:= Next_Entity
(Tag_Comp
);
10962 pragma Assert
(Present
(Offset_To_Top_Comp
));
10964 Append_To
(Init_Tags_List
,
10965 Make_Assignment_Statement
(Loc
,
10967 Make_Selected_Component
(Loc
,
10968 Prefix
=> New_Copy_Tree
(Target
),
10970 New_Occurrence_Of
(Offset_To_Top_Comp
, Loc
)),
10973 Make_Op_Minus
(Loc
,
10974 Make_Attribute_Reference
(Loc
,
10976 Make_Selected_Component
(Loc
,
10977 Prefix
=> New_Copy_Tree
(Target
),
10978 Selector_Name
=> New_Occurrence_Of
(Tag_Comp
, Loc
)),
10979 Attribute_Name
=> Name_Position
))));
10981 -- Normal case: No discriminants in the parent type
10984 -- Don't need to set any value if the offset-to-top field is
10985 -- statically set or if this interface shares the primary
10988 if not Building_Static_Secondary_DT
(Typ
)
10989 and then not Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True)
10991 Append_To
(Stmts_List
,
10992 Build_Set_Static_Offset_To_Top
(Loc
,
10993 Iface_Tag
=> New_Occurrence_Of
(Iface_Tag
, Loc
),
10995 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
10996 Make_Op_Minus
(Loc
,
10997 Make_Attribute_Reference
(Loc
,
10999 Make_Selected_Component
(Loc
,
11000 Prefix
=> New_Copy_Tree
(Target
),
11002 New_Occurrence_Of
(Tag_Comp
, Loc
)),
11003 Attribute_Name
=> Name_Position
)))));
11007 -- Register_Interface_Offset
11008 -- (Prim_T => Typ'Tag,
11009 -- Interface_T => Iface'Tag,
11010 -- Is_Constant => True,
11011 -- Offset_Value => n,
11012 -- Offset_Func => null);
11014 if not Building_Static_Secondary_DT
(Typ
)
11015 and then RTE_Available
(RE_Register_Interface_Offset
)
11017 Append_To
(Stmts_List
,
11018 Make_Procedure_Call_Statement
(Loc
,
11021 (RTE
(RE_Register_Interface_Offset
), Loc
),
11022 Parameter_Associations
=> New_List
(
11023 Unchecked_Convert_To
(RTE
(RE_Tag
),
11025 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)),
11027 Unchecked_Convert_To
(RTE
(RE_Tag
),
11029 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))), Loc
)),
11031 New_Occurrence_Of
(Standard_True
, Loc
),
11033 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
11034 Make_Op_Minus
(Loc
,
11035 Make_Attribute_Reference
(Loc
,
11037 Make_Selected_Component
(Loc
,
11038 Prefix
=> New_Copy_Tree
(Target
),
11040 New_Occurrence_Of
(Tag_Comp
, Loc
)),
11041 Attribute_Name
=> Name_Position
))),
11043 Make_Null
(Loc
))));
11046 end Initialize_Tag
;
11050 Full_Typ
: Entity_Id
;
11051 Ifaces_List
: Elist_Id
;
11052 Ifaces_Comp_List
: Elist_Id
;
11053 Ifaces_Tag_List
: Elist_Id
;
11054 Iface_Elmt
: Elmt_Id
;
11055 Iface_Comp_Elmt
: Elmt_Id
;
11056 Iface_Tag_Elmt
: Elmt_Id
;
11057 Tag_Comp
: Node_Id
;
11058 In_Variable_Pos
: Boolean;
11060 -- Start of processing for Init_Secondary_Tags
11063 -- Handle private types
11065 if Present
(Full_View
(Typ
)) then
11066 Full_Typ
:= Full_View
(Typ
);
11071 Collect_Interfaces_Info
11072 (Full_Typ
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
11074 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
11075 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
11076 Iface_Tag_Elmt
:= First_Elmt
(Ifaces_Tag_List
);
11077 while Present
(Iface_Elmt
) loop
11078 Tag_Comp
:= Node
(Iface_Comp_Elmt
);
11080 -- Check if parent of record type has variable size components
11082 In_Variable_Pos
:= Scope
(Tag_Comp
) /= Etype
(Scope
(Tag_Comp
))
11083 and then Is_Variable_Size_Record
(Etype
(Scope
(Tag_Comp
)));
11085 -- If we are compiling under the CPP full ABI compatibility mode and
11086 -- the ancestor is a CPP_Pragma tagged type then we generate code to
11087 -- initialize the secondary tag components from tags that reference
11088 -- secondary tables filled with copy of parent slots.
11090 if Is_CPP_Class
(Root_Type
(Full_Typ
)) then
11092 -- Reject interface components located at variable offset in
11093 -- C++ derivations. This is currently unsupported.
11095 if not Fixed_Comps
and then In_Variable_Pos
then
11097 -- Locate the first dynamic component of the record. Done to
11098 -- improve the text of the warning.
11102 Comp_Typ
: Entity_Id
;
11105 Comp
:= First_Entity
(Typ
);
11106 while Present
(Comp
) loop
11107 Comp_Typ
:= Etype
(Comp
);
11109 if Ekind
(Comp
) /= E_Discriminant
11110 and then not Is_Tag
(Comp
)
11113 (Is_Record_Type
(Comp_Typ
)
11115 Is_Variable_Size_Record
(Base_Type
(Comp_Typ
)))
11117 (Is_Array_Type
(Comp_Typ
)
11118 and then Is_Variable_Size_Array
(Comp_Typ
));
11121 Next_Entity
(Comp
);
11124 pragma Assert
(Present
(Comp
));
11126 -- Move this check to sem???
11127 Error_Msg_Node_2
:= Comp
;
11129 ("parent type & with dynamic component & cannot be parent"
11130 & " of 'C'P'P derivation if new interfaces are present",
11131 Typ
, Scope
(Original_Record_Component
(Comp
)));
11134 Sloc
(Scope
(Original_Record_Component
(Comp
)));
11136 ("type derived from 'C'P'P type & defined #",
11137 Typ
, Scope
(Original_Record_Component
(Comp
)));
11139 -- Avoid duplicated warnings
11144 -- Initialize secondary tags
11149 Iface
=> Node
(Iface_Elmt
),
11150 Tag_Comp
=> Tag_Comp
,
11151 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
11154 -- Otherwise generate code to initialize the tag
11157 if (In_Variable_Pos
and then Variable_Comps
)
11158 or else (not In_Variable_Pos
and then Fixed_Comps
)
11162 Iface
=> Node
(Iface_Elmt
),
11163 Tag_Comp
=> Tag_Comp
,
11164 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
11168 Next_Elmt
(Iface_Elmt
);
11169 Next_Elmt
(Iface_Comp_Elmt
);
11170 Next_Elmt
(Iface_Tag_Elmt
);
11172 end Init_Secondary_Tags
;
11174 ----------------------------
11175 -- Is_Null_Statement_List --
11176 ----------------------------
11178 function Is_Null_Statement_List
(Stmts
: List_Id
) return Boolean is
11182 -- We must skip SCIL nodes because they may have been added to the list
11183 -- by Insert_Actions.
11185 Stmt
:= First_Non_SCIL_Node
(Stmts
);
11186 while Present
(Stmt
) loop
11187 if Nkind
(Stmt
) = N_Case_Statement
then
11191 Alt
:= First
(Alternatives
(Stmt
));
11192 while Present
(Alt
) loop
11193 if not Is_Null_Statement_List
(Statements
(Alt
)) then
11201 elsif Nkind
(Stmt
) /= N_Null_Statement
then
11205 Stmt
:= Next_Non_SCIL_Node
(Stmt
);
11209 end Is_Null_Statement_List
;
11211 ----------------------------------------
11212 -- Make_Controlling_Function_Wrappers --
11213 ----------------------------------------
11215 procedure Make_Controlling_Function_Wrappers
11216 (Tag_Typ
: Entity_Id
;
11217 Decl_List
: out List_Id
;
11218 Body_List
: out List_Id
)
11220 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11222 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
;
11223 -- Returns a function specification with the same profile as Subp
11225 --------------------------------
11226 -- Make_Wrapper_Specification --
11227 --------------------------------
11229 function Make_Wrapper_Specification
(Subp
: Entity_Id
) return Node_Id
is
11232 Make_Function_Specification
(Loc
,
11233 Defining_Unit_Name
=>
11234 Make_Defining_Identifier
(Loc
,
11235 Chars
=> Chars
(Subp
)),
11236 Parameter_Specifications
=>
11237 Copy_Parameter_List
(Subp
),
11238 Result_Definition
=>
11239 New_Occurrence_Of
(Etype
(Subp
), Loc
));
11240 end Make_Wrapper_Specification
;
11242 Prim_Elmt
: Elmt_Id
;
11244 Actual_List
: List_Id
;
11245 Formal
: Entity_Id
;
11246 Par_Formal
: Entity_Id
;
11247 Ext_Aggr
: Node_Id
;
11248 Formal_Node
: Node_Id
;
11249 Func_Body
: Node_Id
;
11250 Func_Decl
: Node_Id
;
11251 Func_Id
: Entity_Id
;
11253 -- Start of processing for Make_Controlling_Function_Wrappers
11256 Decl_List
:= New_List
;
11257 Body_List
:= New_List
;
11259 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11260 while Present
(Prim_Elmt
) loop
11261 Subp
:= Node
(Prim_Elmt
);
11263 -- If a primitive function with a controlling result of the type has
11264 -- not been overridden by the user, then we must create a wrapper
11265 -- function here that effectively overrides it and invokes the
11266 -- (non-abstract) parent function. This can only occur for a null
11267 -- extension. Note that functions with anonymous controlling access
11268 -- results don't qualify and must be overridden. We also exclude
11269 -- Input attributes, since each type will have its own version of
11270 -- Input constructed by the expander. The test for Comes_From_Source
11271 -- is needed to distinguish inherited operations from renamings
11272 -- (which also have Alias set). We exclude internal entities with
11273 -- Interface_Alias to avoid generating duplicated wrappers since
11274 -- the primitive which covers the interface is also available in
11275 -- the list of primitive operations.
11277 -- The function may be abstract, or require_Overriding may be set
11278 -- for it, because tests for null extensions may already have reset
11279 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
11280 -- set, functions that need wrappers are recognized by having an
11281 -- alias that returns the parent type.
11283 if Comes_From_Source
(Subp
)
11284 or else No
(Alias
(Subp
))
11285 or else Present
(Interface_Alias
(Subp
))
11286 or else Ekind
(Subp
) /= E_Function
11287 or else not Has_Controlling_Result
(Subp
)
11288 or else Is_Access_Type
(Etype
(Subp
))
11289 or else Is_Abstract_Subprogram
(Alias
(Subp
))
11290 or else Is_TSS
(Subp
, TSS_Stream_Input
)
11294 elsif Is_Abstract_Subprogram
(Subp
)
11295 or else Requires_Overriding
(Subp
)
11297 (Is_Null_Extension
(Etype
(Subp
))
11298 and then Etype
(Alias
(Subp
)) /= Etype
(Subp
))
11300 -- If there is a non-overloadable homonym in the current
11301 -- scope, the implicit declaration remains invisible.
11302 -- We check the current entity with the same name, or its
11303 -- homonym in case the derivation takes place after the
11304 -- hiding object declaration.
11306 if Present
(Current_Entity
(Subp
)) then
11308 Curr
: constant Entity_Id
:= Current_Entity
(Subp
);
11309 Prev
: constant Entity_Id
:= Homonym
(Curr
);
11311 if (Comes_From_Source
(Curr
)
11312 and then Scope
(Curr
) = Current_Scope
11313 and then not Is_Overloadable
(Curr
))
11316 and then Comes_From_Source
(Prev
)
11317 and then Scope
(Prev
) = Current_Scope
11318 and then not Is_Overloadable
(Prev
))
11326 Make_Subprogram_Declaration
(Loc
,
11327 Specification
=> Make_Wrapper_Specification
(Subp
));
11329 Append_To
(Decl_List
, Func_Decl
);
11331 -- Build a wrapper body that calls the parent function. The body
11332 -- contains a single return statement that returns an extension
11333 -- aggregate whose ancestor part is a call to the parent function,
11334 -- passing the formals as actuals (with any controlling arguments
11335 -- converted to the types of the corresponding formals of the
11336 -- parent function, which might be anonymous access types), and
11337 -- having a null extension.
11339 Formal
:= First_Formal
(Subp
);
11340 Par_Formal
:= First_Formal
(Alias
(Subp
));
11342 First
(Parameter_Specifications
(Specification
(Func_Decl
)));
11344 if Present
(Formal
) then
11345 Actual_List
:= New_List
;
11347 while Present
(Formal
) loop
11348 if Is_Controlling_Formal
(Formal
) then
11349 Append_To
(Actual_List
,
11350 Make_Type_Conversion
(Loc
,
11352 New_Occurrence_Of
(Etype
(Par_Formal
), Loc
),
11355 (Defining_Identifier
(Formal_Node
), Loc
)));
11360 (Defining_Identifier
(Formal_Node
), Loc
));
11363 Next_Formal
(Formal
);
11364 Next_Formal
(Par_Formal
);
11365 Next
(Formal_Node
);
11368 Actual_List
:= No_List
;
11372 Make_Extension_Aggregate
(Loc
,
11374 Make_Function_Call
(Loc
,
11376 New_Occurrence_Of
(Alias
(Subp
), Loc
),
11377 Parameter_Associations
=> Actual_List
),
11378 Null_Record_Present
=> True);
11380 -- GNATprove will use expression of an expression function as an
11381 -- implicit postcondition. GNAT will also benefit from expression
11382 -- function to avoid premature freezing, but would struggle if we
11383 -- added an expression function to freezing actions, so we create
11384 -- the expanded form directly.
11386 if GNATprove_Mode
then
11388 Make_Expression_Function
(Loc
,
11390 Make_Wrapper_Specification
(Subp
),
11391 Expression
=> Ext_Aggr
);
11394 Make_Subprogram_Body
(Loc
,
11396 Make_Wrapper_Specification
(Subp
),
11397 Declarations
=> Empty_List
,
11398 Handled_Statement_Sequence
=>
11399 Make_Handled_Sequence_Of_Statements
(Loc
,
11400 Statements
=> New_List
(
11401 Make_Simple_Return_Statement
(Loc
,
11402 Expression
=> Ext_Aggr
))));
11403 Set_Was_Expression_Function
(Func_Body
);
11406 Append_To
(Body_List
, Func_Body
);
11408 -- Replace the inherited function with the wrapper function in the
11409 -- primitive operations list. We add the minimum decoration needed
11410 -- to override interface primitives.
11412 Func_Id
:= Defining_Unit_Name
(Specification
(Func_Decl
));
11414 Mutate_Ekind
(Func_Id
, E_Function
);
11415 Set_Is_Wrapper
(Func_Id
);
11417 -- Corresponding_Spec will be set again to the same value during
11418 -- analysis, but we need this information earlier.
11419 -- Expand_N_Freeze_Entity needs to know whether a subprogram body
11420 -- is a wrapper's body in order to get check suppression right.
11422 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
11426 Next_Elmt
(Prim_Elmt
);
11428 end Make_Controlling_Function_Wrappers
;
11434 function Make_Eq_Body
11436 Eq_Name
: Name_Id
) return Node_Id
11438 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Typ
));
11440 Def
: constant Node_Id
:= Parent
(Typ
);
11441 Stmts
: constant List_Id
:= New_List
;
11442 Variant_Case
: Boolean := Has_Discriminants
(Typ
);
11443 Comps
: Node_Id
:= Empty
;
11444 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
11448 Predef_Spec_Or_Body
(Loc
,
11451 Profile
=> New_List
(
11452 Make_Parameter_Specification
(Loc
,
11453 Defining_Identifier
=>
11454 Make_Defining_Identifier
(Loc
, Name_X
),
11455 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
11457 Make_Parameter_Specification
(Loc
,
11458 Defining_Identifier
=>
11459 Make_Defining_Identifier
(Loc
, Name_Y
),
11460 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
11462 Ret_Type
=> Standard_Boolean
,
11465 if Variant_Case
then
11466 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
11467 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
11470 if Present
(Typ_Def
) then
11471 Comps
:= Component_List
(Typ_Def
);
11475 Present
(Comps
) and then Present
(Variant_Part
(Comps
));
11478 if Variant_Case
then
11480 Make_Eq_If
(Typ
, Discriminant_Specifications
(Def
)));
11481 Append_List_To
(Stmts
, Make_Eq_Case
(Typ
, Comps
));
11483 Make_Simple_Return_Statement
(Loc
,
11484 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11488 Make_Simple_Return_Statement
(Loc
,
11490 Expand_Record_Equality
11493 Lhs
=> Make_Identifier
(Loc
, Name_X
),
11494 Rhs
=> Make_Identifier
(Loc
, Name_Y
))));
11497 Set_Handled_Statement_Sequence
11498 (Decl
, Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
11506 -- <Make_Eq_If shared components>
11509 -- when V1 => <Make_Eq_Case> on subcomponents
11511 -- when Vn => <Make_Eq_Case> on subcomponents
11514 function Make_Eq_Case
11517 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
11519 Loc
: constant Source_Ptr
:= Sloc
(E
);
11520 Result
: constant List_Id
:= New_List
;
11522 Alt_List
: List_Id
;
11524 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
;
11525 -- Given the discriminant that controls a given variant of an unchecked
11526 -- union, find the formal of the equality function that carries the
11527 -- inferred value of the discriminant.
11529 function External_Name
(E
: Entity_Id
) return Name_Id
;
11530 -- The value of a given discriminant is conveyed in the corresponding
11531 -- formal parameter of the equality routine. The name of this formal
11532 -- parameter carries a one-character suffix which is removed here.
11534 --------------------------
11535 -- Corresponding_Formal --
11536 --------------------------
11538 function Corresponding_Formal
(C
: Node_Id
) return Entity_Id
is
11539 Discr
: constant Entity_Id
:= Entity
(Name
(Variant_Part
(C
)));
11543 Elm
:= First_Elmt
(Discrs
);
11544 while Present
(Elm
) loop
11545 if Chars
(Discr
) = External_Name
(Node
(Elm
)) then
11552 -- A formal of the proper name must be found
11554 raise Program_Error
;
11555 end Corresponding_Formal
;
11557 -------------------
11558 -- External_Name --
11559 -------------------
11561 function External_Name
(E
: Entity_Id
) return Name_Id
is
11563 Get_Name_String
(Chars
(E
));
11564 Name_Len
:= Name_Len
- 1;
11568 -- Start of processing for Make_Eq_Case
11571 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
11573 if No
(Variant_Part
(CL
)) then
11577 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
11579 if No
(Variant
) then
11583 Alt_List
:= New_List
;
11584 while Present
(Variant
) loop
11585 Append_To
(Alt_List
,
11586 Make_Case_Statement_Alternative
(Loc
,
11587 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
11589 Make_Eq_Case
(E
, Component_List
(Variant
), Discrs
)));
11590 Next_Non_Pragma
(Variant
);
11593 -- If we have an Unchecked_Union, use one of the parameters of the
11594 -- enclosing equality routine that captures the discriminant, to use
11595 -- as the expression in the generated case statement.
11597 if Is_Unchecked_Union
(E
) then
11599 Make_Case_Statement
(Loc
,
11601 New_Occurrence_Of
(Corresponding_Formal
(CL
), Loc
),
11602 Alternatives
=> Alt_List
));
11606 Make_Case_Statement
(Loc
,
11608 Make_Selected_Component
(Loc
,
11609 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11610 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
11611 Alternatives
=> Alt_List
));
11632 -- or a null statement if the list L is empty
11634 -- Equality may be user-defined for a given component type, in which case
11635 -- a function call is constructed instead of an operator node. This is an
11636 -- Ada 2012 change in the composability of equality for untagged composite
11639 function Make_Eq_If
11641 L
: List_Id
) return Node_Id
11643 Loc
: constant Source_Ptr
:= Sloc
(E
);
11647 Field_Name
: Name_Id
;
11648 Next_Test
: Node_Id
;
11653 return Make_Null_Statement
(Loc
);
11658 C
:= First_Non_Pragma
(L
);
11659 while Present
(C
) loop
11660 Typ
:= Etype
(Defining_Identifier
(C
));
11661 Field_Name
:= Chars
(Defining_Identifier
(C
));
11663 -- The tags must not be compared: they are not part of the value.
11664 -- Ditto for parent interfaces because their equality operator is
11667 -- Note also that in the following, we use Make_Identifier for
11668 -- the component names. Use of New_Occurrence_Of to identify the
11669 -- components would be incorrect because the wrong entities for
11670 -- discriminants could be picked up in the private type case.
11672 if Field_Name
= Name_uParent
11673 and then Is_Interface
(Typ
)
11677 elsif Field_Name
/= Name_uTag
then
11679 Lhs
: constant Node_Id
:=
11680 Make_Selected_Component
(Loc
,
11681 Prefix
=> Make_Identifier
(Loc
, Name_X
),
11682 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11684 Rhs
: constant Node_Id
:=
11685 Make_Selected_Component
(Loc
,
11686 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
11687 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
));
11691 -- Build equality code with a user-defined operator, if
11692 -- available, and with the predefined "=" otherwise. For
11693 -- compatibility with older Ada versions, we also use the
11694 -- predefined operation if the component-type equality is
11695 -- abstract, rather than raising Program_Error.
11697 if Ada_Version
< Ada_2012
then
11698 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11701 Eq_Call
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
11703 if No
(Eq_Call
) then
11704 Next_Test
:= Make_Op_Ne
(Loc
, Lhs
, Rhs
);
11706 -- If a component has a defined abstract equality, its
11707 -- application raises Program_Error on that component
11708 -- and therefore on the current variant.
11710 elsif Nkind
(Eq_Call
) = N_Raise_Program_Error
then
11711 Set_Etype
(Eq_Call
, Standard_Boolean
);
11712 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11715 Next_Test
:= Make_Op_Not
(Loc
, Eq_Call
);
11720 Evolve_Or_Else
(Cond
, Next_Test
);
11723 Next_Non_Pragma
(C
);
11727 return Make_Null_Statement
(Loc
);
11731 Make_Implicit_If_Statement
(E
,
11733 Then_Statements
=> New_List
(
11734 Make_Simple_Return_Statement
(Loc
,
11735 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
11740 -------------------
11741 -- Make_Neq_Body --
11742 -------------------
11744 function Make_Neq_Body
(Tag_Typ
: Entity_Id
) return Node_Id
is
11746 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean;
11747 -- Returns true if Prim is a renaming of an unresolved predefined
11748 -- inequality operation.
11750 --------------------------------
11751 -- Is_Predefined_Neq_Renaming --
11752 --------------------------------
11754 function Is_Predefined_Neq_Renaming
(Prim
: Node_Id
) return Boolean is
11756 return Chars
(Prim
) /= Name_Op_Ne
11757 and then Present
(Alias
(Prim
))
11758 and then Comes_From_Source
(Prim
)
11759 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
11760 and then Chars
(Alias
(Prim
)) = Name_Op_Ne
;
11761 end Is_Predefined_Neq_Renaming
;
11765 Loc
: constant Source_Ptr
:= Sloc
(Parent
(Tag_Typ
));
11767 Eq_Prim
: Entity_Id
;
11768 Left_Op
: Entity_Id
;
11769 Renaming_Prim
: Entity_Id
;
11770 Right_Op
: Entity_Id
;
11771 Target
: Entity_Id
;
11773 -- Start of processing for Make_Neq_Body
11776 -- For a call on a renaming of a dispatching subprogram that is
11777 -- overridden, if the overriding occurred before the renaming, then
11778 -- the body executed is that of the overriding declaration, even if the
11779 -- overriding declaration is not visible at the place of the renaming;
11780 -- otherwise, the inherited or predefined subprogram is called, see
11783 -- Stage 1: Search for a renaming of the inequality primitive and also
11784 -- search for an overriding of the equality primitive located before the
11785 -- renaming declaration.
11793 Renaming_Prim
:= Empty
;
11795 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11796 while Present
(Elmt
) loop
11797 Prim
:= Node
(Elmt
);
11799 if Is_User_Defined_Equality
(Prim
) and then No
(Alias
(Prim
)) then
11800 if No
(Renaming_Prim
) then
11801 pragma Assert
(No
(Eq_Prim
));
11805 elsif Is_Predefined_Neq_Renaming
(Prim
) then
11806 Renaming_Prim
:= Prim
;
11813 -- No further action needed if no renaming was found
11815 if No
(Renaming_Prim
) then
11819 -- Stage 2: Replace the renaming declaration by a subprogram declaration
11820 -- (required to add its body)
11822 Decl
:= Parent
(Parent
(Renaming_Prim
));
11824 Make_Subprogram_Declaration
(Loc
,
11825 Specification
=> Specification
(Decl
)));
11826 Set_Analyzed
(Decl
);
11828 -- Remove the decoration of intrinsic renaming subprogram
11830 Set_Is_Intrinsic_Subprogram
(Renaming_Prim
, False);
11831 Set_Convention
(Renaming_Prim
, Convention_Ada
);
11832 Set_Alias
(Renaming_Prim
, Empty
);
11833 Set_Has_Completion
(Renaming_Prim
, False);
11835 -- Stage 3: Build the corresponding body
11837 Left_Op
:= First_Formal
(Renaming_Prim
);
11838 Right_Op
:= Next_Formal
(Left_Op
);
11841 Predef_Spec_Or_Body
(Loc
,
11842 Tag_Typ
=> Tag_Typ
,
11843 Name
=> Chars
(Renaming_Prim
),
11844 Profile
=> New_List
(
11845 Make_Parameter_Specification
(Loc
,
11846 Defining_Identifier
=>
11847 Make_Defining_Identifier
(Loc
, Chars
(Left_Op
)),
11848 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
11850 Make_Parameter_Specification
(Loc
,
11851 Defining_Identifier
=>
11852 Make_Defining_Identifier
(Loc
, Chars
(Right_Op
)),
11853 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
11855 Ret_Type
=> Standard_Boolean
,
11858 -- If the overriding of the equality primitive occurred before the
11859 -- renaming, then generate:
11861 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11863 -- return not Oeq (X, Y);
11866 if Present
(Eq_Prim
) then
11869 -- Otherwise build a nested subprogram which performs the predefined
11870 -- evaluation of the equality operator. That is, generate:
11872 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11873 -- function Oeq (X : Y) return Boolean is
11875 -- <<body of default implementation>>
11878 -- return not Oeq (X, Y);
11883 Local_Subp
: Node_Id
;
11885 Local_Subp
:= Make_Eq_Body
(Tag_Typ
, Name_Op_Eq
);
11886 Set_Declarations
(Decl
, New_List
(Local_Subp
));
11887 Target
:= Defining_Entity
(Local_Subp
);
11891 Set_Handled_Statement_Sequence
11893 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
11894 Make_Simple_Return_Statement
(Loc
,
11897 Make_Function_Call
(Loc
,
11898 Name
=> New_Occurrence_Of
(Target
, Loc
),
11899 Parameter_Associations
=> New_List
(
11900 Make_Identifier
(Loc
, Chars
(Left_Op
)),
11901 Make_Identifier
(Loc
, Chars
(Right_Op
)))))))));
11906 -------------------------------
11907 -- Make_Null_Procedure_Specs --
11908 -------------------------------
11910 function Make_Null_Procedure_Specs
(Tag_Typ
: Entity_Id
) return List_Id
is
11911 Decl_List
: constant List_Id
:= New_List
;
11912 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
11913 Formal
: Entity_Id
;
11914 New_Param_Spec
: Node_Id
;
11915 New_Spec
: Node_Id
;
11916 Parent_Subp
: Entity_Id
;
11917 Prim_Elmt
: Elmt_Id
;
11921 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
11922 while Present
(Prim_Elmt
) loop
11923 Subp
:= Node
(Prim_Elmt
);
11925 -- If a null procedure inherited from an interface has not been
11926 -- overridden, then we build a null procedure declaration to
11927 -- override the inherited procedure.
11929 Parent_Subp
:= Alias
(Subp
);
11931 if Present
(Parent_Subp
)
11932 and then Is_Null_Interface_Primitive
(Parent_Subp
)
11934 -- The null procedure spec is copied from the inherited procedure,
11935 -- except for the IS NULL (which must be added) and the overriding
11936 -- indicators (which must be removed, if present).
11939 Copy_Subprogram_Spec
(Subprogram_Specification
(Subp
), Loc
);
11941 Set_Null_Present
(New_Spec
, True);
11942 Set_Must_Override
(New_Spec
, False);
11943 Set_Must_Not_Override
(New_Spec
, False);
11945 Formal
:= First_Formal
(Subp
);
11946 New_Param_Spec
:= First
(Parameter_Specifications
(New_Spec
));
11948 while Present
(Formal
) loop
11950 -- For controlling arguments we must change their parameter
11951 -- type to reference the tagged type (instead of the interface
11954 if Is_Controlling_Formal
(Formal
) then
11955 if Nkind
(Parameter_Type
(Parent
(Formal
))) = N_Identifier
11957 Set_Parameter_Type
(New_Param_Spec
,
11958 New_Occurrence_Of
(Tag_Typ
, Loc
));
11961 (Nkind
(Parameter_Type
(Parent
(Formal
))) =
11962 N_Access_Definition
);
11963 Set_Subtype_Mark
(Parameter_Type
(New_Param_Spec
),
11964 New_Occurrence_Of
(Tag_Typ
, Loc
));
11968 Next_Formal
(Formal
);
11969 Next
(New_Param_Spec
);
11972 Append_To
(Decl_List
,
11973 Make_Subprogram_Declaration
(Loc
,
11974 Specification
=> New_Spec
));
11977 Next_Elmt
(Prim_Elmt
);
11981 end Make_Null_Procedure_Specs
;
11983 ---------------------------------------
11984 -- Make_Predefined_Primitive_Eq_Spec --
11985 ---------------------------------------
11987 procedure Make_Predefined_Primitive_Eq_Spec
11988 (Tag_Typ
: Entity_Id
;
11989 Predef_List
: List_Id
;
11990 Renamed_Eq
: out Entity_Id
)
11992 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
11993 -- Returns true if Prim is a renaming of an unresolved predefined
11994 -- equality operation.
11996 -------------------------------
11997 -- Is_Predefined_Eq_Renaming --
11998 -------------------------------
12000 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
12002 return Chars
(Prim
) /= Name_Op_Eq
12003 and then Present
(Alias
(Prim
))
12004 and then Comes_From_Source
(Prim
)
12005 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
12006 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
12007 end Is_Predefined_Eq_Renaming
;
12011 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12013 Eq_Name
: Name_Id
:= Name_Op_Eq
;
12014 Eq_Needed
: Boolean := True;
12018 Has_Predef_Eq_Renaming
: Boolean := False;
12019 -- Set to True if Tag_Typ has a primitive that renames the predefined
12020 -- equality operator. Used to implement (RM 8-5-4(8)).
12022 -- Start of processing for Make_Predefined_Primitive_Specs
12025 Renamed_Eq
:= Empty
;
12027 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12028 while Present
(Prim
) loop
12030 -- If a primitive is encountered that renames the predefined equality
12031 -- operator before reaching any explicit equality primitive, then we
12032 -- still need to create a predefined equality function, because calls
12033 -- to it can occur via the renaming. A new name is created for the
12034 -- equality to avoid conflicting with any user-defined equality.
12035 -- (Note that this doesn't account for renamings of equality nested
12036 -- within subpackages???)
12038 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
12039 Has_Predef_Eq_Renaming
:= True;
12040 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
12042 -- User-defined equality
12044 elsif Is_User_Defined_Equality
(Node
(Prim
)) then
12045 if No
(Alias
(Node
(Prim
)))
12046 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
12047 N_Subprogram_Renaming_Declaration
12049 Eq_Needed
:= False;
12052 -- If the parent is not an interface type and has an abstract
12053 -- equality function explicitly defined in the sources, then the
12054 -- inherited equality is abstract as well, and no body can be
12057 elsif not Is_Interface
(Etype
(Tag_Typ
))
12058 and then Present
(Alias
(Node
(Prim
)))
12059 and then Comes_From_Source
(Alias
(Node
(Prim
)))
12060 and then Is_Abstract_Subprogram
(Alias
(Node
(Prim
)))
12062 Eq_Needed
:= False;
12065 -- If the type has an equality function corresponding with a
12066 -- primitive defined in an interface type, the inherited equality
12067 -- is abstract as well, and no body can be created for it.
12069 elsif Present
(Alias
(Node
(Prim
)))
12070 and then Comes_From_Source
(Ultimate_Alias
(Node
(Prim
)))
12073 (Find_Dispatching_Type
(Ultimate_Alias
(Node
(Prim
))))
12075 Eq_Needed
:= False;
12083 -- If a renaming of predefined equality was found but there was no
12084 -- user-defined equality (so Eq_Needed is still true), then set the name
12085 -- back to Name_Op_Eq. But in the case where a user-defined equality was
12086 -- located after such a renaming, then the predefined equality function
12087 -- is still needed, so Eq_Needed must be set back to True.
12089 if Eq_Name
/= Name_Op_Eq
then
12091 Eq_Name
:= Name_Op_Eq
;
12098 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
12099 Tag_Typ
=> Tag_Typ
,
12101 Profile
=> New_List
(
12102 Make_Parameter_Specification
(Loc
,
12103 Defining_Identifier
=>
12104 Make_Defining_Identifier
(Loc
, Name_X
),
12105 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12107 Make_Parameter_Specification
(Loc
,
12108 Defining_Identifier
=>
12109 Make_Defining_Identifier
(Loc
, Name_Y
),
12110 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12111 Ret_Type
=> Standard_Boolean
);
12112 Append_To
(Predef_List
, Eq_Spec
);
12114 if Has_Predef_Eq_Renaming
then
12115 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
12117 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12118 while Present
(Prim
) loop
12120 -- Any renamings of equality that appeared before an overriding
12121 -- equality must be updated to refer to the entity for the
12122 -- predefined equality, otherwise calls via the renaming would
12123 -- get incorrectly resolved to call the user-defined equality
12126 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
12127 Set_Alias
(Node
(Prim
), Renamed_Eq
);
12129 -- Exit upon encountering a user-defined equality
12131 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
12132 and then No
(Alias
(Node
(Prim
)))
12141 end Make_Predefined_Primitive_Eq_Spec
;
12143 -------------------------------------
12144 -- Make_Predefined_Primitive_Specs --
12145 -------------------------------------
12147 procedure Make_Predefined_Primitive_Specs
12148 (Tag_Typ
: Entity_Id
;
12149 Predef_List
: out List_Id
;
12150 Renamed_Eq
: out Entity_Id
)
12152 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12153 Res
: constant List_Id
:= New_List
;
12158 Renamed_Eq
:= Empty
;
12162 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12163 Tag_Typ
=> Tag_Typ
,
12164 Name
=> Name_uSize
,
12165 Profile
=> New_List
(
12166 Make_Parameter_Specification
(Loc
,
12167 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12168 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12170 Ret_Type
=> Standard_Long_Long_Integer
));
12172 -- Spec of Put_Image
12174 if not No_Run_Time_Mode
12175 and then RTE_Available
(RE_Root_Buffer_Type
)
12177 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
12178 -- (like any tagged type) will be rejected. Given this, avoid
12179 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
12182 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12183 Tag_Typ
=> Tag_Typ
,
12184 Name
=> Make_TSS_Name
(Tag_Typ
, TSS_Put_Image
),
12185 Profile
=> Build_Put_Image_Profile
(Loc
, Tag_Typ
)));
12188 -- Specs for dispatching stream attributes
12191 Stream_Op_TSS_Names
:
12192 constant array (Positive range <>) of TSS_Name_Type
:=
12196 TSS_Stream_Output
);
12199 for Op
in Stream_Op_TSS_Names
'Range loop
12200 if Stream_Operation_OK
(Tag_Typ
, Stream_Op_TSS_Names
(Op
)) then
12202 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
,
12203 Stream_Op_TSS_Names
(Op
)));
12208 -- Spec of "=" is expanded if the type is not limited and if a user
12209 -- defined "=" was not already declared for the non-full view of a
12210 -- private extension.
12212 if not Is_Limited_Type
(Tag_Typ
) then
12213 Make_Predefined_Primitive_Eq_Spec
(Tag_Typ
, Res
, Renamed_Eq
);
12215 -- Spec for dispatching assignment
12217 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
12218 Tag_Typ
=> Tag_Typ
,
12219 Name
=> Name_uAssign
,
12220 Profile
=> New_List
(
12221 Make_Parameter_Specification
(Loc
,
12222 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12223 Out_Present
=> True,
12224 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12226 Make_Parameter_Specification
(Loc
,
12227 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12228 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)))));
12231 -- Ada 2005: Generate declarations for the following primitive
12232 -- operations for limited interfaces and synchronized types that
12233 -- implement a limited interface.
12235 -- Disp_Asynchronous_Select
12236 -- Disp_Conditional_Select
12237 -- Disp_Get_Prim_Op_Kind
12238 -- Disp_Get_Task_Id
12240 -- Disp_Timed_Select
12242 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12244 if Ada_Version
>= Ada_2005
12245 and then not Restriction_Active
(No_Select_Statements
)
12246 and then RTE_Available
(RE_Select_Specific_Data
)
12248 -- These primitives are defined abstract in interface types
12250 if Is_Interface
(Tag_Typ
)
12251 and then Is_Limited_Record
(Tag_Typ
)
12254 Make_Abstract_Subprogram_Declaration
(Loc
,
12256 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
12259 Make_Abstract_Subprogram_Declaration
(Loc
,
12261 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
12264 Make_Abstract_Subprogram_Declaration
(Loc
,
12266 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
12269 Make_Abstract_Subprogram_Declaration
(Loc
,
12271 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12274 Make_Abstract_Subprogram_Declaration
(Loc
,
12276 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12279 Make_Abstract_Subprogram_Declaration
(Loc
,
12281 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12283 -- If ancestor is an interface type, declare non-abstract primitives
12284 -- to override the abstract primitives of the interface type.
12286 -- In VM targets we define these primitives in all root tagged types
12287 -- that are not interface types. Done because in VM targets we don't
12288 -- have secondary dispatch tables and any derivation of Tag_Typ may
12289 -- cover limited interfaces (which always have these primitives since
12290 -- they may be ancestors of synchronized interface types).
12292 elsif (not Is_Interface
(Tag_Typ
)
12293 and then Is_Interface
(Etype
(Tag_Typ
))
12294 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12296 (Is_Concurrent_Record_Type
(Tag_Typ
)
12297 and then Has_Interfaces
(Tag_Typ
))
12299 (not Tagged_Type_Expansion
12300 and then not Is_Interface
(Tag_Typ
)
12301 and then Tag_Typ
= Root_Type
(Tag_Typ
))
12304 Make_Subprogram_Declaration
(Loc
,
12306 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
12309 Make_Subprogram_Declaration
(Loc
,
12311 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
12314 Make_Subprogram_Declaration
(Loc
,
12316 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
12319 Make_Subprogram_Declaration
(Loc
,
12321 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
12324 Make_Subprogram_Declaration
(Loc
,
12326 Make_Disp_Requeue_Spec
(Tag_Typ
)));
12329 Make_Subprogram_Declaration
(Loc
,
12331 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
12335 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
12336 -- regardless of whether they are controlled or may contain controlled
12339 -- Do not generate the routines if finalization is disabled
12341 if Restriction_Active
(No_Finalization
) then
12345 if not Is_Limited_Type
(Tag_Typ
) then
12346 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
12349 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
12352 Predef_List
:= Res
;
12353 end Make_Predefined_Primitive_Specs
;
12355 -------------------------
12356 -- Make_Tag_Assignment --
12357 -------------------------
12359 function Make_Tag_Assignment
(N
: Node_Id
) return Node_Id
is
12360 Loc
: constant Source_Ptr
:= Sloc
(N
);
12361 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
12362 Expr
: constant Node_Id
:= Expression
(N
);
12363 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
12364 Full_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
12367 -- This expansion activity is called during analysis
12369 if Is_Tagged_Type
(Typ
)
12370 and then not Is_Class_Wide_Type
(Typ
)
12371 and then not Is_CPP_Class
(Typ
)
12372 and then Tagged_Type_Expansion
12373 and then Nkind
(Unqualify
(Expr
)) /= N_Aggregate
12376 Make_Tag_Assignment_From_Type
12377 (Loc
, New_Occurrence_Of
(Def_Id
, Loc
), Full_Typ
);
12382 end Make_Tag_Assignment
;
12384 ----------------------
12385 -- Predef_Deep_Spec --
12386 ----------------------
12388 function Predef_Deep_Spec
12390 Tag_Typ
: Entity_Id
;
12391 Name
: TSS_Name_Type
;
12392 For_Body
: Boolean := False) return Node_Id
12397 -- V : in out Tag_Typ
12399 Formals
:= New_List
(
12400 Make_Parameter_Specification
(Loc
,
12401 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
12402 In_Present
=> True,
12403 Out_Present
=> True,
12404 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)));
12406 -- F : Boolean := True
12408 if Name
= TSS_Deep_Adjust
12409 or else Name
= TSS_Deep_Finalize
12411 Append_To
(Formals
,
12412 Make_Parameter_Specification
(Loc
,
12413 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
12414 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
12415 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12419 Predef_Spec_Or_Body
(Loc
,
12420 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12421 Tag_Typ
=> Tag_Typ
,
12422 Profile
=> Formals
,
12423 For_Body
=> For_Body
);
12426 when RE_Not_Available
=>
12428 end Predef_Deep_Spec
;
12430 -------------------------
12431 -- Predef_Spec_Or_Body --
12432 -------------------------
12434 function Predef_Spec_Or_Body
12436 Tag_Typ
: Entity_Id
;
12439 Ret_Type
: Entity_Id
:= Empty
;
12440 For_Body
: Boolean := False) return Node_Id
12442 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
12446 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
12448 -- The internal flag is set to mark these declarations because they have
12449 -- specific properties. First, they are primitives even if they are not
12450 -- defined in the type scope (the freezing point is not necessarily in
12451 -- the same scope). Second, the predefined equality can be overridden by
12452 -- a user-defined equality, no body will be generated in this case.
12454 Set_Is_Internal
(Id
);
12456 if not Debug_Generated_Code
then
12457 Set_Debug_Info_Off
(Id
);
12460 if No
(Ret_Type
) then
12462 Make_Procedure_Specification
(Loc
,
12463 Defining_Unit_Name
=> Id
,
12464 Parameter_Specifications
=> Profile
);
12467 Make_Function_Specification
(Loc
,
12468 Defining_Unit_Name
=> Id
,
12469 Parameter_Specifications
=> Profile
,
12470 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
12473 -- Declare an abstract subprogram for primitive subprograms of an
12474 -- interface type (except for "=").
12476 if Is_Interface
(Tag_Typ
) then
12477 if Name
/= Name_Op_Eq
then
12478 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12480 -- The equality function (if any) for an interface type is defined
12481 -- to be nonabstract, so we create an expression function for it that
12482 -- always returns False. Note that the function can never actually be
12483 -- invoked because interface types are abstract, so there aren't any
12484 -- objects of such types (and their equality operation will always
12488 return Make_Expression_Function
12489 (Loc
, Spec
, New_Occurrence_Of
(Standard_False
, Loc
));
12492 -- If body case, return empty subprogram body. Note that this is ill-
12493 -- formed, because there is not even a null statement, and certainly not
12494 -- a return in the function case. The caller is expected to do surgery
12495 -- on the body to add the appropriate stuff.
12497 elsif For_Body
then
12498 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
12500 -- For the case of an Input attribute predefined for an abstract type,
12501 -- generate an abstract specification. This will never be called, but we
12502 -- need the slot allocated in the dispatching table so that attributes
12503 -- typ'Class'Input and typ'Class'Output will work properly.
12505 elsif Is_TSS
(Name
, TSS_Stream_Input
)
12506 and then Is_Abstract_Type
(Tag_Typ
)
12508 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
12510 -- Normal spec case, where we return a subprogram declaration
12513 return Make_Subprogram_Declaration
(Loc
, Spec
);
12515 end Predef_Spec_Or_Body
;
12517 -----------------------------
12518 -- Predef_Stream_Attr_Spec --
12519 -----------------------------
12521 function Predef_Stream_Attr_Spec
12523 Tag_Typ
: Entity_Id
;
12524 Name
: TSS_Name_Type
) return Node_Id
12526 Ret_Type
: Entity_Id
;
12529 if Name
= TSS_Stream_Input
then
12530 Ret_Type
:= Tag_Typ
;
12536 Predef_Spec_Or_Body
12538 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
12539 Tag_Typ
=> Tag_Typ
,
12540 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
12541 Ret_Type
=> Ret_Type
,
12542 For_Body
=> False);
12543 end Predef_Stream_Attr_Spec
;
12545 ----------------------------------
12546 -- Predefined_Primitive_Eq_Body --
12547 ----------------------------------
12549 procedure Predefined_Primitive_Eq_Body
12550 (Tag_Typ
: Entity_Id
;
12551 Predef_List
: List_Id
;
12552 Renamed_Eq
: Entity_Id
)
12555 Eq_Needed
: Boolean;
12560 -- See if we have a predefined "=" operator
12562 if Present
(Renamed_Eq
) then
12564 Eq_Name
:= Chars
(Renamed_Eq
);
12566 -- If the parent is an interface type then it has defined all the
12567 -- predefined primitives abstract and we need to check if the type
12568 -- has some user defined "=" function which matches the profile of
12569 -- the Ada predefined equality operator to avoid generating it.
12571 elsif Is_Interface
(Etype
(Tag_Typ
)) then
12573 Eq_Name
:= Name_Op_Eq
;
12575 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12576 while Present
(Prim
) loop
12577 if Is_User_Defined_Equality
(Node
(Prim
))
12578 and then not Is_Internal
(Node
(Prim
))
12580 Eq_Needed
:= False;
12581 Eq_Name
:= No_Name
;
12589 Eq_Needed
:= False;
12590 Eq_Name
:= No_Name
;
12592 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12593 while Present
(Prim
) loop
12594 if Is_User_Defined_Equality
(Node
(Prim
))
12595 and then Is_Internal
(Node
(Prim
))
12598 Eq_Name
:= Name_Op_Eq
;
12606 -- If equality is needed, we will have its name
12608 pragma Assert
(Eq_Needed
= Present
(Eq_Name
));
12610 -- Body for equality
12613 Decl
:= Make_Eq_Body
(Tag_Typ
, Eq_Name
);
12614 Append_To
(Predef_List
, Decl
);
12617 -- Body for inequality (if required)
12619 Decl
:= Make_Neq_Body
(Tag_Typ
);
12621 if Present
(Decl
) then
12622 Append_To
(Predef_List
, Decl
);
12624 end Predefined_Primitive_Eq_Body
;
12626 ---------------------------------
12627 -- Predefined_Primitive_Bodies --
12628 ---------------------------------
12630 function Predefined_Primitive_Bodies
12631 (Tag_Typ
: Entity_Id
;
12632 Renamed_Eq
: Entity_Id
) return List_Id
12634 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
12635 Res
: constant List_Id
:= New_List
;
12636 Adj_Call
: Node_Id
;
12638 Fin_Call
: Node_Id
;
12641 pragma Warnings
(Off
, Ent
);
12646 pragma Assert
(not Is_Interface
(Tag_Typ
));
12650 Decl
:= Predef_Spec_Or_Body
(Loc
,
12651 Tag_Typ
=> Tag_Typ
,
12652 Name
=> Name_uSize
,
12653 Profile
=> New_List
(
12654 Make_Parameter_Specification
(Loc
,
12655 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12656 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12658 Ret_Type
=> Standard_Long_Long_Integer
,
12661 Set_Handled_Statement_Sequence
(Decl
,
12662 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12663 Make_Simple_Return_Statement
(Loc
,
12665 Make_Attribute_Reference
(Loc
,
12666 Prefix
=> Make_Identifier
(Loc
, Name_X
),
12667 Attribute_Name
=> Name_Size
)))));
12669 Append_To
(Res
, Decl
);
12671 -- Body of Put_Image
12673 if No
(TSS
(Tag_Typ
, TSS_Put_Image
))
12674 and then not No_Run_Time_Mode
12675 and then RTE_Available
(RE_Root_Buffer_Type
)
12677 Build_Record_Put_Image_Procedure
(Tag_Typ
, Decl
, Ent
);
12678 Append_To
(Res
, Decl
);
12681 -- Bodies for Dispatching stream IO routines. We need these only for
12682 -- non-limited types (in the limited case there is no dispatching).
12683 -- We also skip them if dispatching or finalization are not available
12684 -- or if stream operations are prohibited by restriction No_Streams or
12685 -- from use of pragma/aspect No_Tagged_Streams.
12687 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Read
)
12688 and then No
(TSS
(Tag_Typ
, TSS_Stream_Read
))
12690 Build_Record_Read_Procedure
(Tag_Typ
, Decl
, Ent
);
12691 Append_To
(Res
, Decl
);
12694 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Write
)
12695 and then No
(TSS
(Tag_Typ
, TSS_Stream_Write
))
12697 Build_Record_Write_Procedure
(Tag_Typ
, Decl
, Ent
);
12698 Append_To
(Res
, Decl
);
12701 -- Skip body of _Input for the abstract case, since the corresponding
12702 -- spec is abstract (see Predef_Spec_Or_Body).
12704 if not Is_Abstract_Type
(Tag_Typ
)
12705 and then Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Input
)
12706 and then No
(TSS
(Tag_Typ
, TSS_Stream_Input
))
12708 Build_Record_Or_Elementary_Input_Function
(Tag_Typ
, Decl
, Ent
);
12709 Append_To
(Res
, Decl
);
12712 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Output
)
12713 and then No
(TSS
(Tag_Typ
, TSS_Stream_Output
))
12715 Build_Record_Or_Elementary_Output_Procedure
(Tag_Typ
, Decl
, Ent
);
12716 Append_To
(Res
, Decl
);
12719 -- Ada 2005: Generate bodies for the following primitive operations for
12720 -- limited interfaces and synchronized types that implement a limited
12723 -- disp_asynchronous_select
12724 -- disp_conditional_select
12725 -- disp_get_prim_op_kind
12726 -- disp_get_task_id
12727 -- disp_timed_select
12729 -- The interface versions will have null bodies
12731 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12733 -- In VM targets we define these primitives in all root tagged types
12734 -- that are not interface types. Done because in VM targets we don't
12735 -- have secondary dispatch tables and any derivation of Tag_Typ may
12736 -- cover limited interfaces (which always have these primitives since
12737 -- they may be ancestors of synchronized interface types).
12739 if Ada_Version
>= Ada_2005
12741 ((Is_Interface
(Etype
(Tag_Typ
))
12742 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
12744 (Is_Concurrent_Record_Type
(Tag_Typ
)
12745 and then Has_Interfaces
(Tag_Typ
))
12747 (not Tagged_Type_Expansion
12748 and then Tag_Typ
= Root_Type
(Tag_Typ
)))
12749 and then not Restriction_Active
(No_Select_Statements
)
12750 and then RTE_Available
(RE_Select_Specific_Data
)
12752 Append_To
(Res
, Make_Disp_Asynchronous_Select_Body
(Tag_Typ
));
12753 Append_To
(Res
, Make_Disp_Conditional_Select_Body
(Tag_Typ
));
12754 Append_To
(Res
, Make_Disp_Get_Prim_Op_Kind_Body
(Tag_Typ
));
12755 Append_To
(Res
, Make_Disp_Get_Task_Id_Body
(Tag_Typ
));
12756 Append_To
(Res
, Make_Disp_Requeue_Body
(Tag_Typ
));
12757 Append_To
(Res
, Make_Disp_Timed_Select_Body
(Tag_Typ
));
12760 if not Is_Limited_Type
(Tag_Typ
) then
12761 -- Body for equality and inequality
12763 Predefined_Primitive_Eq_Body
(Tag_Typ
, Res
, Renamed_Eq
);
12765 -- Body for dispatching assignment
12768 Predef_Spec_Or_Body
(Loc
,
12769 Tag_Typ
=> Tag_Typ
,
12770 Name
=> Name_uAssign
,
12771 Profile
=> New_List
(
12772 Make_Parameter_Specification
(Loc
,
12773 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
12774 Out_Present
=> True,
12775 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
)),
12777 Make_Parameter_Specification
(Loc
,
12778 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
12779 Parameter_Type
=> New_Occurrence_Of
(Tag_Typ
, Loc
))),
12782 Set_Handled_Statement_Sequence
(Decl
,
12783 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
12784 Make_Assignment_Statement
(Loc
,
12785 Name
=> Make_Identifier
(Loc
, Name_X
),
12786 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
12788 Append_To
(Res
, Decl
);
12791 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
12792 -- tagged types which do not contain controlled components.
12794 -- Do not generate the routines if finalization is disabled
12796 if Restriction_Active
(No_Finalization
) then
12799 elsif not Has_Controlled_Component
(Tag_Typ
) then
12800 if not Is_Limited_Type
(Tag_Typ
) then
12802 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
12804 if Is_Controlled
(Tag_Typ
) then
12807 Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12811 if No
(Adj_Call
) then
12812 Adj_Call
:= Make_Null_Statement
(Loc
);
12815 Set_Handled_Statement_Sequence
(Decl
,
12816 Make_Handled_Sequence_Of_Statements
(Loc
,
12817 Statements
=> New_List
(Adj_Call
)));
12819 Append_To
(Res
, Decl
);
12823 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
12825 if Is_Controlled
(Tag_Typ
) then
12828 (Obj_Ref
=> Make_Identifier
(Loc
, Name_V
),
12832 if No
(Fin_Call
) then
12833 Fin_Call
:= Make_Null_Statement
(Loc
);
12836 Set_Handled_Statement_Sequence
(Decl
,
12837 Make_Handled_Sequence_Of_Statements
(Loc
,
12838 Statements
=> New_List
(Fin_Call
)));
12840 Append_To
(Res
, Decl
);
12844 end Predefined_Primitive_Bodies
;
12846 ---------------------------------
12847 -- Predefined_Primitive_Freeze --
12848 ---------------------------------
12850 function Predefined_Primitive_Freeze
12851 (Tag_Typ
: Entity_Id
) return List_Id
12853 Res
: constant List_Id
:= New_List
;
12858 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12859 while Present
(Prim
) loop
12860 if Is_Predefined_Dispatching_Operation
(Node
(Prim
)) then
12861 Frnodes
:= Freeze_Entity
(Node
(Prim
), Tag_Typ
);
12863 if Present
(Frnodes
) then
12864 Append_List_To
(Res
, Frnodes
);
12872 end Predefined_Primitive_Freeze
;
12874 -------------------------
12875 -- Stream_Operation_OK --
12876 -------------------------
12878 function Stream_Operation_OK
12880 Operation
: TSS_Name_Type
) return Boolean
12882 Has_Predefined_Or_Specified_Stream_Attribute
: Boolean := False;
12885 -- Special case of a limited type extension: a default implementation
12886 -- of the stream attributes Read or Write exists if that attribute
12887 -- has been specified or is available for an ancestor type; a default
12888 -- implementation of the attribute Output (resp. Input) exists if the
12889 -- attribute has been specified or Write (resp. Read) is available for
12890 -- an ancestor type. The last condition only applies under Ada 2005.
12892 if Is_Limited_Type
(Typ
) and then Is_Tagged_Type
(Typ
) then
12893 if Operation
= TSS_Stream_Read
then
12894 Has_Predefined_Or_Specified_Stream_Attribute
:=
12895 Has_Specified_Stream_Read
(Typ
);
12897 elsif Operation
= TSS_Stream_Write
then
12898 Has_Predefined_Or_Specified_Stream_Attribute
:=
12899 Has_Specified_Stream_Write
(Typ
);
12901 elsif Operation
= TSS_Stream_Input
then
12902 Has_Predefined_Or_Specified_Stream_Attribute
:=
12903 Has_Specified_Stream_Input
(Typ
)
12905 (Ada_Version
>= Ada_2005
12906 and then Stream_Operation_OK
(Typ
, TSS_Stream_Read
));
12908 elsif Operation
= TSS_Stream_Output
then
12909 Has_Predefined_Or_Specified_Stream_Attribute
:=
12910 Has_Specified_Stream_Output
(Typ
)
12912 (Ada_Version
>= Ada_2005
12913 and then Stream_Operation_OK
(Typ
, TSS_Stream_Write
));
12916 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
12918 if not Has_Predefined_Or_Specified_Stream_Attribute
12919 and then Is_Derived_Type
(Typ
)
12920 and then (Operation
= TSS_Stream_Read
12921 or else Operation
= TSS_Stream_Write
)
12923 Has_Predefined_Or_Specified_Stream_Attribute
:=
12925 (Find_Inherited_TSS
(Base_Type
(Etype
(Typ
)), Operation
));
12929 -- If the type is not limited, or else is limited but the attribute is
12930 -- explicitly specified or is predefined for the type, then return True,
12931 -- unless other conditions prevail, such as restrictions prohibiting
12932 -- streams or dispatching operations. We also return True for limited
12933 -- interfaces, because they may be extended by nonlimited types and
12934 -- permit inheritance in this case (addresses cases where an abstract
12935 -- extension doesn't get 'Input declared, as per comments below, but
12936 -- 'Class'Input must still be allowed). Note that attempts to apply
12937 -- stream attributes to a limited interface or its class-wide type
12938 -- (or limited extensions thereof) will still get properly rejected
12939 -- by Check_Stream_Attribute.
12941 -- We exclude the Input operation from being a predefined subprogram in
12942 -- the case where the associated type is an abstract extension, because
12943 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
12944 -- we don't want an abstract version created because types derived from
12945 -- the abstract type may not even have Input available (for example if
12946 -- derived from a private view of the abstract type that doesn't have
12947 -- a visible Input).
12950 (not Is_Limited_Type
(Typ
)
12951 or else Is_Interface
(Typ
)
12952 or else Has_Predefined_Or_Specified_Stream_Attribute
)
12954 (Operation
/= TSS_Stream_Input
12955 or else not Is_Abstract_Type
(Typ
)
12956 or else not Is_Derived_Type
(Typ
))
12957 and then not Has_Unknown_Discriminants
(Typ
)
12958 and then not Is_Concurrent_Interface
(Typ
)
12959 and then not Restriction_Active
(No_Streams
)
12960 and then not Restriction_Active
(No_Dispatch
)
12961 and then No
(No_Tagged_Streams_Pragma
(Typ
))
12962 and then not No_Run_Time_Mode
12963 and then RTE_Available
(RE_Tag
)
12965 (not Restriction_Active
(No_Default_Stream_Attributes
)
12966 or else No
(Type_Without_Stream_Operation
(Typ
)))
12967 and then RTE_Available
(RE_Root_Stream_Type
);
12968 end Stream_Operation_OK
;