1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Aggr
; use Exp_Aggr
;
31 with Exp_Atag
; use Exp_Atag
;
32 with Exp_Ch4
; use Exp_Ch4
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Ch11
; use Exp_Ch11
;
37 with Exp_Disp
; use Exp_Disp
;
38 with Exp_Dist
; use Exp_Dist
;
39 with Exp_Smem
; use Exp_Smem
;
40 with Exp_Strm
; use Exp_Strm
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
44 with Nlists
; use Nlists
;
45 with Namet
; use Namet
;
46 with Nmake
; use Nmake
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
52 with Sem_Attr
; use Sem_Attr
;
53 with Sem_Cat
; use Sem_Cat
;
54 with Sem_Ch3
; use Sem_Ch3
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Mech
; use Sem_Mech
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Type
; use Sem_Type
;
61 with Sem_Util
; use Sem_Util
;
62 with Sinfo
; use Sinfo
;
63 with Stand
; use Stand
;
64 with Snames
; use Snames
;
65 with Targparm
; use Targparm
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Validsw
; use Validsw
;
70 package body Exp_Ch3
is
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 function Add_Final_Chain
(Def_Id
: Entity_Id
) return Entity_Id
;
77 -- Add the declaration of a finalization list to the freeze actions for
78 -- Def_Id, and return its defining identifier.
80 procedure Adjust_Discriminants
(Rtype
: Entity_Id
);
81 -- This is used when freezing a record type. It attempts to construct
82 -- more restrictive subtypes for discriminants so that the max size of
83 -- the record can be calculated more accurately. See the body of this
84 -- procedure for details.
86 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
);
87 -- Build initialization procedure for given array type. Nod is a node
88 -- used for attachment of any actions required in its construction.
89 -- It also supplies the source location used for the procedure.
91 function Build_Discriminant_Formals
93 Use_Dl
: Boolean) return List_Id
;
94 -- This function uses the discriminants of a type to build a list of
95 -- formal parameters, used in the following function. If the flag Use_Dl
96 -- is set, the list is built using the already defined discriminals
97 -- of the type. Otherwise new identifiers are created, with the source
98 -- names of the discriminants.
100 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
;
101 -- This function builds a static aggregate that can serve as the initial
102 -- value for an array type whose bounds are static, and whose component
103 -- type is a composite type that has a static equivalent aggregate.
104 -- The equivalent array aggregate is used both for object initialization
105 -- and for component initialization, when used in the following function.
107 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
;
108 -- This function builds a static aggregate that can serve as the initial
109 -- value for a record type whose components are scalar and initialized
110 -- with compile-time values, or arrays with similar initialization or
111 -- defaults. When possible, initialization of an object of the type can
112 -- be achieved by using a copy of the aggregate as an initial value, thus
113 -- removing the implicit call that would otherwise constitute elaboration
116 function Build_Master_Renaming
118 T
: Entity_Id
) return Entity_Id
;
119 -- If the designated type of an access type is a task type or contains
120 -- tasks, we make sure that a _Master variable is declared in the current
121 -- scope, and then declare a renaming for it:
123 -- atypeM : Master_Id renames _Master;
125 -- where atyp is the name of the access type. This declaration is used when
126 -- an allocator for the access type is expanded. The node is the full
127 -- declaration of the designated type that contains tasks. The renaming
128 -- declaration is inserted before N, and after the Master declaration.
130 procedure Build_Record_Init_Proc
(N
: Node_Id
; Pe
: Entity_Id
);
131 -- Build record initialization procedure. N is the type declaration
132 -- node, and Pe is the corresponding entity for the record type.
134 procedure Build_Slice_Assignment
(Typ
: Entity_Id
);
135 -- Build assignment procedure for one-dimensional arrays of controlled
136 -- types. Other array and slice assignments are expanded in-line, but
137 -- the code expansion for controlled components (when control actions
138 -- are active) can lead to very large blocks that GCC3 handles poorly.
140 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
141 -- Create An Equality function for the non-tagged variant record 'Typ'
142 -- and attach it to the TSS list
144 procedure Check_Stream_Attributes
(Typ
: Entity_Id
);
145 -- Check that if a limited extension has a parent with user-defined stream
146 -- attributes, and does not itself have user-defined stream-attributes,
147 -- then any limited component of the extension also has the corresponding
148 -- user-defined stream attributes.
150 procedure Clean_Task_Names
152 Proc_Id
: Entity_Id
);
153 -- If an initialization procedure includes calls to generate names
154 -- for task subcomponents, indicate that secondary stack cleanup is
155 -- needed after an initialization. Typ is the component type, and Proc_Id
156 -- the initialization procedure for the enclosing composite type.
158 procedure Expand_Tagged_Root
(T
: Entity_Id
);
159 -- Add a field _Tag at the beginning of the record. This field carries
160 -- the value of the access to the Dispatch table. This procedure is only
161 -- called on root type, the _Tag field being inherited by the descendants.
163 procedure Expand_Record_Controller
(T
: Entity_Id
);
164 -- T must be a record type that Has_Controlled_Component. Add a field
165 -- _controller of type Record_Controller or Limited_Record_Controller
168 procedure Freeze_Array_Type
(N
: Node_Id
);
169 -- Freeze an array type. Deals with building the initialization procedure,
170 -- creating the packed array type for a packed array and also with the
171 -- creation of the controlling procedures for the controlled case. The
172 -- argument N is the N_Freeze_Entity node for the type.
174 procedure Freeze_Enumeration_Type
(N
: Node_Id
);
175 -- Freeze enumeration type with non-standard representation. Builds the
176 -- array and function needed to convert between enumeration pos and
177 -- enumeration representation values. N is the N_Freeze_Entity node
180 procedure Freeze_Record_Type
(N
: Node_Id
);
181 -- Freeze record type. Builds all necessary discriminant checking
182 -- and other ancillary functions, and builds dispatch tables where
183 -- needed. The argument N is the N_Freeze_Entity node. This processing
184 -- applies only to E_Record_Type entities, not to class wide types,
185 -- record subtypes, or private types.
187 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
);
188 -- Treat user-defined stream operations as renaming_as_body if the
189 -- subprogram they rename is not frozen when the type is frozen.
191 procedure Initialization_Warning
(E
: Entity_Id
);
192 -- If static elaboration of the package is requested, indicate
193 -- when a type does meet the conditions for static initialization. If
194 -- E is a type, it has components that have no static initialization.
195 -- if E is an entity, its initial expression is not compile-time known.
197 function Init_Formals
(Typ
: Entity_Id
) return List_Id
;
198 -- This function builds the list of formals for an initialization routine.
199 -- The first formal is always _Init with the given type. For task value
200 -- record types and types containing tasks, three additional formals are
203 -- _Master : Master_Id
204 -- _Chain : in out Activation_Chain
205 -- _Task_Name : String
207 -- The caller must append additional entries for discriminants if required.
209 function In_Runtime
(E
: Entity_Id
) return Boolean;
210 -- Check if E is defined in the RTL (in a child of Ada or System). Used
211 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
213 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean;
214 -- Returns true if E has variable size components
216 function Make_Eq_Case
219 Discr
: Entity_Id
:= Empty
) return List_Id
;
220 -- Building block for variant record equality. Defined to share the code
221 -- between the tagged and non-tagged case. Given a Component_List node CL,
222 -- it generates an 'if' followed by a 'case' statement that compares all
223 -- components of local temporaries named X and Y (that are declared as
224 -- formals at some upper level). E provides the Sloc to be used for the
225 -- generated code. Discr is used as the case statement switch in the case
226 -- of Unchecked_Union equality.
230 L
: List_Id
) return Node_Id
;
231 -- Building block for variant record equality. Defined to share the code
232 -- between the tagged and non-tagged case. Given the list of components
233 -- (or discriminants) L, it generates a return statement that compares all
234 -- components of local temporaries named X and Y (that are declared as
235 -- formals at some upper level). E provides the Sloc to be used for the
238 procedure Make_Predefined_Primitive_Specs
239 (Tag_Typ
: Entity_Id
;
240 Predef_List
: out List_Id
;
241 Renamed_Eq
: out Entity_Id
);
242 -- Create a list with the specs of the predefined primitive operations.
243 -- For tagged types that are interfaces all these primitives are defined
246 -- The following entries are present for all tagged types, and provide
247 -- the results of the corresponding attribute applied to the object.
248 -- Dispatching is required in general, since the result of the attribute
249 -- will vary with the actual object subtype.
251 -- _alignment provides result of 'Alignment attribute
252 -- _size provides result of 'Size attribute
253 -- typSR provides result of 'Read attribute
254 -- typSW provides result of 'Write attribute
255 -- typSI provides result of 'Input attribute
256 -- typSO provides result of 'Output attribute
258 -- The following entries are additionally present for non-limited tagged
259 -- types, and implement additional dispatching operations for predefined
262 -- _equality implements "=" operator
263 -- _assign implements assignment operation
264 -- typDF implements deep finalization
265 -- typDA implements deep adjust
267 -- The latter two are empty procedures unless the type contains some
268 -- controlled components that require finalization actions (the deep
269 -- in the name refers to the fact that the action applies to components).
271 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
272 -- returns the value Empty, or else the defining unit name for the
273 -- predefined equality function in the case where the type has a primitive
274 -- operation that is a renaming of predefined equality (but only if there
275 -- is also an overriding user-defined equality function). The returned
276 -- Renamed_Eq will be passed to the corresponding parameter of
277 -- Predefined_Primitive_Bodies.
279 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean;
280 -- returns True if there are representation clauses for type T that are not
281 -- inherited. If the result is false, the init_proc and the discriminant
282 -- checking functions of the parent can be reused by a derived type.
284 procedure Make_Controlling_Function_Wrappers
285 (Tag_Typ
: Entity_Id
;
286 Decl_List
: out List_Id
;
287 Body_List
: out List_Id
);
288 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
289 -- associated with inherited functions with controlling results which
290 -- are not overridden. The body of each wrapper function consists solely
291 -- of a return statement whose expression is an extension aggregate
292 -- invoking the inherited subprogram's parent subprogram and extended
293 -- with a null association list.
295 procedure Make_Null_Procedure_Specs
296 (Tag_Typ
: Entity_Id
;
297 Decl_List
: out List_Id
);
298 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
299 -- null procedures inherited from an interface type that have not been
300 -- overridden. Only one null procedure will be created for a given set of
301 -- inherited null procedures with homographic profiles.
303 function Predef_Spec_Or_Body
308 Ret_Type
: Entity_Id
:= Empty
;
309 For_Body
: Boolean := False) return Node_Id
;
310 -- This function generates the appropriate expansion for a predefined
311 -- primitive operation specified by its name, parameter profile and
312 -- return type (Empty means this is a procedure). If For_Body is false,
313 -- then the returned node is a subprogram declaration. If For_Body is
314 -- true, then the returned node is a empty subprogram body containing
315 -- no declarations and no statements.
317 function Predef_Stream_Attr_Spec
320 Name
: TSS_Name_Type
;
321 For_Body
: Boolean := False) return Node_Id
;
322 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
323 -- input and output attribute whose specs are constructed in Exp_Strm.
325 function Predef_Deep_Spec
328 Name
: TSS_Name_Type
;
329 For_Body
: Boolean := False) return Node_Id
;
330 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
331 -- and _deep_finalize
333 function Predefined_Primitive_Bodies
334 (Tag_Typ
: Entity_Id
;
335 Renamed_Eq
: Entity_Id
) return List_Id
;
336 -- Create the bodies of the predefined primitives that are described in
337 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
338 -- the defining unit name of the type's predefined equality as returned
339 -- by Make_Predefined_Primitive_Specs.
341 function Predefined_Primitive_Freeze
(Tag_Typ
: Entity_Id
) return List_Id
;
342 -- Freeze entities of all predefined primitive operations. This is needed
343 -- because the bodies of these operations do not normally do any freezing.
345 function Stream_Operation_OK
347 Operation
: TSS_Name_Type
) return Boolean;
348 -- Check whether the named stream operation must be emitted for a given
349 -- type. The rules for inheritance of stream attributes by type extensions
350 -- are enforced by this function. Furthermore, various restrictions prevent
351 -- the generation of these operations, as a useful optimization or for
352 -- certification purposes.
354 ---------------------
355 -- Add_Final_Chain --
356 ---------------------
358 function Add_Final_Chain
(Def_Id
: Entity_Id
) return Entity_Id
is
359 Loc
: constant Source_Ptr
:= Sloc
(Def_Id
);
364 Make_Defining_Identifier
(Loc
,
365 New_External_Name
(Chars
(Def_Id
), 'L'));
367 Append_Freeze_Action
(Def_Id
,
368 Make_Object_Declaration
(Loc
,
369 Defining_Identifier
=> Flist
,
371 New_Reference_To
(RTE
(RE_List_Controller
), Loc
)));
376 --------------------------
377 -- Adjust_Discriminants --
378 --------------------------
380 -- This procedure attempts to define subtypes for discriminants that are
381 -- more restrictive than those declared. Such a replacement is possible if
382 -- we can demonstrate that values outside the restricted range would cause
383 -- constraint errors in any case. The advantage of restricting the
384 -- discriminant types in this way is that the maximum size of the variant
385 -- record can be calculated more conservatively.
387 -- An example of a situation in which we can perform this type of
388 -- restriction is the following:
390 -- subtype B is range 1 .. 10;
391 -- type Q is array (B range <>) of Integer;
393 -- type V (N : Natural) is record
397 -- In this situation, we can restrict the upper bound of N to 10, since
398 -- any larger value would cause a constraint error in any case.
400 -- There are many situations in which such restriction is possible, but
401 -- for now, we just look for cases like the above, where the component
402 -- in question is a one dimensional array whose upper bound is one of
403 -- the record discriminants. Also the component must not be part of
404 -- any variant part, since then the component does not always exist.
406 procedure Adjust_Discriminants
(Rtype
: Entity_Id
) is
407 Loc
: constant Source_Ptr
:= Sloc
(Rtype
);
424 Comp
:= First_Component
(Rtype
);
425 while Present
(Comp
) loop
427 -- If our parent is a variant, quit, we do not look at components
428 -- that are in variant parts, because they may not always exist.
430 P
:= Parent
(Comp
); -- component declaration
431 P
:= Parent
(P
); -- component list
433 exit when Nkind
(Parent
(P
)) = N_Variant
;
435 -- We are looking for a one dimensional array type
437 Ctyp
:= Etype
(Comp
);
439 if not Is_Array_Type
(Ctyp
)
440 or else Number_Dimensions
(Ctyp
) > 1
445 -- The lower bound must be constant, and the upper bound is a
446 -- discriminant (which is a discriminant of the current record).
448 Ityp
:= Etype
(First_Index
(Ctyp
));
449 Lo
:= Type_Low_Bound
(Ityp
);
450 Hi
:= Type_High_Bound
(Ityp
);
452 if not Compile_Time_Known_Value
(Lo
)
453 or else Nkind
(Hi
) /= N_Identifier
454 or else No
(Entity
(Hi
))
455 or else Ekind
(Entity
(Hi
)) /= E_Discriminant
460 -- We have an array with appropriate bounds
462 Loval
:= Expr_Value
(Lo
);
463 Discr
:= Entity
(Hi
);
464 Dtyp
:= Etype
(Discr
);
466 -- See if the discriminant has a known upper bound
468 Dhi
:= Type_High_Bound
(Dtyp
);
470 if not Compile_Time_Known_Value
(Dhi
) then
474 Dhiv
:= Expr_Value
(Dhi
);
476 -- See if base type of component array has known upper bound
478 Ahi
:= Type_High_Bound
(Etype
(First_Index
(Base_Type
(Ctyp
))));
480 if not Compile_Time_Known_Value
(Ahi
) then
484 Ahiv
:= Expr_Value
(Ahi
);
486 -- The condition for doing the restriction is that the high bound
487 -- of the discriminant is greater than the low bound of the array,
488 -- and is also greater than the high bound of the base type index.
490 if Dhiv
> Loval
and then Dhiv
> Ahiv
then
492 -- We can reset the upper bound of the discriminant type to
493 -- whichever is larger, the low bound of the component, or
494 -- the high bound of the base type array index.
496 -- We build a subtype that is declared as
498 -- subtype Tnn is discr_type range discr_type'First .. max;
500 -- And insert this declaration into the tree. The type of the
501 -- discriminant is then reset to this more restricted subtype.
503 Tnn
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
505 Insert_Action
(Declaration_Node
(Rtype
),
506 Make_Subtype_Declaration
(Loc
,
507 Defining_Identifier
=> Tnn
,
508 Subtype_Indication
=>
509 Make_Subtype_Indication
(Loc
,
510 Subtype_Mark
=> New_Occurrence_Of
(Dtyp
, Loc
),
512 Make_Range_Constraint
(Loc
,
516 Make_Attribute_Reference
(Loc
,
517 Attribute_Name
=> Name_First
,
518 Prefix
=> New_Occurrence_Of
(Dtyp
, Loc
)),
520 Make_Integer_Literal
(Loc
,
521 Intval
=> UI_Max
(Loval
, Ahiv
)))))));
523 Set_Etype
(Discr
, Tnn
);
527 Next_Component
(Comp
);
529 end Adjust_Discriminants
;
531 ---------------------------
532 -- Build_Array_Init_Proc --
533 ---------------------------
535 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
) is
536 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
537 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
538 Index_List
: List_Id
;
540 Body_Stmts
: List_Id
;
541 Has_Default_Init
: Boolean;
543 function Init_Component
return List_Id
;
544 -- Create one statement to initialize one array component, designated
545 -- by a full set of indices.
547 function Init_One_Dimension
(N
: Int
) return List_Id
;
548 -- Create loop to initialize one dimension of the array. The single
549 -- statement in the loop body initializes the inner dimensions if any,
550 -- or else the single component. Note that this procedure is called
551 -- recursively, with N being the dimension to be initialized. A call
552 -- with N greater than the number of dimensions simply generates the
553 -- component initialization, terminating the recursion.
559 function Init_Component
return List_Id
is
564 Make_Indexed_Component
(Loc
,
565 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
566 Expressions
=> Index_List
);
568 if Needs_Simple_Initialization
(Comp_Type
) then
569 Set_Assignment_OK
(Comp
);
571 Make_Assignment_Statement
(Loc
,
575 (Comp_Type
, Nod
, Component_Size
(A_Type
))));
578 Clean_Task_Names
(Comp_Type
, Proc_Id
);
580 Build_Initialization_Call
581 (Loc
, Comp
, Comp_Type
,
582 In_Init_Proc
=> True,
583 Enclos_Type
=> A_Type
);
587 ------------------------
588 -- Init_One_Dimension --
589 ------------------------
591 function Init_One_Dimension
(N
: Int
) return List_Id
is
595 -- If the component does not need initializing, then there is nothing
596 -- to do here, so we return a null body. This occurs when generating
597 -- the dummy Init_Proc needed for Initialize_Scalars processing.
599 if not Has_Non_Null_Base_Init_Proc
(Comp_Type
)
600 and then not Needs_Simple_Initialization
(Comp_Type
)
601 and then not Has_Task
(Comp_Type
)
603 return New_List
(Make_Null_Statement
(Loc
));
605 -- If all dimensions dealt with, we simply initialize the component
607 elsif N
> Number_Dimensions
(A_Type
) then
608 return Init_Component
;
610 -- Here we generate the required loop
614 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
616 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
619 Make_Implicit_Loop_Statement
(Nod
,
622 Make_Iteration_Scheme
(Loc
,
623 Loop_Parameter_Specification
=>
624 Make_Loop_Parameter_Specification
(Loc
,
625 Defining_Identifier
=> Index
,
626 Discrete_Subtype_Definition
=>
627 Make_Attribute_Reference
(Loc
,
628 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
629 Attribute_Name
=> Name_Range
,
630 Expressions
=> New_List
(
631 Make_Integer_Literal
(Loc
, N
))))),
632 Statements
=> Init_One_Dimension
(N
+ 1)));
634 end Init_One_Dimension
;
636 -- Start of processing for Build_Array_Init_Proc
639 -- Nothing to generate in the following cases:
641 -- 1. Initialization is suppressed for the type
642 -- 2. The type is a value type, in the CIL sense.
643 -- 3. An initialization already exists for the base type
645 if Suppress_Init_Proc
(A_Type
)
646 or else Is_Value_Type
(Comp_Type
)
647 or else Present
(Base_Init_Proc
(A_Type
))
652 Index_List
:= New_List
;
654 -- We need an initialization procedure if any of the following is true:
656 -- 1. The component type has an initialization procedure
657 -- 2. The component type needs simple initialization
658 -- 3. Tasks are present
659 -- 4. The type is marked as a public entity
661 -- The reason for the public entity test is to deal properly with the
662 -- Initialize_Scalars pragma. This pragma can be set in the client and
663 -- not in the declaring package, this means the client will make a call
664 -- to the initialization procedure (because one of conditions 1-3 must
665 -- apply in this case), and we must generate a procedure (even if it is
666 -- null) to satisfy the call in this case.
668 -- Exception: do not build an array init_proc for a type whose root
669 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
670 -- is no place to put the code, and in any case we handle initialization
671 -- of such types (in the Initialize_Scalars case, that's the only time
672 -- the issue arises) in a special manner anyway which does not need an
675 Has_Default_Init
:= Has_Non_Null_Base_Init_Proc
(Comp_Type
)
676 or else Needs_Simple_Initialization
(Comp_Type
)
677 or else Has_Task
(Comp_Type
);
680 or else (not Restriction_Active
(No_Initialize_Scalars
)
681 and then Is_Public
(A_Type
)
682 and then Root_Type
(A_Type
) /= Standard_String
683 and then Root_Type
(A_Type
) /= Standard_Wide_String
684 and then Root_Type
(A_Type
) /= Standard_Wide_Wide_String
)
687 Make_Defining_Identifier
(Loc
,
688 Chars
=> Make_Init_Proc_Name
(A_Type
));
690 -- If No_Default_Initialization restriction is active, then we don't
691 -- want to build an init_proc, but we need to mark that an init_proc
692 -- would be needed if this restriction was not active (so that we can
693 -- detect attempts to call it), so set a dummy init_proc in place.
694 -- This is only done though when actual default initialization is
695 -- needed, so we exclude the setting in the Is_Public case, such
696 -- as for arrays of scalars, since otherwise such objects would be
697 -- wrongly flagged as violating the restriction.
699 if Restriction_Active
(No_Default_Initialization
) then
700 if Has_Default_Init
then
701 Set_Init_Proc
(A_Type
, Proc_Id
);
707 Body_Stmts
:= Init_One_Dimension
(1);
710 Make_Subprogram_Body
(Loc
,
712 Make_Procedure_Specification
(Loc
,
713 Defining_Unit_Name
=> Proc_Id
,
714 Parameter_Specifications
=> Init_Formals
(A_Type
)),
715 Declarations
=> New_List
,
716 Handled_Statement_Sequence
=>
717 Make_Handled_Sequence_Of_Statements
(Loc
,
718 Statements
=> Body_Stmts
)));
720 Set_Ekind
(Proc_Id
, E_Procedure
);
721 Set_Is_Public
(Proc_Id
, Is_Public
(A_Type
));
722 Set_Is_Internal
(Proc_Id
);
723 Set_Has_Completion
(Proc_Id
);
725 if not Debug_Generated_Code
then
726 Set_Debug_Info_Off
(Proc_Id
);
729 -- Set inlined unless controlled stuff or tasks around, in which
730 -- case we do not want to inline, because nested stuff may cause
731 -- difficulties in inter-unit inlining, and furthermore there is
732 -- in any case no point in inlining such complex init procs.
734 if not Has_Task
(Proc_Id
)
735 and then not Controlled_Type
(Proc_Id
)
737 Set_Is_Inlined
(Proc_Id
);
740 -- Associate Init_Proc with type, and determine if the procedure
741 -- is null (happens because of the Initialize_Scalars pragma case,
742 -- where we have to generate a null procedure in case it is called
743 -- by a client with Initialize_Scalars set). Such procedures have
744 -- to be generated, but do not have to be called, so we mark them
745 -- as null to suppress the call.
747 Set_Init_Proc
(A_Type
, Proc_Id
);
749 if List_Length
(Body_Stmts
) = 1
750 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
752 Set_Is_Null_Init_Proc
(Proc_Id
);
755 -- Try to build a static aggregate to initialize statically
756 -- objects of the type. This can only be done for constrained
757 -- one-dimensional arrays with static bounds.
759 Set_Static_Initialization
761 Build_Equivalent_Array_Aggregate
(First_Subtype
(A_Type
)));
764 end Build_Array_Init_Proc
;
766 -----------------------------
767 -- Build_Class_Wide_Master --
768 -----------------------------
770 procedure Build_Class_Wide_Master
(T
: Entity_Id
) is
771 Loc
: constant Source_Ptr
:= Sloc
(T
);
778 -- Nothing to do if there is no task hierarchy
780 if Restriction_Active
(No_Task_Hierarchy
) then
784 -- Find declaration that created the access type: either a type
785 -- declaration, or an object declaration with an access definition,
786 -- in which case the type is anonymous.
789 P
:= Associated_Node_For_Itype
(T
);
794 -- Nothing to do if we already built a master entity for this scope
796 if not Has_Master_Entity
(Scope
(T
)) then
798 -- First build the master entity
799 -- _Master : constant Master_Id := Current_Master.all;
800 -- and insert it just before the current declaration.
803 Make_Object_Declaration
(Loc
,
804 Defining_Identifier
=>
805 Make_Defining_Identifier
(Loc
, Name_uMaster
),
806 Constant_Present
=> True,
807 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
809 Make_Explicit_Dereference
(Loc
,
810 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
812 Insert_Action
(P
, Decl
);
814 Set_Has_Master_Entity
(Scope
(T
));
816 -- Now mark the containing scope as a task master
819 while Nkind
(Par
) /= N_Compilation_Unit
loop
822 -- If we fall off the top, we are at the outer level, and the
823 -- environment task is our effective master, so nothing to mark.
826 (Par
, N_Task_Body
, N_Block_Statement
, N_Subprogram_Body
)
828 Set_Is_Task_Master
(Par
, True);
834 -- Now define the renaming of the master_id
837 Make_Defining_Identifier
(Loc
,
838 New_External_Name
(Chars
(T
), 'M'));
841 Make_Object_Renaming_Declaration
(Loc
,
842 Defining_Identifier
=> M_Id
,
843 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
844 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
845 Insert_Before
(P
, Decl
);
848 Set_Master_Id
(T
, M_Id
);
851 when RE_Not_Available
=>
853 end Build_Class_Wide_Master
;
855 --------------------------------
856 -- Build_Discr_Checking_Funcs --
857 --------------------------------
859 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
) is
862 Enclosing_Func_Id
: Entity_Id
;
867 function Build_Case_Statement
868 (Case_Id
: Entity_Id
;
869 Variant
: Node_Id
) return Node_Id
;
870 -- Build a case statement containing only two alternatives. The first
871 -- alternative corresponds exactly to the discrete choices given on the
872 -- variant with contains the components that we are generating the
873 -- checks for. If the discriminant is one of these return False. The
874 -- second alternative is an OTHERS choice that will return True
875 -- indicating the discriminant did not match.
877 function Build_Dcheck_Function
878 (Case_Id
: Entity_Id
;
879 Variant
: Node_Id
) return Entity_Id
;
880 -- Build the discriminant checking function for a given variant
882 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
);
883 -- Builds the discriminant checking function for each variant of the
884 -- given variant part of the record type.
886 --------------------------
887 -- Build_Case_Statement --
888 --------------------------
890 function Build_Case_Statement
891 (Case_Id
: Entity_Id
;
892 Variant
: Node_Id
) return Node_Id
894 Alt_List
: constant List_Id
:= New_List
;
895 Actuals_List
: List_Id
;
897 Case_Alt_Node
: Node_Id
;
899 Choice_List
: List_Id
;
901 Return_Node
: Node_Id
;
904 Case_Node
:= New_Node
(N_Case_Statement
, Loc
);
906 -- Replace the discriminant which controls the variant, with the name
907 -- of the formal of the checking function.
909 Set_Expression
(Case_Node
,
910 Make_Identifier
(Loc
, Chars
(Case_Id
)));
912 Choice
:= First
(Discrete_Choices
(Variant
));
914 if Nkind
(Choice
) = N_Others_Choice
then
915 Choice_List
:= New_Copy_List
(Others_Discrete_Choices
(Choice
));
917 Choice_List
:= New_Copy_List
(Discrete_Choices
(Variant
));
920 if not Is_Empty_List
(Choice_List
) then
921 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
922 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
924 -- In case this is a nested variant, we need to return the result
925 -- of the discriminant checking function for the immediately
926 -- enclosing variant.
928 if Present
(Enclosing_Func_Id
) then
929 Actuals_List
:= New_List
;
931 D
:= First_Discriminant
(Rec_Id
);
932 while Present
(D
) loop
933 Append
(Make_Identifier
(Loc
, Chars
(D
)), Actuals_List
);
934 Next_Discriminant
(D
);
938 Make_Simple_Return_Statement
(Loc
,
940 Make_Function_Call
(Loc
,
942 New_Reference_To
(Enclosing_Func_Id
, Loc
),
943 Parameter_Associations
=>
948 Make_Simple_Return_Statement
(Loc
,
950 New_Reference_To
(Standard_False
, Loc
));
953 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
954 Append
(Case_Alt_Node
, Alt_List
);
957 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
958 Choice_List
:= New_List
(New_Node
(N_Others_Choice
, Loc
));
959 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
962 Make_Simple_Return_Statement
(Loc
,
964 New_Reference_To
(Standard_True
, Loc
));
966 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
967 Append
(Case_Alt_Node
, Alt_List
);
969 Set_Alternatives
(Case_Node
, Alt_List
);
971 end Build_Case_Statement
;
973 ---------------------------
974 -- Build_Dcheck_Function --
975 ---------------------------
977 function Build_Dcheck_Function
978 (Case_Id
: Entity_Id
;
979 Variant
: Node_Id
) return Entity_Id
983 Parameter_List
: List_Id
;
987 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
988 Sequence
:= Sequence
+ 1;
991 Make_Defining_Identifier
(Loc
,
992 Chars
=> New_External_Name
(Chars
(Rec_Id
), 'D', Sequence
));
994 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
995 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
997 Parameter_List
:= Build_Discriminant_Formals
(Rec_Id
, False);
999 Set_Parameter_Specifications
(Spec_Node
, Parameter_List
);
1000 Set_Result_Definition
(Spec_Node
,
1001 New_Reference_To
(Standard_Boolean
, Loc
));
1002 Set_Specification
(Body_Node
, Spec_Node
);
1003 Set_Declarations
(Body_Node
, New_List
);
1005 Set_Handled_Statement_Sequence
(Body_Node
,
1006 Make_Handled_Sequence_Of_Statements
(Loc
,
1007 Statements
=> New_List
(
1008 Build_Case_Statement
(Case_Id
, Variant
))));
1010 Set_Ekind
(Func_Id
, E_Function
);
1011 Set_Mechanism
(Func_Id
, Default_Mechanism
);
1012 Set_Is_Inlined
(Func_Id
, True);
1013 Set_Is_Pure
(Func_Id
, True);
1014 Set_Is_Public
(Func_Id
, Is_Public
(Rec_Id
));
1015 Set_Is_Internal
(Func_Id
, True);
1017 if not Debug_Generated_Code
then
1018 Set_Debug_Info_Off
(Func_Id
);
1021 Analyze
(Body_Node
);
1023 Append_Freeze_Action
(Rec_Id
, Body_Node
);
1024 Set_Dcheck_Function
(Variant
, Func_Id
);
1026 end Build_Dcheck_Function
;
1028 ----------------------------
1029 -- Build_Dcheck_Functions --
1030 ----------------------------
1032 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
) is
1033 Component_List_Node
: Node_Id
;
1035 Discr_Name
: Entity_Id
;
1036 Func_Id
: Entity_Id
;
1038 Saved_Enclosing_Func_Id
: Entity_Id
;
1041 -- Build the discriminant-checking function for each variant, and
1042 -- label all components of that variant with the function's name.
1043 -- We only Generate a discriminant-checking function when the
1044 -- variant is not empty, to prevent the creation of dead code.
1045 -- The exception to that is when Frontend_Layout_On_Target is set,
1046 -- because the variant record size function generated in package
1047 -- Layout needs to generate calls to all discriminant-checking
1048 -- functions, including those for empty variants.
1050 Discr_Name
:= Entity
(Name
(Variant_Part_Node
));
1051 Variant
:= First_Non_Pragma
(Variants
(Variant_Part_Node
));
1053 while Present
(Variant
) loop
1054 Component_List_Node
:= Component_List
(Variant
);
1056 if not Null_Present
(Component_List_Node
)
1057 or else Frontend_Layout_On_Target
1059 Func_Id
:= Build_Dcheck_Function
(Discr_Name
, Variant
);
1061 First_Non_Pragma
(Component_Items
(Component_List_Node
));
1063 while Present
(Decl
) loop
1064 Set_Discriminant_Checking_Func
1065 (Defining_Identifier
(Decl
), Func_Id
);
1067 Next_Non_Pragma
(Decl
);
1070 if Present
(Variant_Part
(Component_List_Node
)) then
1071 Saved_Enclosing_Func_Id
:= Enclosing_Func_Id
;
1072 Enclosing_Func_Id
:= Func_Id
;
1073 Build_Dcheck_Functions
(Variant_Part
(Component_List_Node
));
1074 Enclosing_Func_Id
:= Saved_Enclosing_Func_Id
;
1078 Next_Non_Pragma
(Variant
);
1080 end Build_Dcheck_Functions
;
1082 -- Start of processing for Build_Discr_Checking_Funcs
1085 -- Only build if not done already
1087 if not Discr_Check_Funcs_Built
(N
) then
1088 Type_Def
:= Type_Definition
(N
);
1090 if Nkind
(Type_Def
) = N_Record_Definition
then
1091 if No
(Component_List
(Type_Def
)) then -- null record.
1094 V
:= Variant_Part
(Component_List
(Type_Def
));
1097 else pragma Assert
(Nkind
(Type_Def
) = N_Derived_Type_Definition
);
1098 if No
(Component_List
(Record_Extension_Part
(Type_Def
))) then
1102 (Component_List
(Record_Extension_Part
(Type_Def
)));
1106 Rec_Id
:= Defining_Identifier
(N
);
1108 if Present
(V
) and then not Is_Unchecked_Union
(Rec_Id
) then
1110 Enclosing_Func_Id
:= Empty
;
1111 Build_Dcheck_Functions
(V
);
1114 Set_Discr_Check_Funcs_Built
(N
);
1116 end Build_Discr_Checking_Funcs
;
1118 --------------------------------
1119 -- Build_Discriminant_Formals --
1120 --------------------------------
1122 function Build_Discriminant_Formals
1123 (Rec_Id
: Entity_Id
;
1124 Use_Dl
: Boolean) return List_Id
1126 Loc
: Source_Ptr
:= Sloc
(Rec_Id
);
1127 Parameter_List
: constant List_Id
:= New_List
;
1130 Param_Spec_Node
: Node_Id
;
1133 if Has_Discriminants
(Rec_Id
) then
1134 D
:= First_Discriminant
(Rec_Id
);
1135 while Present
(D
) loop
1139 Formal
:= Discriminal
(D
);
1141 Formal
:= Make_Defining_Identifier
(Loc
, Chars
(D
));
1145 Make_Parameter_Specification
(Loc
,
1146 Defining_Identifier
=> Formal
,
1148 New_Reference_To
(Etype
(D
), Loc
));
1149 Append
(Param_Spec_Node
, Parameter_List
);
1150 Next_Discriminant
(D
);
1154 return Parameter_List
;
1155 end Build_Discriminant_Formals
;
1157 --------------------------------------
1158 -- Build_Equivalent_Array_Aggregate --
1159 --------------------------------------
1161 function Build_Equivalent_Array_Aggregate
(T
: Entity_Id
) return Node_Id
is
1162 Loc
: constant Source_Ptr
:= Sloc
(T
);
1163 Comp_Type
: constant Entity_Id
:= Component_Type
(T
);
1164 Index_Type
: constant Entity_Id
:= Etype
(First_Index
(T
));
1165 Proc
: constant Entity_Id
:= Base_Init_Proc
(T
);
1171 if not Is_Constrained
(T
)
1172 or else Number_Dimensions
(T
) > 1
1175 Initialization_Warning
(T
);
1179 Lo
:= Type_Low_Bound
(Index_Type
);
1180 Hi
:= Type_High_Bound
(Index_Type
);
1182 if not Compile_Time_Known_Value
(Lo
)
1183 or else not Compile_Time_Known_Value
(Hi
)
1185 Initialization_Warning
(T
);
1189 if Is_Record_Type
(Comp_Type
)
1190 and then Present
(Base_Init_Proc
(Comp_Type
))
1192 Expr
:= Static_Initialization
(Base_Init_Proc
(Comp_Type
));
1195 Initialization_Warning
(T
);
1200 Initialization_Warning
(T
);
1204 Aggr
:= Make_Aggregate
(Loc
, No_List
, New_List
);
1205 Set_Etype
(Aggr
, T
);
1206 Set_Aggregate_Bounds
(Aggr
,
1208 Low_Bound
=> New_Copy
(Lo
),
1209 High_Bound
=> New_Copy
(Hi
)));
1210 Set_Parent
(Aggr
, Parent
(Proc
));
1212 Append_To
(Component_Associations
(Aggr
),
1213 Make_Component_Association
(Loc
,
1217 Low_Bound
=> New_Copy
(Lo
),
1218 High_Bound
=> New_Copy
(Hi
))),
1219 Expression
=> Expr
));
1221 if Static_Array_Aggregate
(Aggr
) then
1224 Initialization_Warning
(T
);
1227 end Build_Equivalent_Array_Aggregate
;
1229 ---------------------------------------
1230 -- Build_Equivalent_Record_Aggregate --
1231 ---------------------------------------
1233 function Build_Equivalent_Record_Aggregate
(T
: Entity_Id
) return Node_Id
is
1237 -- Start of processing for Build_Equivalent_Record_Aggregate
1240 if not Is_Record_Type
(T
)
1241 or else Has_Discriminants
(T
)
1242 or else Is_Limited_Type
(T
)
1243 or else Has_Non_Standard_Rep
(T
)
1245 Initialization_Warning
(T
);
1249 Comp
:= First_Component
(T
);
1251 -- A null record needs no warning
1257 while Present
(Comp
) loop
1259 -- Array components are acceptable if initialized by a positional
1260 -- aggregate with static components.
1262 if Is_Array_Type
(Etype
(Comp
)) then
1264 Comp_Type
: constant Entity_Id
:= Component_Type
(Etype
(Comp
));
1267 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1268 or else No
(Expression
(Parent
(Comp
)))
1269 or else Nkind
(Expression
(Parent
(Comp
))) /= N_Aggregate
1271 Initialization_Warning
(T
);
1274 elsif Is_Scalar_Type
(Component_Type
(Etype
(Comp
)))
1276 (not Compile_Time_Known_Value
(Type_Low_Bound
(Comp_Type
))
1277 or else not Compile_Time_Known_Value
1278 (Type_High_Bound
(Comp_Type
)))
1280 Initialization_Warning
(T
);
1284 not Static_Array_Aggregate
(Expression
(Parent
(Comp
)))
1286 Initialization_Warning
(T
);
1291 elsif Is_Scalar_Type
(Etype
(Comp
)) then
1292 if Nkind
(Parent
(Comp
)) /= N_Component_Declaration
1293 or else No
(Expression
(Parent
(Comp
)))
1294 or else not Compile_Time_Known_Value
(Expression
(Parent
(Comp
)))
1296 Initialization_Warning
(T
);
1300 -- For now, other types are excluded
1303 Initialization_Warning
(T
);
1307 Next_Component
(Comp
);
1310 -- All components have static initialization. Build positional
1311 -- aggregate from the given expressions or defaults.
1313 Agg
:= Make_Aggregate
(Sloc
(T
), New_List
, New_List
);
1314 Set_Parent
(Agg
, Parent
(T
));
1316 Comp
:= First_Component
(T
);
1317 while Present
(Comp
) loop
1319 (New_Copy_Tree
(Expression
(Parent
(Comp
))), Expressions
(Agg
));
1320 Next_Component
(Comp
);
1323 Analyze_And_Resolve
(Agg
, T
);
1325 end Build_Equivalent_Record_Aggregate
;
1327 -------------------------------
1328 -- Build_Initialization_Call --
1329 -------------------------------
1331 -- References to a discriminant inside the record type declaration can
1332 -- appear either in the subtype_indication to constrain a record or an
1333 -- array, or as part of a larger expression given for the initial value
1334 -- of a component. In both of these cases N appears in the record
1335 -- initialization procedure and needs to be replaced by the formal
1336 -- parameter of the initialization procedure which corresponds to that
1339 -- In the example below, references to discriminants D1 and D2 in proc_1
1340 -- are replaced by references to formals with the same name
1343 -- A similar replacement is done for calls to any record initialization
1344 -- procedure for any components that are themselves of a record type.
1346 -- type R (D1, D2 : Integer) is record
1347 -- X : Integer := F * D1;
1348 -- Y : Integer := F * D2;
1351 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1355 -- Out_2.X := F * D1;
1356 -- Out_2.Y := F * D2;
1359 function Build_Initialization_Call
1363 In_Init_Proc
: Boolean := False;
1364 Enclos_Type
: Entity_Id
:= Empty
;
1365 Discr_Map
: Elist_Id
:= New_Elmt_List
;
1366 With_Default_Init
: Boolean := False) return List_Id
1368 First_Arg
: Node_Id
;
1374 Proc
: constant Entity_Id
:= Base_Init_Proc
(Typ
);
1375 Init_Type
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
1376 Full_Init_Type
: constant Entity_Id
:= Underlying_Type
(Init_Type
);
1377 Res
: constant List_Id
:= New_List
;
1378 Full_Type
: Entity_Id
:= Typ
;
1379 Controller_Typ
: Entity_Id
;
1382 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1383 -- is active (in which case we make the call anyway, since in the
1384 -- actual compiled client it may be non null).
1385 -- Also nothing to do for value types.
1387 if (Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
)
1388 or else Is_Value_Type
(Typ
)
1389 or else Is_Value_Type
(Component_Type
(Typ
))
1394 -- Go to full view if private type. In the case of successive
1395 -- private derivations, this can require more than one step.
1397 while Is_Private_Type
(Full_Type
)
1398 and then Present
(Full_View
(Full_Type
))
1400 Full_Type
:= Full_View
(Full_Type
);
1403 -- If Typ is derived, the procedure is the initialization procedure for
1404 -- the root type. Wrap the argument in an conversion to make it type
1405 -- honest. Actually it isn't quite type honest, because there can be
1406 -- conflicts of views in the private type case. That is why we set
1407 -- Conversion_OK in the conversion node.
1409 if (Is_Record_Type
(Typ
)
1410 or else Is_Array_Type
(Typ
)
1411 or else Is_Private_Type
(Typ
))
1412 and then Init_Type
/= Base_Type
(Typ
)
1414 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
1415 Set_Etype
(First_Arg
, Init_Type
);
1418 First_Arg
:= Id_Ref
;
1421 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
1423 -- In the tasks case, add _Master as the value of the _Master parameter
1424 -- and _Chain as the value of the _Chain parameter. At the outer level,
1425 -- these will be variables holding the corresponding values obtained
1426 -- from GNARL. At inner levels, they will be the parameters passed down
1427 -- through the outer routines.
1429 if Has_Task
(Full_Type
) then
1430 if Restriction_Active
(No_Task_Hierarchy
) then
1432 -- See comments in System.Tasking.Initialization.Init_RTS
1433 -- for the value 3 (should be rtsfindable constant ???)
1435 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1438 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1441 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1443 -- Ada 2005 (AI-287): In case of default initialized components
1444 -- with tasks, we generate a null string actual parameter.
1445 -- This is just a workaround that must be improved later???
1447 if With_Default_Init
then
1449 Make_String_Literal
(Loc
,
1454 Build_Task_Image_Decls
(Loc
, Id_Ref
, Enclos_Type
, In_Init_Proc
);
1455 Decl
:= Last
(Decls
);
1458 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
1459 Append_List
(Decls
, Res
);
1467 -- Add discriminant values if discriminants are present
1469 if Has_Discriminants
(Full_Init_Type
) then
1470 Discr
:= First_Discriminant
(Full_Init_Type
);
1472 while Present
(Discr
) loop
1474 -- If this is a discriminated concurrent type, the init_proc
1475 -- for the corresponding record is being called. Use that type
1476 -- directly to find the discriminant value, to handle properly
1477 -- intervening renamed discriminants.
1480 T
: Entity_Id
:= Full_Type
;
1483 if Is_Protected_Type
(T
) then
1484 T
:= Corresponding_Record_Type
(T
);
1486 elsif Is_Private_Type
(T
)
1487 and then Present
(Underlying_Full_View
(T
))
1488 and then Is_Protected_Type
(Underlying_Full_View
(T
))
1490 T
:= Corresponding_Record_Type
(Underlying_Full_View
(T
));
1494 Get_Discriminant_Value
(
1497 Discriminant_Constraint
(Full_Type
));
1500 if In_Init_Proc
then
1502 -- Replace any possible references to the discriminant in the
1503 -- call to the record initialization procedure with references
1504 -- to the appropriate formal parameter.
1506 if Nkind
(Arg
) = N_Identifier
1507 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1509 Arg
:= New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
);
1511 -- Case of access discriminants. We replace the reference
1512 -- to the type by a reference to the actual object
1514 elsif Nkind
(Arg
) = N_Attribute_Reference
1515 and then Is_Access_Type
(Etype
(Arg
))
1516 and then Is_Entity_Name
(Prefix
(Arg
))
1517 and then Is_Type
(Entity
(Prefix
(Arg
)))
1520 Make_Attribute_Reference
(Loc
,
1521 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
1522 Attribute_Name
=> Name_Unrestricted_Access
);
1524 -- Otherwise make a copy of the default expression. Note that
1525 -- we use the current Sloc for this, because we do not want the
1526 -- call to appear to be at the declaration point. Within the
1527 -- expression, replace discriminants with their discriminals.
1531 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
1535 if Is_Constrained
(Full_Type
) then
1536 Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
1538 -- The constraints come from the discriminant default exps,
1539 -- they must be reevaluated, so we use New_Copy_Tree but we
1540 -- ensure the proper Sloc (for any embedded calls).
1542 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
1546 -- Ada 2005 (AI-287) In case of default initialized components,
1547 -- we need to generate the corresponding selected component node
1548 -- to access the discriminant value. In other cases this is not
1549 -- required because we are inside the init proc and we use the
1550 -- corresponding formal.
1552 if With_Default_Init
1553 and then Nkind
(Id_Ref
) = N_Selected_Component
1554 and then Nkind
(Arg
) = N_Identifier
1557 Make_Selected_Component
(Loc
,
1558 Prefix
=> New_Copy_Tree
(Prefix
(Id_Ref
)),
1559 Selector_Name
=> Arg
));
1561 Append_To
(Args
, Arg
);
1564 Next_Discriminant
(Discr
);
1568 -- If this is a call to initialize the parent component of a derived
1569 -- tagged type, indicate that the tag should not be set in the parent.
1571 if Is_Tagged_Type
(Full_Init_Type
)
1572 and then not Is_CPP_Class
(Full_Init_Type
)
1573 and then Nkind
(Id_Ref
) = N_Selected_Component
1574 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
1576 Append_To
(Args
, New_Occurrence_Of
(Standard_False
, Loc
));
1580 Make_Procedure_Call_Statement
(Loc
,
1581 Name
=> New_Occurrence_Of
(Proc
, Loc
),
1582 Parameter_Associations
=> Args
));
1584 if Controlled_Type
(Typ
)
1585 and then Nkind
(Id_Ref
) = N_Selected_Component
1587 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
1588 Append_List_To
(Res
,
1590 Ref
=> New_Copy_Tree
(First_Arg
),
1593 Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1594 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1596 -- If the enclosing type is an extension with new controlled
1597 -- components, it has his own record controller. If the parent
1598 -- also had a record controller, attach it to the new one.
1600 -- Build_Init_Statements relies on the fact that in this specific
1601 -- case the last statement of the result is the attach call to
1602 -- the controller. If this is changed, it must be synchronized.
1604 elsif Present
(Enclos_Type
)
1605 and then Has_New_Controlled_Component
(Enclos_Type
)
1606 and then Has_Controlled_Component
(Typ
)
1608 if Is_Inherently_Limited_Type
(Typ
) then
1609 Controller_Typ
:= RTE
(RE_Limited_Record_Controller
);
1611 Controller_Typ
:= RTE
(RE_Record_Controller
);
1614 Append_List_To
(Res
,
1617 Make_Selected_Component
(Loc
,
1618 Prefix
=> New_Copy_Tree
(First_Arg
),
1619 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
)),
1620 Typ
=> Controller_Typ
,
1621 Flist_Ref
=> Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1622 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1629 when RE_Not_Available
=>
1631 end Build_Initialization_Call
;
1633 ---------------------------
1634 -- Build_Master_Renaming --
1635 ---------------------------
1637 function Build_Master_Renaming
1639 T
: Entity_Id
) return Entity_Id
1641 Loc
: constant Source_Ptr
:= Sloc
(N
);
1646 -- Nothing to do if there is no task hierarchy
1648 if Restriction_Active
(No_Task_Hierarchy
) then
1653 Make_Defining_Identifier
(Loc
,
1654 New_External_Name
(Chars
(T
), 'M'));
1657 Make_Object_Renaming_Declaration
(Loc
,
1658 Defining_Identifier
=> M_Id
,
1659 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
1660 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
1661 Insert_Before
(N
, Decl
);
1666 when RE_Not_Available
=>
1668 end Build_Master_Renaming
;
1670 ---------------------------
1671 -- Build_Master_Renaming --
1672 ---------------------------
1674 procedure Build_Master_Renaming
(N
: Node_Id
; T
: Entity_Id
) is
1678 -- Nothing to do if there is no task hierarchy
1680 if Restriction_Active
(No_Task_Hierarchy
) then
1684 M_Id
:= Build_Master_Renaming
(N
, T
);
1685 Set_Master_Id
(T
, M_Id
);
1688 when RE_Not_Available
=>
1690 end Build_Master_Renaming
;
1692 ----------------------------
1693 -- Build_Record_Init_Proc --
1694 ----------------------------
1696 procedure Build_Record_Init_Proc
(N
: Node_Id
; Pe
: Entity_Id
) is
1697 Loc
: Source_Ptr
:= Sloc
(N
);
1698 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
1699 Proc_Id
: Entity_Id
;
1700 Rec_Type
: Entity_Id
;
1701 Set_Tag
: Entity_Id
:= Empty
;
1703 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
;
1704 -- Build a assignment statement node which assigns to record component
1705 -- its default expression if defined. The assignment left hand side is
1706 -- marked Assignment_OK so that initialization of limited private
1707 -- records works correctly, Return also the adjustment call for
1708 -- controlled objects
1710 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
1711 -- If the record has discriminants, adds assignment statements to
1712 -- statement list to initialize the discriminant values from the
1713 -- arguments of the initialization procedure.
1715 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
1716 -- Build a list representing a sequence of statements which initialize
1717 -- components of the given component list. This may involve building
1718 -- case statements for the variant parts.
1720 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
;
1721 -- Given a non-tagged type-derivation that declares discriminants,
1724 -- type R (R1, R2 : Integer) is record ... end record;
1726 -- type D (D1 : Integer) is new R (1, D1);
1728 -- we make the _init_proc of D be
1730 -- procedure _init_proc(X : D; D1 : Integer) is
1732 -- _init_proc( R(X), 1, D1);
1735 -- This function builds the call statement in this _init_proc.
1737 procedure Build_Init_Procedure
;
1738 -- Build the tree corresponding to the procedure specification and body
1739 -- of the initialization procedure (by calling all the preceding
1740 -- auxiliary routines), and install it as the _init TSS.
1742 procedure Build_Offset_To_Top_Functions
;
1743 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1744 -- and body of the Offset_To_Top function that is generated when the
1745 -- parent of a type with discriminants has secondary dispatch tables.
1747 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
1748 -- Add range checks to components of discriminated records. S is a
1749 -- subtype indication of a record component. Check_List is a list
1750 -- to which the check actions are appended.
1752 function Component_Needs_Simple_Initialization
1753 (T
: Entity_Id
) return Boolean;
1754 -- Determines if a component needs simple initialization, given its type
1755 -- T. This is the same as Needs_Simple_Initialization except for the
1756 -- following difference: the types Tag and Interface_Tag, that are
1757 -- access types which would normally require simple initialization to
1758 -- null, do not require initialization as components, since they are
1759 -- explicitly initialized by other means.
1761 procedure Constrain_Array
1763 Check_List
: List_Id
);
1764 -- Called from Build_Record_Checks.
1765 -- Apply a list of index constraints to an unconstrained array type.
1766 -- The first parameter is the entity for the resulting subtype.
1767 -- Check_List is a list to which the check actions are appended.
1769 procedure Constrain_Index
1772 Check_List
: List_Id
);
1773 -- Process an index constraint in a constrained array declaration.
1774 -- The constraint can be a subtype name, or a range with or without
1775 -- an explicit subtype mark. The index is the corresponding index of the
1776 -- unconstrained array. S is the range expression. Check_List is a list
1777 -- to which the check actions are appended (called from
1778 -- Build_Record_Checks).
1780 function Parent_Subtype_Renaming_Discrims
return Boolean;
1781 -- Returns True for base types N that rename discriminants, else False
1783 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
1784 -- Determines whether a record initialization procedure needs to be
1785 -- generated for the given record type.
1787 ----------------------
1788 -- Build_Assignment --
1789 ----------------------
1791 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
is
1794 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
1795 Kind
: Node_Kind
:= Nkind
(N
);
1801 Make_Selected_Component
(Loc
,
1802 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1803 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
));
1804 Set_Assignment_OK
(Lhs
);
1806 -- Case of an access attribute applied to the current instance.
1807 -- Replace the reference to the type by a reference to the actual
1808 -- object. (Note that this handles the case of the top level of
1809 -- the expression being given by such an attribute, but does not
1810 -- cover uses nested within an initial value expression. Nested
1811 -- uses are unlikely to occur in practice, but are theoretically
1812 -- possible. It is not clear how to handle them without fully
1813 -- traversing the expression. ???
1815 if Kind
= N_Attribute_Reference
1816 and then (Attribute_Name
(N
) = Name_Unchecked_Access
1818 Attribute_Name
(N
) = Name_Unrestricted_Access
)
1819 and then Is_Entity_Name
(Prefix
(N
))
1820 and then Is_Type
(Entity
(Prefix
(N
)))
1821 and then Entity
(Prefix
(N
)) = Rec_Type
1824 Make_Attribute_Reference
(Loc
,
1825 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1826 Attribute_Name
=> Name_Unrestricted_Access
);
1829 -- Ada 2005 (AI-231): Add the run-time check if required
1831 if Ada_Version
>= Ada_05
1832 and then Can_Never_Be_Null
(Etype
(Id
)) -- Lhs
1834 if Known_Null
(Exp
) then
1836 Make_Raise_Constraint_Error
(Sloc
(Exp
),
1837 Reason
=> CE_Null_Not_Allowed
));
1839 elsif Present
(Etype
(Exp
))
1840 and then not Can_Never_Be_Null
(Etype
(Exp
))
1842 Install_Null_Excluding_Check
(Exp
);
1846 -- Take a copy of Exp to ensure that later copies of this component
1847 -- declaration in derived types see the original tree, not a node
1848 -- rewritten during expansion of the init_proc.
1850 Exp
:= New_Copy_Tree
(Exp
);
1853 Make_Assignment_Statement
(Loc
,
1855 Expression
=> Exp
));
1857 Set_No_Ctrl_Actions
(First
(Res
));
1859 -- Adjust the tag if tagged (because of possible view conversions).
1860 -- Suppress the tag adjustment when VM_Target because VM tags are
1861 -- represented implicitly in objects.
1863 if Is_Tagged_Type
(Typ
) and then VM_Target
= No_VM
then
1865 Make_Assignment_Statement
(Loc
,
1867 Make_Selected_Component
(Loc
,
1868 Prefix
=> New_Copy_Tree
(Lhs
),
1870 New_Reference_To
(First_Tag_Component
(Typ
), Loc
)),
1873 Unchecked_Convert_To
(RTE
(RE_Tag
),
1875 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
))));
1878 -- Adjust the component if controlled except if it is an aggregate
1879 -- that will be expanded inline
1881 if Kind
= N_Qualified_Expression
then
1882 Kind
:= Nkind
(Expression
(N
));
1885 if Controlled_Type
(Typ
)
1886 and then not (Kind
= N_Aggregate
or else Kind
= N_Extension_Aggregate
)
1887 and then not Is_Inherently_Limited_Type
(Typ
)
1889 Append_List_To
(Res
,
1891 Ref
=> New_Copy_Tree
(Lhs
),
1894 Find_Final_List
(Etype
(Id
), New_Copy_Tree
(Lhs
)),
1895 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1901 when RE_Not_Available
=>
1903 end Build_Assignment
;
1905 ------------------------------------
1906 -- Build_Discriminant_Assignments --
1907 ------------------------------------
1909 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
1911 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
1914 if Has_Discriminants
(Rec_Type
)
1915 and then not Is_Unchecked_Union
(Rec_Type
)
1917 D
:= First_Discriminant
(Rec_Type
);
1919 while Present
(D
) loop
1920 -- Don't generate the assignment for discriminants in derived
1921 -- tagged types if the discriminant is a renaming of some
1922 -- ancestor discriminant. This initialization will be done
1923 -- when initializing the _parent field of the derived record.
1925 if Is_Tagged
and then
1926 Present
(Corresponding_Discriminant
(D
))
1932 Append_List_To
(Statement_List
,
1933 Build_Assignment
(D
,
1934 New_Reference_To
(Discriminal
(D
), Loc
)));
1937 Next_Discriminant
(D
);
1940 end Build_Discriminant_Assignments
;
1942 --------------------------
1943 -- Build_Init_Call_Thru --
1944 --------------------------
1946 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
is
1947 Parent_Proc
: constant Entity_Id
:=
1948 Base_Init_Proc
(Etype
(Rec_Type
));
1950 Parent_Type
: constant Entity_Id
:=
1951 Etype
(First_Formal
(Parent_Proc
));
1953 Uparent_Type
: constant Entity_Id
:=
1954 Underlying_Type
(Parent_Type
);
1956 First_Discr_Param
: Node_Id
;
1958 Parent_Discr
: Entity_Id
;
1959 First_Arg
: Node_Id
;
1965 -- First argument (_Init) is the object to be initialized.
1966 -- ??? not sure where to get a reasonable Loc for First_Arg
1969 OK_Convert_To
(Parent_Type
,
1970 New_Reference_To
(Defining_Identifier
(First
(Parameters
)), Loc
));
1972 Set_Etype
(First_Arg
, Parent_Type
);
1974 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
1976 -- In the tasks case,
1977 -- add _Master as the value of the _Master parameter
1978 -- add _Chain as the value of the _Chain parameter.
1979 -- add _Task_Name as the value of the _Task_Name parameter.
1980 -- At the outer level, these will be variables holding the
1981 -- corresponding values obtained from GNARL or the expander.
1983 -- At inner levels, they will be the parameters passed down through
1984 -- the outer routines.
1986 First_Discr_Param
:= Next
(First
(Parameters
));
1988 if Has_Task
(Rec_Type
) then
1989 if Restriction_Active
(No_Task_Hierarchy
) then
1991 -- See comments in System.Tasking.Initialization.Init_RTS
1994 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1996 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1999 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2000 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
2001 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
2004 -- Append discriminant values
2006 if Has_Discriminants
(Uparent_Type
) then
2007 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
2009 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
2010 while Present
(Parent_Discr
) loop
2012 -- Get the initial value for this discriminant
2013 -- ??? needs to be cleaned up to use parent_Discr_Constr
2017 Discr_Value
: Elmt_Id
:=
2019 (Stored_Constraint
(Rec_Type
));
2021 Discr
: Entity_Id
:=
2022 First_Stored_Discriminant
(Uparent_Type
);
2024 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
2025 Next_Stored_Discriminant
(Discr
);
2026 Next_Elmt
(Discr_Value
);
2029 Arg
:= Node
(Discr_Value
);
2032 -- Append it to the list
2034 if Nkind
(Arg
) = N_Identifier
2035 and then Ekind
(Entity
(Arg
)) = E_Discriminant
2038 New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
));
2040 -- Case of access discriminants. We replace the reference
2041 -- to the type by a reference to the actual object.
2043 -- Is above comment right??? Use of New_Copy below seems mighty
2047 Append_To
(Args
, New_Copy
(Arg
));
2050 Next_Discriminant
(Parent_Discr
);
2056 Make_Procedure_Call_Statement
(Loc
,
2057 Name
=> New_Occurrence_Of
(Parent_Proc
, Loc
),
2058 Parameter_Associations
=> Args
));
2061 end Build_Init_Call_Thru
;
2063 -----------------------------------
2064 -- Build_Offset_To_Top_Functions --
2065 -----------------------------------
2067 procedure Build_Offset_To_Top_Functions
is
2069 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
);
2071 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2073 -- return O.Iface_Comp'Position;
2076 ------------------------------
2077 -- Build_Offset_To_Top_Body --
2078 ------------------------------
2080 procedure Build_Offset_To_Top_Function
(Iface_Comp
: Entity_Id
) is
2081 Body_Node
: Node_Id
;
2082 Func_Id
: Entity_Id
;
2083 Spec_Node
: Node_Id
;
2087 Make_Defining_Identifier
(Loc
,
2088 Chars
=> New_Internal_Name
('F'));
2090 Set_DT_Offset_To_Top_Func
(Iface_Comp
, Func_Id
);
2093 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2095 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
2096 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
2097 Set_Parameter_Specifications
(Spec_Node
, New_List
(
2098 Make_Parameter_Specification
(Loc
,
2099 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
2101 Parameter_Type
=> New_Reference_To
(Rec_Type
, Loc
))));
2102 Set_Result_Definition
(Spec_Node
,
2103 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
));
2106 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2108 -- return O.Iface_Comp'Position;
2111 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2112 Set_Specification
(Body_Node
, Spec_Node
);
2113 Set_Declarations
(Body_Node
, New_List
);
2114 Set_Handled_Statement_Sequence
(Body_Node
,
2115 Make_Handled_Sequence_Of_Statements
(Loc
,
2116 Statements
=> New_List
(
2117 Make_Simple_Return_Statement
(Loc
,
2119 Make_Attribute_Reference
(Loc
,
2121 Make_Selected_Component
(Loc
,
2122 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
2123 Selector_Name
=> New_Reference_To
2125 Attribute_Name
=> Name_Position
)))));
2127 Set_Ekind
(Func_Id
, E_Function
);
2128 Set_Mechanism
(Func_Id
, Default_Mechanism
);
2129 Set_Is_Internal
(Func_Id
, True);
2131 if not Debug_Generated_Code
then
2132 Set_Debug_Info_Off
(Func_Id
);
2135 Analyze
(Body_Node
);
2137 Append_Freeze_Action
(Rec_Type
, Body_Node
);
2138 end Build_Offset_To_Top_Function
;
2142 Ifaces_List
: Elist_Id
;
2143 Ifaces_Comp_List
: Elist_Id
;
2144 Ifaces_Tag_List
: Elist_Id
;
2145 Iface_Elmt
: Elmt_Id
;
2146 Comp_Elmt
: Elmt_Id
;
2148 pragma Warnings
(Off
, Ifaces_Tag_List
);
2150 -- Start of processing for Build_Offset_To_Top_Functions
2153 -- Offset_To_Top_Functions are built only for derivations of types
2154 -- with discriminants that cover interface types.
2155 -- Nothing is needed either in case of virtual machines, since
2156 -- interfaces are handled directly by the VM.
2158 if not Is_Tagged_Type
(Rec_Type
)
2159 or else Etype
(Rec_Type
) = Rec_Type
2160 or else not Has_Discriminants
(Etype
(Rec_Type
))
2161 or else VM_Target
/= No_VM
2166 Collect_Interfaces_Info
2167 (Rec_Type
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
2169 -- For each interface type with secondary dispatch table we generate
2170 -- the Offset_To_Top_Functions (required to displace the pointer in
2171 -- interface conversions)
2173 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
2174 Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
2175 while Present
(Iface_Elmt
) loop
2177 -- If the interface is a parent of Rec_Type it shares the primary
2178 -- dispatch table and hence there is no need to build the function
2180 if not Is_Ancestor
(Node
(Iface_Elmt
), Rec_Type
) then
2181 Build_Offset_To_Top_Function
(Iface_Comp
=> Node
(Comp_Elmt
));
2184 Next_Elmt
(Iface_Elmt
);
2185 Next_Elmt
(Comp_Elmt
);
2187 end Build_Offset_To_Top_Functions
;
2189 --------------------------
2190 -- Build_Init_Procedure --
2191 --------------------------
2193 procedure Build_Init_Procedure
is
2194 Body_Node
: Node_Id
;
2195 Handled_Stmt_Node
: Node_Id
;
2196 Parameters
: List_Id
;
2197 Proc_Spec_Node
: Node_Id
;
2198 Body_Stmts
: List_Id
;
2199 Record_Extension_Node
: Node_Id
;
2200 Init_Tags_List
: List_Id
;
2203 Body_Stmts
:= New_List
;
2204 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
2205 Set_Ekind
(Proc_Id
, E_Procedure
);
2207 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
2208 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
2210 Parameters
:= Init_Formals
(Rec_Type
);
2211 Append_List_To
(Parameters
,
2212 Build_Discriminant_Formals
(Rec_Type
, True));
2214 -- For tagged types, we add a flag to indicate whether the routine
2215 -- is called to initialize a parent component in the init_proc of
2216 -- a type extension. If the flag is false, we do not set the tag
2217 -- because it has been set already in the extension.
2219 if Is_Tagged_Type
(Rec_Type
)
2220 and then not Is_CPP_Class
(Rec_Type
)
2223 Make_Defining_Identifier
(Loc
,
2224 Chars
=> New_Internal_Name
('P'));
2226 Append_To
(Parameters
,
2227 Make_Parameter_Specification
(Loc
,
2228 Defining_Identifier
=> Set_Tag
,
2229 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2230 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
2233 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
2234 Set_Specification
(Body_Node
, Proc_Spec_Node
);
2235 Set_Declarations
(Body_Node
, New_List
);
2237 if Parent_Subtype_Renaming_Discrims
then
2239 -- N is a Derived_Type_Definition that renames the parameters
2240 -- of the ancestor type. We initialize it by expanding our
2241 -- discriminants and call the ancestor _init_proc with a
2242 -- type-converted object
2244 Append_List_To
(Body_Stmts
,
2245 Build_Init_Call_Thru
(Parameters
));
2247 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
2248 Build_Discriminant_Assignments
(Body_Stmts
);
2250 if not Null_Present
(Type_Definition
(N
)) then
2251 Append_List_To
(Body_Stmts
,
2252 Build_Init_Statements
(
2253 Component_List
(Type_Definition
(N
))));
2257 -- N is a Derived_Type_Definition with a possible non-empty
2258 -- extension. The initialization of a type extension consists
2259 -- in the initialization of the components in the extension.
2261 Build_Discriminant_Assignments
(Body_Stmts
);
2263 Record_Extension_Node
:=
2264 Record_Extension_Part
(Type_Definition
(N
));
2266 if not Null_Present
(Record_Extension_Node
) then
2268 Stmts
: constant List_Id
:=
2269 Build_Init_Statements
(
2270 Component_List
(Record_Extension_Node
));
2273 -- The parent field must be initialized first because
2274 -- the offset of the new discriminants may depend on it
2276 Prepend_To
(Body_Stmts
, Remove_Head
(Stmts
));
2277 Append_List_To
(Body_Stmts
, Stmts
);
2282 -- Add here the assignment to instantiate the Tag
2284 -- The assignment corresponds to the code:
2286 -- _Init._Tag := Typ'Tag;
2288 -- Suppress the tag assignment when VM_Target because VM tags are
2289 -- represented implicitly in objects. It is also suppressed in case
2290 -- of CPP_Class types because in this case the tag is initialized in
2293 if Is_Tagged_Type
(Rec_Type
)
2294 and then not Is_CPP_Class
(Rec_Type
)
2295 and then VM_Target
= No_VM
2296 and then not No_Run_Time_Mode
2298 -- Initialize the primary tag
2300 Init_Tags_List
:= New_List
(
2301 Make_Assignment_Statement
(Loc
,
2303 Make_Selected_Component
(Loc
,
2304 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2306 New_Reference_To
(First_Tag_Component
(Rec_Type
), Loc
)),
2310 (Node
(First_Elmt
(Access_Disp_Table
(Rec_Type
))), Loc
)));
2312 -- Ada 2005 (AI-251): Initialize the secondary tags components
2313 -- located at fixed positions (tags whose position depends on
2314 -- variable size components are initialized later ---see below).
2316 if Ada_Version
>= Ada_05
2317 and then not Is_Interface
(Rec_Type
)
2318 and then Has_Interfaces
(Rec_Type
)
2322 Target
=> Make_Identifier
(Loc
, Name_uInit
),
2323 Stmts_List
=> Init_Tags_List
,
2324 Fixed_Comps
=> True,
2325 Variable_Comps
=> False);
2328 -- The tag must be inserted before the assignments to other
2329 -- components, because the initial value of the component may
2330 -- depend on the tag (eg. through a dispatching operation on
2331 -- an access to the current type). The tag assignment is not done
2332 -- when initializing the parent component of a type extension,
2333 -- because in that case the tag is set in the extension.
2335 -- Extensions of imported C++ classes add a final complication,
2336 -- because we cannot inhibit tag setting in the constructor for
2337 -- the parent. In that case we insert the tag initialization
2338 -- after the calls to initialize the parent.
2340 if not Is_CPP_Class
(Root_Type
(Rec_Type
)) then
2341 Prepend_To
(Body_Stmts
,
2342 Make_If_Statement
(Loc
,
2343 Condition
=> New_Occurrence_Of
(Set_Tag
, Loc
),
2344 Then_Statements
=> Init_Tags_List
));
2346 -- CPP_Class derivation: In this case the dispatch table of the
2347 -- parent was built in the C++ side and we copy the table of the
2348 -- parent to initialize the new dispatch table.
2355 -- We assume the first init_proc call is for the parent
2357 Nod
:= First
(Body_Stmts
);
2358 while Present
(Next
(Nod
))
2359 and then (Nkind
(Nod
) /= N_Procedure_Call_Statement
2360 or else not Is_Init_Proc
(Name
(Nod
)))
2366 -- ancestor_constructor (_init.parent);
2368 -- inherit_prim_ops (_init._tag, new_dt, num_prims);
2369 -- _init._tag := new_dt;
2372 Prepend_To
(Init_Tags_List
,
2373 Build_Inherit_Prims
(Loc
,
2376 Make_Selected_Component
(Loc
,
2378 Make_Identifier
(Loc
,
2379 Chars
=> Name_uInit
),
2382 (First_Tag_Component
(Rec_Type
), Loc
)),
2385 (Node
(First_Elmt
(Access_Disp_Table
(Rec_Type
))),
2389 (DT_Entry_Count
(First_Tag_Component
(Rec_Type
)))));
2392 Make_If_Statement
(Loc
,
2393 Condition
=> New_Occurrence_Of
(Set_Tag
, Loc
),
2394 Then_Statements
=> Init_Tags_List
));
2396 -- We have inherited table of the parent from the CPP side.
2397 -- Now we fill the slots associated with Ada primitives.
2398 -- This needs more work to avoid its execution each time
2399 -- an object is initialized???
2406 E
:= First_Elmt
(Primitive_Operations
(Rec_Type
));
2407 while Present
(E
) loop
2410 if not Is_Imported
(Prim
)
2411 and then Convention
(Prim
) = Convention_CPP
2412 and then not Present
(Interface_Alias
(Prim
))
2414 Register_Primitive
(Loc
,
2416 Ins_Nod
=> Last
(Init_Tags_List
));
2425 -- Ada 2005 (AI-251): Initialize the secondary tag components
2426 -- located at variable positions. We delay the generation of this
2427 -- code until here because the value of the attribute 'Position
2428 -- applied to variable size components of the parent type that
2429 -- depend on discriminants is only safely read at runtime after
2430 -- the parent components have been initialized.
2432 if Ada_Version
>= Ada_05
2433 and then not Is_Interface
(Rec_Type
)
2434 and then Has_Interfaces
(Rec_Type
)
2435 and then Has_Discriminants
(Etype
(Rec_Type
))
2436 and then Is_Variable_Size_Record
(Etype
(Rec_Type
))
2438 Init_Tags_List
:= New_List
;
2442 Target
=> Make_Identifier
(Loc
, Name_uInit
),
2443 Stmts_List
=> Init_Tags_List
,
2444 Fixed_Comps
=> False,
2445 Variable_Comps
=> True);
2447 if Is_Non_Empty_List
(Init_Tags_List
) then
2448 Append_List_To
(Body_Stmts
, Init_Tags_List
);
2453 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
2454 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
2455 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
2456 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
2458 if not Debug_Generated_Code
then
2459 Set_Debug_Info_Off
(Proc_Id
);
2462 -- Associate Init_Proc with type, and determine if the procedure
2463 -- is null (happens because of the Initialize_Scalars pragma case,
2464 -- where we have to generate a null procedure in case it is called
2465 -- by a client with Initialize_Scalars set). Such procedures have
2466 -- to be generated, but do not have to be called, so we mark them
2467 -- as null to suppress the call.
2469 Set_Init_Proc
(Rec_Type
, Proc_Id
);
2471 if List_Length
(Body_Stmts
) = 1
2472 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
2473 and then VM_Target
/= CLI_Target
2475 -- Even though the init proc may be null at this time it might get
2476 -- some stuff added to it later by the CIL backend, so always keep
2477 -- it when VM_Target = CLI_Target.
2479 Set_Is_Null_Init_Proc
(Proc_Id
);
2481 end Build_Init_Procedure
;
2483 ---------------------------
2484 -- Build_Init_Statements --
2485 ---------------------------
2487 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
2488 Check_List
: constant List_Id
:= New_List
;
2493 Statement_List
: List_Id
;
2498 Per_Object_Constraint_Components
: Boolean;
2500 function Has_Access_Constraint
(E
: Entity_Id
) return Boolean;
2501 -- Components with access discriminants that depend on the current
2502 -- instance must be initialized after all other components.
2504 ---------------------------
2505 -- Has_Access_Constraint --
2506 ---------------------------
2508 function Has_Access_Constraint
(E
: Entity_Id
) return Boolean is
2510 T
: constant Entity_Id
:= Etype
(E
);
2513 if Has_Per_Object_Constraint
(E
)
2514 and then Has_Discriminants
(T
)
2516 Disc
:= First_Discriminant
(T
);
2517 while Present
(Disc
) loop
2518 if Is_Access_Type
(Etype
(Disc
)) then
2522 Next_Discriminant
(Disc
);
2529 end Has_Access_Constraint
;
2531 -- Start of processing for Build_Init_Statements
2534 if Null_Present
(Comp_List
) then
2535 return New_List
(Make_Null_Statement
(Loc
));
2538 Statement_List
:= New_List
;
2540 -- Loop through components, skipping pragmas, in 2 steps. The first
2541 -- step deals with regular components. The second step deals with
2542 -- components have per object constraints, and no explicit initia-
2545 Per_Object_Constraint_Components
:= False;
2547 -- First step : regular components
2549 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
2550 while Present
(Decl
) loop
2553 (Subtype_Indication
(Component_Definition
(Decl
)), Check_List
);
2555 Id
:= Defining_Identifier
(Decl
);
2558 if Has_Access_Constraint
(Id
)
2559 and then No
(Expression
(Decl
))
2561 -- Skip processing for now and ask for a second pass
2563 Per_Object_Constraint_Components
:= True;
2566 -- Case of explicit initialization
2568 if Present
(Expression
(Decl
)) then
2569 Stmts
:= Build_Assignment
(Id
, Expression
(Decl
));
2571 -- Case of composite component with its own Init_Proc
2573 elsif not Is_Interface
(Typ
)
2574 and then Has_Non_Null_Base_Init_Proc
(Typ
)
2577 Build_Initialization_Call
2579 Make_Selected_Component
(Loc
,
2580 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2581 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
2583 In_Init_Proc
=> True,
2584 Enclos_Type
=> Rec_Type
,
2585 Discr_Map
=> Discr_Map
);
2587 Clean_Task_Names
(Typ
, Proc_Id
);
2589 -- Case of component needing simple initialization
2591 elsif Component_Needs_Simple_Initialization
(Typ
) then
2594 (Id
, Get_Simple_Init_Val
(Typ
, N
, Esize
(Id
)));
2596 -- Nothing needed for this case
2602 if Present
(Check_List
) then
2603 Append_List_To
(Statement_List
, Check_List
);
2606 if Present
(Stmts
) then
2608 -- Add the initialization of the record controller before
2609 -- the _Parent field is attached to it when the attachment
2610 -- can occur. It does not work to simply initialize the
2611 -- controller first: it must be initialized after the parent
2612 -- if the parent holds discriminants that can be used to
2613 -- compute the offset of the controller. We assume here that
2614 -- the last statement of the initialization call is the
2615 -- attachment of the parent (see Build_Initialization_Call)
2617 if Chars
(Id
) = Name_uController
2618 and then Rec_Type
/= Etype
(Rec_Type
)
2619 and then Has_Controlled_Component
(Etype
(Rec_Type
))
2620 and then Has_New_Controlled_Component
(Rec_Type
)
2621 and then Present
(Last
(Statement_List
))
2623 Insert_List_Before
(Last
(Statement_List
), Stmts
);
2625 Append_List_To
(Statement_List
, Stmts
);
2630 Next_Non_Pragma
(Decl
);
2633 if Per_Object_Constraint_Components
then
2635 -- Second pass: components with per-object constraints
2637 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
2638 while Present
(Decl
) loop
2640 Id
:= Defining_Identifier
(Decl
);
2643 if Has_Access_Constraint
(Id
)
2644 and then No
(Expression
(Decl
))
2646 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2647 Append_List_To
(Statement_List
,
2648 Build_Initialization_Call
(Loc
,
2649 Make_Selected_Component
(Loc
,
2650 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2651 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
2653 In_Init_Proc
=> True,
2654 Enclos_Type
=> Rec_Type
,
2655 Discr_Map
=> Discr_Map
));
2657 Clean_Task_Names
(Typ
, Proc_Id
);
2659 elsif Component_Needs_Simple_Initialization
(Typ
) then
2660 Append_List_To
(Statement_List
,
2662 (Id
, Get_Simple_Init_Val
(Typ
, N
, Esize
(Id
))));
2666 Next_Non_Pragma
(Decl
);
2670 -- Process the variant part
2672 if Present
(Variant_Part
(Comp_List
)) then
2673 Alt_List
:= New_List
;
2674 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2675 while Present
(Variant
) loop
2676 Loc
:= Sloc
(Variant
);
2677 Append_To
(Alt_List
,
2678 Make_Case_Statement_Alternative
(Loc
,
2680 New_Copy_List
(Discrete_Choices
(Variant
)),
2682 Build_Init_Statements
(Component_List
(Variant
))));
2683 Next_Non_Pragma
(Variant
);
2686 -- The expression of the case statement which is a reference
2687 -- to one of the discriminants is replaced by the appropriate
2688 -- formal parameter of the initialization procedure.
2690 Append_To
(Statement_List
,
2691 Make_Case_Statement
(Loc
,
2693 New_Reference_To
(Discriminal
(
2694 Entity
(Name
(Variant_Part
(Comp_List
)))), Loc
),
2695 Alternatives
=> Alt_List
));
2698 -- For a task record type, add the task create call and calls
2699 -- to bind any interrupt (signal) entries.
2701 if Is_Task_Record_Type
(Rec_Type
) then
2703 -- In the case of the restricted run time the ATCB has already
2704 -- been preallocated.
2706 if Restricted_Profile
then
2707 Append_To
(Statement_List
,
2708 Make_Assignment_Statement
(Loc
,
2709 Name
=> Make_Selected_Component
(Loc
,
2710 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2711 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2712 Expression
=> Make_Attribute_Reference
(Loc
,
2714 Make_Selected_Component
(Loc
,
2715 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2717 Make_Identifier
(Loc
, Name_uATCB
)),
2718 Attribute_Name
=> Name_Unchecked_Access
)));
2721 Append_To
(Statement_List
, Make_Task_Create_Call
(Rec_Type
));
2723 -- Generate the statements which map a string entry name to a
2724 -- task entry index. Note that the task may not have entries.
2726 if Entry_Names_OK
then
2727 Names
:= Build_Entry_Names
(Rec_Type
);
2729 if Present
(Names
) then
2730 Append_To
(Statement_List
, Names
);
2735 Task_Type
: constant Entity_Id
:=
2736 Corresponding_Concurrent_Type
(Rec_Type
);
2737 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
2738 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
2743 if Present
(Task_Def
) then
2744 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
2745 while Present
(Vis_Decl
) loop
2746 Loc
:= Sloc
(Vis_Decl
);
2748 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
2749 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
2752 Ent
:= Entity
(Name
(Vis_Decl
));
2754 if Ekind
(Ent
) = E_Entry
then
2755 Append_To
(Statement_List
,
2756 Make_Procedure_Call_Statement
(Loc
,
2757 Name
=> New_Reference_To
(
2758 RTE
(RE_Bind_Interrupt_To_Entry
), Loc
),
2759 Parameter_Associations
=> New_List
(
2760 Make_Selected_Component
(Loc
,
2762 Make_Identifier
(Loc
, Name_uInit
),
2764 Make_Identifier
(Loc
, Name_uTask_Id
)),
2765 Entry_Index_Expression
(
2766 Loc
, Ent
, Empty
, Task_Type
),
2767 Expression
(Vis_Decl
))));
2778 -- For a protected type, add statements generated by
2779 -- Make_Initialize_Protection.
2781 if Is_Protected_Record_Type
(Rec_Type
) then
2782 Append_List_To
(Statement_List
,
2783 Make_Initialize_Protection
(Rec_Type
));
2785 -- Generate the statements which map a string entry name to a
2786 -- protected entry index. Note that the protected type may not
2789 if Entry_Names_OK
then
2790 Names
:= Build_Entry_Names
(Rec_Type
);
2792 if Present
(Names
) then
2793 Append_To
(Statement_List
, Names
);
2798 -- If no initializations when generated for component declarations
2799 -- corresponding to this Statement_List, append a null statement
2800 -- to the Statement_List to make it a valid Ada tree.
2802 if Is_Empty_List
(Statement_List
) then
2803 Append
(New_Node
(N_Null_Statement
, Loc
), Statement_List
);
2806 return Statement_List
;
2809 when RE_Not_Available
=>
2811 end Build_Init_Statements
;
2813 -------------------------
2814 -- Build_Record_Checks --
2815 -------------------------
2817 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
2818 Subtype_Mark_Id
: Entity_Id
;
2821 if Nkind
(S
) = N_Subtype_Indication
then
2822 Find_Type
(Subtype_Mark
(S
));
2823 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
2825 -- Remaining processing depends on type
2827 case Ekind
(Subtype_Mark_Id
) is
2830 Constrain_Array
(S
, Check_List
);
2836 end Build_Record_Checks
;
2838 -------------------------------------------
2839 -- Component_Needs_Simple_Initialization --
2840 -------------------------------------------
2842 function Component_Needs_Simple_Initialization
2843 (T
: Entity_Id
) return Boolean
2847 Needs_Simple_Initialization
(T
)
2848 and then not Is_RTE
(T
, RE_Tag
)
2850 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
2852 and then not Is_RTE
(T
, RE_Interface_Tag
);
2853 end Component_Needs_Simple_Initialization
;
2855 ---------------------
2856 -- Constrain_Array --
2857 ---------------------
2859 procedure Constrain_Array
2861 Check_List
: List_Id
)
2863 C
: constant Node_Id
:= Constraint
(SI
);
2864 Number_Of_Constraints
: Nat
:= 0;
2869 T
:= Entity
(Subtype_Mark
(SI
));
2871 if Ekind
(T
) in Access_Kind
then
2872 T
:= Designated_Type
(T
);
2875 S
:= First
(Constraints
(C
));
2877 while Present
(S
) loop
2878 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
2882 -- In either case, the index constraint must provide a discrete
2883 -- range for each index of the array type and the type of each
2884 -- discrete range must be the same as that of the corresponding
2885 -- index. (RM 3.6.1)
2887 S
:= First
(Constraints
(C
));
2888 Index
:= First_Index
(T
);
2891 -- Apply constraints to each index type
2893 for J
in 1 .. Number_Of_Constraints
loop
2894 Constrain_Index
(Index
, S
, Check_List
);
2899 end Constrain_Array
;
2901 ---------------------
2902 -- Constrain_Index --
2903 ---------------------
2905 procedure Constrain_Index
2908 Check_List
: List_Id
)
2910 T
: constant Entity_Id
:= Etype
(Index
);
2913 if Nkind
(S
) = N_Range
then
2914 Process_Range_Expr_In_Decl
(S
, T
, Check_List
);
2916 end Constrain_Index
;
2918 --------------------------------------
2919 -- Parent_Subtype_Renaming_Discrims --
2920 --------------------------------------
2922 function Parent_Subtype_Renaming_Discrims
return Boolean is
2927 if Base_Type
(Pe
) /= Pe
then
2932 or else not Has_Discriminants
(Pe
)
2933 or else Is_Constrained
(Pe
)
2934 or else Is_Tagged_Type
(Pe
)
2939 -- If there are no explicit stored discriminants we have inherited
2940 -- the root type discriminants so far, so no renamings occurred.
2942 if First_Discriminant
(Pe
) = First_Stored_Discriminant
(Pe
) then
2946 -- Check if we have done some trivial renaming of the parent
2947 -- discriminants, i.e. something like
2949 -- type DT (X1,X2: int) is new PT (X1,X2);
2951 De
:= First_Discriminant
(Pe
);
2952 Dp
:= First_Discriminant
(Etype
(Pe
));
2954 while Present
(De
) loop
2955 pragma Assert
(Present
(Dp
));
2957 if Corresponding_Discriminant
(De
) /= Dp
then
2961 Next_Discriminant
(De
);
2962 Next_Discriminant
(Dp
);
2965 return Present
(Dp
);
2966 end Parent_Subtype_Renaming_Discrims
;
2968 ------------------------
2969 -- Requires_Init_Proc --
2970 ------------------------
2972 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
2973 Comp_Decl
: Node_Id
;
2978 -- Definitely do not need one if specifically suppressed
2980 if Suppress_Init_Proc
(Rec_Id
) then
2984 -- If it is a type derived from a type with unknown discriminants,
2985 -- we cannot build an initialization procedure for it.
2987 if Has_Unknown_Discriminants
(Rec_Id
) then
2991 -- Otherwise we need to generate an initialization procedure if
2992 -- Is_CPP_Class is False and at least one of the following applies:
2994 -- 1. Discriminants are present, since they need to be initialized
2995 -- with the appropriate discriminant constraint expressions.
2996 -- However, the discriminant of an unchecked union does not
2997 -- count, since the discriminant is not present.
2999 -- 2. The type is a tagged type, since the implicit Tag component
3000 -- needs to be initialized with a pointer to the dispatch table.
3002 -- 3. The type contains tasks
3004 -- 4. One or more components has an initial value
3006 -- 5. One or more components is for a type which itself requires
3007 -- an initialization procedure.
3009 -- 6. One or more components is a type that requires simple
3010 -- initialization (see Needs_Simple_Initialization), except
3011 -- that types Tag and Interface_Tag are excluded, since fields
3012 -- of these types are initialized by other means.
3014 -- 7. The type is the record type built for a task type (since at
3015 -- the very least, Create_Task must be called)
3017 -- 8. The type is the record type built for a protected type (since
3018 -- at least Initialize_Protection must be called)
3020 -- 9. The type is marked as a public entity. The reason we add this
3021 -- case (even if none of the above apply) is to properly handle
3022 -- Initialize_Scalars. If a package is compiled without an IS
3023 -- pragma, and the client is compiled with an IS pragma, then
3024 -- the client will think an initialization procedure is present
3025 -- and call it, when in fact no such procedure is required, but
3026 -- since the call is generated, there had better be a routine
3027 -- at the other end of the call, even if it does nothing!)
3029 -- Note: the reason we exclude the CPP_Class case is because in this
3030 -- case the initialization is performed in the C++ side.
3032 if Is_CPP_Class
(Rec_Id
) then
3035 elsif Is_Interface
(Rec_Id
) then
3038 elsif not Restriction_Active
(No_Initialize_Scalars
)
3039 and then Is_Public
(Rec_Id
)
3043 elsif (Has_Discriminants
(Rec_Id
)
3044 and then not Is_Unchecked_Union
(Rec_Id
))
3045 or else Is_Tagged_Type
(Rec_Id
)
3046 or else Is_Concurrent_Record_Type
(Rec_Id
)
3047 or else Has_Task
(Rec_Id
)
3052 Id
:= First_Component
(Rec_Id
);
3053 while Present
(Id
) loop
3054 Comp_Decl
:= Parent
(Id
);
3057 if Present
(Expression
(Comp_Decl
))
3058 or else Has_Non_Null_Base_Init_Proc
(Typ
)
3059 or else Component_Needs_Simple_Initialization
(Typ
)
3064 Next_Component
(Id
);
3068 end Requires_Init_Proc
;
3070 -- Start of processing for Build_Record_Init_Proc
3073 -- Check for value type, which means no initialization required
3075 Rec_Type
:= Defining_Identifier
(N
);
3077 if Is_Value_Type
(Rec_Type
) then
3081 -- This may be full declaration of a private type, in which case
3082 -- the visible entity is a record, and the private entity has been
3083 -- exchanged with it in the private part of the current package.
3084 -- The initialization procedure is built for the record type, which
3085 -- is retrievable from the private entity.
3087 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
3088 Rec_Type
:= Underlying_Type
(Rec_Type
);
3091 -- If there are discriminants, build the discriminant map to replace
3092 -- discriminants by their discriminals in complex bound expressions.
3093 -- These only arise for the corresponding records of protected types.
3095 if Is_Concurrent_Record_Type
(Rec_Type
)
3096 and then Has_Discriminants
(Rec_Type
)
3101 Disc
:= First_Discriminant
(Rec_Type
);
3102 while Present
(Disc
) loop
3103 Append_Elmt
(Disc
, Discr_Map
);
3104 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
3105 Next_Discriminant
(Disc
);
3110 -- Derived types that have no type extension can use the initialization
3111 -- procedure of their parent and do not need a procedure of their own.
3112 -- This is only correct if there are no representation clauses for the
3113 -- type or its parent, and if the parent has in fact been frozen so
3114 -- that its initialization procedure exists.
3116 if Is_Derived_Type
(Rec_Type
)
3117 and then not Is_Tagged_Type
(Rec_Type
)
3118 and then not Is_Unchecked_Union
(Rec_Type
)
3119 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
3120 and then not Parent_Subtype_Renaming_Discrims
3121 and then Has_Non_Null_Base_Init_Proc
(Etype
(Rec_Type
))
3123 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
3125 -- Otherwise if we need an initialization procedure, then build one,
3126 -- mark it as public and inlinable and as having a completion.
3128 elsif Requires_Init_Proc
(Rec_Type
)
3129 or else Is_Unchecked_Union
(Rec_Type
)
3132 Make_Defining_Identifier
(Loc
,
3133 Chars
=> Make_Init_Proc_Name
(Rec_Type
));
3135 -- If No_Default_Initialization restriction is active, then we don't
3136 -- want to build an init_proc, but we need to mark that an init_proc
3137 -- would be needed if this restriction was not active (so that we can
3138 -- detect attempts to call it), so set a dummy init_proc in place.
3140 if Restriction_Active
(No_Default_Initialization
) then
3141 Set_Init_Proc
(Rec_Type
, Proc_Id
);
3145 Build_Offset_To_Top_Functions
;
3146 Build_Init_Procedure
;
3147 Set_Is_Public
(Proc_Id
, Is_Public
(Pe
));
3149 -- The initialization of protected records is not worth inlining.
3150 -- In addition, when compiled for another unit for inlining purposes,
3151 -- it may make reference to entities that have not been elaborated
3152 -- yet. The initialization of controlled records contains a nested
3153 -- clean-up procedure that makes it impractical to inline as well,
3154 -- and leads to undefined symbols if inlined in a different unit.
3155 -- Similar considerations apply to task types.
3157 if not Is_Concurrent_Type
(Rec_Type
)
3158 and then not Has_Task
(Rec_Type
)
3159 and then not Controlled_Type
(Rec_Type
)
3161 Set_Is_Inlined
(Proc_Id
);
3164 Set_Is_Internal
(Proc_Id
);
3165 Set_Has_Completion
(Proc_Id
);
3167 if not Debug_Generated_Code
then
3168 Set_Debug_Info_Off
(Proc_Id
);
3172 Agg
: constant Node_Id
:=
3173 Build_Equivalent_Record_Aggregate
(Rec_Type
);
3175 procedure Collect_Itypes
(Comp
: Node_Id
);
3176 -- Generate references to itypes in the aggregate, because
3177 -- the first use of the aggregate may be in a nested scope.
3179 --------------------
3180 -- Collect_Itypes --
3181 --------------------
3183 procedure Collect_Itypes
(Comp
: Node_Id
) is
3186 Typ
: constant Entity_Id
:= Etype
(Comp
);
3189 if Is_Array_Type
(Typ
)
3190 and then Is_Itype
(Typ
)
3192 Ref
:= Make_Itype_Reference
(Loc
);
3193 Set_Itype
(Ref
, Typ
);
3194 Append_Freeze_Action
(Rec_Type
, Ref
);
3196 Ref
:= Make_Itype_Reference
(Loc
);
3197 Set_Itype
(Ref
, Etype
(First_Index
(Typ
)));
3198 Append_Freeze_Action
(Rec_Type
, Ref
);
3200 Sub_Aggr
:= First
(Expressions
(Comp
));
3202 -- Recurse on nested arrays
3204 while Present
(Sub_Aggr
) loop
3205 Collect_Itypes
(Sub_Aggr
);
3212 -- If there is a static initialization aggregate for the type,
3213 -- generate itype references for the types of its (sub)components,
3214 -- to prevent out-of-scope errors in the resulting tree.
3215 -- The aggregate may have been rewritten as a Raise node, in which
3216 -- case there are no relevant itypes.
3219 and then Nkind
(Agg
) = N_Aggregate
3221 Set_Static_Initialization
(Proc_Id
, Agg
);
3226 Comp
:= First
(Component_Associations
(Agg
));
3227 while Present
(Comp
) loop
3228 Collect_Itypes
(Expression
(Comp
));
3235 end Build_Record_Init_Proc
;
3237 ----------------------------
3238 -- Build_Slice_Assignment --
3239 ----------------------------
3241 -- Generates the following subprogram:
3244 -- (Source, Target : Array_Type,
3245 -- Left_Lo, Left_Hi : Index;
3246 -- Right_Lo, Right_Hi : Index;
3254 -- if Left_Hi < Left_Lo then
3267 -- Target (Li1) := Source (Ri1);
3270 -- exit when Li1 = Left_Lo;
3271 -- Li1 := Index'pred (Li1);
3272 -- Ri1 := Index'pred (Ri1);
3274 -- exit when Li1 = Left_Hi;
3275 -- Li1 := Index'succ (Li1);
3276 -- Ri1 := Index'succ (Ri1);
3281 procedure Build_Slice_Assignment
(Typ
: Entity_Id
) is
3282 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3283 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
3285 -- Build formal parameters of procedure
3287 Larray
: constant Entity_Id
:=
3288 Make_Defining_Identifier
3289 (Loc
, Chars
=> New_Internal_Name
('A'));
3290 Rarray
: constant Entity_Id
:=
3291 Make_Defining_Identifier
3292 (Loc
, Chars
=> New_Internal_Name
('R'));
3293 Left_Lo
: constant Entity_Id
:=
3294 Make_Defining_Identifier
3295 (Loc
, Chars
=> New_Internal_Name
('L'));
3296 Left_Hi
: constant Entity_Id
:=
3297 Make_Defining_Identifier
3298 (Loc
, Chars
=> New_Internal_Name
('L'));
3299 Right_Lo
: constant Entity_Id
:=
3300 Make_Defining_Identifier
3301 (Loc
, Chars
=> New_Internal_Name
('R'));
3302 Right_Hi
: constant Entity_Id
:=
3303 Make_Defining_Identifier
3304 (Loc
, Chars
=> New_Internal_Name
('R'));
3305 Rev
: constant Entity_Id
:=
3306 Make_Defining_Identifier
3307 (Loc
, Chars
=> New_Internal_Name
('D'));
3308 Proc_Name
: constant Entity_Id
:=
3309 Make_Defining_Identifier
(Loc
,
3310 Chars
=> Make_TSS_Name
(Typ
, TSS_Slice_Assign
));
3312 Lnn
: constant Entity_Id
:=
3313 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
3314 Rnn
: constant Entity_Id
:=
3315 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3316 -- Subscripts for left and right sides
3323 -- Build declarations for indices
3328 Make_Object_Declaration
(Loc
,
3329 Defining_Identifier
=> Lnn
,
3330 Object_Definition
=>
3331 New_Occurrence_Of
(Index
, Loc
)));
3334 Make_Object_Declaration
(Loc
,
3335 Defining_Identifier
=> Rnn
,
3336 Object_Definition
=>
3337 New_Occurrence_Of
(Index
, Loc
)));
3341 -- Build test for empty slice case
3344 Make_If_Statement
(Loc
,
3347 Left_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
),
3348 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
)),
3349 Then_Statements
=> New_List
(Make_Simple_Return_Statement
(Loc
))));
3351 -- Build initializations for indices
3354 F_Init
: constant List_Id
:= New_List
;
3355 B_Init
: constant List_Id
:= New_List
;
3359 Make_Assignment_Statement
(Loc
,
3360 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3361 Expression
=> New_Occurrence_Of
(Left_Lo
, Loc
)));
3364 Make_Assignment_Statement
(Loc
,
3365 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
3366 Expression
=> New_Occurrence_Of
(Right_Lo
, Loc
)));
3369 Make_Assignment_Statement
(Loc
,
3370 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3371 Expression
=> New_Occurrence_Of
(Left_Hi
, Loc
)));
3374 Make_Assignment_Statement
(Loc
,
3375 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
3376 Expression
=> New_Occurrence_Of
(Right_Hi
, Loc
)));
3379 Make_If_Statement
(Loc
,
3380 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
3381 Then_Statements
=> B_Init
,
3382 Else_Statements
=> F_Init
));
3385 -- Now construct the assignment statement
3388 Make_Loop_Statement
(Loc
,
3389 Statements
=> New_List
(
3390 Make_Assignment_Statement
(Loc
,
3392 Make_Indexed_Component
(Loc
,
3393 Prefix
=> New_Occurrence_Of
(Larray
, Loc
),
3394 Expressions
=> New_List
(New_Occurrence_Of
(Lnn
, Loc
))),
3396 Make_Indexed_Component
(Loc
,
3397 Prefix
=> New_Occurrence_Of
(Rarray
, Loc
),
3398 Expressions
=> New_List
(New_Occurrence_Of
(Rnn
, Loc
))))),
3399 End_Label
=> Empty
);
3401 -- Build the exit condition and increment/decrement statements
3404 F_Ass
: constant List_Id
:= New_List
;
3405 B_Ass
: constant List_Id
:= New_List
;
3409 Make_Exit_Statement
(Loc
,
3412 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3413 Right_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
))));
3416 Make_Assignment_Statement
(Loc
,
3417 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3419 Make_Attribute_Reference
(Loc
,
3421 New_Occurrence_Of
(Index
, Loc
),
3422 Attribute_Name
=> Name_Succ
,
3423 Expressions
=> New_List
(
3424 New_Occurrence_Of
(Lnn
, Loc
)))));
3427 Make_Assignment_Statement
(Loc
,
3428 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
3430 Make_Attribute_Reference
(Loc
,
3432 New_Occurrence_Of
(Index
, Loc
),
3433 Attribute_Name
=> Name_Succ
,
3434 Expressions
=> New_List
(
3435 New_Occurrence_Of
(Rnn
, Loc
)))));
3438 Make_Exit_Statement
(Loc
,
3441 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3442 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
))));
3445 Make_Assignment_Statement
(Loc
,
3446 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3448 Make_Attribute_Reference
(Loc
,
3450 New_Occurrence_Of
(Index
, Loc
),
3451 Attribute_Name
=> Name_Pred
,
3452 Expressions
=> New_List
(
3453 New_Occurrence_Of
(Lnn
, Loc
)))));
3456 Make_Assignment_Statement
(Loc
,
3457 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
3459 Make_Attribute_Reference
(Loc
,
3461 New_Occurrence_Of
(Index
, Loc
),
3462 Attribute_Name
=> Name_Pred
,
3463 Expressions
=> New_List
(
3464 New_Occurrence_Of
(Rnn
, Loc
)))));
3466 Append_To
(Statements
(Loops
),
3467 Make_If_Statement
(Loc
,
3468 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
3469 Then_Statements
=> B_Ass
,
3470 Else_Statements
=> F_Ass
));
3473 Append_To
(Stats
, Loops
);
3477 Formals
: List_Id
:= New_List
;
3480 Formals
:= New_List
(
3481 Make_Parameter_Specification
(Loc
,
3482 Defining_Identifier
=> Larray
,
3483 Out_Present
=> True,
3485 New_Reference_To
(Base_Type
(Typ
), Loc
)),
3487 Make_Parameter_Specification
(Loc
,
3488 Defining_Identifier
=> Rarray
,
3490 New_Reference_To
(Base_Type
(Typ
), Loc
)),
3492 Make_Parameter_Specification
(Loc
,
3493 Defining_Identifier
=> Left_Lo
,
3495 New_Reference_To
(Index
, Loc
)),
3497 Make_Parameter_Specification
(Loc
,
3498 Defining_Identifier
=> Left_Hi
,
3500 New_Reference_To
(Index
, Loc
)),
3502 Make_Parameter_Specification
(Loc
,
3503 Defining_Identifier
=> Right_Lo
,
3505 New_Reference_To
(Index
, Loc
)),
3507 Make_Parameter_Specification
(Loc
,
3508 Defining_Identifier
=> Right_Hi
,
3510 New_Reference_To
(Index
, Loc
)));
3513 Make_Parameter_Specification
(Loc
,
3514 Defining_Identifier
=> Rev
,
3516 New_Reference_To
(Standard_Boolean
, Loc
)));
3519 Make_Procedure_Specification
(Loc
,
3520 Defining_Unit_Name
=> Proc_Name
,
3521 Parameter_Specifications
=> Formals
);
3524 Make_Subprogram_Body
(Loc
,
3525 Specification
=> Spec
,
3526 Declarations
=> Decls
,
3527 Handled_Statement_Sequence
=>
3528 Make_Handled_Sequence_Of_Statements
(Loc
,
3529 Statements
=> Stats
)));
3532 Set_TSS
(Typ
, Proc_Name
);
3533 Set_Is_Pure
(Proc_Name
);
3534 end Build_Slice_Assignment
;
3536 ------------------------------------
3537 -- Build_Variant_Record_Equality --
3538 ------------------------------------
3542 -- function _Equality (X, Y : T) return Boolean is
3544 -- -- Compare discriminants
3546 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
3550 -- -- Compare components
3552 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
3556 -- -- Compare variant part
3560 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
3565 -- if False or else X.Cn /= Y.Cn then
3573 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
3574 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3576 F
: constant Entity_Id
:=
3577 Make_Defining_Identifier
(Loc
,
3578 Chars
=> Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
3580 X
: constant Entity_Id
:=
3581 Make_Defining_Identifier
(Loc
,
3584 Y
: constant Entity_Id
:=
3585 Make_Defining_Identifier
(Loc
,
3588 Def
: constant Node_Id
:= Parent
(Typ
);
3589 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
3590 Stmts
: constant List_Id
:= New_List
;
3591 Pspecs
: constant List_Id
:= New_List
;
3594 -- Derived Unchecked_Union types no longer inherit the equality function
3597 if Is_Derived_Type
(Typ
)
3598 and then not Is_Unchecked_Union
(Typ
)
3599 and then not Has_New_Non_Standard_Rep
(Typ
)
3602 Parent_Eq
: constant Entity_Id
:=
3603 TSS
(Root_Type
(Typ
), TSS_Composite_Equality
);
3606 if Present
(Parent_Eq
) then
3607 Copy_TSS
(Parent_Eq
, Typ
);
3614 Make_Subprogram_Body
(Loc
,
3616 Make_Function_Specification
(Loc
,
3617 Defining_Unit_Name
=> F
,
3618 Parameter_Specifications
=> Pspecs
,
3619 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
3620 Declarations
=> New_List
,
3621 Handled_Statement_Sequence
=>
3622 Make_Handled_Sequence_Of_Statements
(Loc
,
3623 Statements
=> Stmts
)));
3626 Make_Parameter_Specification
(Loc
,
3627 Defining_Identifier
=> X
,
3628 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
3631 Make_Parameter_Specification
(Loc
,
3632 Defining_Identifier
=> Y
,
3633 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
3635 -- Unchecked_Unions require additional machinery to support equality.
3636 -- Two extra parameters (A and B) are added to the equality function
3637 -- parameter list in order to capture the inferred values of the
3638 -- discriminants in later calls.
3640 if Is_Unchecked_Union
(Typ
) then
3642 Discr_Type
: constant Node_Id
:= Etype
(First_Discriminant
(Typ
));
3644 A
: constant Node_Id
:=
3645 Make_Defining_Identifier
(Loc
,
3648 B
: constant Node_Id
:=
3649 Make_Defining_Identifier
(Loc
,
3653 -- Add A and B to the parameter list
3656 Make_Parameter_Specification
(Loc
,
3657 Defining_Identifier
=> A
,
3658 Parameter_Type
=> New_Reference_To
(Discr_Type
, Loc
)));
3661 Make_Parameter_Specification
(Loc
,
3662 Defining_Identifier
=> B
,
3663 Parameter_Type
=> New_Reference_To
(Discr_Type
, Loc
)));
3665 -- Generate the following header code to compare the inferred
3673 Make_If_Statement
(Loc
,
3676 Left_Opnd
=> New_Reference_To
(A
, Loc
),
3677 Right_Opnd
=> New_Reference_To
(B
, Loc
)),
3678 Then_Statements
=> New_List
(
3679 Make_Simple_Return_Statement
(Loc
,
3680 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3682 -- Generate component-by-component comparison. Note that we must
3683 -- propagate one of the inferred discriminant formals to act as
3684 -- the case statement switch.
3686 Append_List_To
(Stmts
,
3687 Make_Eq_Case
(Typ
, Comps
, A
));
3691 -- Normal case (not unchecked union)
3696 Discriminant_Specifications
(Def
)));
3698 Append_List_To
(Stmts
,
3699 Make_Eq_Case
(Typ
, Comps
));
3703 Make_Simple_Return_Statement
(Loc
,
3704 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
3709 if not Debug_Generated_Code
then
3710 Set_Debug_Info_Off
(F
);
3712 end Build_Variant_Record_Equality
;
3714 -----------------------------
3715 -- Check_Stream_Attributes --
3716 -----------------------------
3718 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
3720 Par_Read
: constant Boolean :=
3721 Stream_Attribute_Available
(Typ
, TSS_Stream_Read
)
3722 and then not Has_Specified_Stream_Read
(Typ
);
3723 Par_Write
: constant Boolean :=
3724 Stream_Attribute_Available
(Typ
, TSS_Stream_Write
)
3725 and then not Has_Specified_Stream_Write
(Typ
);
3727 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
);
3728 -- Check that Comp has a user-specified Nam stream attribute
3734 procedure Check_Attr
(Nam
: Name_Id
; TSS_Nam
: TSS_Name_Type
) is
3736 if not Stream_Attribute_Available
(Etype
(Comp
), TSS_Nam
) then
3737 Error_Msg_Name_1
:= Nam
;
3739 ("|component& in limited extension must have% attribute", Comp
);
3743 -- Start of processing for Check_Stream_Attributes
3746 if Par_Read
or else Par_Write
then
3747 Comp
:= First_Component
(Typ
);
3748 while Present
(Comp
) loop
3749 if Comes_From_Source
(Comp
)
3750 and then Original_Record_Component
(Comp
) = Comp
3751 and then Is_Limited_Type
(Etype
(Comp
))
3754 Check_Attr
(Name_Read
, TSS_Stream_Read
);
3758 Check_Attr
(Name_Write
, TSS_Stream_Write
);
3762 Next_Component
(Comp
);
3765 end Check_Stream_Attributes
;
3767 -----------------------------
3768 -- Expand_Record_Extension --
3769 -----------------------------
3771 -- Add a field _parent at the beginning of the record extension. This is
3772 -- used to implement inheritance. Here are some examples of expansion:
3774 -- 1. no discriminants
3775 -- type T2 is new T1 with null record;
3777 -- type T2 is new T1 with record
3781 -- 2. renamed discriminants
3782 -- type T2 (B, C : Int) is new T1 (A => B) with record
3783 -- _Parent : T1 (A => B);
3787 -- 3. inherited discriminants
3788 -- type T2 is new T1 with record -- discriminant A inherited
3789 -- _Parent : T1 (A);
3793 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
3794 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
3795 Loc
: constant Source_Ptr
:= Sloc
(Def
);
3796 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
3797 Par_Subtype
: Entity_Id
;
3798 Comp_List
: Node_Id
;
3799 Comp_Decl
: Node_Id
;
3802 List_Constr
: constant List_Id
:= New_List
;
3805 -- Expand_Record_Extension is called directly from the semantics, so
3806 -- we must check to see whether expansion is active before proceeding
3808 if not Expander_Active
then
3812 -- This may be a derivation of an untagged private type whose full
3813 -- view is tagged, in which case the Derived_Type_Definition has no
3814 -- extension part. Build an empty one now.
3816 if No
(Rec_Ext_Part
) then
3818 Make_Record_Definition
(Loc
,
3820 Component_List
=> Empty
,
3821 Null_Present
=> True);
3823 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
3824 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
3827 Comp_List
:= Component_List
(Rec_Ext_Part
);
3829 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
3831 -- If the derived type inherits its discriminants the type of the
3832 -- _parent field must be constrained by the inherited discriminants
3834 if Has_Discriminants
(T
)
3835 and then Nkind
(Indic
) /= N_Subtype_Indication
3836 and then not Is_Constrained
(Entity
(Indic
))
3838 D
:= First_Discriminant
(T
);
3839 while Present
(D
) loop
3840 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
3841 Next_Discriminant
(D
);
3846 Make_Subtype_Indication
(Loc
,
3847 Subtype_Mark
=> New_Reference_To
(Entity
(Indic
), Loc
),
3849 Make_Index_Or_Discriminant_Constraint
(Loc
,
3850 Constraints
=> List_Constr
)),
3853 -- Otherwise the original subtype_indication is just what is needed
3856 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
3859 Set_Parent_Subtype
(T
, Par_Subtype
);
3862 Make_Component_Declaration
(Loc
,
3863 Defining_Identifier
=> Parent_N
,
3864 Component_Definition
=>
3865 Make_Component_Definition
(Loc
,
3866 Aliased_Present
=> False,
3867 Subtype_Indication
=> New_Reference_To
(Par_Subtype
, Loc
)));
3869 if Null_Present
(Rec_Ext_Part
) then
3870 Set_Component_List
(Rec_Ext_Part
,
3871 Make_Component_List
(Loc
,
3872 Component_Items
=> New_List
(Comp_Decl
),
3873 Variant_Part
=> Empty
,
3874 Null_Present
=> False));
3875 Set_Null_Present
(Rec_Ext_Part
, False);
3877 elsif Null_Present
(Comp_List
)
3878 or else Is_Empty_List
(Component_Items
(Comp_List
))
3880 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3881 Set_Null_Present
(Comp_List
, False);
3884 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
3887 Analyze
(Comp_Decl
);
3888 end Expand_Record_Extension
;
3890 ------------------------------------
3891 -- Expand_N_Full_Type_Declaration --
3892 ------------------------------------
3894 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
3895 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3896 B_Id
: constant Entity_Id
:= Base_Type
(Def_Id
);
3900 procedure Build_Master
(Def_Id
: Entity_Id
);
3901 -- Create the master associated with Def_Id
3907 procedure Build_Master
(Def_Id
: Entity_Id
) is
3909 -- Anonymous access types are created for the components of the
3910 -- record parameter for an entry declaration. No master is created
3913 if Has_Task
(Designated_Type
(Def_Id
))
3914 and then Comes_From_Source
(N
)
3916 Build_Master_Entity
(Def_Id
);
3917 Build_Master_Renaming
(Parent
(Def_Id
), Def_Id
);
3919 -- Create a class-wide master because a Master_Id must be generated
3920 -- for access-to-limited-class-wide types whose root may be extended
3921 -- with task components, and for access-to-limited-interfaces because
3922 -- they can be used to reference tasks implementing such interface.
3924 elsif Is_Class_Wide_Type
(Designated_Type
(Def_Id
))
3925 and then (Is_Limited_Type
(Designated_Type
(Def_Id
))
3927 (Is_Interface
(Designated_Type
(Def_Id
))
3929 Is_Limited_Interface
(Designated_Type
(Def_Id
))))
3930 and then Tasking_Allowed
3932 -- Do not create a class-wide master for types whose convention is
3933 -- Java since these types cannot embed Ada tasks anyway. Note that
3934 -- the following test cannot catch the following case:
3936 -- package java.lang.Object is
3937 -- type Typ is tagged limited private;
3938 -- type Ref is access all Typ'Class;
3940 -- type Typ is tagged limited ...;
3941 -- pragma Convention (Typ, Java)
3944 -- Because the convention appears after we have done the
3945 -- processing for type Ref.
3947 and then Convention
(Designated_Type
(Def_Id
)) /= Convention_Java
3948 and then Convention
(Designated_Type
(Def_Id
)) /= Convention_CIL
3950 Build_Class_Wide_Master
(Def_Id
);
3954 -- Start of processing for Expand_N_Full_Type_Declaration
3957 if Is_Access_Type
(Def_Id
) then
3958 Build_Master
(Def_Id
);
3960 if Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
3961 Expand_Access_Protected_Subprogram_Type
(N
);
3964 elsif Ada_Version
>= Ada_05
3965 and then Is_Array_Type
(Def_Id
)
3966 and then Is_Access_Type
(Component_Type
(Def_Id
))
3967 and then Ekind
(Component_Type
(Def_Id
)) = E_Anonymous_Access_Type
3969 Build_Master
(Component_Type
(Def_Id
));
3971 elsif Has_Task
(Def_Id
) then
3972 Expand_Previous_Access_Type
(Def_Id
);
3974 elsif Ada_Version
>= Ada_05
3976 (Is_Record_Type
(Def_Id
)
3977 or else (Is_Array_Type
(Def_Id
)
3978 and then Is_Record_Type
(Component_Type
(Def_Id
))))
3986 -- Look for the first anonymous access type component
3988 if Is_Array_Type
(Def_Id
) then
3989 Comp
:= First_Entity
(Component_Type
(Def_Id
));
3991 Comp
:= First_Entity
(Def_Id
);
3994 while Present
(Comp
) loop
3995 Typ
:= Etype
(Comp
);
3997 exit when Is_Access_Type
(Typ
)
3998 and then Ekind
(Typ
) = E_Anonymous_Access_Type
;
4003 -- If found we add a renaming declaration of master_id and we
4004 -- associate it to each anonymous access type component. Do
4005 -- nothing if the access type already has a master. This will be
4006 -- the case if the array type is the packed array created for a
4007 -- user-defined array type T, where the master_id is created when
4008 -- expanding the declaration for T.
4011 and then Ekind
(Typ
) = E_Anonymous_Access_Type
4012 and then not Restriction_Active
(No_Task_Hierarchy
)
4013 and then No
(Master_Id
(Typ
))
4015 -- Do not consider run-times with no tasking support
4017 and then RTE_Available
(RE_Current_Master
)
4018 and then Has_Task
(Non_Limited_Designated_Type
(Typ
))
4020 Build_Master_Entity
(Def_Id
);
4021 M_Id
:= Build_Master_Renaming
(N
, Def_Id
);
4023 if Is_Array_Type
(Def_Id
) then
4024 Comp
:= First_Entity
(Component_Type
(Def_Id
));
4026 Comp
:= First_Entity
(Def_Id
);
4029 while Present
(Comp
) loop
4030 Typ
:= Etype
(Comp
);
4032 if Is_Access_Type
(Typ
)
4033 and then Ekind
(Typ
) = E_Anonymous_Access_Type
4035 Set_Master_Id
(Typ
, M_Id
);
4044 Par_Id
:= Etype
(B_Id
);
4046 -- The parent type is private then we need to inherit any TSS operations
4047 -- from the full view.
4049 if Ekind
(Par_Id
) in Private_Kind
4050 and then Present
(Full_View
(Par_Id
))
4052 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
4055 if Nkind
(Type_Definition
(Original_Node
(N
))) =
4056 N_Derived_Type_Definition
4057 and then not Is_Tagged_Type
(Def_Id
)
4058 and then Present
(Freeze_Node
(Par_Id
))
4059 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
4061 Ensure_Freeze_Node
(B_Id
);
4062 FN
:= Freeze_Node
(B_Id
);
4064 if No
(TSS_Elist
(FN
)) then
4065 Set_TSS_Elist
(FN
, New_Elmt_List
);
4069 T_E
: constant Elist_Id
:= TSS_Elist
(FN
);
4073 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
4074 while Present
(Elmt
) loop
4075 if Chars
(Node
(Elmt
)) /= Name_uInit
then
4076 Append_Elmt
(Node
(Elmt
), T_E
);
4082 -- If the derived type itself is private with a full view, then
4083 -- associate the full view with the inherited TSS_Elist as well.
4085 if Ekind
(B_Id
) in Private_Kind
4086 and then Present
(Full_View
(B_Id
))
4088 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
4090 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
4094 end Expand_N_Full_Type_Declaration
;
4096 ---------------------------------
4097 -- Expand_N_Object_Declaration --
4098 ---------------------------------
4100 -- First we do special processing for objects of a tagged type where this
4101 -- is the point at which the type is frozen. The creation of the dispatch
4102 -- table and the initialization procedure have to be deferred to this
4103 -- point, since we reference previously declared primitive subprograms.
4105 -- For all types, we call an initialization procedure if there is one
4107 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
4108 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
4109 Expr
: constant Node_Id
:= Expression
(N
);
4110 Loc
: constant Source_Ptr
:= Sloc
(N
);
4111 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
4112 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
4116 BIP_Call
: Boolean := False;
4118 Init_After
: Node_Id
:= N
;
4119 -- Node after which the init proc call is to be inserted. This is
4120 -- normally N, except for the case of a shared passive variable, in
4121 -- which case the init proc call must be inserted only after the bodies
4122 -- of the shared variable procedures have been seen.
4125 -- Don't do anything for deferred constants. All proper actions will
4126 -- be expanded during the full declaration.
4128 if No
(Expr
) and Constant_Present
(N
) then
4132 -- Force construction of dispatch tables of library level tagged types
4134 if VM_Target
= No_VM
4135 and then Static_Dispatch_Tables
4136 and then Is_Library_Level_Entity
(Def_Id
)
4137 and then Is_Library_Level_Tagged_Type
(Base_Typ
)
4138 and then (Ekind
(Base_Typ
) = E_Record_Type
4139 or else Ekind
(Base_Typ
) = E_Protected_Type
4140 or else Ekind
(Base_Typ
) = E_Task_Type
)
4141 and then not Has_Dispatch_Table
(Base_Typ
)
4144 New_Nodes
: List_Id
:= No_List
;
4147 if Is_Concurrent_Type
(Base_Typ
) then
4148 New_Nodes
:= Make_DT
(Corresponding_Record_Type
(Base_Typ
), N
);
4150 New_Nodes
:= Make_DT
(Base_Typ
, N
);
4153 if not Is_Empty_List
(New_Nodes
) then
4154 Insert_List_Before
(N
, New_Nodes
);
4159 -- Make shared memory routines for shared passive variable
4161 if Is_Shared_Passive
(Def_Id
) then
4162 Init_After
:= Make_Shared_Var_Procs
(N
);
4165 -- If tasks being declared, make sure we have an activation chain
4166 -- defined for the tasks (has no effect if we already have one), and
4167 -- also that a Master variable is established and that the appropriate
4168 -- enclosing construct is established as a task master.
4170 if Has_Task
(Typ
) then
4171 Build_Activation_Chain_Entity
(N
);
4172 Build_Master_Entity
(Def_Id
);
4175 -- Build a list controller for declarations where the type is anonymous
4176 -- access and the designated type is controlled. Only declarations from
4177 -- source files receive such controllers in order to provide the same
4178 -- lifespan for any potential coextensions that may be associated with
4179 -- the object. Finalization lists of internal controlled anonymous
4180 -- access objects are already handled in Expand_N_Allocator.
4182 if Comes_From_Source
(N
)
4183 and then Ekind
(Typ
) = E_Anonymous_Access_Type
4184 and then Is_Controlled
(Directly_Designated_Type
(Typ
))
4185 and then No
(Associated_Final_Chain
(Typ
))
4187 Build_Final_List
(N
, Typ
);
4190 -- Default initialization required, and no expression present
4194 -- Expand Initialize call for controlled objects. One may wonder why
4195 -- the Initialize Call is not done in the regular Init procedure
4196 -- attached to the record type. That's because the init procedure is
4197 -- recursively called on each component, including _Parent, thus the
4198 -- Init call for a controlled object would generate not only one
4199 -- Initialize call as it is required but one for each ancestor of
4200 -- its type. This processing is suppressed if No_Initialization set.
4202 if not Controlled_Type
(Typ
)
4203 or else No_Initialization
(N
)
4207 elsif not Abort_Allowed
4208 or else not Comes_From_Source
(N
)
4210 Insert_Actions_After
(Init_After
,
4212 Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
4213 Typ
=> Base_Type
(Typ
),
4214 Flist_Ref
=> Find_Final_List
(Def_Id
),
4215 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
4220 -- We need to protect the initialize call
4224 -- Initialize (...);
4226 -- Undefer_Abort.all;
4229 -- ??? this won't protect the initialize call for controlled
4230 -- components which are part of the init proc, so this block
4231 -- should probably also contain the call to _init_proc but this
4232 -- requires some code reorganization...
4235 L
: constant List_Id
:=
4237 (Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
4238 Typ
=> Base_Type
(Typ
),
4239 Flist_Ref
=> Find_Final_List
(Def_Id
),
4240 With_Attach
=> Make_Integer_Literal
(Loc
, 1));
4242 Blk
: constant Node_Id
:=
4243 Make_Block_Statement
(Loc
,
4244 Handled_Statement_Sequence
=>
4245 Make_Handled_Sequence_Of_Statements
(Loc
, L
));
4248 Prepend_To
(L
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
4249 Set_At_End_Proc
(Handled_Statement_Sequence
(Blk
),
4250 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
4251 Insert_Actions_After
(Init_After
, New_List
(Blk
));
4252 Expand_At_End_Handler
4253 (Handled_Statement_Sequence
(Blk
), Entity
(Identifier
(Blk
)));
4257 -- Call type initialization procedure if there is one. We build the
4258 -- call and put it immediately after the object declaration, so that
4259 -- it will be expanded in the usual manner. Note that this will
4260 -- result in proper handling of defaulted discriminants.
4262 -- Need call if there is a base init proc
4264 if Has_Non_Null_Base_Init_Proc
(Typ
)
4266 -- Suppress call if No_Initialization set on declaration
4268 and then not No_Initialization
(N
)
4270 -- Suppress call for special case of value type for VM
4272 and then not Is_Value_Type
(Typ
)
4274 -- Suppress call if Suppress_Init_Proc set on the type. This is
4275 -- needed for the derived type case, where Suppress_Initialization
4276 -- may be set for the derived type, even if there is an init proc
4277 -- defined for the root type.
4279 and then not Suppress_Init_Proc
(Typ
)
4281 -- Return without initializing when No_Default_Initialization
4282 -- applies. Note that the actual restriction check occurs later,
4283 -- when the object is frozen, because we don't know yet whether
4284 -- the object is imported, which is a case where the check does
4287 if Restriction_Active
(No_Default_Initialization
) then
4291 -- The call to the initialization procedure does NOT freeze the
4292 -- object being initialized. This is because the call is not a
4293 -- source level call. This works fine, because the only possible
4294 -- statements depending on freeze status that can appear after the
4295 -- _Init call are rep clauses which can safely appear after actual
4296 -- references to the object.
4298 Id_Ref
:= New_Reference_To
(Def_Id
, Loc
);
4299 Set_Must_Not_Freeze
(Id_Ref
);
4300 Set_Assignment_OK
(Id_Ref
);
4303 Init_Expr
: constant Node_Id
:=
4304 Static_Initialization
(Base_Init_Proc
(Typ
));
4306 if Present
(Init_Expr
) then
4308 (N
, New_Copy_Tree
(Init_Expr
, New_Scope
=> Current_Scope
));
4311 Initialization_Warning
(Id_Ref
);
4313 Insert_Actions_After
(Init_After
,
4314 Build_Initialization_Call
(Loc
, Id_Ref
, Typ
));
4318 -- If simple initialization is required, then set an appropriate
4319 -- simple initialization expression in place. This special
4320 -- initialization is required even though No_Init_Flag is present,
4321 -- but is not needed if there was an explicit initialization.
4323 -- An internally generated temporary needs no initialization because
4324 -- it will be assigned subsequently. In particular, there is no point
4325 -- in applying Initialize_Scalars to such a temporary.
4327 elsif Needs_Simple_Initialization
(Typ
)
4328 and then not Is_Internal
(Def_Id
)
4329 and then not Has_Init_Expression
(N
)
4331 Set_No_Initialization
(N
, False);
4332 Set_Expression
(N
, Get_Simple_Init_Val
(Typ
, N
, Esize
(Def_Id
)));
4333 Analyze_And_Resolve
(Expression
(N
), Typ
);
4336 -- Generate attribute for Persistent_BSS if needed
4338 if Persistent_BSS_Mode
4339 and then Comes_From_Source
(N
)
4340 and then Is_Potentially_Persistent_Type
(Typ
)
4341 and then not Has_Init_Expression
(N
)
4342 and then Is_Library_Level_Entity
(Def_Id
)
4348 Make_Linker_Section_Pragma
4349 (Def_Id
, Sloc
(N
), ".persistent.bss");
4350 Insert_After
(N
, Prag
);
4355 -- If access type, then we know it is null if not initialized
4357 if Is_Access_Type
(Typ
) then
4358 Set_Is_Known_Null
(Def_Id
);
4361 -- Explicit initialization present
4364 -- Obtain actual expression from qualified expression
4366 if Nkind
(Expr
) = N_Qualified_Expression
then
4367 Expr_Q
:= Expression
(Expr
);
4372 -- When we have the appropriate type of aggregate in the expression
4373 -- (it has been determined during analysis of the aggregate by
4374 -- setting the delay flag), let's perform in place assignment and
4375 -- thus avoid creating a temporary.
4377 if Is_Delayed_Aggregate
(Expr_Q
) then
4378 Convert_Aggr_In_Object_Decl
(N
);
4381 -- Ada 2005 (AI-318-02): If the initialization expression is a
4382 -- call to a build-in-place function, then access to the declared
4383 -- object must be passed to the function. Currently we limit such
4384 -- functions to those with constrained limited result subtypes,
4385 -- but eventually we plan to expand the allowed forms of functions
4386 -- that are treated as build-in-place.
4388 if Ada_Version
>= Ada_05
4389 and then Is_Build_In_Place_Function_Call
(Expr_Q
)
4391 Make_Build_In_Place_Call_In_Object_Declaration
(N
, Expr_Q
);
4395 -- In most cases, we must check that the initial value meets any
4396 -- constraint imposed by the declared type. However, there is one
4397 -- very important exception to this rule. If the entity has an
4398 -- unconstrained nominal subtype, then it acquired its constraints
4399 -- from the expression in the first place, and not only does this
4400 -- mean that the constraint check is not needed, but an attempt to
4401 -- perform the constraint check can cause order order of
4402 -- elaboration problems.
4404 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
4406 -- If this is an allocator for an aggregate that has been
4407 -- allocated in place, delay checks until assignments are
4408 -- made, because the discriminants are not initialized.
4410 if Nkind
(Expr
) = N_Allocator
4411 and then No_Initialization
(Expr
)
4415 Apply_Constraint_Check
(Expr
, Typ
);
4419 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
4420 -- class-wide object to ensure that we copy the full object,
4421 -- unless we are targetting a VM where interfaces are handled by
4422 -- VM itself. Note that if the root type of Typ is an ancestor
4423 -- of Expr's type, both types share the same dispatch table and
4424 -- there is no need to displace the pointer.
4427 -- CW : I'Class := Obj;
4429 -- Temp : I'Class := I'Class (Base_Address (Obj'Address));
4430 -- CW : I'Class renames Displace (Temp, I'Tag);
4432 if Is_Interface
(Typ
)
4433 and then Is_Class_Wide_Type
(Typ
)
4435 (Is_Class_Wide_Type
(Etype
(Expr
))
4437 not Is_Ancestor
(Root_Type
(Typ
), Etype
(Expr
)))
4438 and then Comes_From_Source
(Def_Id
)
4439 and then VM_Target
= No_VM
4447 Make_Object_Declaration
(Loc
,
4448 Defining_Identifier
=>
4449 Make_Defining_Identifier
(Loc
,
4450 New_Internal_Name
('D')),
4452 Object_Definition
=>
4453 Make_Attribute_Reference
(Loc
,
4456 (Root_Type
(Etype
(Def_Id
)), Loc
),
4457 Attribute_Name
=> Name_Class
),
4460 Unchecked_Convert_To
4461 (Class_Wide_Type
(Root_Type
(Etype
(Def_Id
))),
4462 Make_Explicit_Dereference
(Loc
,
4463 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
4464 Make_Function_Call
(Loc
,
4466 New_Reference_To
(RTE
(RE_Base_Address
),
4468 Parameter_Associations
=> New_List
(
4469 Make_Attribute_Reference
(Loc
,
4470 Prefix
=> Relocate_Node
(Expr
),
4471 Attribute_Name
=> Name_Address
)))))));
4473 Insert_Action
(N
, Decl_1
);
4476 Make_Object_Renaming_Declaration
(Loc
,
4477 Defining_Identifier
=>
4478 Make_Defining_Identifier
(Loc
,
4479 New_Internal_Name
('D')),
4482 Make_Attribute_Reference
(Loc
,
4485 (Root_Type
(Etype
(Def_Id
)), Loc
),
4486 Attribute_Name
=> Name_Class
),
4489 Unchecked_Convert_To
(
4490 Class_Wide_Type
(Root_Type
(Etype
(Def_Id
))),
4491 Make_Explicit_Dereference
(Loc
,
4492 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
4493 Make_Function_Call
(Loc
,
4495 New_Reference_To
(RTE
(RE_Displace
), Loc
),
4497 Parameter_Associations
=> New_List
(
4498 Make_Attribute_Reference
(Loc
,
4501 (Defining_Identifier
(Decl_1
), Loc
),
4502 Attribute_Name
=> Name_Address
),
4504 Unchecked_Convert_To
(RTE
(RE_Tag
),
4509 (Root_Type
(Typ
)))),
4512 Rewrite
(N
, Decl_2
);
4515 -- Replace internal identifier of Decl_2 by the identifier
4516 -- found in the sources. We also have to exchange entities
4517 -- containing their defining identifiers to ensure the
4518 -- correct replacement of the object declaration by this
4519 -- object renaming declaration (because such definings
4520 -- identifier have been previously added by Enter_Name to
4521 -- the current scope). We must preserve the homonym chain
4522 -- of the source entity as well.
4524 Set_Chars
(Defining_Identifier
(N
), Chars
(Def_Id
));
4525 Set_Homonym
(Defining_Identifier
(N
), Homonym
(Def_Id
));
4526 Exchange_Entities
(Defining_Identifier
(N
), Def_Id
);
4532 -- If the type is controlled and not inherently limited, then
4533 -- the target is adjusted after the copy and attached to the
4534 -- finalization list. However, no adjustment is done in the case
4535 -- where the object was initialized by a call to a function whose
4536 -- result is built in place, since no copy occurred. (Eventually
4537 -- we plan to support in-place function results for some cases
4538 -- of nonlimited types. ???)
4540 if Controlled_Type
(Typ
)
4541 and then not Is_Inherently_Limited_Type
(Typ
)
4542 and then not BIP_Call
4544 Insert_Actions_After
(Init_After
,
4546 Ref
=> New_Reference_To
(Def_Id
, Loc
),
4547 Typ
=> Base_Type
(Typ
),
4548 Flist_Ref
=> Find_Final_List
(Def_Id
),
4549 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
4552 -- For tagged types, when an init value is given, the tag has to
4553 -- be re-initialized separately in order to avoid the propagation
4554 -- of a wrong tag coming from a view conversion unless the type
4555 -- is class wide (in this case the tag comes from the init value).
4556 -- Suppress the tag assignment when VM_Target because VM tags are
4557 -- represented implicitly in objects. Ditto for types that are
4558 -- CPP_CLASS, and for initializations that are aggregates, because
4559 -- they have to have the right tag.
4561 if Is_Tagged_Type
(Typ
)
4562 and then not Is_Class_Wide_Type
(Typ
)
4563 and then not Is_CPP_Class
(Typ
)
4564 and then VM_Target
= No_VM
4565 and then Nkind
(Expr
) /= N_Aggregate
4567 -- The re-assignment of the tag has to be done even if the
4568 -- object is a constant.
4571 Make_Selected_Component
(Loc
,
4572 Prefix
=> New_Reference_To
(Def_Id
, Loc
),
4574 New_Reference_To
(First_Tag_Component
(Typ
), Loc
));
4576 Set_Assignment_OK
(New_Ref
);
4578 Insert_After
(Init_After
,
4579 Make_Assignment_Statement
(Loc
,
4582 Unchecked_Convert_To
(RTE
(RE_Tag
),
4586 (Access_Disp_Table
(Base_Type
(Typ
)))),
4589 -- For discrete types, set the Is_Known_Valid flag if the
4590 -- initializing value is known to be valid.
4592 elsif Is_Discrete_Type
(Typ
) and then Expr_Known_Valid
(Expr
) then
4593 Set_Is_Known_Valid
(Def_Id
);
4595 elsif Is_Access_Type
(Typ
) then
4597 -- For access types set the Is_Known_Non_Null flag if the
4598 -- initializing value is known to be non-null. We can also set
4599 -- Can_Never_Be_Null if this is a constant.
4601 if Known_Non_Null
(Expr
) then
4602 Set_Is_Known_Non_Null
(Def_Id
, True);
4604 if Constant_Present
(N
) then
4605 Set_Can_Never_Be_Null
(Def_Id
);
4610 -- If validity checking on copies, validate initial expression.
4611 -- But skip this if declaration is for a generic type, since it
4612 -- makes no sense to validate generic types. Not clear if this
4613 -- can happen for legal programs, but it definitely can arise
4614 -- from previous instantiation errors.
4616 if Validity_Checks_On
4617 and then Validity_Check_Copies
4618 and then not Is_Generic_Type
(Etype
(Def_Id
))
4620 Ensure_Valid
(Expr
);
4621 Set_Is_Known_Valid
(Def_Id
);
4625 -- Cases where the back end cannot handle the initialization directly
4626 -- In such cases, we expand an assignment that will be appropriately
4627 -- handled by Expand_N_Assignment_Statement.
4629 -- The exclusion of the unconstrained case is wrong, but for now it
4630 -- is too much trouble ???
4632 if (Is_Possibly_Unaligned_Slice
(Expr
)
4633 or else (Is_Possibly_Unaligned_Object
(Expr
)
4634 and then not Represented_As_Scalar
(Etype
(Expr
))))
4636 -- The exclusion of the unconstrained case is wrong, but for now
4637 -- it is too much trouble ???
4639 and then not (Is_Array_Type
(Etype
(Expr
))
4640 and then not Is_Constrained
(Etype
(Expr
)))
4643 Stat
: constant Node_Id
:=
4644 Make_Assignment_Statement
(Loc
,
4645 Name
=> New_Reference_To
(Def_Id
, Loc
),
4646 Expression
=> Relocate_Node
(Expr
));
4648 Set_Expression
(N
, Empty
);
4649 Set_No_Initialization
(N
);
4650 Set_Assignment_OK
(Name
(Stat
));
4651 Set_No_Ctrl_Actions
(Stat
);
4652 Insert_After_And_Analyze
(Init_After
, Stat
);
4658 when RE_Not_Available
=>
4660 end Expand_N_Object_Declaration
;
4662 ---------------------------------
4663 -- Expand_N_Subtype_Indication --
4664 ---------------------------------
4666 -- Add a check on the range of the subtype. The static case is partially
4667 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
4668 -- to check here for the static case in order to avoid generating
4669 -- extraneous expanded code. Also deal with validity checking.
4671 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
4672 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
4673 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
4676 if Nkind
(Constraint
(N
)) = N_Range_Constraint
then
4677 Validity_Check_Range
(Range_Expression
(Constraint
(N
)));
4680 if Nkind_In
(Parent
(N
), N_Constrained_Array_Definition
, N_Slice
) then
4681 Apply_Range_Check
(Ran
, Typ
);
4683 end Expand_N_Subtype_Indication
;
4685 ---------------------------
4686 -- Expand_N_Variant_Part --
4687 ---------------------------
4689 -- If the last variant does not contain the Others choice, replace it with
4690 -- an N_Others_Choice node since Gigi always wants an Others. Note that we
4691 -- do not bother to call Analyze on the modified variant part, since it's
4692 -- only effect would be to compute the Others_Discrete_Choices node
4693 -- laboriously, and of course we already know the list of choices that
4694 -- corresponds to the others choice (it's the list we are replacing!)
4696 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
4697 Last_Var
: constant Node_Id
:= Last_Non_Pragma
(Variants
(N
));
4698 Others_Node
: Node_Id
;
4700 if Nkind
(First
(Discrete_Choices
(Last_Var
))) /= N_Others_Choice
then
4701 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Var
));
4702 Set_Others_Discrete_Choices
4703 (Others_Node
, Discrete_Choices
(Last_Var
));
4704 Set_Discrete_Choices
(Last_Var
, New_List
(Others_Node
));
4706 end Expand_N_Variant_Part
;
4708 ---------------------------------
4709 -- Expand_Previous_Access_Type --
4710 ---------------------------------
4712 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
4713 T
: Entity_Id
:= First_Entity
(Current_Scope
);
4716 -- Find all access types declared in the current scope, whose
4717 -- designated type is Def_Id. If it does not have a Master_Id,
4720 while Present
(T
) loop
4721 if Is_Access_Type
(T
)
4722 and then Designated_Type
(T
) = Def_Id
4723 and then No
(Master_Id
(T
))
4725 Build_Master_Entity
(Def_Id
);
4726 Build_Master_Renaming
(Parent
(Def_Id
), T
);
4731 end Expand_Previous_Access_Type
;
4733 ------------------------------
4734 -- Expand_Record_Controller --
4735 ------------------------------
4737 procedure Expand_Record_Controller
(T
: Entity_Id
) is
4738 Def
: Node_Id
:= Type_Definition
(Parent
(T
));
4739 Comp_List
: Node_Id
;
4740 Comp_Decl
: Node_Id
;
4742 First_Comp
: Node_Id
;
4743 Controller_Type
: Entity_Id
;
4747 if Nkind
(Def
) = N_Derived_Type_Definition
then
4748 Def
:= Record_Extension_Part
(Def
);
4751 if Null_Present
(Def
) then
4752 Set_Component_List
(Def
,
4753 Make_Component_List
(Sloc
(Def
),
4754 Component_Items
=> Empty_List
,
4755 Variant_Part
=> Empty
,
4756 Null_Present
=> True));
4759 Comp_List
:= Component_List
(Def
);
4761 if Null_Present
(Comp_List
)
4762 or else Is_Empty_List
(Component_Items
(Comp_List
))
4764 Loc
:= Sloc
(Comp_List
);
4766 Loc
:= Sloc
(First
(Component_Items
(Comp_List
)));
4769 if Is_Inherently_Limited_Type
(T
) then
4770 Controller_Type
:= RTE
(RE_Limited_Record_Controller
);
4772 Controller_Type
:= RTE
(RE_Record_Controller
);
4775 Ent
:= Make_Defining_Identifier
(Loc
, Name_uController
);
4778 Make_Component_Declaration
(Loc
,
4779 Defining_Identifier
=> Ent
,
4780 Component_Definition
=>
4781 Make_Component_Definition
(Loc
,
4782 Aliased_Present
=> False,
4783 Subtype_Indication
=> New_Reference_To
(Controller_Type
, Loc
)));
4785 if Null_Present
(Comp_List
)
4786 or else Is_Empty_List
(Component_Items
(Comp_List
))
4788 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
4789 Set_Null_Present
(Comp_List
, False);
4792 -- The controller cannot be placed before the _Parent field since
4793 -- gigi lays out field in order and _parent must be first to preserve
4794 -- the polymorphism of tagged types.
4796 First_Comp
:= First
(Component_Items
(Comp_List
));
4798 if not Is_Tagged_Type
(T
) then
4799 Insert_Before
(First_Comp
, Comp_Decl
);
4801 -- if T is a tagged type, place controller declaration after parent
4802 -- field and after eventual tags of interface types.
4805 while Present
(First_Comp
)
4807 (Chars
(Defining_Identifier
(First_Comp
)) = Name_uParent
4808 or else Is_Tag
(Defining_Identifier
(First_Comp
))
4810 -- Ada 2005 (AI-251): The following condition covers secondary
4811 -- tags but also the adjacent component containing the offset
4812 -- to the base of the object (component generated if the parent
4813 -- has discriminants --- see Add_Interface_Tag_Components).
4814 -- This is required to avoid the addition of the controller
4815 -- between the secondary tag and its adjacent component.
4819 (Defining_Identifier
(First_Comp
))))
4824 -- An empty tagged extension might consist only of the parent
4825 -- component. Otherwise insert the controller before the first
4826 -- component that is neither parent nor tag.
4828 if Present
(First_Comp
) then
4829 Insert_Before
(First_Comp
, Comp_Decl
);
4831 Append
(Comp_Decl
, Component_Items
(Comp_List
));
4837 Analyze
(Comp_Decl
);
4838 Set_Ekind
(Ent
, E_Component
);
4839 Init_Component_Location
(Ent
);
4841 -- Move the _controller entity ahead in the list of internal entities
4842 -- of the enclosing record so that it is selected instead of a
4843 -- potentially inherited one.
4846 E
: constant Entity_Id
:= Last_Entity
(T
);
4850 pragma Assert
(Chars
(E
) = Name_uController
);
4852 Set_Next_Entity
(E
, First_Entity
(T
));
4853 Set_First_Entity
(T
, E
);
4855 Comp
:= Next_Entity
(E
);
4856 while Next_Entity
(Comp
) /= E
loop
4860 Set_Next_Entity
(Comp
, Empty
);
4861 Set_Last_Entity
(T
, Comp
);
4867 when RE_Not_Available
=>
4869 end Expand_Record_Controller
;
4871 ------------------------
4872 -- Expand_Tagged_Root --
4873 ------------------------
4875 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
4876 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
4877 Comp_List
: Node_Id
;
4878 Comp_Decl
: Node_Id
;
4879 Sloc_N
: Source_Ptr
;
4882 if Null_Present
(Def
) then
4883 Set_Component_List
(Def
,
4884 Make_Component_List
(Sloc
(Def
),
4885 Component_Items
=> Empty_List
,
4886 Variant_Part
=> Empty
,
4887 Null_Present
=> True));
4890 Comp_List
:= Component_List
(Def
);
4892 if Null_Present
(Comp_List
)
4893 or else Is_Empty_List
(Component_Items
(Comp_List
))
4895 Sloc_N
:= Sloc
(Comp_List
);
4897 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
4901 Make_Component_Declaration
(Sloc_N
,
4902 Defining_Identifier
=> First_Tag_Component
(T
),
4903 Component_Definition
=>
4904 Make_Component_Definition
(Sloc_N
,
4905 Aliased_Present
=> False,
4906 Subtype_Indication
=> New_Reference_To
(RTE
(RE_Tag
), Sloc_N
)));
4908 if Null_Present
(Comp_List
)
4909 or else Is_Empty_List
(Component_Items
(Comp_List
))
4911 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
4912 Set_Null_Present
(Comp_List
, False);
4915 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
4918 -- We don't Analyze the whole expansion because the tag component has
4919 -- already been analyzed previously. Here we just insure that the tree
4920 -- is coherent with the semantic decoration
4922 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
4925 when RE_Not_Available
=>
4927 end Expand_Tagged_Root
;
4929 ----------------------
4930 -- Clean_Task_Names --
4931 ----------------------
4933 procedure Clean_Task_Names
4935 Proc_Id
: Entity_Id
)
4939 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
4940 and then not Global_Discard_Names
4941 and then VM_Target
= No_VM
4943 Set_Uses_Sec_Stack
(Proc_Id
);
4945 end Clean_Task_Names
;
4947 -----------------------
4948 -- Freeze_Array_Type --
4949 -----------------------
4951 procedure Freeze_Array_Type
(N
: Node_Id
) is
4952 Typ
: constant Entity_Id
:= Entity
(N
);
4953 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4954 Base
: constant Entity_Id
:= Base_Type
(Typ
);
4957 if not Is_Bit_Packed_Array
(Typ
) then
4959 -- If the component contains tasks, so does the array type. This may
4960 -- not be indicated in the array type because the component may have
4961 -- been a private type at the point of definition. Same if component
4962 -- type is controlled.
4964 Set_Has_Task
(Base
, Has_Task
(Comp_Typ
));
4965 Set_Has_Controlled_Component
(Base
,
4966 Has_Controlled_Component
(Comp_Typ
)
4967 or else Is_Controlled
(Comp_Typ
));
4969 if No
(Init_Proc
(Base
)) then
4971 -- If this is an anonymous array created for a declaration with
4972 -- an initial value, its init_proc will never be called. The
4973 -- initial value itself may have been expanded into assignments,
4974 -- in which case the object declaration is carries the
4975 -- No_Initialization flag.
4978 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
4979 N_Object_Declaration
4980 and then (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
4982 No_Initialization
(Associated_Node_For_Itype
(Base
)))
4986 -- We do not need an init proc for string or wide [wide] string,
4987 -- since the only time these need initialization in normalize or
4988 -- initialize scalars mode, and these types are treated specially
4989 -- and do not need initialization procedures.
4991 elsif Root_Type
(Base
) = Standard_String
4992 or else Root_Type
(Base
) = Standard_Wide_String
4993 or else Root_Type
(Base
) = Standard_Wide_Wide_String
4997 -- Otherwise we have to build an init proc for the subtype
5000 Build_Array_Init_Proc
(Base
, N
);
5005 if Has_Controlled_Component
(Base
) then
5006 Build_Controlling_Procs
(Base
);
5008 if not Is_Limited_Type
(Comp_Typ
)
5009 and then Number_Dimensions
(Typ
) = 1
5011 Build_Slice_Assignment
(Typ
);
5014 elsif Ekind
(Comp_Typ
) = E_Anonymous_Access_Type
5015 and then Controlled_Type
(Directly_Designated_Type
(Comp_Typ
))
5017 Set_Associated_Final_Chain
(Comp_Typ
, Add_Final_Chain
(Typ
));
5021 -- For packed case, default initialization, except if the component type
5022 -- is itself a packed structure with an initialization procedure, or
5023 -- initialize/normalize scalars active, and we have a base type, or the
5024 -- type is public, because in that case a client might specify
5025 -- Normalize_Scalars and there better be a public Init_Proc for it.
5027 elsif (Present
(Init_Proc
(Component_Type
(Base
)))
5028 and then No
(Base_Init_Proc
(Base
)))
5029 or else (Init_Or_Norm_Scalars
and then Base
= Typ
)
5030 or else Is_Public
(Typ
)
5032 Build_Array_Init_Proc
(Base
, N
);
5034 end Freeze_Array_Type
;
5036 -----------------------------
5037 -- Freeze_Enumeration_Type --
5038 -----------------------------
5040 procedure Freeze_Enumeration_Type
(N
: Node_Id
) is
5041 Typ
: constant Entity_Id
:= Entity
(N
);
5042 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5049 Is_Contiguous
: Boolean;
5054 pragma Warnings
(Off
, Func
);
5057 -- Various optimizations possible if given representation is contiguous
5059 Is_Contiguous
:= True;
5061 Ent
:= First_Literal
(Typ
);
5062 Last_Repval
:= Enumeration_Rep
(Ent
);
5065 while Present
(Ent
) loop
5066 if Enumeration_Rep
(Ent
) - Last_Repval
/= 1 then
5067 Is_Contiguous
:= False;
5070 Last_Repval
:= Enumeration_Rep
(Ent
);
5076 if Is_Contiguous
then
5077 Set_Has_Contiguous_Rep
(Typ
);
5078 Ent
:= First_Literal
(Typ
);
5080 Lst
:= New_List
(New_Reference_To
(Ent
, Sloc
(Ent
)));
5083 -- Build list of literal references
5088 Ent
:= First_Literal
(Typ
);
5089 while Present
(Ent
) loop
5090 Append_To
(Lst
, New_Reference_To
(Ent
, Sloc
(Ent
)));
5096 -- Now build an array declaration
5098 -- typA : array (Natural range 0 .. num - 1) of ctype :=
5099 -- (v, v, v, v, v, ....)
5101 -- where ctype is the corresponding integer type. If the representation
5102 -- is contiguous, we only keep the first literal, which provides the
5103 -- offset for Pos_To_Rep computations.
5106 Make_Defining_Identifier
(Loc
,
5107 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
5109 Append_Freeze_Action
(Typ
,
5110 Make_Object_Declaration
(Loc
,
5111 Defining_Identifier
=> Arr
,
5112 Constant_Present
=> True,
5114 Object_Definition
=>
5115 Make_Constrained_Array_Definition
(Loc
,
5116 Discrete_Subtype_Definitions
=> New_List
(
5117 Make_Subtype_Indication
(Loc
,
5118 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
5120 Make_Range_Constraint
(Loc
,
5124 Make_Integer_Literal
(Loc
, 0),
5126 Make_Integer_Literal
(Loc
, Num
- 1))))),
5128 Component_Definition
=>
5129 Make_Component_Definition
(Loc
,
5130 Aliased_Present
=> False,
5131 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
))),
5134 Make_Aggregate
(Loc
,
5135 Expressions
=> Lst
)));
5137 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
5139 -- Now we build the function that converts representation values to
5140 -- position values. This function has the form:
5142 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5145 -- when enum-lit'Enum_Rep => return posval;
5146 -- when enum-lit'Enum_Rep => return posval;
5149 -- [raise Constraint_Error when F "invalid data"]
5154 -- Note: the F parameter determines whether the others case (no valid
5155 -- representation) raises Constraint_Error or returns a unique value
5156 -- of minus one. The latter case is used, e.g. in 'Valid code.
5158 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5159 -- the code generator making inappropriate assumptions about the range
5160 -- of the values in the case where the value is invalid. ityp is a
5161 -- signed or unsigned integer type of appropriate width.
5163 -- Note: if exceptions are not supported, then we suppress the raise
5164 -- and return -1 unconditionally (this is an erroneous program in any
5165 -- case and there is no obligation to raise Constraint_Error here!) We
5166 -- also do this if pragma Restrictions (No_Exceptions) is active.
5168 -- Is this right??? What about No_Exception_Propagation???
5170 -- Representations are signed
5172 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
5174 -- The underlying type is signed. Reset the Is_Unsigned_Type
5175 -- explicitly, because it might have been inherited from
5178 Set_Is_Unsigned_Type
(Typ
, False);
5180 if Esize
(Typ
) <= Standard_Integer_Size
then
5181 Ityp
:= Standard_Integer
;
5183 Ityp
:= Universal_Integer
;
5186 -- Representations are unsigned
5189 if Esize
(Typ
) <= Standard_Integer_Size
then
5190 Ityp
:= RTE
(RE_Unsigned
);
5192 Ityp
:= RTE
(RE_Long_Long_Unsigned
);
5196 -- The body of the function is a case statement. First collect case
5197 -- alternatives, or optimize the contiguous case.
5201 -- If representation is contiguous, Pos is computed by subtracting
5202 -- the representation of the first literal.
5204 if Is_Contiguous
then
5205 Ent
:= First_Literal
(Typ
);
5207 if Enumeration_Rep
(Ent
) = Last_Repval
then
5209 -- Another special case: for a single literal, Pos is zero
5211 Pos_Expr
:= Make_Integer_Literal
(Loc
, Uint_0
);
5215 Convert_To
(Standard_Integer
,
5216 Make_Op_Subtract
(Loc
,
5218 Unchecked_Convert_To
(Ityp
,
5219 Make_Identifier
(Loc
, Name_uA
)),
5221 Make_Integer_Literal
(Loc
,
5223 Enumeration_Rep
(First_Literal
(Typ
)))));
5227 Make_Case_Statement_Alternative
(Loc
,
5228 Discrete_Choices
=> New_List
(
5229 Make_Range
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5231 Make_Integer_Literal
(Loc
,
5232 Intval
=> Enumeration_Rep
(Ent
)),
5234 Make_Integer_Literal
(Loc
, Intval
=> Last_Repval
))),
5236 Statements
=> New_List
(
5237 Make_Simple_Return_Statement
(Loc
,
5238 Expression
=> Pos_Expr
))));
5241 Ent
:= First_Literal
(Typ
);
5242 while Present
(Ent
) loop
5244 Make_Case_Statement_Alternative
(Loc
,
5245 Discrete_Choices
=> New_List
(
5246 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
5247 Intval
=> Enumeration_Rep
(Ent
))),
5249 Statements
=> New_List
(
5250 Make_Simple_Return_Statement
(Loc
,
5252 Make_Integer_Literal
(Loc
,
5253 Intval
=> Enumeration_Pos
(Ent
))))));
5259 -- In normal mode, add the others clause with the test
5261 if not No_Exception_Handlers_Set
then
5263 Make_Case_Statement_Alternative
(Loc
,
5264 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5265 Statements
=> New_List
(
5266 Make_Raise_Constraint_Error
(Loc
,
5267 Condition
=> Make_Identifier
(Loc
, Name_uF
),
5268 Reason
=> CE_Invalid_Data
),
5269 Make_Simple_Return_Statement
(Loc
,
5271 Make_Integer_Literal
(Loc
, -1)))));
5273 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5274 -- active then return -1 (we cannot usefully raise Constraint_Error in
5275 -- this case). See description above for further details.
5279 Make_Case_Statement_Alternative
(Loc
,
5280 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5281 Statements
=> New_List
(
5282 Make_Simple_Return_Statement
(Loc
,
5284 Make_Integer_Literal
(Loc
, -1)))));
5287 -- Now we can build the function body
5290 Make_Defining_Identifier
(Loc
, Make_TSS_Name
(Typ
, TSS_Rep_To_Pos
));
5293 Make_Subprogram_Body
(Loc
,
5295 Make_Function_Specification
(Loc
,
5296 Defining_Unit_Name
=> Fent
,
5297 Parameter_Specifications
=> New_List
(
5298 Make_Parameter_Specification
(Loc
,
5299 Defining_Identifier
=>
5300 Make_Defining_Identifier
(Loc
, Name_uA
),
5301 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
5302 Make_Parameter_Specification
(Loc
,
5303 Defining_Identifier
=>
5304 Make_Defining_Identifier
(Loc
, Name_uF
),
5305 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
))),
5307 Result_Definition
=> New_Reference_To
(Standard_Integer
, Loc
)),
5309 Declarations
=> Empty_List
,
5311 Handled_Statement_Sequence
=>
5312 Make_Handled_Sequence_Of_Statements
(Loc
,
5313 Statements
=> New_List
(
5314 Make_Case_Statement
(Loc
,
5316 Unchecked_Convert_To
(Ityp
,
5317 Make_Identifier
(Loc
, Name_uA
)),
5318 Alternatives
=> Lst
))));
5320 Set_TSS
(Typ
, Fent
);
5323 if not Debug_Generated_Code
then
5324 Set_Debug_Info_Off
(Fent
);
5328 when RE_Not_Available
=>
5330 end Freeze_Enumeration_Type
;
5332 ------------------------
5333 -- Freeze_Record_Type --
5334 ------------------------
5336 procedure Freeze_Record_Type
(N
: Node_Id
) is
5338 procedure Add_Internal_Interface_Entities
(Tagged_Type
: Entity_Id
);
5339 -- Add to the list of primitives of Tagged_Types the internal entities
5340 -- associated with interface primitives that are located in secondary
5343 -------------------------------------
5344 -- Add_Internal_Interface_Entities --
5345 -------------------------------------
5347 procedure Add_Internal_Interface_Entities
(Tagged_Type
: Entity_Id
) is
5350 Iface_Elmt
: Elmt_Id
;
5351 Iface_Prim
: Entity_Id
;
5352 Ifaces_List
: Elist_Id
;
5353 New_Subp
: Entity_Id
:= Empty
;
5357 pragma Assert
(Ada_Version
>= Ada_05
5358 and then Is_Record_Type
(Tagged_Type
)
5359 and then Is_Tagged_Type
(Tagged_Type
)
5360 and then Has_Interfaces
(Tagged_Type
)
5361 and then not Is_Interface
(Tagged_Type
));
5363 Collect_Interfaces
(Tagged_Type
, Ifaces_List
);
5365 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5366 while Present
(Iface_Elmt
) loop
5367 Iface
:= Node
(Iface_Elmt
);
5369 -- Exclude from this processing interfaces that are parents
5370 -- of Tagged_Type because their primitives are located in the
5371 -- primary dispatch table (and hence no auxiliary internal
5372 -- entities are required to handle secondary dispatch tables
5375 if not Is_Ancestor
(Iface
, Tagged_Type
) then
5376 Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
5377 while Present
(Elmt
) loop
5378 Iface_Prim
:= Node
(Elmt
);
5380 if not Is_Predefined_Dispatching_Operation
(Iface_Prim
) then
5382 Find_Primitive_Covering_Interface
5383 (Tagged_Type
=> Tagged_Type
,
5384 Iface_Prim
=> Iface_Prim
);
5386 pragma Assert
(Present
(Prim
));
5389 (New_Subp
=> New_Subp
,
5390 Parent_Subp
=> Iface_Prim
,
5391 Derived_Type
=> Tagged_Type
,
5392 Parent_Type
=> Iface
);
5394 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
5395 -- associated with interface types. These entities are
5396 -- only registered in the list of primitives of its
5397 -- corresponding tagged type because they are only used
5398 -- to fill the contents of the secondary dispatch tables.
5399 -- Therefore they are removed from the homonym chains.
5401 Set_Is_Hidden
(New_Subp
);
5402 Set_Is_Internal
(New_Subp
);
5403 Set_Alias
(New_Subp
, Prim
);
5404 Set_Is_Abstract_Subprogram
(New_Subp
,
5405 Is_Abstract_Subprogram
(Prim
));
5406 Set_Interface_Alias
(New_Subp
, Iface_Prim
);
5408 -- Internal entities associated with interface types are
5409 -- only registered in the list of primitives of the
5410 -- tagged type. They are only used to fill the contents
5411 -- of the secondary dispatch tables. Therefore they are
5412 -- not needed in the homonym chains.
5414 Remove_Homonym
(New_Subp
);
5416 -- Hidden entities associated with interfaces must have
5417 -- set the Has_Delay_Freeze attribute to ensure that, in
5418 -- case of locally defined tagged types (or compiling
5419 -- with static dispatch tables generation disabled) the
5420 -- corresponding entry of the secondary dispatch table is
5421 -- filled when such entity is frozen.
5423 Set_Has_Delayed_Freeze
(New_Subp
);
5430 Next_Elmt
(Iface_Elmt
);
5432 end Add_Internal_Interface_Entities
;
5436 Def_Id
: constant Node_Id
:= Entity
(N
);
5437 Type_Decl
: constant Node_Id
:= Parent
(Def_Id
);
5439 Comp_Typ
: Entity_Id
;
5440 Has_Static_DT
: Boolean := False;
5441 Predef_List
: List_Id
;
5443 Flist
: Entity_Id
:= Empty
;
5444 -- Finalization list allocated for the case of a type with anonymous
5445 -- access components whose designated type is potentially controlled.
5447 Renamed_Eq
: Node_Id
:= Empty
;
5448 -- Defining unit name for the predefined equality function in the case
5449 -- where the type has a primitive operation that is a renaming of
5450 -- predefined equality (but only if there is also an overriding
5451 -- user-defined equality function). Used to pass this entity from
5452 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
5454 Wrapper_Decl_List
: List_Id
:= No_List
;
5455 Wrapper_Body_List
: List_Id
:= No_List
;
5456 Null_Proc_Decl_List
: List_Id
:= No_List
;
5458 -- Start of processing for Freeze_Record_Type
5461 -- Build discriminant checking functions if not a derived type (for
5462 -- derived types that are not tagged types, always use the discriminant
5463 -- checking functions of the parent type). However, for untagged types
5464 -- the derivation may have taken place before the parent was frozen, so
5465 -- we copy explicitly the discriminant checking functions from the
5466 -- parent into the components of the derived type.
5468 if not Is_Derived_Type
(Def_Id
)
5469 or else Has_New_Non_Standard_Rep
(Def_Id
)
5470 or else Is_Tagged_Type
(Def_Id
)
5472 Build_Discr_Checking_Funcs
(Type_Decl
);
5474 elsif Is_Derived_Type
(Def_Id
)
5475 and then not Is_Tagged_Type
(Def_Id
)
5477 -- If we have a derived Unchecked_Union, we do not inherit the
5478 -- discriminant checking functions from the parent type since the
5479 -- discriminants are non existent.
5481 and then not Is_Unchecked_Union
(Def_Id
)
5482 and then Has_Discriminants
(Def_Id
)
5485 Old_Comp
: Entity_Id
;
5489 First_Component
(Base_Type
(Underlying_Type
(Etype
(Def_Id
))));
5490 Comp
:= First_Component
(Def_Id
);
5491 while Present
(Comp
) loop
5492 if Ekind
(Comp
) = E_Component
5493 and then Chars
(Comp
) = Chars
(Old_Comp
)
5495 Set_Discriminant_Checking_Func
(Comp
,
5496 Discriminant_Checking_Func
(Old_Comp
));
5499 Next_Component
(Old_Comp
);
5500 Next_Component
(Comp
);
5505 if Is_Derived_Type
(Def_Id
)
5506 and then Is_Limited_Type
(Def_Id
)
5507 and then Is_Tagged_Type
(Def_Id
)
5509 Check_Stream_Attributes
(Def_Id
);
5512 -- Update task and controlled component flags, because some of the
5513 -- component types may have been private at the point of the record
5516 Comp
:= First_Component
(Def_Id
);
5518 while Present
(Comp
) loop
5519 Comp_Typ
:= Etype
(Comp
);
5521 if Has_Task
(Comp_Typ
) then
5522 Set_Has_Task
(Def_Id
);
5524 elsif Has_Controlled_Component
(Comp_Typ
)
5525 or else (Chars
(Comp
) /= Name_uParent
5526 and then Is_Controlled
(Comp_Typ
))
5528 Set_Has_Controlled_Component
(Def_Id
);
5530 elsif Ekind
(Comp_Typ
) = E_Anonymous_Access_Type
5531 and then Controlled_Type
(Directly_Designated_Type
(Comp_Typ
))
5534 Flist
:= Add_Final_Chain
(Def_Id
);
5537 Set_Associated_Final_Chain
(Comp_Typ
, Flist
);
5540 Next_Component
(Comp
);
5543 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5544 -- for regular tagged types as well as for Ada types deriving from a C++
5545 -- Class, but not for tagged types directly corresponding to C++ classes
5546 -- In the later case we assume that it is created in the C++ side and we
5549 if Is_Tagged_Type
(Def_Id
) then
5551 Static_Dispatch_Tables
5552 and then Is_Library_Level_Tagged_Type
(Def_Id
);
5554 -- Add the _Tag component
5556 if Underlying_Type
(Etype
(Def_Id
)) = Def_Id
then
5557 Expand_Tagged_Root
(Def_Id
);
5560 if Is_CPP_Class
(Def_Id
) then
5561 Set_All_DT_Position
(Def_Id
);
5562 Set_Default_Constructor
(Def_Id
);
5564 -- Create the tag entities with a minimum decoration
5566 if VM_Target
= No_VM
then
5567 Append_Freeze_Actions
(Def_Id
, Make_Tags
(Def_Id
));
5571 if not Has_Static_DT
then
5573 -- Usually inherited primitives are not delayed but the first
5574 -- Ada extension of a CPP_Class is an exception since the
5575 -- address of the inherited subprogram has to be inserted in
5576 -- the new Ada Dispatch Table and this is a freezing action.
5578 -- Similarly, if this is an inherited operation whose parent is
5579 -- not frozen yet, it is not in the DT of the parent, and we
5580 -- generate an explicit freeze node for the inherited operation
5581 -- so that it is properly inserted in the DT of the current
5585 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Def_Id
));
5589 while Present
(Elmt
) loop
5590 Subp
:= Node
(Elmt
);
5592 if Present
(Alias
(Subp
)) then
5593 if Is_CPP_Class
(Etype
(Def_Id
)) then
5594 Set_Has_Delayed_Freeze
(Subp
);
5596 elsif Has_Delayed_Freeze
(Alias
(Subp
))
5597 and then not Is_Frozen
(Alias
(Subp
))
5599 Set_Is_Frozen
(Subp
, False);
5600 Set_Has_Delayed_Freeze
(Subp
);
5609 -- Unfreeze momentarily the type to add the predefined primitives
5610 -- operations. The reason we unfreeze is so that these predefined
5611 -- operations will indeed end up as primitive operations (which
5612 -- must be before the freeze point).
5614 Set_Is_Frozen
(Def_Id
, False);
5616 -- Do not add the spec of predefined primitives in case of
5617 -- CPP tagged type derivations that have convention CPP.
5619 if Is_CPP_Class
(Root_Type
(Def_Id
))
5620 and then Convention
(Def_Id
) = Convention_CPP
5624 -- Do not add the spec of the predefined primitives if we are
5625 -- compiling under restriction No_Dispatching_Calls
5627 elsif not Restriction_Active
(No_Dispatching_Calls
) then
5628 Make_Predefined_Primitive_Specs
5629 (Def_Id
, Predef_List
, Renamed_Eq
);
5630 Insert_List_Before_And_Analyze
(N
, Predef_List
);
5633 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5634 -- wrapper functions for each nonoverridden inherited function
5635 -- with a controlling result of the type. The wrapper for such
5636 -- a function returns an extension aggregate that invokes the
5637 -- the parent function.
5639 if Ada_Version
>= Ada_05
5640 and then not Is_Abstract_Type
(Def_Id
)
5641 and then Is_Null_Extension
(Def_Id
)
5643 Make_Controlling_Function_Wrappers
5644 (Def_Id
, Wrapper_Decl_List
, Wrapper_Body_List
);
5645 Insert_List_Before_And_Analyze
(N
, Wrapper_Decl_List
);
5648 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5649 -- null procedure declarations for each set of homographic null
5650 -- procedures that are inherited from interface types but not
5651 -- overridden. This is done to ensure that the dispatch table
5652 -- entry associated with such null primitives are properly filled.
5654 if Ada_Version
>= Ada_05
5655 and then Etype
(Def_Id
) /= Def_Id
5656 and then not Is_Abstract_Type
(Def_Id
)
5658 Make_Null_Procedure_Specs
(Def_Id
, Null_Proc_Decl_List
);
5659 Insert_Actions
(N
, Null_Proc_Decl_List
);
5662 -- Ada 2005 (AI-251): Add internal entities associated with
5663 -- secondary dispatch tables to the list of primitives of tagged
5664 -- types that are not interfaces
5666 if Ada_Version
>= Ada_05
5667 and then not Is_Interface
(Def_Id
)
5668 and then Has_Interfaces
(Def_Id
)
5670 Add_Internal_Interface_Entities
(Def_Id
);
5673 Set_Is_Frozen
(Def_Id
);
5674 Set_All_DT_Position
(Def_Id
);
5676 -- Add the controlled component before the freezing actions
5677 -- referenced in those actions.
5679 if Has_New_Controlled_Component
(Def_Id
) then
5680 Expand_Record_Controller
(Def_Id
);
5683 -- Create and decorate the tags. Suppress their creation when
5684 -- VM_Target because the dispatching mechanism is handled
5685 -- internally by the VMs.
5687 if VM_Target
= No_VM
then
5688 Append_Freeze_Actions
(Def_Id
, Make_Tags
(Def_Id
));
5690 -- Generate dispatch table of locally defined tagged type.
5691 -- Dispatch tables of library level tagged types are built
5692 -- later (see Analyze_Declarations).
5694 if VM_Target
= No_VM
5695 and then not Has_Static_DT
5697 Append_Freeze_Actions
(Def_Id
, Make_DT
(Def_Id
));
5701 -- Make sure that the primitives Initialize, Adjust and Finalize
5702 -- are Frozen before other TSS subprograms. We don't want them
5705 if Is_Controlled
(Def_Id
) then
5706 if not Is_Limited_Type
(Def_Id
) then
5707 Append_Freeze_Actions
(Def_Id
,
5709 (Find_Prim_Op
(Def_Id
, Name_Adjust
), Sloc
(Def_Id
)));
5712 Append_Freeze_Actions
(Def_Id
,
5714 (Find_Prim_Op
(Def_Id
, Name_Initialize
), Sloc
(Def_Id
)));
5716 Append_Freeze_Actions
(Def_Id
,
5718 (Find_Prim_Op
(Def_Id
, Name_Finalize
), Sloc
(Def_Id
)));
5721 -- Freeze rest of primitive operations. There is no need to handle
5722 -- the predefined primitives if we are compiling under restriction
5723 -- No_Dispatching_Calls
5725 if not Restriction_Active
(No_Dispatching_Calls
) then
5726 Append_Freeze_Actions
5727 (Def_Id
, Predefined_Primitive_Freeze
(Def_Id
));
5731 -- In the non-tagged case, an equality function is provided only for
5732 -- variant records (that are not unchecked unions).
5734 elsif Has_Discriminants
(Def_Id
)
5735 and then not Is_Limited_Type
(Def_Id
)
5738 Comps
: constant Node_Id
:=
5739 Component_List
(Type_Definition
(Type_Decl
));
5743 and then Present
(Variant_Part
(Comps
))
5745 Build_Variant_Record_Equality
(Def_Id
);
5750 -- Before building the record initialization procedure, if we are
5751 -- dealing with a concurrent record value type, then we must go through
5752 -- the discriminants, exchanging discriminals between the concurrent
5753 -- type and the concurrent record value type. See the section "Handling
5754 -- of Discriminants" in the Einfo spec for details.
5756 if Is_Concurrent_Record_Type
(Def_Id
)
5757 and then Has_Discriminants
(Def_Id
)
5760 Ctyp
: constant Entity_Id
:=
5761 Corresponding_Concurrent_Type
(Def_Id
);
5762 Conc_Discr
: Entity_Id
;
5763 Rec_Discr
: Entity_Id
;
5767 Conc_Discr
:= First_Discriminant
(Ctyp
);
5768 Rec_Discr
:= First_Discriminant
(Def_Id
);
5770 while Present
(Conc_Discr
) loop
5771 Temp
:= Discriminal
(Conc_Discr
);
5772 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
5773 Set_Discriminal
(Rec_Discr
, Temp
);
5775 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
5776 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
5778 Next_Discriminant
(Conc_Discr
);
5779 Next_Discriminant
(Rec_Discr
);
5784 if Has_Controlled_Component
(Def_Id
) then
5785 if No
(Controller_Component
(Def_Id
)) then
5786 Expand_Record_Controller
(Def_Id
);
5789 Build_Controlling_Procs
(Def_Id
);
5792 Adjust_Discriminants
(Def_Id
);
5794 if VM_Target
= No_VM
or else not Is_Interface
(Def_Id
) then
5796 -- Do not need init for interfaces on e.g. CIL since they're
5797 -- abstract. Helps operation of peverify (the PE Verify tool).
5799 Build_Record_Init_Proc
(Type_Decl
, Def_Id
);
5802 -- For tagged type that are not interfaces, build bodies of primitive
5803 -- operations. Note that we do this after building the record
5804 -- initialization procedure, since the primitive operations may need
5805 -- the initialization routine. There is no need to add predefined
5806 -- primitives of interfaces because all their predefined primitives
5809 if Is_Tagged_Type
(Def_Id
)
5810 and then not Is_Interface
(Def_Id
)
5812 -- Do not add the body of predefined primitives in case of
5813 -- CPP tagged type derivations that have convention CPP.
5815 if Is_CPP_Class
(Root_Type
(Def_Id
))
5816 and then Convention
(Def_Id
) = Convention_CPP
5820 -- Do not add the body of the predefined primitives if we are
5821 -- compiling under restriction No_Dispatching_Calls or if we are
5822 -- compiling a CPP tagged type.
5824 elsif not Restriction_Active
(No_Dispatching_Calls
) then
5825 Predef_List
:= Predefined_Primitive_Bodies
(Def_Id
, Renamed_Eq
);
5826 Append_Freeze_Actions
(Def_Id
, Predef_List
);
5829 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5830 -- inherited functions, then add their bodies to the freeze actions.
5832 if Present
(Wrapper_Body_List
) then
5833 Append_Freeze_Actions
(Def_Id
, Wrapper_Body_List
);
5836 end Freeze_Record_Type
;
5838 ------------------------------
5839 -- Freeze_Stream_Operations --
5840 ------------------------------
5842 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
5843 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
5848 Stream_Op
: Entity_Id
;
5851 -- Primitive operations of tagged types are frozen when the dispatch
5852 -- table is constructed.
5854 if not Comes_From_Source
(Typ
)
5855 or else Is_Tagged_Type
(Typ
)
5860 for J
in Names
'Range loop
5861 Stream_Op
:= TSS
(Typ
, Names
(J
));
5863 if Present
(Stream_Op
)
5864 and then Is_Subprogram
(Stream_Op
)
5865 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
5866 N_Subprogram_Declaration
5867 and then not Is_Frozen
(Stream_Op
)
5869 Append_Freeze_Actions
5870 (Typ
, Freeze_Entity
(Stream_Op
, Sloc
(N
)));
5873 end Freeze_Stream_Operations
;
5879 -- Full type declarations are expanded at the point at which the type is
5880 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
5881 -- declarations generated by the freezing (e.g. the procedure generated
5882 -- for initialization) are chained in the Actions field list of the freeze
5883 -- node using Append_Freeze_Actions.
5885 function Freeze_Type
(N
: Node_Id
) return Boolean is
5886 Def_Id
: constant Entity_Id
:= Entity
(N
);
5887 RACW_Seen
: Boolean := False;
5888 Result
: Boolean := False;
5891 -- Process associated access types needing special processing
5893 if Present
(Access_Types_To_Process
(N
)) then
5895 E
: Elmt_Id
:= First_Elmt
(Access_Types_To_Process
(N
));
5897 while Present
(E
) loop
5899 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
5900 Validate_RACW_Primitives
(Node
(E
));
5910 -- If there are RACWs designating this type, make stubs now
5912 Remote_Types_Tagged_Full_View_Encountered
(Def_Id
);
5916 -- Freeze processing for record types
5918 if Is_Record_Type
(Def_Id
) then
5919 if Ekind
(Def_Id
) = E_Record_Type
then
5920 Freeze_Record_Type
(N
);
5922 -- The subtype may have been declared before the type was frozen. If
5923 -- the type has controlled components it is necessary to create the
5924 -- entity for the controller explicitly because it did not exist at
5925 -- the point of the subtype declaration. Only the entity is needed,
5926 -- the back-end will obtain the layout from the type. This is only
5927 -- necessary if this is constrained subtype whose component list is
5928 -- not shared with the base type.
5930 elsif Ekind
(Def_Id
) = E_Record_Subtype
5931 and then Has_Discriminants
(Def_Id
)
5932 and then Last_Entity
(Def_Id
) /= Last_Entity
(Base_Type
(Def_Id
))
5933 and then Present
(Controller_Component
(Def_Id
))
5936 Old_C
: constant Entity_Id
:= Controller_Component
(Def_Id
);
5940 if Scope
(Old_C
) = Base_Type
(Def_Id
) then
5942 -- The entity is the one in the parent. Create new one
5944 New_C
:= New_Copy
(Old_C
);
5945 Set_Parent
(New_C
, Parent
(Old_C
));
5946 Push_Scope
(Def_Id
);
5952 if Is_Itype
(Def_Id
)
5953 and then Is_Record_Type
(Underlying_Type
(Scope
(Def_Id
)))
5955 -- The freeze node is only used to introduce the controller,
5956 -- the back-end has no use for it for a discriminated
5959 Set_Freeze_Node
(Def_Id
, Empty
);
5960 Set_Has_Delayed_Freeze
(Def_Id
, False);
5964 -- Similar process if the controller of the subtype is not present
5965 -- but the parent has it. This can happen with constrained
5966 -- record components where the subtype is an itype.
5968 elsif Ekind
(Def_Id
) = E_Record_Subtype
5969 and then Is_Itype
(Def_Id
)
5970 and then No
(Controller_Component
(Def_Id
))
5971 and then Present
(Controller_Component
(Etype
(Def_Id
)))
5974 Old_C
: constant Entity_Id
:=
5975 Controller_Component
(Etype
(Def_Id
));
5976 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
5979 Set_Next_Entity
(New_C
, First_Entity
(Def_Id
));
5980 Set_First_Entity
(Def_Id
, New_C
);
5982 -- The freeze node is only used to introduce the controller,
5983 -- the back-end has no use for it for a discriminated
5986 Set_Freeze_Node
(Def_Id
, Empty
);
5987 Set_Has_Delayed_Freeze
(Def_Id
, False);
5992 -- Freeze processing for array types
5994 elsif Is_Array_Type
(Def_Id
) then
5995 Freeze_Array_Type
(N
);
5997 -- Freeze processing for access types
5999 -- For pool-specific access types, find out the pool object used for
6000 -- this type, needs actual expansion of it in some cases. Here are the
6001 -- different cases :
6003 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
6004 -- ---> don't use any storage pool
6006 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
6008 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
6010 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
6011 -- ---> Storage Pool is the specified one
6013 -- See GNAT Pool packages in the Run-Time for more details
6015 elsif Ekind
(Def_Id
) = E_Access_Type
6016 or else Ekind
(Def_Id
) = E_General_Access_Type
6019 Loc
: constant Source_Ptr
:= Sloc
(N
);
6020 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
6021 Pool_Object
: Entity_Id
;
6023 Freeze_Action_Typ
: Entity_Id
;
6028 -- Rep Clause "for Def_Id'Storage_Size use 0;"
6029 -- ---> don't use any storage pool
6031 if No_Pool_Assigned
(Def_Id
) then
6036 -- Rep Clause : for Def_Id'Storage_Size use Expr.
6038 -- Def_Id__Pool : Stack_Bounded_Pool
6039 -- (Expr, DT'Size, DT'Alignment);
6041 elsif Has_Storage_Size_Clause
(Def_Id
) then
6047 -- For unconstrained composite types we give a size of zero
6048 -- so that the pool knows that it needs a special algorithm
6049 -- for variable size object allocation.
6051 if Is_Composite_Type
(Desig_Type
)
6052 and then not Is_Constrained
(Desig_Type
)
6055 Make_Integer_Literal
(Loc
, 0);
6058 Make_Integer_Literal
(Loc
, Maximum_Alignment
);
6062 Make_Attribute_Reference
(Loc
,
6063 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
6064 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
6067 Make_Attribute_Reference
(Loc
,
6068 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
6069 Attribute_Name
=> Name_Alignment
);
6073 Make_Defining_Identifier
(Loc
,
6074 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
6076 -- We put the code associated with the pools in the entity
6077 -- that has the later freeze node, usually the access type
6078 -- but it can also be the designated_type; because the pool
6079 -- code requires both those types to be frozen
6081 if Is_Frozen
(Desig_Type
)
6082 and then (No
(Freeze_Node
(Desig_Type
))
6083 or else Analyzed
(Freeze_Node
(Desig_Type
)))
6085 Freeze_Action_Typ
:= Def_Id
;
6087 -- A Taft amendment type cannot get the freeze actions
6088 -- since the full view is not there.
6090 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
6091 and then No
(Full_View
(Desig_Type
))
6093 Freeze_Action_Typ
:= Def_Id
;
6096 Freeze_Action_Typ
:= Desig_Type
;
6099 Append_Freeze_Action
(Freeze_Action_Typ
,
6100 Make_Object_Declaration
(Loc
,
6101 Defining_Identifier
=> Pool_Object
,
6102 Object_Definition
=>
6103 Make_Subtype_Indication
(Loc
,
6106 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
6109 Make_Index_Or_Discriminant_Constraint
(Loc
,
6110 Constraints
=> New_List
(
6112 -- First discriminant is the Pool Size
6115 Storage_Size_Variable
(Def_Id
), Loc
),
6117 -- Second discriminant is the element size
6121 -- Third discriminant is the alignment
6126 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
6130 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
6131 -- ---> Storage Pool is the specified one
6133 elsif Present
(Associated_Storage_Pool
(Def_Id
)) then
6135 -- Nothing to do the associated storage pool has been attached
6136 -- when analyzing the rep. clause
6141 -- For access-to-controlled types (including class-wide types and
6142 -- Taft-amendment types which potentially have controlled
6143 -- components), expand the list controller object that will store
6144 -- the dynamically allocated objects. Do not do this
6145 -- transformation for expander-generated access types, but do it
6146 -- for types that are the full view of types derived from other
6147 -- private types. Also suppress the list controller in the case
6148 -- of a designated type with convention Java, since this is used
6149 -- when binding to Java API specs, where there's no equivalent of
6150 -- a finalization list and we don't want to pull in the
6151 -- finalization support if not needed.
6153 if not Comes_From_Source
(Def_Id
)
6154 and then not Has_Private_Declaration
(Def_Id
)
6158 elsif (Controlled_Type
(Desig_Type
)
6159 and then Convention
(Desig_Type
) /= Convention_Java
6160 and then Convention
(Desig_Type
) /= Convention_CIL
)
6162 (Is_Incomplete_Or_Private_Type
(Desig_Type
)
6163 and then No
(Full_View
(Desig_Type
))
6165 -- An exception is made for types defined in the run-time
6166 -- because Ada.Tags.Tag itself is such a type and cannot
6167 -- afford this unnecessary overhead that would generates a
6168 -- loop in the expansion scheme...
6170 and then not In_Runtime
(Def_Id
)
6172 -- Another exception is if Restrictions (No_Finalization)
6173 -- is active, since then we know nothing is controlled.
6175 and then not Restriction_Active
(No_Finalization
))
6177 -- If the designated type is not frozen yet, its controlled
6178 -- status must be retrieved explicitly.
6180 or else (Is_Array_Type
(Desig_Type
)
6181 and then not Is_Frozen
(Desig_Type
)
6182 and then Controlled_Type
(Component_Type
(Desig_Type
)))
6184 -- The designated type has controlled anonymous access
6187 or else Has_Controlled_Coextensions
(Desig_Type
)
6189 Set_Associated_Final_Chain
(Def_Id
, Add_Final_Chain
(Def_Id
));
6193 -- Freeze processing for enumeration types
6195 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
6197 -- We only have something to do if we have a non-standard
6198 -- representation (i.e. at least one literal whose pos value
6199 -- is not the same as its representation)
6201 if Has_Non_Standard_Rep
(Def_Id
) then
6202 Freeze_Enumeration_Type
(N
);
6205 -- Private types that are completed by a derivation from a private
6206 -- type have an internally generated full view, that needs to be
6207 -- frozen. This must be done explicitly because the two views share
6208 -- the freeze node, and the underlying full view is not visible when
6209 -- the freeze node is analyzed.
6211 elsif Is_Private_Type
(Def_Id
)
6212 and then Is_Derived_Type
(Def_Id
)
6213 and then Present
(Full_View
(Def_Id
))
6214 and then Is_Itype
(Full_View
(Def_Id
))
6215 and then Has_Private_Declaration
(Full_View
(Def_Id
))
6216 and then Freeze_Node
(Full_View
(Def_Id
)) = N
6218 Set_Entity
(N
, Full_View
(Def_Id
));
6219 Result
:= Freeze_Type
(N
);
6220 Set_Entity
(N
, Def_Id
);
6222 -- All other types require no expander action. There are such cases
6223 -- (e.g. task types and protected types). In such cases, the freeze
6224 -- nodes are there for use by Gigi.
6228 Freeze_Stream_Operations
(N
, Def_Id
);
6232 when RE_Not_Available
=>
6236 -------------------------
6237 -- Get_Simple_Init_Val --
6238 -------------------------
6240 function Get_Simple_Init_Val
6243 Size
: Uint
:= No_Uint
) return Node_Id
6245 Loc
: constant Source_Ptr
:= Sloc
(N
);
6251 -- This is the size to be used for computation of the appropriate
6252 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
6254 IV_Attribute
: constant Boolean :=
6255 Nkind
(N
) = N_Attribute_Reference
6256 and then Attribute_Name
(N
) = Name_Invalid_Value
;
6260 -- These are the values computed by the procedure Check_Subtype_Bounds
6262 procedure Check_Subtype_Bounds
;
6263 -- This procedure examines the subtype T, and its ancestor subtypes and
6264 -- derived types to determine the best known information about the
6265 -- bounds of the subtype. After the call Lo_Bound is set either to
6266 -- No_Uint if no information can be determined, or to a value which
6267 -- represents a known low bound, i.e. a valid value of the subtype can
6268 -- not be less than this value. Hi_Bound is similarly set to a known
6269 -- high bound (valid value cannot be greater than this).
6271 --------------------------
6272 -- Check_Subtype_Bounds --
6273 --------------------------
6275 procedure Check_Subtype_Bounds
is
6284 Lo_Bound
:= No_Uint
;
6285 Hi_Bound
:= No_Uint
;
6287 -- Loop to climb ancestor subtypes and derived types
6291 if not Is_Discrete_Type
(ST1
) then
6295 Lo
:= Type_Low_Bound
(ST1
);
6296 Hi
:= Type_High_Bound
(ST1
);
6298 if Compile_Time_Known_Value
(Lo
) then
6299 Loval
:= Expr_Value
(Lo
);
6301 if Lo_Bound
= No_Uint
or else Lo_Bound
< Loval
then
6306 if Compile_Time_Known_Value
(Hi
) then
6307 Hival
:= Expr_Value
(Hi
);
6309 if Hi_Bound
= No_Uint
or else Hi_Bound
> Hival
then
6314 ST2
:= Ancestor_Subtype
(ST1
);
6320 exit when ST1
= ST2
;
6323 end Check_Subtype_Bounds
;
6325 -- Start of processing for Get_Simple_Init_Val
6328 -- For a private type, we should always have an underlying type
6329 -- (because this was already checked in Needs_Simple_Initialization).
6330 -- What we do is to get the value for the underlying type and then do
6331 -- an Unchecked_Convert to the private type.
6333 if Is_Private_Type
(T
) then
6334 Val
:= Get_Simple_Init_Val
(Underlying_Type
(T
), N
, Size
);
6336 -- A special case, if the underlying value is null, then qualify it
6337 -- with the underlying type, so that the null is properly typed
6338 -- Similarly, if it is an aggregate it must be qualified, because an
6339 -- unchecked conversion does not provide a context for it.
6341 if Nkind_In
(Val
, N_Null
, N_Aggregate
) then
6343 Make_Qualified_Expression
(Loc
,
6345 New_Occurrence_Of
(Underlying_Type
(T
), Loc
),
6349 Result
:= Unchecked_Convert_To
(T
, Val
);
6351 -- Don't truncate result (important for Initialize/Normalize_Scalars)
6353 if Nkind
(Result
) = N_Unchecked_Type_Conversion
6354 and then Is_Scalar_Type
(Underlying_Type
(T
))
6356 Set_No_Truncation
(Result
);
6361 -- For scalars, we must have normalize/initialize scalars case, or
6362 -- if the node N is an 'Invalid_Value attribute node.
6364 elsif Is_Scalar_Type
(T
) then
6365 pragma Assert
(Init_Or_Norm_Scalars
or IV_Attribute
);
6367 -- Compute size of object. If it is given by the caller, we can use
6368 -- it directly, otherwise we use Esize (T) as an estimate. As far as
6369 -- we know this covers all cases correctly.
6371 if Size
= No_Uint
or else Size
<= Uint_0
then
6372 Size_To_Use
:= UI_Max
(Uint_1
, Esize
(T
));
6374 Size_To_Use
:= Size
;
6377 -- Maximum size to use is 64 bits, since we will create values
6378 -- of type Unsigned_64 and the range must fit this type.
6380 if Size_To_Use
/= No_Uint
and then Size_To_Use
> Uint_64
then
6381 Size_To_Use
:= Uint_64
;
6384 -- Check known bounds of subtype
6386 Check_Subtype_Bounds
;
6388 -- Processing for Normalize_Scalars case
6390 if Normalize_Scalars
and then not IV_Attribute
then
6392 -- If zero is invalid, it is a convenient value to use that is
6393 -- for sure an appropriate invalid value in all situations.
6395 if Lo_Bound
/= No_Uint
and then Lo_Bound
> Uint_0
then
6396 Val
:= Make_Integer_Literal
(Loc
, 0);
6398 -- Cases where all one bits is the appropriate invalid value
6400 -- For modular types, all 1 bits is either invalid or valid. If
6401 -- it is valid, then there is nothing that can be done since there
6402 -- are no invalid values (we ruled out zero already).
6404 -- For signed integer types that have no negative values, either
6405 -- there is room for negative values, or there is not. If there
6406 -- is, then all 1 bits may be interpreted as minus one, which is
6407 -- certainly invalid. Alternatively it is treated as the largest
6408 -- positive value, in which case the observation for modular types
6411 -- For float types, all 1-bits is a NaN (not a number), which is
6412 -- certainly an appropriately invalid value.
6414 elsif Is_Unsigned_Type
(T
)
6415 or else Is_Floating_Point_Type
(T
)
6416 or else Is_Enumeration_Type
(T
)
6418 Val
:= Make_Integer_Literal
(Loc
, 2 ** Size_To_Use
- 1);
6420 -- Resolve as Unsigned_64, because the largest number we
6421 -- can generate is out of range of universal integer.
6423 Analyze_And_Resolve
(Val
, RTE
(RE_Unsigned_64
));
6425 -- Case of signed types
6429 Signed_Size
: constant Uint
:=
6430 UI_Min
(Uint_63
, Size_To_Use
- 1);
6433 -- Normally we like to use the most negative number. The
6434 -- one exception is when this number is in the known
6435 -- subtype range and the largest positive number is not in
6436 -- the known subtype range.
6438 -- For this exceptional case, use largest positive value
6440 if Lo_Bound
/= No_Uint
and then Hi_Bound
/= No_Uint
6441 and then Lo_Bound
<= (-(2 ** Signed_Size
))
6442 and then Hi_Bound
< 2 ** Signed_Size
6444 Val
:= Make_Integer_Literal
(Loc
, 2 ** Signed_Size
- 1);
6446 -- Normal case of largest negative value
6449 Val
:= Make_Integer_Literal
(Loc
, -(2 ** Signed_Size
));
6454 -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
6457 -- For float types, use float values from System.Scalar_Values
6459 if Is_Floating_Point_Type
(T
) then
6460 if Root_Type
(T
) = Standard_Short_Float
then
6461 Val_RE
:= RE_IS_Isf
;
6462 elsif Root_Type
(T
) = Standard_Float
then
6463 Val_RE
:= RE_IS_Ifl
;
6464 elsif Root_Type
(T
) = Standard_Long_Float
then
6465 Val_RE
:= RE_IS_Ilf
;
6466 else pragma Assert
(Root_Type
(T
) = Standard_Long_Long_Float
);
6467 Val_RE
:= RE_IS_Ill
;
6470 -- If zero is invalid, use zero values from System.Scalar_Values
6472 elsif Lo_Bound
/= No_Uint
and then Lo_Bound
> Uint_0
then
6473 if Size_To_Use
<= 8 then
6474 Val_RE
:= RE_IS_Iz1
;
6475 elsif Size_To_Use
<= 16 then
6476 Val_RE
:= RE_IS_Iz2
;
6477 elsif Size_To_Use
<= 32 then
6478 Val_RE
:= RE_IS_Iz4
;
6480 Val_RE
:= RE_IS_Iz8
;
6483 -- For unsigned, use unsigned values from System.Scalar_Values
6485 elsif Is_Unsigned_Type
(T
) then
6486 if Size_To_Use
<= 8 then
6487 Val_RE
:= RE_IS_Iu1
;
6488 elsif Size_To_Use
<= 16 then
6489 Val_RE
:= RE_IS_Iu2
;
6490 elsif Size_To_Use
<= 32 then
6491 Val_RE
:= RE_IS_Iu4
;
6493 Val_RE
:= RE_IS_Iu8
;
6496 -- For signed, use signed values from System.Scalar_Values
6499 if Size_To_Use
<= 8 then
6500 Val_RE
:= RE_IS_Is1
;
6501 elsif Size_To_Use
<= 16 then
6502 Val_RE
:= RE_IS_Is2
;
6503 elsif Size_To_Use
<= 32 then
6504 Val_RE
:= RE_IS_Is4
;
6506 Val_RE
:= RE_IS_Is8
;
6510 Val
:= New_Occurrence_Of
(RTE
(Val_RE
), Loc
);
6513 -- The final expression is obtained by doing an unchecked conversion
6514 -- of this result to the base type of the required subtype. We use
6515 -- the base type to avoid the unchecked conversion from chopping
6516 -- bits, and then we set Kill_Range_Check to preserve the "bad"
6519 Result
:= Unchecked_Convert_To
(Base_Type
(T
), Val
);
6521 -- Ensure result is not truncated, since we want the "bad" bits
6522 -- and also kill range check on result.
6524 if Nkind
(Result
) = N_Unchecked_Type_Conversion
then
6525 Set_No_Truncation
(Result
);
6526 Set_Kill_Range_Check
(Result
, True);
6531 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
6533 elsif Root_Type
(T
) = Standard_String
6535 Root_Type
(T
) = Standard_Wide_String
6537 Root_Type
(T
) = Standard_Wide_Wide_String
6539 pragma Assert
(Init_Or_Norm_Scalars
);
6542 Make_Aggregate
(Loc
,
6543 Component_Associations
=> New_List
(
6544 Make_Component_Association
(Loc
,
6545 Choices
=> New_List
(
6546 Make_Others_Choice
(Loc
)),
6549 (Component_Type
(T
), N
, Esize
(Root_Type
(T
))))));
6551 -- Access type is initialized to null
6553 elsif Is_Access_Type
(T
) then
6557 -- No other possibilities should arise, since we should only be
6558 -- calling Get_Simple_Init_Val if Needs_Simple_Initialization
6559 -- returned True, indicating one of the above cases held.
6562 raise Program_Error
;
6566 when RE_Not_Available
=>
6568 end Get_Simple_Init_Val
;
6570 ------------------------------
6571 -- Has_New_Non_Standard_Rep --
6572 ------------------------------
6574 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
6576 if not Is_Derived_Type
(T
) then
6577 return Has_Non_Standard_Rep
(T
)
6578 or else Has_Non_Standard_Rep
(Root_Type
(T
));
6580 -- If Has_Non_Standard_Rep is not set on the derived type, the
6581 -- representation is fully inherited.
6583 elsif not Has_Non_Standard_Rep
(T
) then
6587 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
6589 -- May need a more precise check here: the First_Rep_Item may
6590 -- be a stream attribute, which does not affect the representation
6593 end Has_New_Non_Standard_Rep
;
6599 function In_Runtime
(E
: Entity_Id
) return Boolean is
6604 while Scope
(S1
) /= Standard_Standard
loop
6608 return Chars
(S1
) = Name_System
or else Chars
(S1
) = Name_Ada
;
6611 ----------------------------
6612 -- Initialization_Warning --
6613 ----------------------------
6615 procedure Initialization_Warning
(E
: Entity_Id
) is
6616 Warning_Needed
: Boolean;
6619 Warning_Needed
:= False;
6621 if Ekind
(Current_Scope
) = E_Package
6622 and then Static_Elaboration_Desired
(Current_Scope
)
6625 if Is_Record_Type
(E
) then
6626 if Has_Discriminants
(E
)
6627 or else Is_Limited_Type
(E
)
6628 or else Has_Non_Standard_Rep
(E
)
6630 Warning_Needed
:= True;
6633 -- Verify that at least one component has an initialization
6634 -- expression. No need for a warning on a type if all its
6635 -- components have no initialization.
6641 Comp
:= First_Component
(E
);
6642 while Present
(Comp
) loop
6643 if Ekind
(Comp
) = E_Discriminant
6645 (Nkind
(Parent
(Comp
)) = N_Component_Declaration
6646 and then Present
(Expression
(Parent
(Comp
))))
6648 Warning_Needed
:= True;
6652 Next_Component
(Comp
);
6657 if Warning_Needed
then
6659 ("Objects of the type cannot be initialized " &
6660 "statically by default?",
6666 Error_Msg_N
("Object cannot be initialized statically?", E
);
6669 end Initialization_Warning
;
6675 function Init_Formals
(Typ
: Entity_Id
) return List_Id
is
6676 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6680 -- First parameter is always _Init : in out typ. Note that we need
6681 -- this to be in/out because in the case of the task record value,
6682 -- there are default record fields (_Priority, _Size, -Task_Info)
6683 -- that may be referenced in the generated initialization routine.
6685 Formals
:= New_List
(
6686 Make_Parameter_Specification
(Loc
,
6687 Defining_Identifier
=>
6688 Make_Defining_Identifier
(Loc
, Name_uInit
),
6690 Out_Present
=> True,
6691 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
6693 -- For task record value, or type that contains tasks, add two more
6694 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
6695 -- We also add these parameters for the task record type case.
6698 or else (Is_Record_Type
(Typ
) and then Is_Task_Record_Type
(Typ
))
6701 Make_Parameter_Specification
(Loc
,
6702 Defining_Identifier
=>
6703 Make_Defining_Identifier
(Loc
, Name_uMaster
),
6704 Parameter_Type
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
)));
6707 Make_Parameter_Specification
(Loc
,
6708 Defining_Identifier
=>
6709 Make_Defining_Identifier
(Loc
, Name_uChain
),
6711 Out_Present
=> True,
6713 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
)));
6716 Make_Parameter_Specification
(Loc
,
6717 Defining_Identifier
=>
6718 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
6721 New_Reference_To
(Standard_String
, Loc
)));
6727 when RE_Not_Available
=>
6731 -------------------------
6732 -- Init_Secondary_Tags --
6733 -------------------------
6735 procedure Init_Secondary_Tags
6738 Stmts_List
: List_Id
;
6739 Fixed_Comps
: Boolean := True;
6740 Variable_Comps
: Boolean := True)
6742 Loc
: constant Source_Ptr
:= Sloc
(Target
);
6744 procedure Inherit_CPP_Tag
6747 Tag_Comp
: Entity_Id
;
6748 Iface_Tag
: Node_Id
);
6749 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
6750 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
6752 procedure Initialize_Tag
6755 Tag_Comp
: Entity_Id
;
6756 Iface_Tag
: Node_Id
);
6757 -- Initialize the tag of the secondary dispatch table of Typ associated
6758 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
6759 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
6760 -- of Typ CPP tagged type we generate code to inherit the contents of
6761 -- the dispatch table directly from the ancestor.
6763 ---------------------
6764 -- Inherit_CPP_Tag --
6765 ---------------------
6767 procedure Inherit_CPP_Tag
6770 Tag_Comp
: Entity_Id
;
6771 Iface_Tag
: Node_Id
)
6774 pragma Assert
(Is_CPP_Class
(Etype
(Typ
)));
6776 Append_To
(Stmts_List
,
6777 Build_Inherit_Prims
(Loc
,
6780 Make_Selected_Component
(Loc
,
6781 Prefix
=> New_Copy_Tree
(Target
),
6782 Selector_Name
=> New_Reference_To
(Tag_Comp
, Loc
)),
6784 New_Reference_To
(Iface_Tag
, Loc
),
6786 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Iface
)))));
6787 end Inherit_CPP_Tag
;
6789 --------------------
6790 -- Initialize_Tag --
6791 --------------------
6793 procedure Initialize_Tag
6796 Tag_Comp
: Entity_Id
;
6797 Iface_Tag
: Node_Id
)
6799 Comp_Typ
: Entity_Id
;
6800 Offset_To_Top_Comp
: Entity_Id
:= Empty
;
6803 -- Initialize the pointer to the secondary DT associated with the
6806 if not Is_Ancestor
(Iface
, Typ
) then
6807 Append_To
(Stmts_List
,
6808 Make_Assignment_Statement
(Loc
,
6810 Make_Selected_Component
(Loc
,
6811 Prefix
=> New_Copy_Tree
(Target
),
6812 Selector_Name
=> New_Reference_To
(Tag_Comp
, Loc
)),
6814 New_Reference_To
(Iface_Tag
, Loc
)));
6817 Comp_Typ
:= Scope
(Tag_Comp
);
6819 -- Initialize the entries of the table of interfaces. We generate a
6820 -- different call when the parent of the type has variable size
6823 if Comp_Typ
/= Etype
(Comp_Typ
)
6824 and then Is_Variable_Size_Record
(Etype
(Comp_Typ
))
6825 and then Chars
(Tag_Comp
) /= Name_uTag
6828 (Present
(DT_Offset_To_Top_Func
(Tag_Comp
)));
6830 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
6831 -- configurable run-time environment.
6833 if not RTE_Available
(RE_Set_Dynamic_Offset_To_Top
) then
6835 ("variable size record with interface types", Typ
);
6840 -- Set_Dynamic_Offset_To_Top
6842 -- Interface_T => Iface'Tag,
6843 -- Offset_Value => n,
6844 -- Offset_Func => Fn'Address)
6846 Append_To
(Stmts_List
,
6847 Make_Procedure_Call_Statement
(Loc
,
6848 Name
=> New_Reference_To
6849 (RTE
(RE_Set_Dynamic_Offset_To_Top
), Loc
),
6850 Parameter_Associations
=> New_List
(
6851 Make_Attribute_Reference
(Loc
,
6852 Prefix
=> New_Copy_Tree
(Target
),
6853 Attribute_Name
=> Name_Address
),
6855 Unchecked_Convert_To
(RTE
(RE_Tag
),
6857 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))),
6860 Unchecked_Convert_To
6861 (RTE
(RE_Storage_Offset
),
6862 Make_Attribute_Reference
(Loc
,
6864 Make_Selected_Component
(Loc
,
6865 Prefix
=> New_Copy_Tree
(Target
),
6867 New_Reference_To
(Tag_Comp
, Loc
)),
6868 Attribute_Name
=> Name_Position
)),
6870 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Function_Ptr
),
6871 Make_Attribute_Reference
(Loc
,
6872 Prefix
=> New_Reference_To
6873 (DT_Offset_To_Top_Func
(Tag_Comp
), Loc
),
6874 Attribute_Name
=> Name_Address
)))));
6876 -- In this case the next component stores the value of the
6877 -- offset to the top.
6879 Offset_To_Top_Comp
:= Next_Entity
(Tag_Comp
);
6880 pragma Assert
(Present
(Offset_To_Top_Comp
));
6882 Append_To
(Stmts_List
,
6883 Make_Assignment_Statement
(Loc
,
6885 Make_Selected_Component
(Loc
,
6886 Prefix
=> New_Copy_Tree
(Target
),
6887 Selector_Name
=> New_Reference_To
6888 (Offset_To_Top_Comp
, Loc
)),
6890 Make_Attribute_Reference
(Loc
,
6892 Make_Selected_Component
(Loc
,
6893 Prefix
=> New_Copy_Tree
(Target
),
6895 New_Reference_To
(Tag_Comp
, Loc
)),
6896 Attribute_Name
=> Name_Position
)));
6898 -- Normal case: No discriminants in the parent type
6901 -- Don't need to set any value if this interface shares
6902 -- the primary dispatch table.
6904 if not Is_Ancestor
(Iface
, Typ
) then
6905 Append_To
(Stmts_List
,
6906 Build_Set_Static_Offset_To_Top
(Loc
,
6907 Iface_Tag
=> New_Reference_To
(Iface_Tag
, Loc
),
6909 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
6910 Make_Attribute_Reference
(Loc
,
6912 Make_Selected_Component
(Loc
,
6913 Prefix
=> New_Copy_Tree
(Target
),
6915 New_Reference_To
(Tag_Comp
, Loc
)),
6916 Attribute_Name
=> Name_Position
))));
6920 -- Register_Interface_Offset
6922 -- Interface_T => Iface'Tag,
6923 -- Is_Constant => True,
6924 -- Offset_Value => n,
6925 -- Offset_Func => null);
6927 if RTE_Available
(RE_Register_Interface_Offset
) then
6928 Append_To
(Stmts_List
,
6929 Make_Procedure_Call_Statement
(Loc
,
6930 Name
=> New_Reference_To
6931 (RTE
(RE_Register_Interface_Offset
), Loc
),
6932 Parameter_Associations
=> New_List
(
6933 Make_Attribute_Reference
(Loc
,
6934 Prefix
=> New_Copy_Tree
(Target
),
6935 Attribute_Name
=> Name_Address
),
6937 Unchecked_Convert_To
(RTE
(RE_Tag
),
6939 (Node
(First_Elmt
(Access_Disp_Table
(Iface
))), Loc
)),
6941 New_Occurrence_Of
(Standard_True
, Loc
),
6943 Unchecked_Convert_To
6944 (RTE
(RE_Storage_Offset
),
6945 Make_Attribute_Reference
(Loc
,
6947 Make_Selected_Component
(Loc
,
6948 Prefix
=> New_Copy_Tree
(Target
),
6950 New_Reference_To
(Tag_Comp
, Loc
)),
6951 Attribute_Name
=> Name_Position
)),
6960 Full_Typ
: Entity_Id
;
6961 Ifaces_List
: Elist_Id
;
6962 Ifaces_Comp_List
: Elist_Id
;
6963 Ifaces_Tag_List
: Elist_Id
;
6964 Iface_Elmt
: Elmt_Id
;
6965 Iface_Comp_Elmt
: Elmt_Id
;
6966 Iface_Tag_Elmt
: Elmt_Id
;
6968 In_Variable_Pos
: Boolean;
6970 -- Start of processing for Init_Secondary_Tags
6973 -- Handle private types
6975 if Present
(Full_View
(Typ
)) then
6976 Full_Typ
:= Full_View
(Typ
);
6981 Collect_Interfaces_Info
6982 (Full_Typ
, Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
6984 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6985 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
6986 Iface_Tag_Elmt
:= First_Elmt
(Ifaces_Tag_List
);
6987 while Present
(Iface_Elmt
) loop
6988 Tag_Comp
:= Node
(Iface_Comp_Elmt
);
6990 -- If we are compiling under the CPP full ABI compatibility mode and
6991 -- the ancestor is a CPP_Pragma tagged type then we generate code to
6992 -- inherit the contents of the dispatch table directly from the
6995 if Is_CPP_Class
(Etype
(Full_Typ
)) then
6996 Inherit_CPP_Tag
(Full_Typ
,
6997 Iface
=> Node
(Iface_Elmt
),
6998 Tag_Comp
=> Tag_Comp
,
6999 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
7001 -- Otherwise generate code to initialize the tag
7004 -- Check if the parent of the record type has variable size
7007 In_Variable_Pos
:= Scope
(Tag_Comp
) /= Etype
(Scope
(Tag_Comp
))
7008 and then Is_Variable_Size_Record
(Etype
(Scope
(Tag_Comp
)));
7010 if (In_Variable_Pos
and then Variable_Comps
)
7011 or else (not In_Variable_Pos
and then Fixed_Comps
)
7013 Initialize_Tag
(Full_Typ
,
7014 Iface
=> Node
(Iface_Elmt
),
7015 Tag_Comp
=> Tag_Comp
,
7016 Iface_Tag
=> Node
(Iface_Tag_Elmt
));
7020 Next_Elmt
(Iface_Elmt
);
7021 Next_Elmt
(Iface_Comp_Elmt
);
7022 Next_Elmt
(Iface_Tag_Elmt
);
7024 end Init_Secondary_Tags
;
7026 -----------------------------
7027 -- Is_Variable_Size_Record --
7028 -----------------------------
7030 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
7032 Comp_Typ
: Entity_Id
;
7035 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean;
7036 -- To simplify handling of array components. Determines whether the
7037 -- given bound is constant (a constant or enumeration literal, or an
7038 -- integer literal) as opposed to per-object, through an expression
7039 -- or a discriminant.
7041 -----------------------
7042 -- Is_Constant_Bound --
7043 -----------------------
7045 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
7047 if Nkind
(Exp
) = N_Integer_Literal
then
7051 Is_Entity_Name
(Exp
)
7052 and then Present
(Entity
(Exp
))
7054 (Ekind
(Entity
(Exp
)) = E_Constant
7055 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
);
7057 end Is_Constant_Bound
;
7059 -- Start of processing for Is_Variable_Sized_Record
7062 pragma Assert
(Is_Record_Type
(E
));
7064 Comp
:= First_Entity
(E
);
7065 while Present
(Comp
) loop
7066 Comp_Typ
:= Etype
(Comp
);
7068 if Is_Record_Type
(Comp_Typ
) then
7070 -- Recursive call if the record type has discriminants
7072 if Has_Discriminants
(Comp_Typ
)
7073 and then Is_Variable_Size_Record
(Comp_Typ
)
7078 elsif Is_Array_Type
(Comp_Typ
) then
7080 -- Check if some index is initialized with a non-constant value
7082 Idx
:= First_Index
(Comp_Typ
);
7083 while Present
(Idx
) loop
7084 if Nkind
(Idx
) = N_Range
then
7085 if not Is_Constant_Bound
(Low_Bound
(Idx
))
7087 not Is_Constant_Bound
(High_Bound
(Idx
))
7093 Idx
:= Next_Index
(Idx
);
7101 end Is_Variable_Size_Record
;
7103 ----------------------------------------
7104 -- Make_Controlling_Function_Wrappers --
7105 ----------------------------------------
7107 procedure Make_Controlling_Function_Wrappers
7108 (Tag_Typ
: Entity_Id
;
7109 Decl_List
: out List_Id
;
7110 Body_List
: out List_Id
)
7112 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
7113 Prim_Elmt
: Elmt_Id
;
7115 Actual_List
: List_Id
;
7116 Formal_List
: List_Id
;
7118 Par_Formal
: Entity_Id
;
7119 Formal_Node
: Node_Id
;
7120 Func_Body
: Node_Id
;
7121 Func_Decl
: Node_Id
;
7122 Func_Spec
: Node_Id
;
7123 Return_Stmt
: Node_Id
;
7126 Decl_List
:= New_List
;
7127 Body_List
:= New_List
;
7129 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
7131 while Present
(Prim_Elmt
) loop
7132 Subp
:= Node
(Prim_Elmt
);
7134 -- If a primitive function with a controlling result of the type has
7135 -- not been overridden by the user, then we must create a wrapper
7136 -- function here that effectively overrides it and invokes the
7137 -- (non-abstract) parent function. This can only occur for a null
7138 -- extension. Note that functions with anonymous controlling access
7139 -- results don't qualify and must be overridden. We also exclude
7140 -- Input attributes, since each type will have its own version of
7141 -- Input constructed by the expander. The test for Comes_From_Source
7142 -- is needed to distinguish inherited operations from renamings
7143 -- (which also have Alias set).
7145 -- The function may be abstract, or require_Overriding may be set
7146 -- for it, because tests for null extensions may already have reset
7147 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
7148 -- set, functions that need wrappers are recognized by having an
7149 -- alias that returns the parent type.
7151 if Comes_From_Source
(Subp
)
7152 or else No
(Alias
(Subp
))
7153 or else Ekind
(Subp
) /= E_Function
7154 or else not Has_Controlling_Result
(Subp
)
7155 or else Is_Access_Type
(Etype
(Subp
))
7156 or else Is_Abstract_Subprogram
(Alias
(Subp
))
7157 or else Is_TSS
(Subp
, TSS_Stream_Input
)
7161 elsif Is_Abstract_Subprogram
(Subp
)
7162 or else Requires_Overriding
(Subp
)
7164 (Is_Null_Extension
(Etype
(Subp
))
7165 and then Etype
(Alias
(Subp
)) /= Etype
(Subp
))
7167 Formal_List
:= No_List
;
7168 Formal
:= First_Formal
(Subp
);
7170 if Present
(Formal
) then
7171 Formal_List
:= New_List
;
7173 while Present
(Formal
) loop
7175 (Make_Parameter_Specification
7177 Defining_Identifier
=>
7178 Make_Defining_Identifier
(Sloc
(Formal
),
7179 Chars
=> Chars
(Formal
)),
7180 In_Present
=> In_Present
(Parent
(Formal
)),
7181 Out_Present
=> Out_Present
(Parent
(Formal
)),
7182 Null_Exclusion_Present
=>
7183 Null_Exclusion_Present
(Parent
(Formal
)),
7185 New_Reference_To
(Etype
(Formal
), Loc
),
7187 New_Copy_Tree
(Expression
(Parent
(Formal
)))),
7190 Next_Formal
(Formal
);
7195 Make_Function_Specification
(Loc
,
7196 Defining_Unit_Name
=>
7197 Make_Defining_Identifier
(Loc
,
7198 Chars
=> Chars
(Subp
)),
7199 Parameter_Specifications
=> Formal_List
,
7200 Result_Definition
=>
7201 New_Reference_To
(Etype
(Subp
), Loc
));
7203 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
7204 Append_To
(Decl_List
, Func_Decl
);
7206 -- Build a wrapper body that calls the parent function. The body
7207 -- contains a single return statement that returns an extension
7208 -- aggregate whose ancestor part is a call to the parent function,
7209 -- passing the formals as actuals (with any controlling arguments
7210 -- converted to the types of the corresponding formals of the
7211 -- parent function, which might be anonymous access types), and
7212 -- having a null extension.
7214 Formal
:= First_Formal
(Subp
);
7215 Par_Formal
:= First_Formal
(Alias
(Subp
));
7216 Formal_Node
:= First
(Formal_List
);
7218 if Present
(Formal
) then
7219 Actual_List
:= New_List
;
7221 Actual_List
:= No_List
;
7224 while Present
(Formal
) loop
7225 if Is_Controlling_Formal
(Formal
) then
7226 Append_To
(Actual_List
,
7227 Make_Type_Conversion
(Loc
,
7229 New_Occurrence_Of
(Etype
(Par_Formal
), Loc
),
7232 (Defining_Identifier
(Formal_Node
), Loc
)));
7237 (Defining_Identifier
(Formal_Node
), Loc
));
7240 Next_Formal
(Formal
);
7241 Next_Formal
(Par_Formal
);
7246 Make_Simple_Return_Statement
(Loc
,
7248 Make_Extension_Aggregate
(Loc
,
7250 Make_Function_Call
(Loc
,
7251 Name
=> New_Reference_To
(Alias
(Subp
), Loc
),
7252 Parameter_Associations
=> Actual_List
),
7253 Null_Record_Present
=> True));
7256 Make_Subprogram_Body
(Loc
,
7257 Specification
=> New_Copy_Tree
(Func_Spec
),
7258 Declarations
=> Empty_List
,
7259 Handled_Statement_Sequence
=>
7260 Make_Handled_Sequence_Of_Statements
(Loc
,
7261 Statements
=> New_List
(Return_Stmt
)));
7263 Set_Defining_Unit_Name
7264 (Specification
(Func_Body
),
7265 Make_Defining_Identifier
(Loc
, Chars
(Subp
)));
7267 Append_To
(Body_List
, Func_Body
);
7269 -- Replace the inherited function with the wrapper function
7270 -- in the primitive operations list.
7272 Override_Dispatching_Operation
7273 (Tag_Typ
, Subp
, New_Op
=> Defining_Unit_Name
(Func_Spec
));
7277 Next_Elmt
(Prim_Elmt
);
7279 end Make_Controlling_Function_Wrappers
;
7285 -- <Make_Eq_If shared components>
7287 -- when V1 => <Make_Eq_Case> on subcomponents
7289 -- when Vn => <Make_Eq_Case> on subcomponents
7292 function Make_Eq_Case
7295 Discr
: Entity_Id
:= Empty
) return List_Id
7297 Loc
: constant Source_Ptr
:= Sloc
(E
);
7298 Result
: constant List_Id
:= New_List
;
7303 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
7305 if No
(Variant_Part
(CL
)) then
7309 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
7311 if No
(Variant
) then
7315 Alt_List
:= New_List
;
7317 while Present
(Variant
) loop
7318 Append_To
(Alt_List
,
7319 Make_Case_Statement_Alternative
(Loc
,
7320 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
7321 Statements
=> Make_Eq_Case
(E
, Component_List
(Variant
))));
7323 Next_Non_Pragma
(Variant
);
7326 -- If we have an Unchecked_Union, use one of the parameters that
7327 -- captures the discriminants.
7329 if Is_Unchecked_Union
(E
) then
7331 Make_Case_Statement
(Loc
,
7332 Expression
=> New_Reference_To
(Discr
, Loc
),
7333 Alternatives
=> Alt_List
));
7337 Make_Case_Statement
(Loc
,
7339 Make_Selected_Component
(Loc
,
7340 Prefix
=> Make_Identifier
(Loc
, Name_X
),
7341 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
7342 Alternatives
=> Alt_List
));
7363 -- or a null statement if the list L is empty
7367 L
: List_Id
) return Node_Id
7369 Loc
: constant Source_Ptr
:= Sloc
(E
);
7371 Field_Name
: Name_Id
;
7376 return Make_Null_Statement
(Loc
);
7381 C
:= First_Non_Pragma
(L
);
7382 while Present
(C
) loop
7383 Field_Name
:= Chars
(Defining_Identifier
(C
));
7385 -- The tags must not be compared: they are not part of the value.
7386 -- Ditto for the controller component, if present.
7388 -- Note also that in the following, we use Make_Identifier for
7389 -- the component names. Use of New_Reference_To to identify the
7390 -- components would be incorrect because the wrong entities for
7391 -- discriminants could be picked up in the private type case.
7393 if Field_Name
/= Name_uTag
7395 Field_Name
/= Name_uController
7397 Evolve_Or_Else
(Cond
,
7400 Make_Selected_Component
(Loc
,
7401 Prefix
=> Make_Identifier
(Loc
, Name_X
),
7403 Make_Identifier
(Loc
, Field_Name
)),
7406 Make_Selected_Component
(Loc
,
7407 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
7409 Make_Identifier
(Loc
, Field_Name
))));
7412 Next_Non_Pragma
(C
);
7416 return Make_Null_Statement
(Loc
);
7420 Make_Implicit_If_Statement
(E
,
7422 Then_Statements
=> New_List
(
7423 Make_Simple_Return_Statement
(Loc
,
7424 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
7429 -------------------------------
7430 -- Make_Null_Procedure_Specs --
7431 -------------------------------
7433 procedure Make_Null_Procedure_Specs
7434 (Tag_Typ
: Entity_Id
;
7435 Decl_List
: out List_Id
)
7437 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
7439 Formal_List
: List_Id
;
7440 Parent_Subp
: Entity_Id
;
7441 Prim_Elmt
: Elmt_Id
;
7442 Proc_Spec
: Node_Id
;
7443 Proc_Decl
: Node_Id
;
7446 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean;
7447 -- Returns True if E is a null procedure that is an interface primitive
7449 ---------------------------------
7450 -- Is_Null_Interface_Primitive --
7451 ---------------------------------
7453 function Is_Null_Interface_Primitive
(E
: Entity_Id
) return Boolean is
7455 return Comes_From_Source
(E
)
7456 and then Is_Dispatching_Operation
(E
)
7457 and then Ekind
(E
) = E_Procedure
7458 and then Null_Present
(Parent
(E
))
7459 and then Is_Interface
(Find_Dispatching_Type
(E
));
7460 end Is_Null_Interface_Primitive
;
7462 -- Start of processing for Make_Null_Procedure_Specs
7465 Decl_List
:= New_List
;
7466 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
7467 while Present
(Prim_Elmt
) loop
7468 Subp
:= Node
(Prim_Elmt
);
7470 -- If a null procedure inherited from an interface has not been
7471 -- overridden, then we build a null procedure declaration to
7472 -- override the inherited procedure.
7474 Parent_Subp
:= Alias
(Subp
);
7476 if Present
(Parent_Subp
)
7477 and then Is_Null_Interface_Primitive
(Parent_Subp
)
7479 Formal_List
:= No_List
;
7480 Formal
:= First_Formal
(Subp
);
7482 if Present
(Formal
) then
7483 Formal_List
:= New_List
;
7485 while Present
(Formal
) loop
7487 (Make_Parameter_Specification
(Loc
,
7488 Defining_Identifier
=>
7489 Make_Defining_Identifier
(Sloc
(Formal
),
7490 Chars
=> Chars
(Formal
)),
7491 In_Present
=> In_Present
(Parent
(Formal
)),
7492 Out_Present
=> Out_Present
(Parent
(Formal
)),
7493 Null_Exclusion_Present
=>
7494 Null_Exclusion_Present
(Parent
(Formal
)),
7496 New_Reference_To
(Etype
(Formal
), Loc
),
7498 New_Copy_Tree
(Expression
(Parent
(Formal
)))),
7501 Next_Formal
(Formal
);
7506 Make_Procedure_Specification
(Loc
,
7507 Defining_Unit_Name
=>
7508 Make_Defining_Identifier
(Loc
, Chars
(Subp
)),
7509 Parameter_Specifications
=> Formal_List
);
7510 Set_Null_Present
(Proc_Spec
);
7512 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
, Proc_Spec
);
7513 Append_To
(Decl_List
, Proc_Decl
);
7514 Analyze
(Proc_Decl
);
7517 Next_Elmt
(Prim_Elmt
);
7519 end Make_Null_Procedure_Specs
;
7521 -------------------------------------
7522 -- Make_Predefined_Primitive_Specs --
7523 -------------------------------------
7525 procedure Make_Predefined_Primitive_Specs
7526 (Tag_Typ
: Entity_Id
;
7527 Predef_List
: out List_Id
;
7528 Renamed_Eq
: out Entity_Id
)
7530 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
7531 Res
: constant List_Id
:= New_List
;
7533 Eq_Needed
: Boolean;
7535 Eq_Name
: Name_Id
:= Name_Op_Eq
;
7537 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
7538 -- Returns true if Prim is a renaming of an unresolved predefined
7539 -- equality operation.
7541 -------------------------------
7542 -- Is_Predefined_Eq_Renaming --
7543 -------------------------------
7545 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
7547 return Chars
(Prim
) /= Name_Op_Eq
7548 and then Present
(Alias
(Prim
))
7549 and then Comes_From_Source
(Prim
)
7550 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
7551 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
7552 end Is_Predefined_Eq_Renaming
;
7554 -- Start of processing for Make_Predefined_Primitive_Specs
7557 Renamed_Eq
:= Empty
;
7561 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
7564 Profile
=> New_List
(
7565 Make_Parameter_Specification
(Loc
,
7566 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
7567 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
7569 Ret_Type
=> Standard_Long_Long_Integer
));
7571 -- Spec of _Alignment
7573 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
7575 Name
=> Name_uAlignment
,
7576 Profile
=> New_List
(
7577 Make_Parameter_Specification
(Loc
,
7578 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
7579 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
7581 Ret_Type
=> Standard_Integer
));
7583 -- Specs for dispatching stream attributes
7586 Stream_Op_TSS_Names
:
7587 constant array (Integer range <>) of TSS_Name_Type
:=
7594 for Op
in Stream_Op_TSS_Names
'Range loop
7595 if Stream_Operation_OK
(Tag_Typ
, Stream_Op_TSS_Names
(Op
)) then
7597 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
,
7598 Stream_Op_TSS_Names
(Op
)));
7603 -- Spec of "=" is expanded if the type is not limited and if a
7604 -- user defined "=" was not already declared for the non-full
7605 -- view of a private extension
7607 if not Is_Limited_Type
(Tag_Typ
) then
7609 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
7610 while Present
(Prim
) loop
7612 -- If a primitive is encountered that renames the predefined
7613 -- equality operator before reaching any explicit equality
7614 -- primitive, then we still need to create a predefined
7615 -- equality function, because calls to it can occur via
7616 -- the renaming. A new name is created for the equality
7617 -- to avoid conflicting with any user-defined equality.
7618 -- (Note that this doesn't account for renamings of
7619 -- equality nested within subpackages???)
7621 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
7622 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
7624 -- User-defined equality
7626 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
7627 and then Etype
(First_Formal
(Node
(Prim
))) =
7628 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7629 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
7631 if No
(Alias
(Node
(Prim
)))
7632 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
7633 N_Subprogram_Renaming_Declaration
7638 -- If the parent is not an interface type and has an abstract
7639 -- equality function, the inherited equality is abstract as
7640 -- well, and no body can be created for it.
7642 elsif not Is_Interface
(Etype
(Tag_Typ
))
7643 and then Present
(Alias
(Node
(Prim
)))
7644 and then Is_Abstract_Subprogram
(Alias
(Node
(Prim
)))
7649 -- If the type has an equality function corresponding with
7650 -- a primitive defined in an interface type, the inherited
7651 -- equality is abstract as well, and no body can be created
7654 elsif Present
(Alias
(Node
(Prim
)))
7655 and then Comes_From_Source
(Ultimate_Alias
(Node
(Prim
)))
7658 (Find_Dispatching_Type
(Ultimate_Alias
(Node
(Prim
))))
7668 -- If a renaming of predefined equality was found but there was no
7669 -- user-defined equality (so Eq_Needed is still true), then set the
7670 -- name back to Name_Op_Eq. But in the case where a user-defined
7671 -- equality was located after such a renaming, then the predefined
7672 -- equality function is still needed, so Eq_Needed must be set back
7675 if Eq_Name
/= Name_Op_Eq
then
7677 Eq_Name
:= Name_Op_Eq
;
7684 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
7687 Profile
=> New_List
(
7688 Make_Parameter_Specification
(Loc
,
7689 Defining_Identifier
=>
7690 Make_Defining_Identifier
(Loc
, Name_X
),
7691 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
7692 Make_Parameter_Specification
(Loc
,
7693 Defining_Identifier
=>
7694 Make_Defining_Identifier
(Loc
, Name_Y
),
7695 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
7696 Ret_Type
=> Standard_Boolean
);
7697 Append_To
(Res
, Eq_Spec
);
7699 if Eq_Name
/= Name_Op_Eq
then
7700 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
7702 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
7703 while Present
(Prim
) loop
7705 -- Any renamings of equality that appeared before an
7706 -- overriding equality must be updated to refer to the
7707 -- entity for the predefined equality, otherwise calls via
7708 -- the renaming would get incorrectly resolved to call the
7709 -- user-defined equality function.
7711 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
7712 Set_Alias
(Node
(Prim
), Renamed_Eq
);
7714 -- Exit upon encountering a user-defined equality
7716 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
7717 and then No
(Alias
(Node
(Prim
)))
7727 -- Spec for dispatching assignment
7729 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
7731 Name
=> Name_uAssign
,
7732 Profile
=> New_List
(
7733 Make_Parameter_Specification
(Loc
,
7734 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
7735 Out_Present
=> True,
7736 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
7738 Make_Parameter_Specification
(Loc
,
7739 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
7740 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)))));
7743 -- Ada 2005: Generate declarations for the following primitive
7744 -- operations for limited interfaces and synchronized types that
7745 -- implement a limited interface.
7747 -- Disp_Asynchronous_Select
7748 -- Disp_Conditional_Select
7749 -- Disp_Get_Prim_Op_Kind
7752 -- Disp_Timed_Select
7754 -- These operations cannot be implemented on VM targets, so we simply
7755 -- disable their generation in this case. We also disable generation
7756 -- of these bodies if No_Dispatching_Calls is active.
7758 if Ada_Version
>= Ada_05
7759 and then VM_Target
= No_VM
7760 and then RTE_Available
(RE_Select_Specific_Data
)
7762 -- These primitives are defined abstract in interface types
7764 if Is_Interface
(Tag_Typ
)
7765 and then Is_Limited_Record
(Tag_Typ
)
7768 Make_Abstract_Subprogram_Declaration
(Loc
,
7770 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
7773 Make_Abstract_Subprogram_Declaration
(Loc
,
7775 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
7778 Make_Abstract_Subprogram_Declaration
(Loc
,
7780 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
7783 Make_Abstract_Subprogram_Declaration
(Loc
,
7785 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
7788 Make_Abstract_Subprogram_Declaration
(Loc
,
7790 Make_Disp_Requeue_Spec
(Tag_Typ
)));
7793 Make_Abstract_Subprogram_Declaration
(Loc
,
7795 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
7797 -- If the ancestor is an interface type we declare non-abstract
7798 -- primitives to override the abstract primitives of the interface
7801 elsif (not Is_Interface
(Tag_Typ
)
7802 and then Is_Interface
(Etype
(Tag_Typ
))
7803 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
7805 (Is_Concurrent_Record_Type
(Tag_Typ
)
7806 and then Has_Interfaces
(Tag_Typ
))
7809 Make_Subprogram_Declaration
(Loc
,
7811 Make_Disp_Asynchronous_Select_Spec
(Tag_Typ
)));
7814 Make_Subprogram_Declaration
(Loc
,
7816 Make_Disp_Conditional_Select_Spec
(Tag_Typ
)));
7819 Make_Subprogram_Declaration
(Loc
,
7821 Make_Disp_Get_Prim_Op_Kind_Spec
(Tag_Typ
)));
7824 Make_Subprogram_Declaration
(Loc
,
7826 Make_Disp_Get_Task_Id_Spec
(Tag_Typ
)));
7829 Make_Subprogram_Declaration
(Loc
,
7831 Make_Disp_Requeue_Spec
(Tag_Typ
)));
7834 Make_Subprogram_Declaration
(Loc
,
7836 Make_Disp_Timed_Select_Spec
(Tag_Typ
)));
7840 -- Specs for finalization actions that may be required in case a future
7841 -- extension contain a controlled element. We generate those only for
7842 -- root tagged types where they will get dummy bodies or when the type
7843 -- has controlled components and their body must be generated. It is
7844 -- also impossible to provide those for tagged types defined within
7845 -- s-finimp since it would involve circularity problems
7847 if In_Finalization_Root
(Tag_Typ
) then
7850 -- We also skip these if finalization is not available
7852 elsif Restriction_Active
(No_Finalization
) then
7855 elsif Etype
(Tag_Typ
) = Tag_Typ
7856 or else Controlled_Type
(Tag_Typ
)
7858 -- Ada 2005 (AI-251): We must also generate these subprograms if
7859 -- the immediate ancestor is an interface to ensure the correct
7860 -- initialization of its dispatch table.
7862 or else (not Is_Interface
(Tag_Typ
)
7863 and then Is_Interface
(Etype
(Tag_Typ
)))
7865 -- Ada 205 (AI-251): We must also generate these subprograms if
7866 -- the parent of an nonlimited interface is a limited interface
7868 or else (Is_Interface
(Tag_Typ
)
7869 and then not Is_Limited_Interface
(Tag_Typ
)
7870 and then Is_Limited_Interface
(Etype
(Tag_Typ
)))
7872 if not Is_Limited_Type
(Tag_Typ
) then
7874 Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
7877 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
7881 end Make_Predefined_Primitive_Specs
;
7883 ---------------------------------
7884 -- Needs_Simple_Initialization --
7885 ---------------------------------
7887 function Needs_Simple_Initialization
(T
: Entity_Id
) return Boolean is
7889 -- Check for private type, in which case test applies to the underlying
7890 -- type of the private type.
7892 if Is_Private_Type
(T
) then
7894 RT
: constant Entity_Id
:= Underlying_Type
(T
);
7897 if Present
(RT
) then
7898 return Needs_Simple_Initialization
(RT
);
7904 -- Cases needing simple initialization are access types, and, if pragma
7905 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
7908 elsif Is_Access_Type
(T
)
7909 or else (Init_Or_Norm_Scalars
and then (Is_Scalar_Type
(T
)))
7913 -- If Initialize/Normalize_Scalars is in effect, string objects also
7914 -- need initialization, unless they are created in the course of
7915 -- expanding an aggregate (since in the latter case they will be
7916 -- filled with appropriate initializing values before they are used).
7918 elsif Init_Or_Norm_Scalars
7920 (Root_Type
(T
) = Standard_String
7921 or else Root_Type
(T
) = Standard_Wide_String
7922 or else Root_Type
(T
) = Standard_Wide_Wide_String
)
7925 or else Nkind
(Associated_Node_For_Itype
(T
)) /= N_Aggregate
)
7932 end Needs_Simple_Initialization
;
7934 ----------------------
7935 -- Predef_Deep_Spec --
7936 ----------------------
7938 function Predef_Deep_Spec
7940 Tag_Typ
: Entity_Id
;
7941 Name
: TSS_Name_Type
;
7942 For_Body
: Boolean := False) return Node_Id
7948 if Name
= TSS_Deep_Finalize
then
7950 Type_B
:= Standard_Boolean
;
7954 Make_Parameter_Specification
(Loc
,
7955 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_L
),
7957 Out_Present
=> True,
7959 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
7960 Type_B
:= Standard_Short_Short_Integer
;
7964 Make_Parameter_Specification
(Loc
,
7965 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7967 Out_Present
=> True,
7968 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)));
7971 Make_Parameter_Specification
(Loc
,
7972 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_B
),
7973 Parameter_Type
=> New_Reference_To
(Type_B
, Loc
)));
7975 return Predef_Spec_Or_Body
(Loc
,
7976 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
7979 For_Body
=> For_Body
);
7982 when RE_Not_Available
=>
7984 end Predef_Deep_Spec
;
7986 -------------------------
7987 -- Predef_Spec_Or_Body --
7988 -------------------------
7990 function Predef_Spec_Or_Body
7992 Tag_Typ
: Entity_Id
;
7995 Ret_Type
: Entity_Id
:= Empty
;
7996 For_Body
: Boolean := False) return Node_Id
7998 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
8002 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
8004 -- The internal flag is set to mark these declarations because they have
8005 -- specific properties. First, they are primitives even if they are not
8006 -- defined in the type scope (the freezing point is not necessarily in
8007 -- the same scope). Second, the predefined equality can be overridden by
8008 -- a user-defined equality, no body will be generated in this case.
8010 Set_Is_Internal
(Id
);
8012 if not Debug_Generated_Code
then
8013 Set_Debug_Info_Off
(Id
);
8016 if No
(Ret_Type
) then
8018 Make_Procedure_Specification
(Loc
,
8019 Defining_Unit_Name
=> Id
,
8020 Parameter_Specifications
=> Profile
);
8023 Make_Function_Specification
(Loc
,
8024 Defining_Unit_Name
=> Id
,
8025 Parameter_Specifications
=> Profile
,
8026 Result_Definition
=>
8027 New_Reference_To
(Ret_Type
, Loc
));
8030 if Is_Interface
(Tag_Typ
) then
8031 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
8033 -- If body case, return empty subprogram body. Note that this is ill-
8034 -- formed, because there is not even a null statement, and certainly not
8035 -- a return in the function case. The caller is expected to do surgery
8036 -- on the body to add the appropriate stuff.
8039 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
8041 -- For the case of an Input attribute predefined for an abstract type,
8042 -- generate an abstract specification. This will never be called, but we
8043 -- need the slot allocated in the dispatching table so that attributes
8044 -- typ'Class'Input and typ'Class'Output will work properly.
8046 elsif Is_TSS
(Name
, TSS_Stream_Input
)
8047 and then Is_Abstract_Type
(Tag_Typ
)
8049 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
8051 -- Normal spec case, where we return a subprogram declaration
8054 return Make_Subprogram_Declaration
(Loc
, Spec
);
8056 end Predef_Spec_Or_Body
;
8058 -----------------------------
8059 -- Predef_Stream_Attr_Spec --
8060 -----------------------------
8062 function Predef_Stream_Attr_Spec
8064 Tag_Typ
: Entity_Id
;
8065 Name
: TSS_Name_Type
;
8066 For_Body
: Boolean := False) return Node_Id
8068 Ret_Type
: Entity_Id
;
8071 if Name
= TSS_Stream_Input
then
8072 Ret_Type
:= Tag_Typ
;
8077 return Predef_Spec_Or_Body
(Loc
,
8078 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
8080 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
8081 Ret_Type
=> Ret_Type
,
8082 For_Body
=> For_Body
);
8083 end Predef_Stream_Attr_Spec
;
8085 ---------------------------------
8086 -- Predefined_Primitive_Bodies --
8087 ---------------------------------
8089 function Predefined_Primitive_Bodies
8090 (Tag_Typ
: Entity_Id
;
8091 Renamed_Eq
: Entity_Id
) return List_Id
8093 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
8094 Res
: constant List_Id
:= New_List
;
8097 Eq_Needed
: Boolean;
8101 pragma Warnings
(Off
, Ent
);
8104 pragma Assert
(not Is_Interface
(Tag_Typ
));
8106 -- See if we have a predefined "=" operator
8108 if Present
(Renamed_Eq
) then
8110 Eq_Name
:= Chars
(Renamed_Eq
);
8112 -- If the parent is an interface type then it has defined all the
8113 -- predefined primitives abstract and we need to check if the type
8114 -- has some user defined "=" function to avoid generating it.
8116 elsif Is_Interface
(Etype
(Tag_Typ
)) then
8118 Eq_Name
:= Name_Op_Eq
;
8120 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
8121 while Present
(Prim
) loop
8122 if Chars
(Node
(Prim
)) = Name_Op_Eq
8123 and then not Is_Internal
(Node
(Prim
))
8137 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
8138 while Present
(Prim
) loop
8139 if Chars
(Node
(Prim
)) = Name_Op_Eq
8140 and then Is_Internal
(Node
(Prim
))
8143 Eq_Name
:= Name_Op_Eq
;
8151 -- Body of _Alignment
8153 Decl
:= Predef_Spec_Or_Body
(Loc
,
8155 Name
=> Name_uAlignment
,
8156 Profile
=> New_List
(
8157 Make_Parameter_Specification
(Loc
,
8158 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
8159 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
8161 Ret_Type
=> Standard_Integer
,
8164 Set_Handled_Statement_Sequence
(Decl
,
8165 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
8166 Make_Simple_Return_Statement
(Loc
,
8168 Make_Attribute_Reference
(Loc
,
8169 Prefix
=> Make_Identifier
(Loc
, Name_X
),
8170 Attribute_Name
=> Name_Alignment
)))));
8172 Append_To
(Res
, Decl
);
8176 Decl
:= Predef_Spec_Or_Body
(Loc
,
8179 Profile
=> New_List
(
8180 Make_Parameter_Specification
(Loc
,
8181 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
8182 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
8184 Ret_Type
=> Standard_Long_Long_Integer
,
8187 Set_Handled_Statement_Sequence
(Decl
,
8188 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
8189 Make_Simple_Return_Statement
(Loc
,
8191 Make_Attribute_Reference
(Loc
,
8192 Prefix
=> Make_Identifier
(Loc
, Name_X
),
8193 Attribute_Name
=> Name_Size
)))));
8195 Append_To
(Res
, Decl
);
8197 -- Bodies for Dispatching stream IO routines. We need these only for
8198 -- non-limited types (in the limited case there is no dispatching).
8199 -- We also skip them if dispatching or finalization are not available.
8201 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Read
)
8202 and then No
(TSS
(Tag_Typ
, TSS_Stream_Read
))
8204 Build_Record_Read_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
8205 Append_To
(Res
, Decl
);
8208 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Write
)
8209 and then No
(TSS
(Tag_Typ
, TSS_Stream_Write
))
8211 Build_Record_Write_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
8212 Append_To
(Res
, Decl
);
8215 -- Skip body of _Input for the abstract case, since the corresponding
8216 -- spec is abstract (see Predef_Spec_Or_Body).
8218 if not Is_Abstract_Type
(Tag_Typ
)
8219 and then Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Input
)
8220 and then No
(TSS
(Tag_Typ
, TSS_Stream_Input
))
8222 Build_Record_Or_Elementary_Input_Function
8223 (Loc
, Tag_Typ
, Decl
, Ent
);
8224 Append_To
(Res
, Decl
);
8227 if Stream_Operation_OK
(Tag_Typ
, TSS_Stream_Output
)
8228 and then No
(TSS
(Tag_Typ
, TSS_Stream_Output
))
8230 Build_Record_Or_Elementary_Output_Procedure
8231 (Loc
, Tag_Typ
, Decl
, Ent
);
8232 Append_To
(Res
, Decl
);
8235 -- Ada 2005: Generate bodies for the following primitive operations for
8236 -- limited interfaces and synchronized types that implement a limited
8239 -- disp_asynchronous_select
8240 -- disp_conditional_select
8241 -- disp_get_prim_op_kind
8243 -- disp_timed_select
8245 -- The interface versions will have null bodies
8247 -- These operations cannot be implemented on VM targets, so we simply
8248 -- disable their generation in this case. We also disable generation
8249 -- of these bodies if No_Dispatching_Calls is active.
8251 if Ada_Version
>= Ada_05
8252 and then VM_Target
= No_VM
8253 and then not Restriction_Active
(No_Dispatching_Calls
)
8254 and then not Is_Interface
(Tag_Typ
)
8256 ((Is_Interface
(Etype
(Tag_Typ
))
8257 and then Is_Limited_Record
(Etype
(Tag_Typ
)))
8258 or else (Is_Concurrent_Record_Type
(Tag_Typ
)
8259 and then Has_Interfaces
(Tag_Typ
)))
8260 and then RTE_Available
(RE_Select_Specific_Data
)
8262 Append_To
(Res
, Make_Disp_Asynchronous_Select_Body
(Tag_Typ
));
8263 Append_To
(Res
, Make_Disp_Conditional_Select_Body
(Tag_Typ
));
8264 Append_To
(Res
, Make_Disp_Get_Prim_Op_Kind_Body
(Tag_Typ
));
8265 Append_To
(Res
, Make_Disp_Get_Task_Id_Body
(Tag_Typ
));
8266 Append_To
(Res
, Make_Disp_Requeue_Body
(Tag_Typ
));
8267 Append_To
(Res
, Make_Disp_Timed_Select_Body
(Tag_Typ
));
8270 if not Is_Limited_Type
(Tag_Typ
)
8271 and then not Is_Interface
(Tag_Typ
)
8273 -- Body for equality
8277 Predef_Spec_Or_Body
(Loc
,
8280 Profile
=> New_List
(
8281 Make_Parameter_Specification
(Loc
,
8282 Defining_Identifier
=>
8283 Make_Defining_Identifier
(Loc
, Name_X
),
8284 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
8286 Make_Parameter_Specification
(Loc
,
8287 Defining_Identifier
=>
8288 Make_Defining_Identifier
(Loc
, Name_Y
),
8289 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
8291 Ret_Type
=> Standard_Boolean
,
8295 Def
: constant Node_Id
:= Parent
(Tag_Typ
);
8296 Stmts
: constant List_Id
:= New_List
;
8297 Variant_Case
: Boolean := Has_Discriminants
(Tag_Typ
);
8298 Comps
: Node_Id
:= Empty
;
8299 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
8302 if Variant_Case
then
8303 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
8304 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
8307 if Present
(Typ_Def
) then
8308 Comps
:= Component_List
(Typ_Def
);
8311 Variant_Case
:= Present
(Comps
)
8312 and then Present
(Variant_Part
(Comps
));
8315 if Variant_Case
then
8317 Make_Eq_If
(Tag_Typ
, Discriminant_Specifications
(Def
)));
8318 Append_List_To
(Stmts
, Make_Eq_Case
(Tag_Typ
, Comps
));
8320 Make_Simple_Return_Statement
(Loc
,
8321 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
8325 Make_Simple_Return_Statement
(Loc
,
8327 Expand_Record_Equality
(Tag_Typ
,
8329 Lhs
=> Make_Identifier
(Loc
, Name_X
),
8330 Rhs
=> Make_Identifier
(Loc
, Name_Y
),
8331 Bodies
=> Declarations
(Decl
))));
8334 Set_Handled_Statement_Sequence
(Decl
,
8335 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8337 Append_To
(Res
, Decl
);
8340 -- Body for dispatching assignment
8343 Predef_Spec_Or_Body
(Loc
,
8345 Name
=> Name_uAssign
,
8346 Profile
=> New_List
(
8347 Make_Parameter_Specification
(Loc
,
8348 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
8349 Out_Present
=> True,
8350 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
8352 Make_Parameter_Specification
(Loc
,
8353 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
8354 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
8357 Set_Handled_Statement_Sequence
(Decl
,
8358 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
8359 Make_Assignment_Statement
(Loc
,
8360 Name
=> Make_Identifier
(Loc
, Name_X
),
8361 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
8363 Append_To
(Res
, Decl
);
8366 -- Generate dummy bodies for finalization actions of types that have
8367 -- no controlled components.
8369 -- Skip this processing if we are in the finalization routine in the
8370 -- runtime itself, otherwise we get hopelessly circularly confused!
8372 if In_Finalization_Root
(Tag_Typ
) then
8375 -- Skip this if finalization is not available
8377 elsif Restriction_Active
(No_Finalization
) then
8380 elsif (Etype
(Tag_Typ
) = Tag_Typ
8381 or else Is_Controlled
(Tag_Typ
)
8383 -- Ada 2005 (AI-251): We must also generate these subprograms
8384 -- if the immediate ancestor of Tag_Typ is an interface to
8385 -- ensure the correct initialization of its dispatch table.
8387 or else (not Is_Interface
(Tag_Typ
)
8389 Is_Interface
(Etype
(Tag_Typ
))))
8390 and then not Has_Controlled_Component
(Tag_Typ
)
8392 if not Is_Limited_Type
(Tag_Typ
) then
8393 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
8395 if Is_Controlled
(Tag_Typ
) then
8396 Set_Handled_Statement_Sequence
(Decl
,
8397 Make_Handled_Sequence_Of_Statements
(Loc
,
8399 Ref
=> Make_Identifier
(Loc
, Name_V
),
8401 Flist_Ref
=> Make_Identifier
(Loc
, Name_L
),
8402 With_Attach
=> Make_Identifier
(Loc
, Name_B
))));
8405 Set_Handled_Statement_Sequence
(Decl
,
8406 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
8407 Make_Null_Statement
(Loc
))));
8410 Append_To
(Res
, Decl
);
8413 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
8415 if Is_Controlled
(Tag_Typ
) then
8416 Set_Handled_Statement_Sequence
(Decl
,
8417 Make_Handled_Sequence_Of_Statements
(Loc
,
8419 Ref
=> Make_Identifier
(Loc
, Name_V
),
8421 With_Detach
=> Make_Identifier
(Loc
, Name_B
))));
8424 Set_Handled_Statement_Sequence
(Decl
,
8425 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
8426 Make_Null_Statement
(Loc
))));
8429 Append_To
(Res
, Decl
);
8433 end Predefined_Primitive_Bodies
;
8435 ---------------------------------
8436 -- Predefined_Primitive_Freeze --
8437 ---------------------------------
8439 function Predefined_Primitive_Freeze
8440 (Tag_Typ
: Entity_Id
) return List_Id
8442 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
8443 Res
: constant List_Id
:= New_List
;
8448 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
8449 while Present
(Prim
) loop
8450 if Is_Predefined_Dispatching_Operation
(Node
(Prim
)) then
8451 Frnodes
:= Freeze_Entity
(Node
(Prim
), Loc
);
8453 if Present
(Frnodes
) then
8454 Append_List_To
(Res
, Frnodes
);
8462 end Predefined_Primitive_Freeze
;
8464 -------------------------
8465 -- Stream_Operation_OK --
8466 -------------------------
8468 function Stream_Operation_OK
8470 Operation
: TSS_Name_Type
) return Boolean
8472 Has_Predefined_Or_Specified_Stream_Attribute
: Boolean := False;
8475 -- Special case of a limited type extension: a default implementation
8476 -- of the stream attributes Read or Write exists if that attribute
8477 -- has been specified or is available for an ancestor type; a default
8478 -- implementation of the attribute Output (resp. Input) exists if the
8479 -- attribute has been specified or Write (resp. Read) is available for
8480 -- an ancestor type. The last condition only applies under Ada 2005.
8482 if Is_Limited_Type
(Typ
)
8483 and then Is_Tagged_Type
(Typ
)
8485 if Operation
= TSS_Stream_Read
then
8486 Has_Predefined_Or_Specified_Stream_Attribute
:=
8487 Has_Specified_Stream_Read
(Typ
);
8489 elsif Operation
= TSS_Stream_Write
then
8490 Has_Predefined_Or_Specified_Stream_Attribute
:=
8491 Has_Specified_Stream_Write
(Typ
);
8493 elsif Operation
= TSS_Stream_Input
then
8494 Has_Predefined_Or_Specified_Stream_Attribute
:=
8495 Has_Specified_Stream_Input
(Typ
)
8497 (Ada_Version
>= Ada_05
8498 and then Stream_Operation_OK
(Typ
, TSS_Stream_Read
));
8500 elsif Operation
= TSS_Stream_Output
then
8501 Has_Predefined_Or_Specified_Stream_Attribute
:=
8502 Has_Specified_Stream_Output
(Typ
)
8504 (Ada_Version
>= Ada_05
8505 and then Stream_Operation_OK
(Typ
, TSS_Stream_Write
));
8508 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
8510 if not Has_Predefined_Or_Specified_Stream_Attribute
8511 and then Is_Derived_Type
(Typ
)
8512 and then (Operation
= TSS_Stream_Read
8513 or else Operation
= TSS_Stream_Write
)
8515 Has_Predefined_Or_Specified_Stream_Attribute
:=
8517 (Find_Inherited_TSS
(Base_Type
(Etype
(Typ
)), Operation
));
8521 -- If the type is not limited, or else is limited but the attribute is
8522 -- explicitly specified or is predefined for the type, then return True,
8523 -- unless other conditions prevail, such as restrictions prohibiting
8524 -- streams or dispatching operations.
8526 -- We exclude the Input operation from being a predefined subprogram in
8527 -- the case where the associated type is an abstract extension, because
8528 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
8529 -- we don't want an abstract version created because types derived from
8530 -- the abstract type may not even have Input available (for example if
8531 -- derived from a private view of the abstract type that doesn't have
8532 -- a visible Input), but a VM such as .NET or the Java VM can treat the
8533 -- operation as inherited anyway, and we don't want an abstract function
8534 -- to be (implicitly) inherited in that case because it can lead to a VM
8537 return (not Is_Limited_Type
(Typ
)
8538 or else Has_Predefined_Or_Specified_Stream_Attribute
)
8539 and then (Operation
/= TSS_Stream_Input
8540 or else not Is_Abstract_Type
(Typ
)
8541 or else not Is_Derived_Type
(Typ
))
8542 and then not Has_Unknown_Discriminants
(Typ
)
8543 and then not (Is_Interface
(Typ
)
8544 and then (Is_Task_Interface
(Typ
)
8545 or else Is_Protected_Interface
(Typ
)
8546 or else Is_Synchronized_Interface
(Typ
)))
8547 and then not Restriction_Active
(No_Streams
)
8548 and then not Restriction_Active
(No_Dispatch
)
8549 and then not No_Run_Time_Mode
8550 and then RTE_Available
(RE_Tag
)
8551 and then RTE_Available
(RE_Root_Stream_Type
);
8552 end Stream_Operation_OK
;