1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Aggr; use Exp_Aggr;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch4; use Exp_Ch4;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Dbug; use Exp_Dbug;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Smem; use Exp_Smem;
41 with Exp_Strm; use Exp_Strm;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Ghost; use Ghost;
46 with Namet; use Namet;
47 with Nlists; use Nlists;
48 with Nmake; use Nmake;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Attr; use Sem_Attr;
56 with Sem_Cat; use Sem_Cat;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Disp; use Sem_Disp;
61 with Sem_Eval; use Sem_Eval;
62 with Sem_Mech; use Sem_Mech;
63 with Sem_Res; use Sem_Res;
64 with Sem_SCIL; use Sem_SCIL;
65 with Sem_Type; use Sem_Type;
66 with Sem_Util; use Sem_Util;
67 with Sinfo; use Sinfo;
68 with Stand; use Stand;
69 with Snames; use Snames;
70 with Tbuild; use Tbuild;
71 with Ttypes; use Ttypes;
72 with Validsw; use Validsw;
74 package body Exp_Ch3 is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
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 Build_Init_Procedure among other places.
96 -- If the flag Use_Dl is set, the list is built using the already
97 -- defined discriminals of the type, as is the case for concurrent
98 -- types with discriminants. Otherwise new identifiers are created,
99 -- with the source names of the discriminants.
101 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
102 -- This function builds a static aggregate that can serve as the initial
103 -- value for an array type whose bounds are static, and whose component
104 -- type is a composite type that has a static equivalent aggregate.
105 -- The equivalent array aggregate is used both for object initialization
106 -- and for component initialization, when used in the following function.
108 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
109 -- This function builds a static aggregate that can serve as the initial
110 -- value for a record type whose components are scalar and initialized
111 -- with compile-time values, or arrays with similar initialization or
112 -- defaults. When possible, initialization of an object of the type can
113 -- be achieved by using a copy of the aggregate as an initial value, thus
114 -- removing the implicit call that would otherwise constitute elaboration
117 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
118 -- Build record initialization procedure. N is the type declaration
119 -- node, and Rec_Ent is the corresponding entity for the record type.
121 procedure Build_Slice_Assignment (Typ : Entity_Id);
122 -- Build assignment procedure for one-dimensional arrays of controlled
123 -- types. Other array and slice assignments are expanded in-line, but
124 -- the code expansion for controlled components (when control actions
125 -- are active) can lead to very large blocks that GCC3 handles poorly.
127 procedure Build_Untagged_Equality (Typ : Entity_Id);
128 -- AI05-0123: Equality on untagged records composes. This procedure
129 -- builds the equality routine for an untagged record that has components
130 -- of a record type that has user-defined primitive equality operations.
131 -- The resulting operation is a TSS subprogram.
133 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
134 -- Create An Equality function for the untagged variant record Typ and
135 -- attach it to the TSS list
137 procedure Check_Stream_Attributes (Typ : Entity_Id);
138 -- Check that if a limited extension has a parent with user-defined stream
139 -- attributes, and does not itself have user-defined stream-attributes,
140 -- then any limited component of the extension also has the corresponding
141 -- user-defined stream attributes.
143 procedure Clean_Task_Names
145 Proc_Id : Entity_Id);
146 -- If an initialization procedure includes calls to generate names
147 -- for task subcomponents, indicate that secondary stack cleanup is
148 -- needed after an initialization. Typ is the component type, and Proc_Id
149 -- the initialization procedure for the enclosing composite type.
151 procedure Expand_Freeze_Array_Type (N : Node_Id);
152 -- Freeze an array type. Deals with building the initialization procedure,
153 -- creating the packed array type for a packed array and also with the
154 -- creation of the controlling procedures for the controlled case. The
155 -- argument N is the N_Freeze_Entity node for the type.
157 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
158 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
159 -- of finalizing controlled derivations from the class-wide's root type.
161 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
162 -- Freeze enumeration type with non-standard representation. Builds the
163 -- array and function needed to convert between enumeration pos and
164 -- enumeration representation values. N is the N_Freeze_Entity node
167 procedure Expand_Freeze_Record_Type (N : Node_Id);
168 -- Freeze record type. Builds all necessary discriminant checking
169 -- and other ancillary functions, and builds dispatch tables where
170 -- needed. The argument N is the N_Freeze_Entity node. This processing
171 -- applies only to E_Record_Type entities, not to class wide types,
172 -- record subtypes, or private types.
174 procedure Expand_Tagged_Root (T : Entity_Id);
175 -- Add a field _Tag at the beginning of the record. This field carries
176 -- the value of the access to the Dispatch table. This procedure is only
177 -- called on root type, the _Tag field being inherited by the descendants.
179 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
180 -- Treat user-defined stream operations as renaming_as_body if the
181 -- subprogram they rename is not frozen when the type is frozen.
183 procedure Initialization_Warning (E : Entity_Id);
184 -- If static elaboration of the package is requested, indicate
185 -- when a type does meet the conditions for static initialization. If
186 -- E is a type, it has components that have no static initialization.
187 -- if E is an entity, its initial expression is not compile-time known.
189 function Init_Formals (Typ : Entity_Id) return List_Id;
190 -- This function builds the list of formals for an initialization routine.
191 -- The first formal is always _Init with the given type. For task value
192 -- record types and types containing tasks, three additional formals are
195 -- _Master : Master_Id
196 -- _Chain : in out Activation_Chain
197 -- _Task_Name : String
199 -- The caller must append additional entries for discriminants if required.
201 function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
202 -- Returns true if the initialization procedure of Typ should be inlined
204 function In_Runtime (E : Entity_Id) return Boolean;
205 -- Check if E is defined in the RTL (in a child of Ada or System). Used
206 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
208 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
209 -- Returns true if Prim is a user defined equality function
211 function Make_Eq_Body
213 Eq_Name : Name_Id) return Node_Id;
214 -- Build the body of a primitive equality operation for a tagged record
215 -- type, or in Ada 2012 for any record type that has components with a
216 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
218 function Make_Eq_Case
221 Discrs : Elist_Id := New_Elmt_List) return List_Id;
222 -- Building block for variant record equality. Defined to share the code
223 -- between the tagged and untagged case. Given a Component_List node CL,
224 -- it generates an 'if' followed by a 'case' statement that compares all
225 -- components of local temporaries named X and Y (that are declared as
226 -- formals at some upper level). E provides the Sloc to be used for the
229 -- IF E is an unchecked_union, Discrs is the list of formals created for
230 -- the inferred discriminants of one operand. These formals are used in
231 -- the generated case statements for each variant of the unchecked union.
235 L : List_Id) return Node_Id;
236 -- Building block for variant record equality. Defined to share the code
237 -- between the tagged and untagged case. Given the list of components
238 -- (or discriminants) L, it generates a return statement that compares all
239 -- components of local temporaries named X and Y (that are declared as
240 -- formals at some upper level). E provides the Sloc to be used for the
243 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
244 -- Search for a renaming of the inequality dispatching primitive of
245 -- this tagged type. If found then build and return the corresponding
246 -- rename-as-body inequality subprogram; otherwise return Empty.
248 procedure Make_Predefined_Primitive_Specs
249 (Tag_Typ : Entity_Id;
250 Predef_List : out List_Id;
251 Renamed_Eq : out Entity_Id);
252 -- Create a list with the specs of the predefined primitive operations.
253 -- For tagged types that are interfaces all these primitives are defined
256 -- The following entries are present for all tagged types, and provide
257 -- the results of the corresponding attribute applied to the object.
258 -- Dispatching is required in general, since the result of the attribute
259 -- will vary with the actual object subtype.
261 -- _size provides result of 'Size attribute
262 -- typSR provides result of 'Read attribute
263 -- typSW provides result of 'Write attribute
264 -- typSI provides result of 'Input attribute
265 -- typSO provides result of 'Output attribute
267 -- The following entries are additionally present for non-limited tagged
268 -- types, and implement additional dispatching operations for predefined
271 -- _equality implements "=" operator
272 -- _assign implements assignment operation
273 -- typDF implements deep finalization
274 -- typDA implements deep adjust
276 -- The latter two are empty procedures unless the type contains some
277 -- controlled components that require finalization actions (the deep
278 -- in the name refers to the fact that the action applies to components).
280 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
281 -- returns the value Empty, or else the defining unit name for the
282 -- predefined equality function in the case where the type has a primitive
283 -- operation that is a renaming of predefined equality (but only if there
284 -- is also an overriding user-defined equality function). The returned
285 -- Renamed_Eq will be passed to the corresponding parameter of
286 -- Predefined_Primitive_Bodies.
288 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
289 -- Returns True if there are representation clauses for type T that are not
290 -- inherited. If the result is false, the init_proc and the discriminant
291 -- checking functions of the parent can be reused by a derived type.
293 procedure Make_Controlling_Function_Wrappers
294 (Tag_Typ : Entity_Id;
295 Decl_List : out List_Id;
296 Body_List : out List_Id);
297 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
298 -- associated with inherited functions with controlling results which
299 -- are not overridden. The body of each wrapper function consists solely
300 -- of a return statement whose expression is an extension aggregate
301 -- invoking the inherited subprogram's parent subprogram and extended
302 -- with a null association list.
304 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
305 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
306 -- null procedures inherited from an interface type that have not been
307 -- overridden. Only one null procedure will be created for a given set of
308 -- inherited null procedures with homographic profiles.
310 function Predef_Spec_Or_Body
315 Ret_Type : Entity_Id := Empty;
316 For_Body : Boolean := False) return Node_Id;
317 -- This function generates the appropriate expansion for a predefined
318 -- primitive operation specified by its name, parameter profile and
319 -- return type (Empty means this is a procedure). If For_Body is false,
320 -- then the returned node is a subprogram declaration. If For_Body is
321 -- true, then the returned node is a empty subprogram body containing
322 -- no declarations and no statements.
324 function Predef_Stream_Attr_Spec
327 Name : TSS_Name_Type;
328 For_Body : Boolean := False) return Node_Id;
329 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
330 -- input and output attribute whose specs are constructed in Exp_Strm.
332 function Predef_Deep_Spec
335 Name : TSS_Name_Type;
336 For_Body : Boolean := False) return Node_Id;
337 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
338 -- and _deep_finalize
340 function Predefined_Primitive_Bodies
341 (Tag_Typ : Entity_Id;
342 Renamed_Eq : Entity_Id) return List_Id;
343 -- Create the bodies of the predefined primitives that are described in
344 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
345 -- the defining unit name of the type's predefined equality as returned
346 -- by Make_Predefined_Primitive_Specs.
348 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
349 -- Freeze entities of all predefined primitive operations. This is needed
350 -- because the bodies of these operations do not normally do any freezing.
352 function Stream_Operation_OK
354 Operation : TSS_Name_Type) return Boolean;
355 -- Check whether the named stream operation must be emitted for a given
356 -- type. The rules for inheritance of stream attributes by type extensions
357 -- are enforced by this function. Furthermore, various restrictions prevent
358 -- the generation of these operations, as a useful optimization or for
359 -- certification purposes and to save unnecessary generated code.
361 --------------------------
362 -- Adjust_Discriminants --
363 --------------------------
365 -- This procedure attempts to define subtypes for discriminants that are
366 -- more restrictive than those declared. Such a replacement is possible if
367 -- we can demonstrate that values outside the restricted range would cause
368 -- constraint errors in any case. The advantage of restricting the
369 -- discriminant types in this way is that the maximum size of the variant
370 -- record can be calculated more conservatively.
372 -- An example of a situation in which we can perform this type of
373 -- restriction is the following:
375 -- subtype B is range 1 .. 10;
376 -- type Q is array (B range <>) of Integer;
378 -- type V (N : Natural) is record
382 -- In this situation, we can restrict the upper bound of N to 10, since
383 -- any larger value would cause a constraint error in any case.
385 -- There are many situations in which such restriction is possible, but
386 -- for now, we just look for cases like the above, where the component
387 -- in question is a one dimensional array whose upper bound is one of
388 -- the record discriminants. Also the component must not be part of
389 -- any variant part, since then the component does not always exist.
391 procedure Adjust_Discriminants (Rtype : Entity_Id) is
392 Loc : constant Source_Ptr := Sloc (Rtype);
409 Comp := First_Component (Rtype);
410 while Present (Comp) loop
412 -- If our parent is a variant, quit, we do not look at components
413 -- that are in variant parts, because they may not always exist.
415 P := Parent (Comp); -- component declaration
416 P := Parent (P); -- component list
418 exit when Nkind (Parent (P)) = N_Variant;
420 -- We are looking for a one dimensional array type
422 Ctyp := Etype (Comp);
424 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
428 -- The lower bound must be constant, and the upper bound is a
429 -- discriminant (which is a discriminant of the current record).
431 Ityp := Etype (First_Index (Ctyp));
432 Lo := Type_Low_Bound (Ityp);
433 Hi := Type_High_Bound (Ityp);
435 if not Compile_Time_Known_Value (Lo)
436 or else Nkind (Hi) /= N_Identifier
437 or else No (Entity (Hi))
438 or else Ekind (Entity (Hi)) /= E_Discriminant
443 -- We have an array with appropriate bounds
445 Loval := Expr_Value (Lo);
446 Discr := Entity (Hi);
447 Dtyp := Etype (Discr);
449 -- See if the discriminant has a known upper bound
451 Dhi := Type_High_Bound (Dtyp);
453 if not Compile_Time_Known_Value (Dhi) then
457 Dhiv := Expr_Value (Dhi);
459 -- See if base type of component array has known upper bound
461 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
463 if not Compile_Time_Known_Value (Ahi) then
467 Ahiv := Expr_Value (Ahi);
469 -- The condition for doing the restriction is that the high bound
470 -- of the discriminant is greater than the low bound of the array,
471 -- and is also greater than the high bound of the base type index.
473 if Dhiv > Loval and then Dhiv > Ahiv then
475 -- We can reset the upper bound of the discriminant type to
476 -- whichever is larger, the low bound of the component, or
477 -- the high bound of the base type array index.
479 -- We build a subtype that is declared as
481 -- subtype Tnn is discr_type range discr_type'First .. max;
483 -- And insert this declaration into the tree. The type of the
484 -- discriminant is then reset to this more restricted subtype.
486 Tnn := Make_Temporary (Loc, 'T');
488 Insert_Action (Declaration_Node (Rtype),
489 Make_Subtype_Declaration (Loc,
490 Defining_Identifier => Tnn,
491 Subtype_Indication =>
492 Make_Subtype_Indication (Loc,
493 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
495 Make_Range_Constraint (Loc,
499 Make_Attribute_Reference (Loc,
500 Attribute_Name => Name_First,
501 Prefix => New_Occurrence_Of (Dtyp, Loc)),
503 Make_Integer_Literal (Loc,
504 Intval => UI_Max (Loval, Ahiv)))))));
506 Set_Etype (Discr, Tnn);
510 Next_Component (Comp);
512 end Adjust_Discriminants;
514 ---------------------------
515 -- Build_Array_Init_Proc --
516 ---------------------------
518 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
519 Comp_Type : constant Entity_Id := Component_Type (A_Type);
520 Comp_Simple_Init : constant Boolean :=
521 Needs_Simple_Initialization
524 not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
525 -- True if the component needs simple initialization, based on its type,
526 -- plus the fact that we do not do simple initialization for components
527 -- of bit-packed arrays when validity checks are enabled, because the
528 -- initialization with deliberately out-of-range values would raise
531 Body_Stmts : List_Id;
532 Has_Default_Init : Boolean;
533 Index_List : List_Id;
537 function Init_Component return List_Id;
538 -- Create one statement to initialize one array component, designated
539 -- by a full set of indexes.
541 function Init_One_Dimension (N : Int) return List_Id;
542 -- Create loop to initialize one dimension of the array. The single
543 -- statement in the loop body initializes the inner dimensions if any,
544 -- or else the single component. Note that this procedure is called
545 -- recursively, with N being the dimension to be initialized. A call
546 -- with N greater than the number of dimensions simply generates the
547 -- component initialization, terminating the recursion.
553 function Init_Component return List_Id is
558 Make_Indexed_Component (Loc,
559 Prefix => Make_Identifier (Loc, Name_uInit),
560 Expressions => Index_List);
562 if Has_Default_Aspect (A_Type) then
563 Set_Assignment_OK (Comp);
565 Make_Assignment_Statement (Loc,
568 Convert_To (Comp_Type,
569 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
571 elsif Comp_Simple_Init then
572 Set_Assignment_OK (Comp);
574 Make_Assignment_Statement (Loc,
578 (Comp_Type, Nod, Component_Size (A_Type))));
581 Clean_Task_Names (Comp_Type, Proc_Id);
583 Build_Initialization_Call
584 (Loc, Comp, Comp_Type,
585 In_Init_Proc => True,
586 Enclos_Type => A_Type);
590 ------------------------
591 -- Init_One_Dimension --
592 ------------------------
594 function Init_One_Dimension (N : Int) return List_Id is
598 -- If the component does not need initializing, then there is nothing
599 -- to do here, so we return a null body. This occurs when generating
600 -- the dummy Init_Proc needed for Initialize_Scalars processing.
602 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
603 and then not Comp_Simple_Init
604 and then not Has_Task (Comp_Type)
605 and then not Has_Default_Aspect (A_Type)
607 return New_List (Make_Null_Statement (Loc));
609 -- If all dimensions dealt with, we simply initialize the component
611 elsif N > Number_Dimensions (A_Type) then
612 return Init_Component;
614 -- Here we generate the required loop
618 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
620 Append (New_Occurrence_Of (Index, Loc), Index_List);
623 Make_Implicit_Loop_Statement (Nod,
626 Make_Iteration_Scheme (Loc,
627 Loop_Parameter_Specification =>
628 Make_Loop_Parameter_Specification (Loc,
629 Defining_Identifier => Index,
630 Discrete_Subtype_Definition =>
631 Make_Attribute_Reference (Loc,
633 Make_Identifier (Loc, Name_uInit),
634 Attribute_Name => Name_Range,
635 Expressions => New_List (
636 Make_Integer_Literal (Loc, N))))),
637 Statements => Init_One_Dimension (N + 1)));
639 end Init_One_Dimension;
641 -- Start of processing for Build_Array_Init_Proc
644 -- The init proc is created when analyzing the freeze node for the type,
645 -- but it properly belongs with the array type declaration. However, if
646 -- the freeze node is for a subtype of a type declared in another unit
647 -- it seems preferable to use the freeze node as the source location of
648 -- the init proc. In any case this is preferable for gcov usage, and
649 -- the Sloc is not otherwise used by the compiler.
651 if In_Open_Scopes (Scope (A_Type)) then
652 Loc := Sloc (A_Type);
657 -- Nothing to generate in the following cases:
659 -- 1. Initialization is suppressed for the type
660 -- 2. An initialization already exists for the base type
662 if Initialization_Suppressed (A_Type)
663 or else Present (Base_Init_Proc (A_Type))
668 Index_List := New_List;
670 -- We need an initialization procedure if any of the following is true:
672 -- 1. The component type has an initialization procedure
673 -- 2. The component type needs simple initialization
674 -- 3. Tasks are present
675 -- 4. The type is marked as a public entity
676 -- 5. The array type has a Default_Component_Value aspect
678 -- The reason for the public entity test is to deal properly with the
679 -- Initialize_Scalars pragma. This pragma can be set in the client and
680 -- not in the declaring package, this means the client will make a call
681 -- to the initialization procedure (because one of conditions 1-3 must
682 -- apply in this case), and we must generate a procedure (even if it is
683 -- null) to satisfy the call in this case.
685 -- Exception: do not build an array init_proc for a type whose root
686 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
687 -- is no place to put the code, and in any case we handle initialization
688 -- of such types (in the Initialize_Scalars case, that's the only time
689 -- the issue arises) in a special manner anyway which does not need an
692 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
693 or else Comp_Simple_Init
694 or else Has_Task (Comp_Type)
695 or else Has_Default_Aspect (A_Type);
698 or else (not Restriction_Active (No_Initialize_Scalars)
699 and then Is_Public (A_Type)
700 and then not Is_Standard_String_Type (A_Type))
703 Make_Defining_Identifier (Loc,
704 Chars => Make_Init_Proc_Name (A_Type));
706 -- If No_Default_Initialization restriction is active, then we don't
707 -- want to build an init_proc, but we need to mark that an init_proc
708 -- would be needed if this restriction was not active (so that we can
709 -- detect attempts to call it), so set a dummy init_proc in place.
710 -- This is only done though when actual default initialization is
711 -- needed (and not done when only Is_Public is True), since otherwise
712 -- objects such as arrays of scalars could be wrongly flagged as
713 -- violating the restriction.
715 if Restriction_Active (No_Default_Initialization) then
716 if Has_Default_Init then
717 Set_Init_Proc (A_Type, Proc_Id);
723 Body_Stmts := Init_One_Dimension (1);
726 Make_Subprogram_Body (Loc,
728 Make_Procedure_Specification (Loc,
729 Defining_Unit_Name => Proc_Id,
730 Parameter_Specifications => Init_Formals (A_Type)),
731 Declarations => New_List,
732 Handled_Statement_Sequence =>
733 Make_Handled_Sequence_Of_Statements (Loc,
734 Statements => Body_Stmts)));
736 Set_Ekind (Proc_Id, E_Procedure);
737 Set_Is_Public (Proc_Id, Is_Public (A_Type));
738 Set_Is_Internal (Proc_Id);
739 Set_Has_Completion (Proc_Id);
741 if not Debug_Generated_Code then
742 Set_Debug_Info_Off (Proc_Id);
745 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
746 -- component type itself (see also Build_Record_Init_Proc).
748 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
750 -- Associate Init_Proc with type, and determine if the procedure
751 -- is null (happens because of the Initialize_Scalars pragma case,
752 -- where we have to generate a null procedure in case it is called
753 -- by a client with Initialize_Scalars set). Such procedures have
754 -- to be generated, but do not have to be called, so we mark them
755 -- as null to suppress the call.
757 Set_Init_Proc (A_Type, Proc_Id);
759 if List_Length (Body_Stmts) = 1
761 -- We must skip SCIL nodes because they may have been added to this
762 -- list by Insert_Actions.
764 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
766 Set_Is_Null_Init_Proc (Proc_Id);
769 -- Try to build a static aggregate to statically initialize
770 -- objects of the type. This can only be done for constrained
771 -- one-dimensional arrays with static bounds.
773 Set_Static_Initialization
775 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
778 end Build_Array_Init_Proc;
780 --------------------------------
781 -- Build_Discr_Checking_Funcs --
782 --------------------------------
784 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
787 Enclosing_Func_Id : Entity_Id;
792 function Build_Case_Statement
793 (Case_Id : Entity_Id;
794 Variant : Node_Id) return Node_Id;
795 -- Build a case statement containing only two alternatives. The first
796 -- alternative corresponds exactly to the discrete choices given on the
797 -- variant with contains the components that we are generating the
798 -- checks for. If the discriminant is one of these return False. The
799 -- second alternative is an OTHERS choice that will return True
800 -- indicating the discriminant did not match.
802 function Build_Dcheck_Function
803 (Case_Id : Entity_Id;
804 Variant : Node_Id) return Entity_Id;
805 -- Build the discriminant checking function for a given variant
807 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
808 -- Builds the discriminant checking function for each variant of the
809 -- given variant part of the record type.
811 --------------------------
812 -- Build_Case_Statement --
813 --------------------------
815 function Build_Case_Statement
816 (Case_Id : Entity_Id;
817 Variant : Node_Id) return Node_Id
819 Alt_List : constant List_Id := New_List;
820 Actuals_List : List_Id;
822 Case_Alt_Node : Node_Id;
824 Choice_List : List_Id;
826 Return_Node : Node_Id;
829 Case_Node := New_Node (N_Case_Statement, Loc);
831 -- Replace the discriminant which controls the variant with the name
832 -- of the formal of the checking function.
834 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
836 Choice := First (Discrete_Choices (Variant));
838 if Nkind (Choice) = N_Others_Choice then
839 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
841 Choice_List := New_Copy_List (Discrete_Choices (Variant));
844 if not Is_Empty_List (Choice_List) then
845 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
846 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
848 -- In case this is a nested variant, we need to return the result
849 -- of the discriminant checking function for the immediately
850 -- enclosing variant.
852 if Present (Enclosing_Func_Id) then
853 Actuals_List := New_List;
855 D := First_Discriminant (Rec_Id);
856 while Present (D) loop
857 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
858 Next_Discriminant (D);
862 Make_Simple_Return_Statement (Loc,
864 Make_Function_Call (Loc,
866 New_Occurrence_Of (Enclosing_Func_Id, Loc),
867 Parameter_Associations =>
872 Make_Simple_Return_Statement (Loc,
874 New_Occurrence_Of (Standard_False, Loc));
877 Set_Statements (Case_Alt_Node, New_List (Return_Node));
878 Append (Case_Alt_Node, Alt_List);
881 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
882 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
883 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
886 Make_Simple_Return_Statement (Loc,
888 New_Occurrence_Of (Standard_True, Loc));
890 Set_Statements (Case_Alt_Node, New_List (Return_Node));
891 Append (Case_Alt_Node, Alt_List);
893 Set_Alternatives (Case_Node, Alt_List);
895 end Build_Case_Statement;
897 ---------------------------
898 -- Build_Dcheck_Function --
899 ---------------------------
901 function Build_Dcheck_Function
902 (Case_Id : Entity_Id;
903 Variant : Node_Id) return Entity_Id
907 Parameter_List : List_Id;
911 Body_Node := New_Node (N_Subprogram_Body, Loc);
912 Sequence := Sequence + 1;
915 Make_Defining_Identifier (Loc,
916 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
917 Set_Is_Discriminant_Check_Function (Func_Id);
919 Spec_Node := New_Node (N_Function_Specification, Loc);
920 Set_Defining_Unit_Name (Spec_Node, Func_Id);
922 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
924 Set_Parameter_Specifications (Spec_Node, Parameter_List);
925 Set_Result_Definition (Spec_Node,
926 New_Occurrence_Of (Standard_Boolean, Loc));
927 Set_Specification (Body_Node, Spec_Node);
928 Set_Declarations (Body_Node, New_List);
930 Set_Handled_Statement_Sequence (Body_Node,
931 Make_Handled_Sequence_Of_Statements (Loc,
932 Statements => New_List (
933 Build_Case_Statement (Case_Id, Variant))));
935 Set_Ekind (Func_Id, E_Function);
936 Set_Mechanism (Func_Id, Default_Mechanism);
937 Set_Is_Inlined (Func_Id, True);
938 Set_Is_Pure (Func_Id, True);
939 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
940 Set_Is_Internal (Func_Id, True);
942 if not Debug_Generated_Code then
943 Set_Debug_Info_Off (Func_Id);
948 Append_Freeze_Action (Rec_Id, Body_Node);
949 Set_Dcheck_Function (Variant, Func_Id);
951 end Build_Dcheck_Function;
953 ----------------------------
954 -- Build_Dcheck_Functions --
955 ----------------------------
957 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
958 Component_List_Node : Node_Id;
960 Discr_Name : Entity_Id;
963 Saved_Enclosing_Func_Id : Entity_Id;
966 -- Build the discriminant-checking function for each variant, and
967 -- label all components of that variant with the function's name.
968 -- We only Generate a discriminant-checking function when the
969 -- variant is not empty, to prevent the creation of dead code.
971 Discr_Name := Entity (Name (Variant_Part_Node));
972 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
974 while Present (Variant) loop
975 Component_List_Node := Component_List (Variant);
977 if not Null_Present (Component_List_Node) then
978 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
981 First_Non_Pragma (Component_Items (Component_List_Node));
982 while Present (Decl) loop
983 Set_Discriminant_Checking_Func
984 (Defining_Identifier (Decl), Func_Id);
985 Next_Non_Pragma (Decl);
988 if Present (Variant_Part (Component_List_Node)) then
989 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
990 Enclosing_Func_Id := Func_Id;
991 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
992 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
996 Next_Non_Pragma (Variant);
998 end Build_Dcheck_Functions;
1000 -- Start of processing for Build_Discr_Checking_Funcs
1003 -- Only build if not done already
1005 if not Discr_Check_Funcs_Built (N) then
1006 Type_Def := Type_Definition (N);
1008 if Nkind (Type_Def) = N_Record_Definition then
1009 if No (Component_List (Type_Def)) then -- null record.
1012 V := Variant_Part (Component_List (Type_Def));
1015 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1016 if No (Component_List (Record_Extension_Part (Type_Def))) then
1020 (Component_List (Record_Extension_Part (Type_Def)));
1024 Rec_Id := Defining_Identifier (N);
1026 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1028 Enclosing_Func_Id := Empty;
1029 Build_Dcheck_Functions (V);
1032 Set_Discr_Check_Funcs_Built (N);
1034 end Build_Discr_Checking_Funcs;
1036 --------------------------------
1037 -- Build_Discriminant_Formals --
1038 --------------------------------
1040 function Build_Discriminant_Formals
1041 (Rec_Id : Entity_Id;
1042 Use_Dl : Boolean) return List_Id
1044 Loc : Source_Ptr := Sloc (Rec_Id);
1045 Parameter_List : constant List_Id := New_List;
1048 Formal_Type : Entity_Id;
1049 Param_Spec_Node : Node_Id;
1052 if Has_Discriminants (Rec_Id) then
1053 D := First_Discriminant (Rec_Id);
1054 while Present (D) loop
1058 Formal := Discriminal (D);
1059 Formal_Type := Etype (Formal);
1061 Formal := Make_Defining_Identifier (Loc, Chars (D));
1062 Formal_Type := Etype (D);
1066 Make_Parameter_Specification (Loc,
1067 Defining_Identifier => Formal,
1069 New_Occurrence_Of (Formal_Type, Loc));
1070 Append (Param_Spec_Node, Parameter_List);
1071 Next_Discriminant (D);
1075 return Parameter_List;
1076 end Build_Discriminant_Formals;
1078 --------------------------------------
1079 -- Build_Equivalent_Array_Aggregate --
1080 --------------------------------------
1082 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1083 Loc : constant Source_Ptr := Sloc (T);
1084 Comp_Type : constant Entity_Id := Component_Type (T);
1085 Index_Type : constant Entity_Id := Etype (First_Index (T));
1086 Proc : constant Entity_Id := Base_Init_Proc (T);
1092 if not Is_Constrained (T)
1093 or else Number_Dimensions (T) > 1
1096 Initialization_Warning (T);
1100 Lo := Type_Low_Bound (Index_Type);
1101 Hi := Type_High_Bound (Index_Type);
1103 if not Compile_Time_Known_Value (Lo)
1104 or else not Compile_Time_Known_Value (Hi)
1106 Initialization_Warning (T);
1110 if Is_Record_Type (Comp_Type)
1111 and then Present (Base_Init_Proc (Comp_Type))
1113 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1116 Initialization_Warning (T);
1121 Initialization_Warning (T);
1125 Aggr := Make_Aggregate (Loc, No_List, New_List);
1126 Set_Etype (Aggr, T);
1127 Set_Aggregate_Bounds (Aggr,
1129 Low_Bound => New_Copy (Lo),
1130 High_Bound => New_Copy (Hi)));
1131 Set_Parent (Aggr, Parent (Proc));
1133 Append_To (Component_Associations (Aggr),
1134 Make_Component_Association (Loc,
1138 Low_Bound => New_Copy (Lo),
1139 High_Bound => New_Copy (Hi))),
1140 Expression => Expr));
1142 if Static_Array_Aggregate (Aggr) then
1145 Initialization_Warning (T);
1148 end Build_Equivalent_Array_Aggregate;
1150 ---------------------------------------
1151 -- Build_Equivalent_Record_Aggregate --
1152 ---------------------------------------
1154 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1157 Comp_Type : Entity_Id;
1159 -- Start of processing for Build_Equivalent_Record_Aggregate
1162 if not Is_Record_Type (T)
1163 or else Has_Discriminants (T)
1164 or else Is_Limited_Type (T)
1165 or else Has_Non_Standard_Rep (T)
1167 Initialization_Warning (T);
1171 Comp := First_Component (T);
1173 -- A null record needs no warning
1179 while Present (Comp) loop
1181 -- Array components are acceptable if initialized by a positional
1182 -- aggregate with static components.
1184 if Is_Array_Type (Etype (Comp)) then
1185 Comp_Type := Component_Type (Etype (Comp));
1187 if Nkind (Parent (Comp)) /= N_Component_Declaration
1188 or else No (Expression (Parent (Comp)))
1189 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1191 Initialization_Warning (T);
1194 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1196 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1198 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1200 Initialization_Warning (T);
1204 not Static_Array_Aggregate (Expression (Parent (Comp)))
1206 Initialization_Warning (T);
1210 elsif Is_Scalar_Type (Etype (Comp)) then
1211 Comp_Type := Etype (Comp);
1213 if Nkind (Parent (Comp)) /= N_Component_Declaration
1214 or else No (Expression (Parent (Comp)))
1215 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1216 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1218 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1220 Initialization_Warning (T);
1224 -- For now, other types are excluded
1227 Initialization_Warning (T);
1231 Next_Component (Comp);
1234 -- All components have static initialization. Build positional aggregate
1235 -- from the given expressions or defaults.
1237 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1238 Set_Parent (Agg, Parent (T));
1240 Comp := First_Component (T);
1241 while Present (Comp) loop
1243 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1244 Next_Component (Comp);
1247 Analyze_And_Resolve (Agg, T);
1249 end Build_Equivalent_Record_Aggregate;
1251 -------------------------------
1252 -- Build_Initialization_Call --
1253 -------------------------------
1255 -- References to a discriminant inside the record type declaration can
1256 -- appear either in the subtype_indication to constrain a record or an
1257 -- array, or as part of a larger expression given for the initial value
1258 -- of a component. In both of these cases N appears in the record
1259 -- initialization procedure and needs to be replaced by the formal
1260 -- parameter of the initialization procedure which corresponds to that
1263 -- In the example below, references to discriminants D1 and D2 in proc_1
1264 -- are replaced by references to formals with the same name
1267 -- A similar replacement is done for calls to any record initialization
1268 -- procedure for any components that are themselves of a record type.
1270 -- type R (D1, D2 : Integer) is record
1271 -- X : Integer := F * D1;
1272 -- Y : Integer := F * D2;
1275 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1279 -- Out_2.X := F * D1;
1280 -- Out_2.Y := F * D2;
1283 function Build_Initialization_Call
1287 In_Init_Proc : Boolean := False;
1288 Enclos_Type : Entity_Id := Empty;
1289 Discr_Map : Elist_Id := New_Elmt_List;
1290 With_Default_Init : Boolean := False;
1291 Constructor_Ref : Node_Id := Empty) return List_Id
1293 Res : constant List_Id := New_List;
1295 Full_Type : Entity_Id;
1297 procedure Check_Predicated_Discriminant
1300 -- Discriminants whose subtypes have predicates are checked in two
1302 -- a) When an object is default-initialized and assertions are enabled
1303 -- we check that the value of the discriminant obeys the predicate.
1305 -- b) In all cases, if the discriminant controls a variant and the
1306 -- variant has no others_choice, Constraint_Error must be raised if
1307 -- the predicate is violated, because there is no variant covered
1308 -- by the illegal discriminant value.
1310 -----------------------------------
1311 -- Check_Predicated_Discriminant --
1312 -----------------------------------
1314 procedure Check_Predicated_Discriminant
1318 Typ : constant Entity_Id := Etype (Discr);
1320 procedure Check_Missing_Others (V : Node_Id);
1323 --------------------------
1324 -- Check_Missing_Others --
1325 --------------------------
1327 procedure Check_Missing_Others (V : Node_Id) is
1333 Last_Var := Last_Non_Pragma (Variants (V));
1334 Choice := First (Discrete_Choices (Last_Var));
1336 -- An others_choice is added during expansion for gcc use, but
1337 -- does not cover the illegality.
1339 if Entity (Name (V)) = Discr then
1341 and then (Nkind (Choice) /= N_Others_Choice
1342 or else not Comes_From_Source (Choice))
1344 Check_Expression_Against_Static_Predicate (Val, Typ);
1346 if not Is_Static_Expression (Val) then
1348 Make_Raise_Constraint_Error (Loc,
1351 Right_Opnd => Make_Predicate_Call (Typ, Val)),
1352 Reason => CE_Invalid_Data));
1357 -- Check whether some nested variant is ruled by the predicated
1360 Alt := First (Variants (V));
1361 while Present (Alt) loop
1362 if Nkind (Alt) = N_Variant
1363 and then Present (Variant_Part (Component_List (Alt)))
1365 Check_Missing_Others
1366 (Variant_Part (Component_List (Alt)));
1371 end Check_Missing_Others;
1377 -- Start of processing for Check_Predicated_Discriminant
1380 if Ekind (Base_Type (Full_Type)) = E_Record_Type then
1381 Def := Type_Definition (Parent (Base_Type (Full_Type)));
1386 if Policy_In_Effect (Name_Assert) = Name_Check
1387 and then not Predicates_Ignored (Etype (Discr))
1389 Prepend_To (Res, Make_Predicate_Check (Typ, Val));
1392 -- If discriminant controls a variant, verify that predicate is
1393 -- obeyed or else an Others_Choice is present.
1395 if Nkind (Def) = N_Record_Definition
1396 and then Present (Variant_Part (Component_List (Def)))
1397 and then Policy_In_Effect (Name_Assert) = Name_Ignore
1399 Check_Missing_Others (Variant_Part (Component_List (Def)));
1401 end Check_Predicated_Discriminant;
1410 First_Arg : Node_Id;
1411 Full_Init_Type : Entity_Id;
1412 Init_Call : Node_Id;
1413 Init_Type : Entity_Id;
1416 -- Start of processing for Build_Initialization_Call
1419 pragma Assert (Constructor_Ref = Empty
1420 or else Is_CPP_Constructor_Call (Constructor_Ref));
1422 if No (Constructor_Ref) then
1423 Proc := Base_Init_Proc (Typ);
1425 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1428 pragma Assert (Present (Proc));
1429 Init_Type := Etype (First_Formal (Proc));
1430 Full_Init_Type := Underlying_Type (Init_Type);
1432 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1433 -- is active (in which case we make the call anyway, since in the
1434 -- actual compiled client it may be non null).
1436 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1439 -- Nothing to do for an array of controlled components that have only
1440 -- the inherited Initialize primitive. This is a useful optimization
1443 elsif Is_Trivial_Subprogram (Proc)
1444 and then Is_Array_Type (Full_Init_Type)
1446 return New_List (Make_Null_Statement (Loc));
1449 -- Use the [underlying] full view when dealing with a private type. This
1450 -- may require several steps depending on derivations.
1454 if Is_Private_Type (Full_Type) then
1455 if Present (Full_View (Full_Type)) then
1456 Full_Type := Full_View (Full_Type);
1458 elsif Present (Underlying_Full_View (Full_Type)) then
1459 Full_Type := Underlying_Full_View (Full_Type);
1461 -- When a private type acts as a generic actual and lacks a full
1462 -- view, use the base type.
1464 elsif Is_Generic_Actual_Type (Full_Type) then
1465 Full_Type := Base_Type (Full_Type);
1467 elsif Ekind (Full_Type) = E_Private_Subtype
1468 and then (not Has_Discriminants (Full_Type)
1469 or else No (Discriminant_Constraint (Full_Type)))
1471 Full_Type := Etype (Full_Type);
1473 -- The loop has recovered the [underlying] full view, stop the
1480 -- The type is not private, nothing to do
1487 -- If Typ is derived, the procedure is the initialization procedure for
1488 -- the root type. Wrap the argument in an conversion to make it type
1489 -- honest. Actually it isn't quite type honest, because there can be
1490 -- conflicts of views in the private type case. That is why we set
1491 -- Conversion_OK in the conversion node.
1493 if (Is_Record_Type (Typ)
1494 or else Is_Array_Type (Typ)
1495 or else Is_Private_Type (Typ))
1496 and then Init_Type /= Base_Type (Typ)
1498 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1499 Set_Etype (First_Arg, Init_Type);
1502 First_Arg := Id_Ref;
1505 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1507 -- In the tasks case, add _Master as the value of the _Master parameter
1508 -- and _Chain as the value of the _Chain parameter. At the outer level,
1509 -- these will be variables holding the corresponding values obtained
1510 -- from GNARL. At inner levels, they will be the parameters passed down
1511 -- through the outer routines.
1513 if Has_Task (Full_Type) then
1514 if Restriction_Active (No_Task_Hierarchy) then
1516 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1518 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1521 -- Add _Chain (not done for sequential elaboration policy, see
1522 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1524 if Partition_Elaboration_Policy /= 'S' then
1525 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1528 -- Ada 2005 (AI-287): In case of default initialized components
1529 -- with tasks, we generate a null string actual parameter.
1530 -- This is just a workaround that must be improved later???
1532 if With_Default_Init then
1534 Make_String_Literal (Loc,
1539 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1540 Decl := Last (Decls);
1543 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1544 Append_List (Decls, Res);
1552 -- Add discriminant values if discriminants are present
1554 if Has_Discriminants (Full_Init_Type) then
1555 Discr := First_Discriminant (Full_Init_Type);
1556 while Present (Discr) loop
1558 -- If this is a discriminated concurrent type, the init_proc
1559 -- for the corresponding record is being called. Use that type
1560 -- directly to find the discriminant value, to handle properly
1561 -- intervening renamed discriminants.
1564 T : Entity_Id := Full_Type;
1567 if Is_Protected_Type (T) then
1568 T := Corresponding_Record_Type (T);
1572 Get_Discriminant_Value (
1575 Discriminant_Constraint (Full_Type));
1578 -- If the target has access discriminants, and is constrained by
1579 -- an access to the enclosing construct, i.e. a current instance,
1580 -- replace the reference to the type by a reference to the object.
1582 if Nkind (Arg) = N_Attribute_Reference
1583 and then Is_Access_Type (Etype (Arg))
1584 and then Is_Entity_Name (Prefix (Arg))
1585 and then Is_Type (Entity (Prefix (Arg)))
1588 Make_Attribute_Reference (Loc,
1589 Prefix => New_Copy (Prefix (Id_Ref)),
1590 Attribute_Name => Name_Unrestricted_Access);
1592 elsif In_Init_Proc then
1594 -- Replace any possible references to the discriminant in the
1595 -- call to the record initialization procedure with references
1596 -- to the appropriate formal parameter.
1598 if Nkind (Arg) = N_Identifier
1599 and then Ekind (Entity (Arg)) = E_Discriminant
1601 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1603 -- Otherwise make a copy of the default expression. Note that
1604 -- we use the current Sloc for this, because we do not want the
1605 -- call to appear to be at the declaration point. Within the
1606 -- expression, replace discriminants with their discriminals.
1610 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1614 if Is_Constrained (Full_Type) then
1615 Arg := Duplicate_Subexpr_No_Checks (Arg);
1617 -- The constraints come from the discriminant default exps,
1618 -- they must be reevaluated, so we use New_Copy_Tree but we
1619 -- ensure the proper Sloc (for any embedded calls).
1620 -- In addition, if a predicate check is needed on the value
1621 -- of the discriminant, insert it ahead of the call.
1623 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1626 if Has_Predicates (Etype (Discr)) then
1627 Check_Predicated_Discriminant (Arg, Discr);
1631 -- Ada 2005 (AI-287): In case of default initialized components,
1632 -- if the component is constrained with a discriminant of the
1633 -- enclosing type, we need to generate the corresponding selected
1634 -- component node to access the discriminant value. In other cases
1635 -- this is not required, either because we are inside the init
1636 -- proc and we use the corresponding formal, or else because the
1637 -- component is constrained by an expression.
1639 if With_Default_Init
1640 and then Nkind (Id_Ref) = N_Selected_Component
1641 and then Nkind (Arg) = N_Identifier
1642 and then Ekind (Entity (Arg)) = E_Discriminant
1645 Make_Selected_Component (Loc,
1646 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1647 Selector_Name => Arg));
1649 Append_To (Args, Arg);
1652 Next_Discriminant (Discr);
1656 -- If this is a call to initialize the parent component of a derived
1657 -- tagged type, indicate that the tag should not be set in the parent.
1659 if Is_Tagged_Type (Full_Init_Type)
1660 and then not Is_CPP_Class (Full_Init_Type)
1661 and then Nkind (Id_Ref) = N_Selected_Component
1662 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1664 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1666 elsif Present (Constructor_Ref) then
1667 Append_List_To (Args,
1668 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1672 Make_Procedure_Call_Statement (Loc,
1673 Name => New_Occurrence_Of (Proc, Loc),
1674 Parameter_Associations => Args));
1676 if Needs_Finalization (Typ)
1677 and then Nkind (Id_Ref) = N_Selected_Component
1679 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1682 (Obj_Ref => New_Copy_Tree (First_Arg),
1685 -- Guard against a missing [Deep_]Initialize when the type was not
1688 if Present (Init_Call) then
1689 Append_To (Res, Init_Call);
1697 when RE_Not_Available =>
1699 end Build_Initialization_Call;
1701 ----------------------------
1702 -- Build_Record_Init_Proc --
1703 ----------------------------
1705 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1706 Decls : constant List_Id := New_List;
1707 Discr_Map : constant Elist_Id := New_Elmt_List;
1708 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1710 Proc_Id : Entity_Id;
1711 Rec_Type : Entity_Id;
1712 Set_Tag : Entity_Id := Empty;
1714 function Build_Assignment
1716 Default : Node_Id) return List_Id;
1717 -- Build an assignment statement that assigns the default expression to
1718 -- its corresponding record component if defined. The left-hand side of
1719 -- the assignment is marked Assignment_OK so that initialization of
1720 -- limited private records works correctly. This routine may also build
1721 -- an adjustment call if the component is controlled.
1723 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1724 -- If the record has discriminants, add assignment statements to
1725 -- Statement_List to initialize the discriminant values from the
1726 -- arguments of the initialization procedure.
1728 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1729 -- Build a list representing a sequence of statements which initialize
1730 -- components of the given component list. This may involve building
1731 -- case statements for the variant parts. Append any locally declared
1732 -- objects on list Decls.
1734 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1735 -- Given an untagged type-derivation that declares discriminants, e.g.
1737 -- type R (R1, R2 : Integer) is record ... end record;
1738 -- type D (D1 : Integer) is new R (1, D1);
1740 -- we make the _init_proc of D be
1742 -- procedure _init_proc (X : D; D1 : Integer) is
1744 -- _init_proc (R (X), 1, D1);
1747 -- This function builds the call statement in this _init_proc.
1749 procedure Build_CPP_Init_Procedure;
1750 -- Build the tree corresponding to the procedure specification and body
1751 -- of the IC procedure that initializes the C++ part of the dispatch
1752 -- table of an Ada tagged type that is a derivation of a CPP type.
1753 -- Install it as the CPP_Init TSS.
1755 procedure Build_Init_Procedure;
1756 -- Build the tree corresponding to the procedure specification and body
1757 -- of the initialization procedure and install it as the _init TSS.
1759 procedure Build_Offset_To_Top_Functions;
1760 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1761 -- and body of Offset_To_Top, a function used in conjuction with types
1762 -- having secondary dispatch tables.
1764 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1765 -- Add range checks to components of discriminated records. S is a
1766 -- subtype indication of a record component. Check_List is a list
1767 -- to which the check actions are appended.
1769 function Component_Needs_Simple_Initialization
1770 (T : Entity_Id) return Boolean;
1771 -- Determine if a component needs simple initialization, given its type
1772 -- T. This routine is the same as Needs_Simple_Initialization except for
1773 -- components of type Tag and Interface_Tag. These two access types do
1774 -- not require initialization since they are explicitly initialized by
1777 function Parent_Subtype_Renaming_Discrims return Boolean;
1778 -- Returns True for base types N that rename discriminants, else False
1780 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1781 -- Determine whether a record initialization procedure needs to be
1782 -- generated for the given record type.
1784 ----------------------
1785 -- Build_Assignment --
1786 ----------------------
1788 function Build_Assignment
1790 Default : Node_Id) return List_Id
1792 Default_Loc : constant Source_Ptr := Sloc (Default);
1793 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1796 Exp : Node_Id := Default;
1797 Kind : Node_Kind := Nkind (Default);
1801 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
1802 -- Analysis of the aggregate has replaced discriminants by their
1803 -- corresponding discriminals, but these are irrelevant when the
1804 -- component has a mutable type and is initialized with an aggregate.
1805 -- Instead, they must be replaced by the values supplied in the
1806 -- aggregate, that will be assigned during the expansion of the
1809 -----------------------
1810 -- Replace_Discr_Ref --
1811 -----------------------
1813 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
1817 if Is_Entity_Name (N)
1818 and then Present (Entity (N))
1819 and then Is_Formal (Entity (N))
1820 and then Present (Discriminal_Link (Entity (N)))
1823 Make_Selected_Component (Default_Loc,
1824 Prefix => New_Copy_Tree (Lhs),
1827 (Discriminal_Link (Entity (N)), Default_Loc));
1829 if Present (Val) then
1830 Rewrite (N, New_Copy_Tree (Val));
1835 end Replace_Discr_Ref;
1837 procedure Replace_Discriminant_References is
1838 new Traverse_Proc (Replace_Discr_Ref);
1840 -- Start of processing for Build_Assignment
1844 Make_Selected_Component (Default_Loc,
1845 Prefix => Make_Identifier (Loc, Name_uInit),
1846 Selector_Name => New_Occurrence_Of (Id, Default_Loc));
1847 Set_Assignment_OK (Lhs);
1849 if Nkind (Exp) = N_Aggregate
1850 and then Has_Discriminants (Typ)
1851 and then not Is_Constrained (Base_Type (Typ))
1853 -- The aggregate may provide new values for the discriminants
1854 -- of the component, and other components may depend on those
1855 -- discriminants. Previous analysis of those expressions have
1856 -- replaced the discriminants by the formals of the initialization
1857 -- procedure for the type, but these are irrelevant in the
1858 -- enclosing initialization procedure: those discriminant
1859 -- references must be replaced by the values provided in the
1862 Replace_Discriminant_References (Exp);
1865 -- Case of an access attribute applied to the current instance.
1866 -- Replace the reference to the type by a reference to the actual
1867 -- object. (Note that this handles the case of the top level of
1868 -- the expression being given by such an attribute, but does not
1869 -- cover uses nested within an initial value expression. Nested
1870 -- uses are unlikely to occur in practice, but are theoretically
1871 -- possible.) It is not clear how to handle them without fully
1872 -- traversing the expression. ???
1874 if Kind = N_Attribute_Reference
1875 and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
1876 Name_Unrestricted_Access)
1877 and then Is_Entity_Name (Prefix (Default))
1878 and then Is_Type (Entity (Prefix (Default)))
1879 and then Entity (Prefix (Default)) = Rec_Type
1882 Make_Attribute_Reference (Default_Loc,
1884 Make_Identifier (Default_Loc, Name_uInit),
1885 Attribute_Name => Name_Unrestricted_Access);
1888 -- Take a copy of Exp to ensure that later copies of this component
1889 -- declaration in derived types see the original tree, not a node
1890 -- rewritten during expansion of the init_proc. If the copy contains
1891 -- itypes, the scope of the new itypes is the init_proc being built.
1893 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1896 Make_Assignment_Statement (Loc,
1898 Expression => Exp));
1900 Set_No_Ctrl_Actions (First (Res));
1902 -- Adjust the tag if tagged (because of possible view conversions).
1903 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
1904 -- tags are represented implicitly in objects.
1906 if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
1908 Make_Assignment_Statement (Default_Loc,
1910 Make_Selected_Component (Default_Loc,
1912 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1915 (First_Tag_Component (Typ), Default_Loc)),
1918 Unchecked_Convert_To (RTE (RE_Tag),
1920 (Node (First_Elmt (Access_Disp_Table (Underlying_Type
1925 -- Adjust the component if controlled except if it is an aggregate
1926 -- that will be expanded inline.
1928 if Kind = N_Qualified_Expression then
1929 Kind := Nkind (Expression (Default));
1932 if Needs_Finalization (Typ)
1933 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1934 and then not Is_Build_In_Place_Function_Call (Exp)
1938 (Obj_Ref => New_Copy_Tree (Lhs),
1941 -- Guard against a missing [Deep_]Adjust when the component type
1942 -- was not properly frozen.
1944 if Present (Adj_Call) then
1945 Append_To (Res, Adj_Call);
1949 -- If a component type has a predicate, add check to the component
1950 -- assignment. Discriminants are handled at the point of the call,
1951 -- which provides for a better error message.
1953 if Comes_From_Source (Exp)
1954 and then Has_Predicates (Typ)
1955 and then not Predicate_Checks_Suppressed (Empty)
1956 and then not Predicates_Ignored (Typ)
1958 Append (Make_Predicate_Check (Typ, Exp), Res);
1964 when RE_Not_Available =>
1966 end Build_Assignment;
1968 ------------------------------------
1969 -- Build_Discriminant_Assignments --
1970 ------------------------------------
1972 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1973 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1978 if Has_Discriminants (Rec_Type)
1979 and then not Is_Unchecked_Union (Rec_Type)
1981 D := First_Discriminant (Rec_Type);
1982 while Present (D) loop
1984 -- Don't generate the assignment for discriminants in derived
1985 -- tagged types if the discriminant is a renaming of some
1986 -- ancestor discriminant. This initialization will be done
1987 -- when initializing the _parent field of the derived record.
1990 and then Present (Corresponding_Discriminant (D))
1996 Append_List_To (Statement_List,
1997 Build_Assignment (D,
1998 New_Occurrence_Of (Discriminal (D), D_Loc)));
2001 Next_Discriminant (D);
2004 end Build_Discriminant_Assignments;
2006 --------------------------
2007 -- Build_Init_Call_Thru --
2008 --------------------------
2010 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
2011 Parent_Proc : constant Entity_Id :=
2012 Base_Init_Proc (Etype (Rec_Type));
2014 Parent_Type : constant Entity_Id :=
2015 Etype (First_Formal (Parent_Proc));
2017 Uparent_Type : constant Entity_Id :=
2018 Underlying_Type (Parent_Type);
2020 First_Discr_Param : Node_Id;
2024 First_Arg : Node_Id;
2025 Parent_Discr : Entity_Id;
2029 -- First argument (_Init) is the object to be initialized.
2030 -- ??? not sure where to get a reasonable Loc for First_Arg
2033 OK_Convert_To (Parent_Type,
2035 (Defining_Identifier (First (Parameters)), Loc));
2037 Set_Etype (First_Arg, Parent_Type);
2039 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
2041 -- In the tasks case,
2042 -- add _Master as the value of the _Master parameter
2043 -- add _Chain as the value of the _Chain parameter.
2044 -- add _Task_Name as the value of the _Task_Name parameter.
2045 -- At the outer level, these will be variables holding the
2046 -- corresponding values obtained from GNARL or the expander.
2048 -- At inner levels, they will be the parameters passed down through
2049 -- the outer routines.
2051 First_Discr_Param := Next (First (Parameters));
2053 if Has_Task (Rec_Type) then
2054 if Restriction_Active (No_Task_Hierarchy) then
2056 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
2058 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2061 -- Add _Chain (not done for sequential elaboration policy, see
2062 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2064 if Partition_Elaboration_Policy /= 'S' then
2065 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2068 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2069 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2072 -- Append discriminant values
2074 if Has_Discriminants (Uparent_Type) then
2075 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2077 Parent_Discr := First_Discriminant (Uparent_Type);
2078 while Present (Parent_Discr) loop
2080 -- Get the initial value for this discriminant
2081 -- ??? needs to be cleaned up to use parent_Discr_Constr
2085 Discr : Entity_Id :=
2086 First_Stored_Discriminant (Uparent_Type);
2088 Discr_Value : Elmt_Id :=
2089 First_Elmt (Stored_Constraint (Rec_Type));
2092 while Original_Record_Component (Parent_Discr) /= Discr loop
2093 Next_Stored_Discriminant (Discr);
2094 Next_Elmt (Discr_Value);
2097 Arg := Node (Discr_Value);
2100 -- Append it to the list
2102 if Nkind (Arg) = N_Identifier
2103 and then Ekind (Entity (Arg)) = E_Discriminant
2106 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2108 -- Case of access discriminants. We replace the reference
2109 -- to the type by a reference to the actual object.
2111 -- Is above comment right??? Use of New_Copy below seems mighty
2115 Append_To (Args, New_Copy (Arg));
2118 Next_Discriminant (Parent_Discr);
2124 Make_Procedure_Call_Statement (Loc,
2126 New_Occurrence_Of (Parent_Proc, Loc),
2127 Parameter_Associations => Args));
2130 end Build_Init_Call_Thru;
2132 -----------------------------------
2133 -- Build_Offset_To_Top_Functions --
2134 -----------------------------------
2136 procedure Build_Offset_To_Top_Functions is
2138 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2140 -- function Fxx (O : Address) return Storage_Offset is
2141 -- type Acc is access all <Typ>;
2143 -- return Acc!(O).Iface_Comp'Position;
2146 ----------------------------------
2147 -- Build_Offset_To_Top_Function --
2148 ----------------------------------
2150 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2151 Body_Node : Node_Id;
2152 Func_Id : Entity_Id;
2153 Spec_Node : Node_Id;
2154 Acc_Type : Entity_Id;
2157 Func_Id := Make_Temporary (Loc, 'F');
2158 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2161 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2163 Spec_Node := New_Node (N_Function_Specification, Loc);
2164 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2165 Set_Parameter_Specifications (Spec_Node, New_List (
2166 Make_Parameter_Specification (Loc,
2167 Defining_Identifier =>
2168 Make_Defining_Identifier (Loc, Name_uO),
2171 New_Occurrence_Of (RTE (RE_Address), Loc))));
2172 Set_Result_Definition (Spec_Node,
2173 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2176 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2178 -- return O.Iface_Comp'Position;
2181 Body_Node := New_Node (N_Subprogram_Body, Loc);
2182 Set_Specification (Body_Node, Spec_Node);
2184 Acc_Type := Make_Temporary (Loc, 'T');
2185 Set_Declarations (Body_Node, New_List (
2186 Make_Full_Type_Declaration (Loc,
2187 Defining_Identifier => Acc_Type,
2189 Make_Access_To_Object_Definition (Loc,
2190 All_Present => True,
2191 Null_Exclusion_Present => False,
2192 Constant_Present => False,
2193 Subtype_Indication =>
2194 New_Occurrence_Of (Rec_Type, Loc)))));
2196 Set_Handled_Statement_Sequence (Body_Node,
2197 Make_Handled_Sequence_Of_Statements (Loc,
2198 Statements => New_List (
2199 Make_Simple_Return_Statement (Loc,
2201 Make_Attribute_Reference (Loc,
2203 Make_Selected_Component (Loc,
2205 Unchecked_Convert_To (Acc_Type,
2206 Make_Identifier (Loc, Name_uO)),
2208 New_Occurrence_Of (Iface_Comp, Loc)),
2209 Attribute_Name => Name_Position)))));
2211 Set_Ekind (Func_Id, E_Function);
2212 Set_Mechanism (Func_Id, Default_Mechanism);
2213 Set_Is_Internal (Func_Id, True);
2215 if not Debug_Generated_Code then
2216 Set_Debug_Info_Off (Func_Id);
2219 Analyze (Body_Node);
2221 Append_Freeze_Action (Rec_Type, Body_Node);
2222 end Build_Offset_To_Top_Function;
2226 Iface_Comp : Node_Id;
2227 Iface_Comp_Elmt : Elmt_Id;
2228 Ifaces_Comp_List : Elist_Id;
2230 -- Start of processing for Build_Offset_To_Top_Functions
2233 -- Offset_To_Top_Functions are built only for derivations of types
2234 -- with discriminants that cover interface types.
2235 -- Nothing is needed either in case of virtual targets, since
2236 -- interfaces are handled directly by the target.
2238 if not Is_Tagged_Type (Rec_Type)
2239 or else Etype (Rec_Type) = Rec_Type
2240 or else not Has_Discriminants (Etype (Rec_Type))
2241 or else not Tagged_Type_Expansion
2246 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2248 -- For each interface type with secondary dispatch table we generate
2249 -- the Offset_To_Top_Functions (required to displace the pointer in
2250 -- interface conversions)
2252 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2253 while Present (Iface_Comp_Elmt) loop
2254 Iface_Comp := Node (Iface_Comp_Elmt);
2255 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2257 -- If the interface is a parent of Rec_Type it shares the primary
2258 -- dispatch table and hence there is no need to build the function
2260 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2261 Use_Full_View => True)
2263 Build_Offset_To_Top_Function (Iface_Comp);
2266 Next_Elmt (Iface_Comp_Elmt);
2268 end Build_Offset_To_Top_Functions;
2270 ------------------------------
2271 -- Build_CPP_Init_Procedure --
2272 ------------------------------
2274 procedure Build_CPP_Init_Procedure is
2275 Body_Node : Node_Id;
2276 Body_Stmts : List_Id;
2277 Flag_Id : Entity_Id;
2278 Handled_Stmt_Node : Node_Id;
2279 Init_Tags_List : List_Id;
2280 Proc_Id : Entity_Id;
2281 Proc_Spec_Node : Node_Id;
2284 -- Check cases requiring no IC routine
2286 if not Is_CPP_Class (Root_Type (Rec_Type))
2287 or else Is_CPP_Class (Rec_Type)
2288 or else CPP_Num_Prims (Rec_Type) = 0
2289 or else not Tagged_Type_Expansion
2290 or else No_Run_Time_Mode
2297 -- Flag : Boolean := False;
2299 -- procedure Typ_IC is
2302 -- Copy C++ dispatch table slots from parent
2303 -- Update C++ slots of overridden primitives
2307 Flag_Id := Make_Temporary (Loc, 'F');
2309 Append_Freeze_Action (Rec_Type,
2310 Make_Object_Declaration (Loc,
2311 Defining_Identifier => Flag_Id,
2312 Object_Definition =>
2313 New_Occurrence_Of (Standard_Boolean, Loc),
2315 New_Occurrence_Of (Standard_True, Loc)));
2317 Body_Stmts := New_List;
2318 Body_Node := New_Node (N_Subprogram_Body, Loc);
2320 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2323 Make_Defining_Identifier (Loc,
2324 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2326 Set_Ekind (Proc_Id, E_Procedure);
2327 Set_Is_Internal (Proc_Id);
2329 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2331 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2332 Set_Specification (Body_Node, Proc_Spec_Node);
2333 Set_Declarations (Body_Node, New_List);
2335 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2337 Append_To (Init_Tags_List,
2338 Make_Assignment_Statement (Loc,
2340 New_Occurrence_Of (Flag_Id, Loc),
2342 New_Occurrence_Of (Standard_False, Loc)));
2344 Append_To (Body_Stmts,
2345 Make_If_Statement (Loc,
2346 Condition => New_Occurrence_Of (Flag_Id, Loc),
2347 Then_Statements => Init_Tags_List));
2349 Handled_Stmt_Node :=
2350 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2351 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2352 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2353 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2355 if not Debug_Generated_Code then
2356 Set_Debug_Info_Off (Proc_Id);
2359 -- Associate CPP_Init_Proc with type
2361 Set_Init_Proc (Rec_Type, Proc_Id);
2362 end Build_CPP_Init_Procedure;
2364 --------------------------
2365 -- Build_Init_Procedure --
2366 --------------------------
2368 procedure Build_Init_Procedure is
2369 Body_Stmts : List_Id;
2370 Body_Node : Node_Id;
2371 Handled_Stmt_Node : Node_Id;
2372 Init_Tags_List : List_Id;
2373 Parameters : List_Id;
2374 Proc_Spec_Node : Node_Id;
2375 Record_Extension_Node : Node_Id;
2378 Body_Stmts := New_List;
2379 Body_Node := New_Node (N_Subprogram_Body, Loc);
2380 Set_Ekind (Proc_Id, E_Procedure);
2382 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2383 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2385 Parameters := Init_Formals (Rec_Type);
2386 Append_List_To (Parameters,
2387 Build_Discriminant_Formals (Rec_Type, True));
2389 -- For tagged types, we add a flag to indicate whether the routine
2390 -- is called to initialize a parent component in the init_proc of
2391 -- a type extension. If the flag is false, we do not set the tag
2392 -- because it has been set already in the extension.
2394 if Is_Tagged_Type (Rec_Type) then
2395 Set_Tag := Make_Temporary (Loc, 'P');
2397 Append_To (Parameters,
2398 Make_Parameter_Specification (Loc,
2399 Defining_Identifier => Set_Tag,
2401 New_Occurrence_Of (Standard_Boolean, Loc),
2403 New_Occurrence_Of (Standard_True, Loc)));
2406 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2407 Set_Specification (Body_Node, Proc_Spec_Node);
2408 Set_Declarations (Body_Node, Decls);
2410 -- N is a Derived_Type_Definition that renames the parameters of the
2411 -- ancestor type. We initialize it by expanding our discriminants and
2412 -- call the ancestor _init_proc with a type-converted object.
2414 if Parent_Subtype_Renaming_Discrims then
2415 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2417 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2418 Build_Discriminant_Assignments (Body_Stmts);
2420 if not Null_Present (Type_Definition (N)) then
2421 Append_List_To (Body_Stmts,
2422 Build_Init_Statements (Component_List (Type_Definition (N))));
2425 -- N is a Derived_Type_Definition with a possible non-empty
2426 -- extension. The initialization of a type extension consists in the
2427 -- initialization of the components in the extension.
2430 Build_Discriminant_Assignments (Body_Stmts);
2432 Record_Extension_Node :=
2433 Record_Extension_Part (Type_Definition (N));
2435 if not Null_Present (Record_Extension_Node) then
2437 Stmts : constant List_Id :=
2438 Build_Init_Statements (
2439 Component_List (Record_Extension_Node));
2442 -- The parent field must be initialized first because the
2443 -- offset of the new discriminants may depend on it. This is
2444 -- not needed if the parent is an interface type because in
2445 -- such case the initialization of the _parent field was not
2448 if not Is_Interface (Etype (Rec_Ent)) then
2450 Parent_IP : constant Name_Id :=
2451 Make_Init_Proc_Name (Etype (Rec_Ent));
2457 -- Look for a call to the parent IP at the beginning
2458 -- of Stmts associated with the record extension
2460 Stmt := First (Stmts);
2462 while Present (Stmt) loop
2463 if Nkind (Stmt) = N_Procedure_Call_Statement
2464 and then Chars (Name (Stmt)) = Parent_IP
2473 -- If found then move it to the beginning of the
2474 -- statements of this IP routine
2476 if Present (IP_Call) then
2477 IP_Stmts := New_List;
2479 Stmt := Remove_Head (Stmts);
2480 Append_To (IP_Stmts, Stmt);
2481 exit when Stmt = IP_Call;
2484 Prepend_List_To (Body_Stmts, IP_Stmts);
2489 Append_List_To (Body_Stmts, Stmts);
2494 -- Add here the assignment to instantiate the Tag
2496 -- The assignment corresponds to the code:
2498 -- _Init._Tag := Typ'Tag;
2500 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2501 -- tags are represented implicitly in objects. It is also suppressed
2502 -- in case of CPP_Class types because in this case the tag is
2503 -- initialized in the C++ side.
2505 if Is_Tagged_Type (Rec_Type)
2506 and then Tagged_Type_Expansion
2507 and then not No_Run_Time_Mode
2509 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2510 -- the actual object and invoke the IP of the parent (in this
2511 -- order). The tag must be initialized before the call to the IP
2512 -- of the parent and the assignments to other components because
2513 -- the initial value of the components may depend on the tag (eg.
2514 -- through a dispatching operation on an access to the current
2515 -- type). The tag assignment is not done when initializing the
2516 -- parent component of a type extension, because in that case the
2517 -- tag is set in the extension.
2519 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2521 -- Initialize the primary tag component
2523 Init_Tags_List := New_List (
2524 Make_Assignment_Statement (Loc,
2526 Make_Selected_Component (Loc,
2527 Prefix => Make_Identifier (Loc, Name_uInit),
2530 (First_Tag_Component (Rec_Type), Loc)),
2534 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2536 -- Ada 2005 (AI-251): Initialize the secondary tags components
2537 -- located at fixed positions (tags whose position depends on
2538 -- variable size components are initialized later ---see below)
2540 if Ada_Version >= Ada_2005
2541 and then not Is_Interface (Rec_Type)
2542 and then Has_Interfaces (Rec_Type)
2545 Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
2550 Target => Make_Identifier (Loc, Name_uInit),
2551 Init_Tags_List => Init_Tags_List,
2552 Stmts_List => Elab_Sec_DT_Stmts_List,
2553 Fixed_Comps => True,
2554 Variable_Comps => False);
2556 Append_To (Elab_Sec_DT_Stmts_List,
2557 Make_Assignment_Statement (Loc,
2560 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2562 New_Occurrence_Of (Standard_False, Loc)));
2564 Prepend_List_To (Body_Stmts, New_List (
2565 Make_If_Statement (Loc,
2566 Condition => New_Occurrence_Of (Set_Tag, Loc),
2567 Then_Statements => Init_Tags_List),
2569 Make_If_Statement (Loc,
2572 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2573 Then_Statements => Elab_Sec_DT_Stmts_List)));
2576 Prepend_To (Body_Stmts,
2577 Make_If_Statement (Loc,
2578 Condition => New_Occurrence_Of (Set_Tag, Loc),
2579 Then_Statements => Init_Tags_List));
2582 -- Case 2: CPP type. The imported C++ constructor takes care of
2583 -- tags initialization. No action needed here because the IP
2584 -- is built by Set_CPP_Constructors; in this case the IP is a
2585 -- wrapper that invokes the C++ constructor and copies the C++
2586 -- tags locally. Done to inherit the C++ slots in Ada derivations
2589 elsif Is_CPP_Class (Rec_Type) then
2590 pragma Assert (False);
2593 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2594 -- type derivations. Derivations of imported C++ classes add a
2595 -- complication, because we cannot inhibit tag setting in the
2596 -- constructor for the parent. Hence we initialize the tag after
2597 -- the call to the parent IP (that is, in reverse order compared
2598 -- with pure Ada hierarchies ---see comment on case 1).
2601 -- Initialize the primary tag
2603 Init_Tags_List := New_List (
2604 Make_Assignment_Statement (Loc,
2606 Make_Selected_Component (Loc,
2607 Prefix => Make_Identifier (Loc, Name_uInit),
2610 (First_Tag_Component (Rec_Type), Loc)),
2614 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2616 -- Ada 2005 (AI-251): Initialize the secondary tags components
2617 -- located at fixed positions (tags whose position depends on
2618 -- variable size components are initialized later ---see below)
2620 if Ada_Version >= Ada_2005
2621 and then not Is_Interface (Rec_Type)
2622 and then Has_Interfaces (Rec_Type)
2626 Target => Make_Identifier (Loc, Name_uInit),
2627 Init_Tags_List => Init_Tags_List,
2628 Stmts_List => Init_Tags_List,
2629 Fixed_Comps => True,
2630 Variable_Comps => False);
2633 -- Initialize the tag component after invocation of parent IP.
2636 -- parent_IP(_init.parent); // Invokes the C++ constructor
2637 -- [ typIC; ] // Inherit C++ slots from parent
2644 -- Search for the call to the IP of the parent. We assume
2645 -- that the first init_proc call is for the parent.
2647 Ins_Nod := First (Body_Stmts);
2648 while Present (Next (Ins_Nod))
2649 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2650 or else not Is_Init_Proc (Name (Ins_Nod)))
2655 -- The IC routine copies the inherited slots of the C+ part
2656 -- of the dispatch table from the parent and updates the
2657 -- overridden C++ slots.
2659 if CPP_Num_Prims (Rec_Type) > 0 then
2661 Init_DT : Entity_Id;
2665 Init_DT := CPP_Init_Proc (Rec_Type);
2666 pragma Assert (Present (Init_DT));
2669 Make_Procedure_Call_Statement (Loc,
2670 New_Occurrence_Of (Init_DT, Loc));
2671 Insert_After (Ins_Nod, New_Nod);
2673 -- Update location of init tag statements
2679 Insert_List_After (Ins_Nod, Init_Tags_List);
2683 -- Ada 2005 (AI-251): Initialize the secondary tag components
2684 -- located at variable positions. We delay the generation of this
2685 -- code until here because the value of the attribute 'Position
2686 -- applied to variable size components of the parent type that
2687 -- depend on discriminants is only safely read at runtime after
2688 -- the parent components have been initialized.
2690 if Ada_Version >= Ada_2005
2691 and then not Is_Interface (Rec_Type)
2692 and then Has_Interfaces (Rec_Type)
2693 and then Has_Discriminants (Etype (Rec_Type))
2694 and then Is_Variable_Size_Record (Etype (Rec_Type))
2696 Init_Tags_List := New_List;
2700 Target => Make_Identifier (Loc, Name_uInit),
2701 Init_Tags_List => Init_Tags_List,
2702 Stmts_List => Init_Tags_List,
2703 Fixed_Comps => False,
2704 Variable_Comps => True);
2706 if Is_Non_Empty_List (Init_Tags_List) then
2707 Append_List_To (Body_Stmts, Init_Tags_List);
2712 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2713 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2716 -- Deep_Finalize (_init, C1, ..., CN);
2720 and then Needs_Finalization (Rec_Type)
2721 and then not Is_Abstract_Type (Rec_Type)
2722 and then not Restriction_Active (No_Exception_Propagation)
2728 -- Create a local version of Deep_Finalize which has indication
2729 -- of partial initialization state.
2732 Make_Defining_Identifier (Loc,
2733 Chars => New_External_Name (Name_uFinalizer));
2735 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2737 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2738 Make_Exception_Handler (Loc,
2739 Exception_Choices => New_List (
2740 Make_Others_Choice (Loc)),
2741 Statements => New_List (
2742 Make_Procedure_Call_Statement (Loc,
2744 New_Occurrence_Of (DF_Id, Loc),
2745 Parameter_Associations => New_List (
2746 Make_Identifier (Loc, Name_uInit),
2747 New_Occurrence_Of (Standard_False, Loc))),
2749 Make_Raise_Statement (Loc)))));
2752 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2755 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2757 if not Debug_Generated_Code then
2758 Set_Debug_Info_Off (Proc_Id);
2761 -- Associate Init_Proc with type, and determine if the procedure
2762 -- is null (happens because of the Initialize_Scalars pragma case,
2763 -- where we have to generate a null procedure in case it is called
2764 -- by a client with Initialize_Scalars set). Such procedures have
2765 -- to be generated, but do not have to be called, so we mark them
2766 -- as null to suppress the call.
2768 Set_Init_Proc (Rec_Type, Proc_Id);
2770 if List_Length (Body_Stmts) = 1
2772 -- We must skip SCIL nodes because they may have been added to this
2773 -- list by Insert_Actions.
2775 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2777 Set_Is_Null_Init_Proc (Proc_Id);
2779 end Build_Init_Procedure;
2781 ---------------------------
2782 -- Build_Init_Statements --
2783 ---------------------------
2785 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2786 Checks : constant List_Id := New_List;
2787 Actions : List_Id := No_List;
2788 Counter_Id : Entity_Id := Empty;
2789 Comp_Loc : Source_Ptr;
2793 Parent_Stmts : List_Id;
2797 procedure Increment_Counter (Loc : Source_Ptr);
2798 -- Generate an "increment by one" statement for the current counter
2799 -- and append it to the list Stmts.
2801 procedure Make_Counter (Loc : Source_Ptr);
2802 -- Create a new counter for the current component list. The routine
2803 -- creates a new defining Id, adds an object declaration and sets
2804 -- the Id generator for the next variant.
2806 -----------------------
2807 -- Increment_Counter --
2808 -----------------------
2810 procedure Increment_Counter (Loc : Source_Ptr) is
2813 -- Counter := Counter + 1;
2816 Make_Assignment_Statement (Loc,
2817 Name => New_Occurrence_Of (Counter_Id, Loc),
2820 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
2821 Right_Opnd => Make_Integer_Literal (Loc, 1))));
2822 end Increment_Counter;
2828 procedure Make_Counter (Loc : Source_Ptr) is
2830 -- Increment the Id generator
2832 Counter := Counter + 1;
2834 -- Create the entity and declaration
2837 Make_Defining_Identifier (Loc,
2838 Chars => New_External_Name ('C', Counter));
2841 -- Cnn : Integer := 0;
2844 Make_Object_Declaration (Loc,
2845 Defining_Identifier => Counter_Id,
2846 Object_Definition =>
2847 New_Occurrence_Of (Standard_Integer, Loc),
2849 Make_Integer_Literal (Loc, 0)));
2852 -- Start of processing for Build_Init_Statements
2855 if Null_Present (Comp_List) then
2856 return New_List (Make_Null_Statement (Loc));
2859 Parent_Stmts := New_List;
2862 -- Loop through visible declarations of task types and protected
2863 -- types moving any expanded code from the spec to the body of the
2866 if Is_Task_Record_Type (Rec_Type)
2867 or else Is_Protected_Record_Type (Rec_Type)
2870 Decl : constant Node_Id :=
2871 Parent (Corresponding_Concurrent_Type (Rec_Type));
2877 if Is_Task_Record_Type (Rec_Type) then
2878 Def := Task_Definition (Decl);
2880 Def := Protected_Definition (Decl);
2883 if Present (Def) then
2884 N1 := First (Visible_Declarations (Def));
2885 while Present (N1) loop
2889 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2890 or else Nkind (N2) in N_Raise_xxx_Error
2891 or else Nkind (N2) = N_Procedure_Call_Statement
2894 New_Copy_Tree (N2, New_Scope => Proc_Id));
2895 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2903 -- Loop through components, skipping pragmas, in 2 steps. The first
2904 -- step deals with regular components. The second step deals with
2905 -- components that have per object constraints and no explicit
2910 -- First pass : regular components
2912 Decl := First_Non_Pragma (Component_Items (Comp_List));
2913 while Present (Decl) loop
2914 Comp_Loc := Sloc (Decl);
2916 (Subtype_Indication (Component_Definition (Decl)), Checks);
2918 Id := Defining_Identifier (Decl);
2921 -- Leave any processing of per-object constrained component for
2924 if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
2927 -- Regular component cases
2930 -- In the context of the init proc, references to discriminants
2931 -- resolve to denote the discriminals: this is where we can
2932 -- freeze discriminant dependent component subtypes.
2934 if not Is_Frozen (Typ) then
2935 Append_List_To (Stmts, Freeze_Entity (Typ, N));
2938 -- Explicit initialization
2940 if Present (Expression (Decl)) then
2941 if Is_CPP_Constructor_Call (Expression (Decl)) then
2943 Build_Initialization_Call
2946 Make_Selected_Component (Comp_Loc,
2948 Make_Identifier (Comp_Loc, Name_uInit),
2950 New_Occurrence_Of (Id, Comp_Loc)),
2952 In_Init_Proc => True,
2953 Enclos_Type => Rec_Type,
2954 Discr_Map => Discr_Map,
2955 Constructor_Ref => Expression (Decl));
2957 Actions := Build_Assignment (Id, Expression (Decl));
2960 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
2961 -- components are filled in with the corresponding rep-item
2962 -- expression of the concurrent type (if any).
2964 elsif Ekind (Scope (Id)) = E_Record_Type
2965 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
2966 and then Nam_In (Chars (Id), Name_uCPU,
2967 Name_uDispatching_Domain,
2969 Name_uSecondary_Stack_Size)
2974 pragma Warnings (Off, Nam);
2978 if Chars (Id) = Name_uCPU then
2981 elsif Chars (Id) = Name_uDispatching_Domain then
2982 Nam := Name_Dispatching_Domain;
2984 elsif Chars (Id) = Name_uPriority then
2985 Nam := Name_Priority;
2987 elsif Chars (Id) = Name_uSecondary_Stack_Size then
2988 Nam := Name_Secondary_Stack_Size;
2991 -- Get the Rep Item (aspect specification, attribute
2992 -- definition clause or pragma) of the corresponding
2997 (Corresponding_Concurrent_Type (Scope (Id)),
2999 Check_Parents => False);
3001 if Present (Ritem) then
3005 if Nkind (Ritem) = N_Pragma then
3006 Exp := First (Pragma_Argument_Associations (Ritem));
3008 if Nkind (Exp) = N_Pragma_Argument_Association then
3009 Exp := Expression (Exp);
3012 -- Conversion for Priority expression
3014 if Nam = Name_Priority then
3015 if Pragma_Name (Ritem) = Name_Priority
3016 and then not GNAT_Mode
3018 Exp := Convert_To (RTE (RE_Priority), Exp);
3021 Convert_To (RTE (RE_Any_Priority), Exp);
3025 -- Aspect/Attribute definition clause case
3028 Exp := Expression (Ritem);
3030 -- Conversion for Priority expression
3032 if Nam = Name_Priority then
3033 if Chars (Ritem) = Name_Priority
3034 and then not GNAT_Mode
3036 Exp := Convert_To (RTE (RE_Priority), Exp);
3039 Convert_To (RTE (RE_Any_Priority), Exp);
3044 -- Conversion for Dispatching_Domain value
3046 if Nam = Name_Dispatching_Domain then
3048 Unchecked_Convert_To
3049 (RTE (RE_Dispatching_Domain_Access), Exp);
3051 -- Conversion for Secondary_Stack_Size value
3053 elsif Nam = Name_Secondary_Stack_Size then
3054 Exp := Convert_To (RTE (RE_Size_Type), Exp);
3057 Actions := Build_Assignment (Id, Exp);
3059 -- Nothing needed if no Rep Item
3066 -- Composite component with its own Init_Proc
3068 elsif not Is_Interface (Typ)
3069 and then Has_Non_Null_Base_Init_Proc (Typ)
3072 Build_Initialization_Call
3074 Make_Selected_Component (Comp_Loc,
3076 Make_Identifier (Comp_Loc, Name_uInit),
3077 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3079 In_Init_Proc => True,
3080 Enclos_Type => Rec_Type,
3081 Discr_Map => Discr_Map);
3083 Clean_Task_Names (Typ, Proc_Id);
3085 -- Simple initialization
3087 elsif Component_Needs_Simple_Initialization (Typ) then
3090 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
3092 -- Nothing needed for this case
3098 if Present (Checks) then
3099 if Chars (Id) = Name_uParent then
3100 Append_List_To (Parent_Stmts, Checks);
3102 Append_List_To (Stmts, Checks);
3106 if Present (Actions) then
3107 if Chars (Id) = Name_uParent then
3108 Append_List_To (Parent_Stmts, Actions);
3111 Append_List_To (Stmts, Actions);
3113 -- Preserve initialization state in the current counter
3115 if Needs_Finalization (Typ) then
3116 if No (Counter_Id) then
3117 Make_Counter (Comp_Loc);
3120 Increment_Counter (Comp_Loc);
3126 Next_Non_Pragma (Decl);
3129 -- The parent field must be initialized first because variable
3130 -- size components of the parent affect the location of all the
3133 Prepend_List_To (Stmts, Parent_Stmts);
3135 -- Set up tasks and protected object support. This needs to be done
3136 -- before any component with a per-object access discriminant
3137 -- constraint, or any variant part (which may contain such
3138 -- components) is initialized, because the initialization of these
3139 -- components may reference the enclosing concurrent object.
3141 -- For a task record type, add the task create call and calls to bind
3142 -- any interrupt (signal) entries.
3144 if Is_Task_Record_Type (Rec_Type) then
3146 -- In the case of the restricted run time the ATCB has already
3147 -- been preallocated.
3149 if Restricted_Profile then
3151 Make_Assignment_Statement (Loc,
3153 Make_Selected_Component (Loc,
3154 Prefix => Make_Identifier (Loc, Name_uInit),
3155 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3157 Make_Attribute_Reference (Loc,
3159 Make_Selected_Component (Loc,
3160 Prefix => Make_Identifier (Loc, Name_uInit),
3161 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3162 Attribute_Name => Name_Unchecked_Access)));
3165 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3168 Task_Type : constant Entity_Id :=
3169 Corresponding_Concurrent_Type (Rec_Type);
3170 Task_Decl : constant Node_Id := Parent (Task_Type);
3171 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3172 Decl_Loc : Source_Ptr;
3177 if Present (Task_Def) then
3178 Vis_Decl := First (Visible_Declarations (Task_Def));
3179 while Present (Vis_Decl) loop
3180 Decl_Loc := Sloc (Vis_Decl);
3182 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3183 if Get_Attribute_Id (Chars (Vis_Decl)) =
3186 Ent := Entity (Name (Vis_Decl));
3188 if Ekind (Ent) = E_Entry then
3190 Make_Procedure_Call_Statement (Decl_Loc,
3192 New_Occurrence_Of (RTE (
3193 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3194 Parameter_Associations => New_List (
3195 Make_Selected_Component (Decl_Loc,
3197 Make_Identifier (Decl_Loc, Name_uInit),
3200 (Decl_Loc, Name_uTask_Id)),
3201 Entry_Index_Expression
3202 (Decl_Loc, Ent, Empty, Task_Type),
3203 Expression (Vis_Decl))));
3214 -- For a protected type, add statements generated by
3215 -- Make_Initialize_Protection.
3217 if Is_Protected_Record_Type (Rec_Type) then
3218 Append_List_To (Stmts,
3219 Make_Initialize_Protection (Rec_Type));
3222 -- Second pass: components with per-object constraints
3225 Decl := First_Non_Pragma (Component_Items (Comp_List));
3226 while Present (Decl) loop
3227 Comp_Loc := Sloc (Decl);
3228 Id := Defining_Identifier (Decl);
3231 if Has_Access_Constraint (Id)
3232 and then No (Expression (Decl))
3234 if Has_Non_Null_Base_Init_Proc (Typ) then
3235 Append_List_To (Stmts,
3236 Build_Initialization_Call (Comp_Loc,
3237 Make_Selected_Component (Comp_Loc,
3239 Make_Identifier (Comp_Loc, Name_uInit),
3240 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3242 In_Init_Proc => True,
3243 Enclos_Type => Rec_Type,
3244 Discr_Map => Discr_Map));
3246 Clean_Task_Names (Typ, Proc_Id);
3248 -- Preserve initialization state in the current counter
3250 if Needs_Finalization (Typ) then
3251 if No (Counter_Id) then
3252 Make_Counter (Comp_Loc);
3255 Increment_Counter (Comp_Loc);
3258 elsif Component_Needs_Simple_Initialization (Typ) then
3259 Append_List_To (Stmts,
3261 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
3265 Next_Non_Pragma (Decl);
3269 -- Process the variant part
3271 if Present (Variant_Part (Comp_List)) then
3273 Variant_Alts : constant List_Id := New_List;
3274 Var_Loc : Source_Ptr := No_Location;
3279 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3280 while Present (Variant) loop
3281 Var_Loc := Sloc (Variant);
3282 Append_To (Variant_Alts,
3283 Make_Case_Statement_Alternative (Var_Loc,
3285 New_Copy_List (Discrete_Choices (Variant)),
3287 Build_Init_Statements (Component_List (Variant))));
3288 Next_Non_Pragma (Variant);
3291 -- The expression of the case statement which is a reference
3292 -- to one of the discriminants is replaced by the appropriate
3293 -- formal parameter of the initialization procedure.
3296 Make_Case_Statement (Var_Loc,
3298 New_Occurrence_Of (Discriminal (
3299 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3300 Alternatives => Variant_Alts));
3304 -- If no initializations when generated for component declarations
3305 -- corresponding to this Stmts, append a null statement to Stmts to
3306 -- to make it a valid Ada tree.
3308 if Is_Empty_List (Stmts) then
3309 Append (Make_Null_Statement (Loc), Stmts);
3315 when RE_Not_Available =>
3317 end Build_Init_Statements;
3319 -------------------------
3320 -- Build_Record_Checks --
3321 -------------------------
3323 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3324 Subtype_Mark_Id : Entity_Id;
3326 procedure Constrain_Array
3328 Check_List : List_Id);
3329 -- Apply a list of index constraints to an unconstrained array type.
3330 -- The first parameter is the entity for the resulting subtype.
3331 -- Check_List is a list to which the check actions are appended.
3333 ---------------------
3334 -- Constrain_Array --
3335 ---------------------
3337 procedure Constrain_Array
3339 Check_List : List_Id)
3341 C : constant Node_Id := Constraint (SI);
3342 Number_Of_Constraints : Nat := 0;
3346 procedure Constrain_Index
3349 Check_List : List_Id);
3350 -- Process an index constraint in a constrained array declaration.
3351 -- The constraint can be either a subtype name or a range with or
3352 -- without an explicit subtype mark. Index is the corresponding
3353 -- index of the unconstrained array. S is the range expression.
3354 -- Check_List is a list to which the check actions are appended.
3356 ---------------------
3357 -- Constrain_Index --
3358 ---------------------
3360 procedure Constrain_Index
3363 Check_List : List_Id)
3365 T : constant Entity_Id := Etype (Index);
3368 if Nkind (S) = N_Range then
3369 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3371 end Constrain_Index;
3373 -- Start of processing for Constrain_Array
3376 T := Entity (Subtype_Mark (SI));
3378 if Is_Access_Type (T) then
3379 T := Designated_Type (T);
3382 S := First (Constraints (C));
3383 while Present (S) loop
3384 Number_Of_Constraints := Number_Of_Constraints + 1;
3388 -- In either case, the index constraint must provide a discrete
3389 -- range for each index of the array type and the type of each
3390 -- discrete range must be the same as that of the corresponding
3391 -- index. (RM 3.6.1)
3393 S := First (Constraints (C));
3394 Index := First_Index (T);
3397 -- Apply constraints to each index type
3399 for J in 1 .. Number_Of_Constraints loop
3400 Constrain_Index (Index, S, Check_List);
3404 end Constrain_Array;
3406 -- Start of processing for Build_Record_Checks
3409 if Nkind (S) = N_Subtype_Indication then
3410 Find_Type (Subtype_Mark (S));
3411 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3413 -- Remaining processing depends on type
3415 case Ekind (Subtype_Mark_Id) is
3417 Constrain_Array (S, Check_List);
3423 end Build_Record_Checks;
3425 -------------------------------------------
3426 -- Component_Needs_Simple_Initialization --
3427 -------------------------------------------
3429 function Component_Needs_Simple_Initialization
3430 (T : Entity_Id) return Boolean
3434 Needs_Simple_Initialization (T)
3435 and then not Is_RTE (T, RE_Tag)
3437 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3439 and then not Is_RTE (T, RE_Interface_Tag);
3440 end Component_Needs_Simple_Initialization;
3442 --------------------------------------
3443 -- Parent_Subtype_Renaming_Discrims --
3444 --------------------------------------
3446 function Parent_Subtype_Renaming_Discrims return Boolean is
3451 if Base_Type (Rec_Ent) /= Rec_Ent then
3455 if Etype (Rec_Ent) = Rec_Ent
3456 or else not Has_Discriminants (Rec_Ent)
3457 or else Is_Constrained (Rec_Ent)
3458 or else Is_Tagged_Type (Rec_Ent)
3463 -- If there are no explicit stored discriminants we have inherited
3464 -- the root type discriminants so far, so no renamings occurred.
3466 if First_Discriminant (Rec_Ent) =
3467 First_Stored_Discriminant (Rec_Ent)
3472 -- Check if we have done some trivial renaming of the parent
3473 -- discriminants, i.e. something like
3475 -- type DT (X1, X2: int) is new PT (X1, X2);
3477 De := First_Discriminant (Rec_Ent);
3478 Dp := First_Discriminant (Etype (Rec_Ent));
3479 while Present (De) loop
3480 pragma Assert (Present (Dp));
3482 if Corresponding_Discriminant (De) /= Dp then
3486 Next_Discriminant (De);
3487 Next_Discriminant (Dp);
3490 return Present (Dp);
3491 end Parent_Subtype_Renaming_Discrims;
3493 ------------------------
3494 -- Requires_Init_Proc --
3495 ------------------------
3497 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3498 Comp_Decl : Node_Id;
3503 -- Definitely do not need one if specifically suppressed
3505 if Initialization_Suppressed (Rec_Id) then
3509 -- If it is a type derived from a type with unknown discriminants,
3510 -- we cannot build an initialization procedure for it.
3512 if Has_Unknown_Discriminants (Rec_Id)
3513 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3518 -- Otherwise we need to generate an initialization procedure if
3519 -- Is_CPP_Class is False and at least one of the following applies:
3521 -- 1. Discriminants are present, since they need to be initialized
3522 -- with the appropriate discriminant constraint expressions.
3523 -- However, the discriminant of an unchecked union does not
3524 -- count, since the discriminant is not present.
3526 -- 2. The type is a tagged type, since the implicit Tag component
3527 -- needs to be initialized with a pointer to the dispatch table.
3529 -- 3. The type contains tasks
3531 -- 4. One or more components has an initial value
3533 -- 5. One or more components is for a type which itself requires
3534 -- an initialization procedure.
3536 -- 6. One or more components is a type that requires simple
3537 -- initialization (see Needs_Simple_Initialization), except
3538 -- that types Tag and Interface_Tag are excluded, since fields
3539 -- of these types are initialized by other means.
3541 -- 7. The type is the record type built for a task type (since at
3542 -- the very least, Create_Task must be called)
3544 -- 8. The type is the record type built for a protected type (since
3545 -- at least Initialize_Protection must be called)
3547 -- 9. The type is marked as a public entity. The reason we add this
3548 -- case (even if none of the above apply) is to properly handle
3549 -- Initialize_Scalars. If a package is compiled without an IS
3550 -- pragma, and the client is compiled with an IS pragma, then
3551 -- the client will think an initialization procedure is present
3552 -- and call it, when in fact no such procedure is required, but
3553 -- since the call is generated, there had better be a routine
3554 -- at the other end of the call, even if it does nothing).
3556 -- Note: the reason we exclude the CPP_Class case is because in this
3557 -- case the initialization is performed by the C++ constructors, and
3558 -- the IP is built by Set_CPP_Constructors.
3560 if Is_CPP_Class (Rec_Id) then
3563 elsif Is_Interface (Rec_Id) then
3566 elsif (Has_Discriminants (Rec_Id)
3567 and then not Is_Unchecked_Union (Rec_Id))
3568 or else Is_Tagged_Type (Rec_Id)
3569 or else Is_Concurrent_Record_Type (Rec_Id)
3570 or else Has_Task (Rec_Id)
3575 Id := First_Component (Rec_Id);
3576 while Present (Id) loop
3577 Comp_Decl := Parent (Id);
3580 if Present (Expression (Comp_Decl))
3581 or else Has_Non_Null_Base_Init_Proc (Typ)
3582 or else Component_Needs_Simple_Initialization (Typ)
3587 Next_Component (Id);
3590 -- As explained above, a record initialization procedure is needed
3591 -- for public types in case Initialize_Scalars applies to a client.
3592 -- However, such a procedure is not needed in the case where either
3593 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3594 -- applies. No_Initialize_Scalars excludes the possibility of using
3595 -- Initialize_Scalars in any partition, and No_Default_Initialization
3596 -- implies that no initialization should ever be done for objects of
3597 -- the type, so is incompatible with Initialize_Scalars.
3599 if not Restriction_Active (No_Initialize_Scalars)
3600 and then not Restriction_Active (No_Default_Initialization)
3601 and then Is_Public (Rec_Id)
3607 end Requires_Init_Proc;
3609 -- Start of processing for Build_Record_Init_Proc
3612 Rec_Type := Defining_Identifier (N);
3614 -- This may be full declaration of a private type, in which case
3615 -- the visible entity is a record, and the private entity has been
3616 -- exchanged with it in the private part of the current package.
3617 -- The initialization procedure is built for the record type, which
3618 -- is retrievable from the private entity.
3620 if Is_Incomplete_Or_Private_Type (Rec_Type) then
3621 Rec_Type := Underlying_Type (Rec_Type);
3624 -- If we have a variant record with restriction No_Implicit_Conditionals
3625 -- in effect, then we skip building the procedure. This is safe because
3626 -- if we can see the restriction, so can any caller, calls to initialize
3627 -- such records are not allowed for variant records if this restriction
3630 if Has_Variant_Part (Rec_Type)
3631 and then Restriction_Active (No_Implicit_Conditionals)
3636 -- If there are discriminants, build the discriminant map to replace
3637 -- discriminants by their discriminals in complex bound expressions.
3638 -- These only arise for the corresponding records of synchronized types.
3640 if Is_Concurrent_Record_Type (Rec_Type)
3641 and then Has_Discriminants (Rec_Type)
3646 Disc := First_Discriminant (Rec_Type);
3647 while Present (Disc) loop
3648 Append_Elmt (Disc, Discr_Map);
3649 Append_Elmt (Discriminal (Disc), Discr_Map);
3650 Next_Discriminant (Disc);
3655 -- Derived types that have no type extension can use the initialization
3656 -- procedure of their parent and do not need a procedure of their own.
3657 -- This is only correct if there are no representation clauses for the
3658 -- type or its parent, and if the parent has in fact been frozen so
3659 -- that its initialization procedure exists.
3661 if Is_Derived_Type (Rec_Type)
3662 and then not Is_Tagged_Type (Rec_Type)
3663 and then not Is_Unchecked_Union (Rec_Type)
3664 and then not Has_New_Non_Standard_Rep (Rec_Type)
3665 and then not Parent_Subtype_Renaming_Discrims
3666 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
3668 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3670 -- Otherwise if we need an initialization procedure, then build one,
3671 -- mark it as public and inlinable and as having a completion.
3673 elsif Requires_Init_Proc (Rec_Type)
3674 or else Is_Unchecked_Union (Rec_Type)
3677 Make_Defining_Identifier (Loc,
3678 Chars => Make_Init_Proc_Name (Rec_Type));
3680 -- If No_Default_Initialization restriction is active, then we don't
3681 -- want to build an init_proc, but we need to mark that an init_proc
3682 -- would be needed if this restriction was not active (so that we can
3683 -- detect attempts to call it), so set a dummy init_proc in place.
3685 if Restriction_Active (No_Default_Initialization) then
3686 Set_Init_Proc (Rec_Type, Proc_Id);
3690 Build_Offset_To_Top_Functions;
3691 Build_CPP_Init_Procedure;
3692 Build_Init_Procedure;
3694 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
3695 Set_Is_Internal (Proc_Id);
3696 Set_Has_Completion (Proc_Id);
3698 if not Debug_Generated_Code then
3699 Set_Debug_Info_Off (Proc_Id);
3702 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
3704 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
3705 -- needed and may generate early references to non frozen types
3706 -- since we expand aggregate much more systematically.
3708 if Modify_Tree_For_C then
3713 Agg : constant Node_Id :=
3714 Build_Equivalent_Record_Aggregate (Rec_Type);
3716 procedure Collect_Itypes (Comp : Node_Id);
3717 -- Generate references to itypes in the aggregate, because
3718 -- the first use of the aggregate may be in a nested scope.
3720 --------------------
3721 -- Collect_Itypes --
3722 --------------------
3724 procedure Collect_Itypes (Comp : Node_Id) is
3727 Typ : constant Entity_Id := Etype (Comp);
3730 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
3731 Ref := Make_Itype_Reference (Loc);
3732 Set_Itype (Ref, Typ);
3733 Append_Freeze_Action (Rec_Type, Ref);
3735 Ref := Make_Itype_Reference (Loc);
3736 Set_Itype (Ref, Etype (First_Index (Typ)));
3737 Append_Freeze_Action (Rec_Type, Ref);
3739 -- Recurse on nested arrays
3741 Sub_Aggr := First (Expressions (Comp));
3742 while Present (Sub_Aggr) loop
3743 Collect_Itypes (Sub_Aggr);
3750 -- If there is a static initialization aggregate for the type,
3751 -- generate itype references for the types of its (sub)components,
3752 -- to prevent out-of-scope errors in the resulting tree.
3753 -- The aggregate may have been rewritten as a Raise node, in which
3754 -- case there are no relevant itypes.
3756 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
3757 Set_Static_Initialization (Proc_Id, Agg);
3762 Comp := First (Component_Associations (Agg));
3763 while Present (Comp) loop
3764 Collect_Itypes (Expression (Comp));
3771 end Build_Record_Init_Proc;
3773 ----------------------------
3774 -- Build_Slice_Assignment --
3775 ----------------------------
3777 -- Generates the following subprogram:
3780 -- (Source, Target : Array_Type,
3781 -- Left_Lo, Left_Hi : Index;
3782 -- Right_Lo, Right_Hi : Index;
3790 -- if Left_Hi < Left_Lo then
3803 -- Target (Li1) := Source (Ri1);
3806 -- exit when Li1 = Left_Lo;
3807 -- Li1 := Index'pred (Li1);
3808 -- Ri1 := Index'pred (Ri1);
3810 -- exit when Li1 = Left_Hi;
3811 -- Li1 := Index'succ (Li1);
3812 -- Ri1 := Index'succ (Ri1);
3817 procedure Build_Slice_Assignment (Typ : Entity_Id) is
3818 Loc : constant Source_Ptr := Sloc (Typ);
3819 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
3821 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
3822 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
3823 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
3824 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
3825 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
3826 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
3827 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
3828 -- Formal parameters of procedure
3830 Proc_Name : constant Entity_Id :=
3831 Make_Defining_Identifier (Loc,
3832 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
3834 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
3835 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
3836 -- Subscripts for left and right sides
3843 -- Build declarations for indexes
3848 Make_Object_Declaration (Loc,
3849 Defining_Identifier => Lnn,
3850 Object_Definition =>
3851 New_Occurrence_Of (Index, Loc)));
3854 Make_Object_Declaration (Loc,
3855 Defining_Identifier => Rnn,
3856 Object_Definition =>
3857 New_Occurrence_Of (Index, Loc)));
3861 -- Build test for empty slice case
3864 Make_If_Statement (Loc,
3867 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
3868 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
3869 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
3871 -- Build initializations for indexes
3874 F_Init : constant List_Id := New_List;
3875 B_Init : constant List_Id := New_List;
3879 Make_Assignment_Statement (Loc,
3880 Name => New_Occurrence_Of (Lnn, Loc),
3881 Expression => New_Occurrence_Of (Left_Lo, Loc)));
3884 Make_Assignment_Statement (Loc,
3885 Name => New_Occurrence_Of (Rnn, Loc),
3886 Expression => New_Occurrence_Of (Right_Lo, Loc)));
3889 Make_Assignment_Statement (Loc,
3890 Name => New_Occurrence_Of (Lnn, Loc),
3891 Expression => New_Occurrence_Of (Left_Hi, Loc)));
3894 Make_Assignment_Statement (Loc,
3895 Name => New_Occurrence_Of (Rnn, Loc),
3896 Expression => New_Occurrence_Of (Right_Hi, Loc)));
3899 Make_If_Statement (Loc,
3900 Condition => New_Occurrence_Of (Rev, Loc),
3901 Then_Statements => B_Init,
3902 Else_Statements => F_Init));
3905 -- Now construct the assignment statement
3908 Make_Loop_Statement (Loc,
3909 Statements => New_List (
3910 Make_Assignment_Statement (Loc,
3912 Make_Indexed_Component (Loc,
3913 Prefix => New_Occurrence_Of (Larray, Loc),
3914 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
3916 Make_Indexed_Component (Loc,
3917 Prefix => New_Occurrence_Of (Rarray, Loc),
3918 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
3919 End_Label => Empty);
3921 -- Build the exit condition and increment/decrement statements
3924 F_Ass : constant List_Id := New_List;
3925 B_Ass : constant List_Id := New_List;
3929 Make_Exit_Statement (Loc,
3932 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3933 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
3936 Make_Assignment_Statement (Loc,
3937 Name => New_Occurrence_Of (Lnn, Loc),
3939 Make_Attribute_Reference (Loc,
3941 New_Occurrence_Of (Index, Loc),
3942 Attribute_Name => Name_Succ,
3943 Expressions => New_List (
3944 New_Occurrence_Of (Lnn, Loc)))));
3947 Make_Assignment_Statement (Loc,
3948 Name => New_Occurrence_Of (Rnn, Loc),
3950 Make_Attribute_Reference (Loc,
3952 New_Occurrence_Of (Index, Loc),
3953 Attribute_Name => Name_Succ,
3954 Expressions => New_List (
3955 New_Occurrence_Of (Rnn, Loc)))));
3958 Make_Exit_Statement (Loc,
3961 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3962 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
3965 Make_Assignment_Statement (Loc,
3966 Name => New_Occurrence_Of (Lnn, Loc),
3968 Make_Attribute_Reference (Loc,
3970 New_Occurrence_Of (Index, Loc),
3971 Attribute_Name => Name_Pred,
3972 Expressions => New_List (
3973 New_Occurrence_Of (Lnn, Loc)))));
3976 Make_Assignment_Statement (Loc,
3977 Name => New_Occurrence_Of (Rnn, Loc),
3979 Make_Attribute_Reference (Loc,
3981 New_Occurrence_Of (Index, Loc),
3982 Attribute_Name => Name_Pred,
3983 Expressions => New_List (
3984 New_Occurrence_Of (Rnn, Loc)))));
3986 Append_To (Statements (Loops),
3987 Make_If_Statement (Loc,
3988 Condition => New_Occurrence_Of (Rev, Loc),
3989 Then_Statements => B_Ass,
3990 Else_Statements => F_Ass));
3993 Append_To (Stats, Loops);
3997 Formals : List_Id := New_List;
4000 Formals := New_List (
4001 Make_Parameter_Specification (Loc,
4002 Defining_Identifier => Larray,
4003 Out_Present => True,
4005 New_Occurrence_Of (Base_Type (Typ), Loc)),
4007 Make_Parameter_Specification (Loc,
4008 Defining_Identifier => Rarray,
4010 New_Occurrence_Of (Base_Type (Typ), Loc)),
4012 Make_Parameter_Specification (Loc,
4013 Defining_Identifier => Left_Lo,
4015 New_Occurrence_Of (Index, Loc)),
4017 Make_Parameter_Specification (Loc,
4018 Defining_Identifier => Left_Hi,
4020 New_Occurrence_Of (Index, Loc)),
4022 Make_Parameter_Specification (Loc,
4023 Defining_Identifier => Right_Lo,
4025 New_Occurrence_Of (Index, Loc)),
4027 Make_Parameter_Specification (Loc,
4028 Defining_Identifier => Right_Hi,
4030 New_Occurrence_Of (Index, Loc)));
4033 Make_Parameter_Specification (Loc,
4034 Defining_Identifier => Rev,
4036 New_Occurrence_Of (Standard_Boolean, Loc)));
4039 Make_Procedure_Specification (Loc,
4040 Defining_Unit_Name => Proc_Name,
4041 Parameter_Specifications => Formals);
4044 Make_Subprogram_Body (Loc,
4045 Specification => Spec,
4046 Declarations => Decls,
4047 Handled_Statement_Sequence =>
4048 Make_Handled_Sequence_Of_Statements (Loc,
4049 Statements => Stats)));
4052 Set_TSS (Typ, Proc_Name);
4053 Set_Is_Pure (Proc_Name);
4054 end Build_Slice_Assignment;
4056 -----------------------------
4057 -- Build_Untagged_Equality --
4058 -----------------------------
4060 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4068 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4069 -- Check whether the type T has a user-defined primitive equality. If so
4070 -- return it, else return Empty. If true for a component of Typ, we have
4071 -- to build the primitive equality for it.
4073 ---------------------
4074 -- User_Defined_Eq --
4075 ---------------------
4077 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4082 Op := TSS (T, TSS_Composite_Equality);
4084 if Present (Op) then
4088 Prim := First_Elmt (Collect_Primitive_Operations (T));
4089 while Present (Prim) loop
4092 if Chars (Op) = Name_Op_Eq
4093 and then Etype (Op) = Standard_Boolean
4094 and then Etype (First_Formal (Op)) = T
4095 and then Etype (Next_Formal (First_Formal (Op))) = T
4104 end User_Defined_Eq;
4106 -- Start of processing for Build_Untagged_Equality
4109 -- If a record component has a primitive equality operation, we must
4110 -- build the corresponding one for the current type.
4113 Comp := First_Component (Typ);
4114 while Present (Comp) loop
4115 if Is_Record_Type (Etype (Comp))
4116 and then Present (User_Defined_Eq (Etype (Comp)))
4121 Next_Component (Comp);
4124 -- If there is a user-defined equality for the type, we do not create
4125 -- the implicit one.
4127 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
4129 while Present (Prim) loop
4130 if Chars (Node (Prim)) = Name_Op_Eq
4131 and then Comes_From_Source (Node (Prim))
4133 -- Don't we also need to check formal types and return type as in
4134 -- User_Defined_Eq above???
4137 Eq_Op := Node (Prim);
4145 -- If the type is derived, inherit the operation, if present, from the
4146 -- parent type. It may have been declared after the type derivation. If
4147 -- the parent type itself is derived, it may have inherited an operation
4148 -- that has itself been overridden, so update its alias and related
4149 -- flags. Ditto for inequality.
4151 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4152 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
4153 while Present (Prim) loop
4154 if Chars (Node (Prim)) = Name_Op_Eq then
4155 Copy_TSS (Node (Prim), Typ);
4159 Op : constant Entity_Id := User_Defined_Eq (Typ);
4160 Eq_Op : constant Entity_Id := Node (Prim);
4161 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4164 if Present (Op) then
4165 Set_Alias (Op, Eq_Op);
4166 Set_Is_Abstract_Subprogram
4167 (Op, Is_Abstract_Subprogram (Eq_Op));
4169 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4170 Set_Is_Abstract_Subprogram
4171 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4183 -- If not inherited and not user-defined, build body as for a type with
4184 -- tagged components.
4188 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4189 Op := Defining_Entity (Decl);
4193 if Is_Library_Level_Entity (Typ) then
4197 end Build_Untagged_Equality;
4199 -----------------------------------
4200 -- Build_Variant_Record_Equality --
4201 -----------------------------------
4205 -- function _Equality (X, Y : T) return Boolean is
4207 -- -- Compare discriminants
4209 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4213 -- -- Compare components
4215 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4219 -- -- Compare variant part
4223 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4228 -- if X.Cn /= Y.Cn or else ... then
4236 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
4237 Loc : constant Source_Ptr := Sloc (Typ);
4239 F : constant Entity_Id :=
4240 Make_Defining_Identifier (Loc,
4241 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
4243 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
4244 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
4246 Def : constant Node_Id := Parent (Typ);
4247 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4248 Stmts : constant List_Id := New_List;
4249 Pspecs : constant List_Id := New_List;
4252 -- If we have a variant record with restriction No_Implicit_Conditionals
4253 -- in effect, then we skip building the procedure. This is safe because
4254 -- if we can see the restriction, so can any caller, calls to equality
4255 -- test routines are not allowed for variant records if this restriction
4258 if Restriction_Active (No_Implicit_Conditionals) then
4262 -- Derived Unchecked_Union types no longer inherit the equality function
4265 if Is_Derived_Type (Typ)
4266 and then not Is_Unchecked_Union (Typ)
4267 and then not Has_New_Non_Standard_Rep (Typ)
4270 Parent_Eq : constant Entity_Id :=
4271 TSS (Root_Type (Typ), TSS_Composite_Equality);
4273 if Present (Parent_Eq) then
4274 Copy_TSS (Parent_Eq, Typ);
4281 Make_Subprogram_Body (Loc,
4283 Make_Function_Specification (Loc,
4284 Defining_Unit_Name => F,
4285 Parameter_Specifications => Pspecs,
4286 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
4287 Declarations => New_List,
4288 Handled_Statement_Sequence =>
4289 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
4292 Make_Parameter_Specification (Loc,
4293 Defining_Identifier => X,
4294 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4297 Make_Parameter_Specification (Loc,
4298 Defining_Identifier => Y,
4299 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4301 -- Unchecked_Unions require additional machinery to support equality.
4302 -- Two extra parameters (A and B) are added to the equality function
4303 -- parameter list for each discriminant of the type, in order to
4304 -- capture the inferred values of the discriminants in equality calls.
4305 -- The names of the parameters match the names of the corresponding
4306 -- discriminant, with an added suffix.
4308 if Is_Unchecked_Union (Typ) then
4311 Discr_Type : Entity_Id;
4313 New_Discrs : Elist_Id;
4316 New_Discrs := New_Elmt_List;
4318 Discr := First_Discriminant (Typ);
4319 while Present (Discr) loop
4320 Discr_Type := Etype (Discr);
4321 A := Make_Defining_Identifier (Loc,
4322 Chars => New_External_Name (Chars (Discr), 'A'));
4324 B := Make_Defining_Identifier (Loc,
4325 Chars => New_External_Name (Chars (Discr), 'B'));
4327 -- Add new parameters to the parameter list
4330 Make_Parameter_Specification (Loc,
4331 Defining_Identifier => A,
4333 New_Occurrence_Of (Discr_Type, Loc)));
4336 Make_Parameter_Specification (Loc,
4337 Defining_Identifier => B,
4339 New_Occurrence_Of (Discr_Type, Loc)));
4341 Append_Elmt (A, New_Discrs);
4343 -- Generate the following code to compare each of the inferred
4351 Make_If_Statement (Loc,
4354 Left_Opnd => New_Occurrence_Of (A, Loc),
4355 Right_Opnd => New_Occurrence_Of (B, Loc)),
4356 Then_Statements => New_List (
4357 Make_Simple_Return_Statement (Loc,
4359 New_Occurrence_Of (Standard_False, Loc)))));
4360 Next_Discriminant (Discr);
4363 -- Generate component-by-component comparison. Note that we must
4364 -- propagate the inferred discriminants formals to act as
4365 -- the case statement switch. Their value is added when an
4366 -- equality call on unchecked unions is expanded.
4368 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4371 -- Normal case (not unchecked union)
4375 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4376 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4380 Make_Simple_Return_Statement (Loc,
4381 Expression => New_Occurrence_Of (Standard_True, Loc)));
4386 if not Debug_Generated_Code then
4387 Set_Debug_Info_Off (F);
4389 end Build_Variant_Record_Equality;
4391 -----------------------------
4392 -- Check_Stream_Attributes --
4393 -----------------------------
4395 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4397 Par_Read : constant Boolean :=
4398 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4399 and then not Has_Specified_Stream_Read (Typ);
4400 Par_Write : constant Boolean :=
4401 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4402 and then not Has_Specified_Stream_Write (Typ);
4404 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4405 -- Check that Comp has a user-specified Nam stream attribute
4411 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4413 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4414 Error_Msg_Name_1 := Nam;
4416 ("|component& in limited extension must have% attribute", Comp);
4420 -- Start of processing for Check_Stream_Attributes
4423 if Par_Read or else Par_Write then
4424 Comp := First_Component (Typ);
4425 while Present (Comp) loop
4426 if Comes_From_Source (Comp)
4427 and then Original_Record_Component (Comp) = Comp
4428 and then Is_Limited_Type (Etype (Comp))
4431 Check_Attr (Name_Read, TSS_Stream_Read);
4435 Check_Attr (Name_Write, TSS_Stream_Write);
4439 Next_Component (Comp);
4442 end Check_Stream_Attributes;
4444 ----------------------
4445 -- Clean_Task_Names --
4446 ----------------------
4448 procedure Clean_Task_Names
4450 Proc_Id : Entity_Id)
4454 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4455 and then not Global_Discard_Names
4456 and then Tagged_Type_Expansion
4458 Set_Uses_Sec_Stack (Proc_Id);
4460 end Clean_Task_Names;
4462 ------------------------------
4463 -- Expand_Freeze_Array_Type --
4464 ------------------------------
4466 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4467 Typ : constant Entity_Id := Entity (N);
4468 Base : constant Entity_Id := Base_Type (Typ);
4469 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4472 if not Is_Bit_Packed_Array (Typ) then
4474 -- If the component contains tasks, so does the array type. This may
4475 -- not be indicated in the array type because the component may have
4476 -- been a private type at the point of definition. Same if component
4477 -- type is controlled or contains protected objects.
4479 Propagate_Concurrent_Flags (Base, Comp_Typ);
4480 Set_Has_Controlled_Component
4481 (Base, Has_Controlled_Component (Comp_Typ)
4482 or else Is_Controlled (Comp_Typ));
4484 if No (Init_Proc (Base)) then
4486 -- If this is an anonymous array created for a declaration with
4487 -- an initial value, its init_proc will never be called. The
4488 -- initial value itself may have been expanded into assignments,
4489 -- in which case the object declaration is carries the
4490 -- No_Initialization flag.
4493 and then Nkind (Associated_Node_For_Itype (Base)) =
4494 N_Object_Declaration
4496 (Present (Expression (Associated_Node_For_Itype (Base)))
4497 or else No_Initialization (Associated_Node_For_Itype (Base)))
4501 -- We do not need an init proc for string or wide [wide] string,
4502 -- since the only time these need initialization in normalize or
4503 -- initialize scalars mode, and these types are treated specially
4504 -- and do not need initialization procedures.
4506 elsif Is_Standard_String_Type (Base) then
4509 -- Otherwise we have to build an init proc for the subtype
4512 Build_Array_Init_Proc (Base, N);
4516 if Typ = Base and then Has_Controlled_Component (Base) then
4517 Build_Controlling_Procs (Base);
4519 if not Is_Limited_Type (Comp_Typ)
4520 and then Number_Dimensions (Typ) = 1
4522 Build_Slice_Assignment (Typ);
4526 -- For packed case, default initialization, except if the component type
4527 -- is itself a packed structure with an initialization procedure, or
4528 -- initialize/normalize scalars active, and we have a base type, or the
4529 -- type is public, because in that case a client might specify
4530 -- Normalize_Scalars and there better be a public Init_Proc for it.
4532 elsif (Present (Init_Proc (Component_Type (Base)))
4533 and then No (Base_Init_Proc (Base)))
4534 or else (Init_Or_Norm_Scalars and then Base = Typ)
4535 or else Is_Public (Typ)
4537 Build_Array_Init_Proc (Base, N);
4539 end Expand_Freeze_Array_Type;
4541 -----------------------------------
4542 -- Expand_Freeze_Class_Wide_Type --
4543 -----------------------------------
4545 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4546 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4547 -- Given a type, determine whether it is derived from a C or C++ root
4549 ---------------------
4550 -- Is_C_Derivation --
4551 ---------------------
4553 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4560 or else Convention (T) = Convention_C
4561 or else Convention (T) = Convention_CPP
4566 exit when T = Etype (T);
4572 end Is_C_Derivation;
4576 Typ : constant Entity_Id := Entity (N);
4577 Root : constant Entity_Id := Root_Type (Typ);
4579 -- Start of processing for Expand_Freeze_Class_Wide_Type
4582 -- Certain run-time configurations and targets do not provide support
4583 -- for controlled types.
4585 if Restriction_Active (No_Finalization) then
4588 -- Do not create TSS routine Finalize_Address when dispatching calls are
4589 -- disabled since the core of the routine is a dispatching call.
4591 elsif Restriction_Active (No_Dispatching_Calls) then
4594 -- Do not create TSS routine Finalize_Address for concurrent class-wide
4595 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
4596 -- non-Ada side will handle their destruction.
4598 elsif Is_Concurrent_Type (Root)
4599 or else Is_C_Derivation (Root)
4600 or else Convention (Typ) = Convention_CPP
4604 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
4605 -- mode since the routine contains an Unchecked_Conversion.
4607 elsif CodePeer_Mode then
4611 -- Create the body of TSS primitive Finalize_Address. This automatically
4612 -- sets the TSS entry for the class-wide type.
4614 Make_Finalize_Address_Body (Typ);
4615 end Expand_Freeze_Class_Wide_Type;
4617 ------------------------------------
4618 -- Expand_Freeze_Enumeration_Type --
4619 ------------------------------------
4621 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
4622 Typ : constant Entity_Id := Entity (N);
4623 Loc : constant Source_Ptr := Sloc (Typ);
4628 Is_Contiguous : Boolean;
4636 pragma Warnings (Off, Func);
4639 -- Various optimizations possible if given representation is contiguous
4641 Is_Contiguous := True;
4643 Ent := First_Literal (Typ);
4644 Last_Repval := Enumeration_Rep (Ent);
4647 while Present (Ent) loop
4648 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4649 Is_Contiguous := False;
4652 Last_Repval := Enumeration_Rep (Ent);
4658 if Is_Contiguous then
4659 Set_Has_Contiguous_Rep (Typ);
4660 Ent := First_Literal (Typ);
4662 Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
4665 -- Build list of literal references
4670 Ent := First_Literal (Typ);
4671 while Present (Ent) loop
4672 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
4678 -- Now build an array declaration
4680 -- typA : array (Natural range 0 .. num - 1) of ctype :=
4681 -- (v, v, v, v, v, ....)
4683 -- where ctype is the corresponding integer type. If the representation
4684 -- is contiguous, we only keep the first literal, which provides the
4685 -- offset for Pos_To_Rep computations.
4688 Make_Defining_Identifier (Loc,
4689 Chars => New_External_Name (Chars (Typ), 'A'));
4691 Append_Freeze_Action (Typ,
4692 Make_Object_Declaration (Loc,
4693 Defining_Identifier => Arr,
4694 Constant_Present => True,
4696 Object_Definition =>
4697 Make_Constrained_Array_Definition (Loc,
4698 Discrete_Subtype_Definitions => New_List (
4699 Make_Subtype_Indication (Loc,
4700 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
4702 Make_Range_Constraint (Loc,
4706 Make_Integer_Literal (Loc, 0),
4708 Make_Integer_Literal (Loc, Num - 1))))),
4710 Component_Definition =>
4711 Make_Component_Definition (Loc,
4712 Aliased_Present => False,
4713 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
4716 Make_Aggregate (Loc,
4717 Expressions => Lst)));
4719 Set_Enum_Pos_To_Rep (Typ, Arr);
4721 -- Now we build the function that converts representation values to
4722 -- position values. This function has the form:
4724 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4727 -- when enum-lit'Enum_Rep => return posval;
4728 -- when enum-lit'Enum_Rep => return posval;
4731 -- [raise Constraint_Error when F "invalid data"]
4736 -- Note: the F parameter determines whether the others case (no valid
4737 -- representation) raises Constraint_Error or returns a unique value
4738 -- of minus one. The latter case is used, e.g. in 'Valid code.
4740 -- Note: the reason we use Enum_Rep values in the case here is to avoid
4741 -- the code generator making inappropriate assumptions about the range
4742 -- of the values in the case where the value is invalid. ityp is a
4743 -- signed or unsigned integer type of appropriate width.
4745 -- Note: if exceptions are not supported, then we suppress the raise
4746 -- and return -1 unconditionally (this is an erroneous program in any
4747 -- case and there is no obligation to raise Constraint_Error here). We
4748 -- also do this if pragma Restrictions (No_Exceptions) is active.
4750 -- Is this right??? What about No_Exception_Propagation???
4752 -- Representations are signed
4754 if Enumeration_Rep (First_Literal (Typ)) < 0 then
4756 -- The underlying type is signed. Reset the Is_Unsigned_Type
4757 -- explicitly, because it might have been inherited from
4760 Set_Is_Unsigned_Type (Typ, False);
4762 if Esize (Typ) <= Standard_Integer_Size then
4763 Ityp := Standard_Integer;
4765 Ityp := Universal_Integer;
4768 -- Representations are unsigned
4771 if Esize (Typ) <= Standard_Integer_Size then
4772 Ityp := RTE (RE_Unsigned);
4774 Ityp := RTE (RE_Long_Long_Unsigned);
4778 -- The body of the function is a case statement. First collect case
4779 -- alternatives, or optimize the contiguous case.
4783 -- If representation is contiguous, Pos is computed by subtracting
4784 -- the representation of the first literal.
4786 if Is_Contiguous then
4787 Ent := First_Literal (Typ);
4789 if Enumeration_Rep (Ent) = Last_Repval then
4791 -- Another special case: for a single literal, Pos is zero
4793 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4797 Convert_To (Standard_Integer,
4798 Make_Op_Subtract (Loc,
4800 Unchecked_Convert_To
4801 (Ityp, Make_Identifier (Loc, Name_uA)),
4803 Make_Integer_Literal (Loc,
4804 Intval => Enumeration_Rep (First_Literal (Typ)))));
4808 Make_Case_Statement_Alternative (Loc,
4809 Discrete_Choices => New_List (
4810 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4812 Make_Integer_Literal (Loc,
4813 Intval => Enumeration_Rep (Ent)),
4815 Make_Integer_Literal (Loc, Intval => Last_Repval))),
4817 Statements => New_List (
4818 Make_Simple_Return_Statement (Loc,
4819 Expression => Pos_Expr))));
4822 Ent := First_Literal (Typ);
4823 while Present (Ent) loop
4825 Make_Case_Statement_Alternative (Loc,
4826 Discrete_Choices => New_List (
4827 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4828 Intval => Enumeration_Rep (Ent))),
4830 Statements => New_List (
4831 Make_Simple_Return_Statement (Loc,
4833 Make_Integer_Literal (Loc,
4834 Intval => Enumeration_Pos (Ent))))));
4840 -- In normal mode, add the others clause with the test.
4841 -- If Predicates_Ignored is True, validity checks do not apply to
4844 if not No_Exception_Handlers_Set
4845 and then not Predicates_Ignored (Typ)
4848 Make_Case_Statement_Alternative (Loc,
4849 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4850 Statements => New_List (
4851 Make_Raise_Constraint_Error (Loc,
4852 Condition => Make_Identifier (Loc, Name_uF),
4853 Reason => CE_Invalid_Data),
4854 Make_Simple_Return_Statement (Loc,
4855 Expression => Make_Integer_Literal (Loc, -1)))));
4857 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
4858 -- active then return -1 (we cannot usefully raise Constraint_Error in
4859 -- this case). See description above for further details.
4863 Make_Case_Statement_Alternative (Loc,
4864 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4865 Statements => New_List (
4866 Make_Simple_Return_Statement (Loc,
4867 Expression => Make_Integer_Literal (Loc, -1)))));
4870 -- Now we can build the function body
4873 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4876 Make_Subprogram_Body (Loc,
4878 Make_Function_Specification (Loc,
4879 Defining_Unit_Name => Fent,
4880 Parameter_Specifications => New_List (
4881 Make_Parameter_Specification (Loc,
4882 Defining_Identifier =>
4883 Make_Defining_Identifier (Loc, Name_uA),
4884 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
4885 Make_Parameter_Specification (Loc,
4886 Defining_Identifier =>
4887 Make_Defining_Identifier (Loc, Name_uF),
4889 New_Occurrence_Of (Standard_Boolean, Loc))),
4891 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
4893 Declarations => Empty_List,
4895 Handled_Statement_Sequence =>
4896 Make_Handled_Sequence_Of_Statements (Loc,
4897 Statements => New_List (
4898 Make_Case_Statement (Loc,
4900 Unchecked_Convert_To
4901 (Ityp, Make_Identifier (Loc, Name_uA)),
4902 Alternatives => Lst))));
4904 Set_TSS (Typ, Fent);
4906 -- Set Pure flag (it will be reset if the current context is not Pure).
4907 -- We also pretend there was a pragma Pure_Function so that for purposes
4908 -- of optimization and constant-folding, we will consider the function
4909 -- Pure even if we are not in a Pure context).
4912 Set_Has_Pragma_Pure_Function (Fent);
4914 -- Unless we are in -gnatD mode, where we are debugging generated code,
4915 -- this is an internal entity for which we don't need debug info.
4917 if not Debug_Generated_Code then
4918 Set_Debug_Info_Off (Fent);
4921 Set_Is_Inlined (Fent);
4924 when RE_Not_Available =>
4926 end Expand_Freeze_Enumeration_Type;
4928 -------------------------------
4929 -- Expand_Freeze_Record_Type --
4930 -------------------------------
4932 procedure Expand_Freeze_Record_Type (N : Node_Id) is
4933 Typ : constant Node_Id := Entity (N);
4934 Typ_Decl : constant Node_Id := Parent (Typ);
4937 Comp_Typ : Entity_Id;
4938 Predef_List : List_Id;
4940 Wrapper_Decl_List : List_Id := No_List;
4941 Wrapper_Body_List : List_Id := No_List;
4943 Renamed_Eq : Node_Id := Empty;
4944 -- Defining unit name for the predefined equality function in the case
4945 -- where the type has a primitive operation that is a renaming of
4946 -- predefined equality (but only if there is also an overriding
4947 -- user-defined equality function). Used to pass this entity from
4948 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
4950 -- Start of processing for Expand_Freeze_Record_Type
4953 -- Build discriminant checking functions if not a derived type (for
4954 -- derived types that are not tagged types, always use the discriminant
4955 -- checking functions of the parent type). However, for untagged types
4956 -- the derivation may have taken place before the parent was frozen, so
4957 -- we copy explicitly the discriminant checking functions from the
4958 -- parent into the components of the derived type.
4960 if not Is_Derived_Type (Typ)
4961 or else Has_New_Non_Standard_Rep (Typ)
4962 or else Is_Tagged_Type (Typ)
4964 Build_Discr_Checking_Funcs (Typ_Decl);
4966 elsif Is_Derived_Type (Typ)
4967 and then not Is_Tagged_Type (Typ)
4969 -- If we have a derived Unchecked_Union, we do not inherit the
4970 -- discriminant checking functions from the parent type since the
4971 -- discriminants are non existent.
4973 and then not Is_Unchecked_Union (Typ)
4974 and then Has_Discriminants (Typ)
4977 Old_Comp : Entity_Id;
4981 First_Component (Base_Type (Underlying_Type (Etype (Typ))));
4982 Comp := First_Component (Typ);
4983 while Present (Comp) loop
4984 if Ekind (Comp) = E_Component
4985 and then Chars (Comp) = Chars (Old_Comp)
4987 Set_Discriminant_Checking_Func
4988 (Comp, Discriminant_Checking_Func (Old_Comp));
4991 Next_Component (Old_Comp);
4992 Next_Component (Comp);
4997 if Is_Derived_Type (Typ)
4998 and then Is_Limited_Type (Typ)
4999 and then Is_Tagged_Type (Typ)
5001 Check_Stream_Attributes (Typ);
5004 -- Update task, protected, and controlled component flags, because some
5005 -- of the component types may have been private at the point of the
5006 -- record declaration. Detect anonymous access-to-controlled components.
5008 Comp := First_Component (Typ);
5009 while Present (Comp) loop
5010 Comp_Typ := Etype (Comp);
5012 Propagate_Concurrent_Flags (Typ, Comp_Typ);
5014 -- Do not set Has_Controlled_Component on a class-wide equivalent
5015 -- type. See Make_CW_Equivalent_Type.
5017 if not Is_Class_Wide_Equivalent_Type (Typ)
5019 (Has_Controlled_Component (Comp_Typ)
5020 or else (Chars (Comp) /= Name_uParent
5021 and then Is_Controlled (Comp_Typ)))
5023 Set_Has_Controlled_Component (Typ);
5026 Next_Component (Comp);
5029 -- Handle constructors of untagged CPP_Class types
5031 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
5032 Set_CPP_Constructors (Typ);
5035 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5036 -- for regular tagged types as well as for Ada types deriving from a C++
5037 -- Class, but not for tagged types directly corresponding to C++ classes
5038 -- In the later case we assume that it is created in the C++ side and we
5041 if Is_Tagged_Type (Typ) then
5043 -- Add the _Tag component
5045 if Underlying_Type (Etype (Typ)) = Typ then
5046 Expand_Tagged_Root (Typ);
5049 if Is_CPP_Class (Typ) then
5050 Set_All_DT_Position (Typ);
5052 -- Create the tag entities with a minimum decoration
5054 if Tagged_Type_Expansion then
5055 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5058 Set_CPP_Constructors (Typ);
5061 if not Building_Static_DT (Typ) then
5063 -- Usually inherited primitives are not delayed but the first
5064 -- Ada extension of a CPP_Class is an exception since the
5065 -- address of the inherited subprogram has to be inserted in
5066 -- the new Ada Dispatch Table and this is a freezing action.
5068 -- Similarly, if this is an inherited operation whose parent is
5069 -- not frozen yet, it is not in the DT of the parent, and we
5070 -- generate an explicit freeze node for the inherited operation
5071 -- so it is properly inserted in the DT of the current type.
5078 Elmt := First_Elmt (Primitive_Operations (Typ));
5079 while Present (Elmt) loop
5080 Subp := Node (Elmt);
5082 if Present (Alias (Subp)) then
5083 if Is_CPP_Class (Etype (Typ)) then
5084 Set_Has_Delayed_Freeze (Subp);
5086 elsif Has_Delayed_Freeze (Alias (Subp))
5087 and then not Is_Frozen (Alias (Subp))
5089 Set_Is_Frozen (Subp, False);
5090 Set_Has_Delayed_Freeze (Subp);
5099 -- Unfreeze momentarily the type to add the predefined primitives
5100 -- operations. The reason we unfreeze is so that these predefined
5101 -- operations will indeed end up as primitive operations (which
5102 -- must be before the freeze point).
5104 Set_Is_Frozen (Typ, False);
5106 -- Do not add the spec of predefined primitives in case of
5107 -- CPP tagged type derivations that have convention CPP.
5109 if Is_CPP_Class (Root_Type (Typ))
5110 and then Convention (Typ) = Convention_CPP
5114 -- Do not add the spec of the predefined primitives if we are
5115 -- compiling under restriction No_Dispatching_Calls.
5117 elsif not Restriction_Active (No_Dispatching_Calls) then
5118 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
5119 Insert_List_Before_And_Analyze (N, Predef_List);
5122 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5123 -- wrapper functions for each nonoverridden inherited function
5124 -- with a controlling result of the type. The wrapper for such
5125 -- a function returns an extension aggregate that invokes the
5128 if Ada_Version >= Ada_2005
5129 and then not Is_Abstract_Type (Typ)
5130 and then Is_Null_Extension (Typ)
5132 Make_Controlling_Function_Wrappers
5133 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
5134 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5137 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5138 -- null procedure declarations for each set of homographic null
5139 -- procedures that are inherited from interface types but not
5140 -- overridden. This is done to ensure that the dispatch table
5141 -- entry associated with such null primitives are properly filled.
5143 if Ada_Version >= Ada_2005
5144 and then Etype (Typ) /= Typ
5145 and then not Is_Abstract_Type (Typ)
5146 and then Has_Interfaces (Typ)
5148 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
5151 Set_Is_Frozen (Typ);
5153 if not Is_Derived_Type (Typ)
5154 or else Is_Tagged_Type (Etype (Typ))
5156 Set_All_DT_Position (Typ);
5158 -- If this is a type derived from an untagged private type whose
5159 -- full view is tagged, the type is marked tagged for layout
5160 -- reasons, but it has no dispatch table.
5162 elsif Is_Derived_Type (Typ)
5163 and then Is_Private_Type (Etype (Typ))
5164 and then not Is_Tagged_Type (Etype (Typ))
5169 -- Create and decorate the tags. Suppress their creation when
5170 -- not Tagged_Type_Expansion because the dispatching mechanism is
5171 -- handled internally by the virtual target.
5173 if Tagged_Type_Expansion then
5174 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5176 -- Generate dispatch table of locally defined tagged type.
5177 -- Dispatch tables of library level tagged types are built
5178 -- later (see Analyze_Declarations).
5180 if not Building_Static_DT (Typ) then
5181 Append_Freeze_Actions (Typ, Make_DT (Typ));
5185 -- If the type has unknown discriminants, propagate dispatching
5186 -- information to its underlying record view, which does not get
5187 -- its own dispatch table.
5189 if Is_Derived_Type (Typ)
5190 and then Has_Unknown_Discriminants (Typ)
5191 and then Present (Underlying_Record_View (Typ))
5194 Rep : constant Entity_Id := Underlying_Record_View (Typ);
5196 Set_Access_Disp_Table
5197 (Rep, Access_Disp_Table (Typ));
5198 Set_Dispatch_Table_Wrappers
5199 (Rep, Dispatch_Table_Wrappers (Typ));
5200 Set_Direct_Primitive_Operations
5201 (Rep, Direct_Primitive_Operations (Typ));
5205 -- Make sure that the primitives Initialize, Adjust and Finalize
5206 -- are Frozen before other TSS subprograms. We don't want them
5209 if Is_Controlled (Typ) then
5210 if not Is_Limited_Type (Typ) then
5211 Append_Freeze_Actions (Typ,
5212 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
5215 Append_Freeze_Actions (Typ,
5216 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
5218 Append_Freeze_Actions (Typ,
5219 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
5222 -- Freeze rest of primitive operations. There is no need to handle
5223 -- the predefined primitives if we are compiling under restriction
5224 -- No_Dispatching_Calls.
5226 if not Restriction_Active (No_Dispatching_Calls) then
5227 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5231 -- In the untagged case, ever since Ada 83 an equality function must
5232 -- be provided for variant records that are not unchecked unions.
5233 -- In Ada 2012 the equality function composes, and thus must be built
5234 -- explicitly just as for tagged records.
5236 elsif Has_Discriminants (Typ)
5237 and then not Is_Limited_Type (Typ)
5240 Comps : constant Node_Id :=
5241 Component_List (Type_Definition (Typ_Decl));
5244 and then Present (Variant_Part (Comps))
5246 Build_Variant_Record_Equality (Typ);
5250 -- Otherwise create primitive equality operation (AI05-0123)
5252 -- This is done unconditionally to ensure that tools can be linked
5253 -- properly with user programs compiled with older language versions.
5254 -- In addition, this is needed because "=" composes for bounded strings
5255 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5257 elsif Comes_From_Source (Typ)
5258 and then Convention (Typ) = Convention_Ada
5259 and then not Is_Limited_Type (Typ)
5261 Build_Untagged_Equality (Typ);
5264 -- Before building the record initialization procedure, if we are
5265 -- dealing with a concurrent record value type, then we must go through
5266 -- the discriminants, exchanging discriminals between the concurrent
5267 -- type and the concurrent record value type. See the section "Handling
5268 -- of Discriminants" in the Einfo spec for details.
5270 if Is_Concurrent_Record_Type (Typ)
5271 and then Has_Discriminants (Typ)
5274 Ctyp : constant Entity_Id :=
5275 Corresponding_Concurrent_Type (Typ);
5276 Conc_Discr : Entity_Id;
5277 Rec_Discr : Entity_Id;
5281 Conc_Discr := First_Discriminant (Ctyp);
5282 Rec_Discr := First_Discriminant (Typ);
5283 while Present (Conc_Discr) loop
5284 Temp := Discriminal (Conc_Discr);
5285 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5286 Set_Discriminal (Rec_Discr, Temp);
5288 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5289 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5291 Next_Discriminant (Conc_Discr);
5292 Next_Discriminant (Rec_Discr);
5297 if Has_Controlled_Component (Typ) then
5298 Build_Controlling_Procs (Typ);
5301 Adjust_Discriminants (Typ);
5303 -- Do not need init for interfaces on virtual targets since they're
5306 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5307 Build_Record_Init_Proc (Typ_Decl, Typ);
5310 -- For tagged type that are not interfaces, build bodies of primitive
5311 -- operations. Note: do this after building the record initialization
5312 -- procedure, since the primitive operations may need the initialization
5313 -- routine. There is no need to add predefined primitives of interfaces
5314 -- because all their predefined primitives are abstract.
5316 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5318 -- Do not add the body of predefined primitives in case of CPP tagged
5319 -- type derivations that have convention CPP.
5321 if Is_CPP_Class (Root_Type (Typ))
5322 and then Convention (Typ) = Convention_CPP
5326 -- Do not add the body of the predefined primitives if we are
5327 -- compiling under restriction No_Dispatching_Calls or if we are
5328 -- compiling a CPP tagged type.
5330 elsif not Restriction_Active (No_Dispatching_Calls) then
5332 -- Create the body of TSS primitive Finalize_Address. This must
5333 -- be done before the bodies of all predefined primitives are
5334 -- created. If Typ is limited, Stream_Input and Stream_Read may
5335 -- produce build-in-place allocations and for those the expander
5336 -- needs Finalize_Address.
5338 Make_Finalize_Address_Body (Typ);
5339 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5340 Append_Freeze_Actions (Typ, Predef_List);
5343 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5344 -- inherited functions, then add their bodies to the freeze actions.
5346 if Present (Wrapper_Body_List) then
5347 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5350 -- Create extra formals for the primitive operations of the type.
5351 -- This must be done before analyzing the body of the initialization
5352 -- procedure, because a self-referential type might call one of these
5353 -- primitives in the body of the init_proc itself.
5360 Elmt := First_Elmt (Primitive_Operations (Typ));
5361 while Present (Elmt) loop
5362 Subp := Node (Elmt);
5363 if not Has_Foreign_Convention (Subp)
5364 and then not Is_Predefined_Dispatching_Operation (Subp)
5366 Create_Extra_Formals (Subp);
5373 end Expand_Freeze_Record_Type;
5375 ------------------------------------
5376 -- Expand_N_Full_Type_Declaration --
5377 ------------------------------------
5379 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5380 procedure Build_Master (Ptr_Typ : Entity_Id);
5381 -- Create the master associated with Ptr_Typ
5387 procedure Build_Master (Ptr_Typ : Entity_Id) is
5388 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5391 -- If the designated type is an incomplete view coming from a
5392 -- limited-with'ed package, we need to use the nonlimited view in
5393 -- case it has tasks.
5395 if Ekind (Desig_Typ) in Incomplete_Kind
5396 and then Present (Non_Limited_View (Desig_Typ))
5398 Desig_Typ := Non_Limited_View (Desig_Typ);
5401 -- Anonymous access types are created for the components of the
5402 -- record parameter for an entry declaration. No master is created
5405 if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
5406 Build_Master_Entity (Ptr_Typ);
5407 Build_Master_Renaming (Ptr_Typ);
5409 -- Create a class-wide master because a Master_Id must be generated
5410 -- for access-to-limited-class-wide types whose root may be extended
5411 -- with task components.
5413 -- Note: This code covers access-to-limited-interfaces because they
5414 -- can be used to reference tasks implementing them.
5416 elsif Is_Limited_Class_Wide_Type (Desig_Typ)
5417 and then Tasking_Allowed
5419 Build_Class_Wide_Master (Ptr_Typ);
5423 -- Local declarations
5425 Def_Id : constant Entity_Id := Defining_Identifier (N);
5426 B_Id : constant Entity_Id := Base_Type (Def_Id);
5430 -- Start of processing for Expand_N_Full_Type_Declaration
5433 if Is_Access_Type (Def_Id) then
5434 Build_Master (Def_Id);
5436 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5437 Expand_Access_Protected_Subprogram_Type (N);
5440 -- Array of anonymous access-to-task pointers
5442 elsif Ada_Version >= Ada_2005
5443 and then Is_Array_Type (Def_Id)
5444 and then Is_Access_Type (Component_Type (Def_Id))
5445 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5447 Build_Master (Component_Type (Def_Id));
5449 elsif Has_Task (Def_Id) then
5450 Expand_Previous_Access_Type (Def_Id);
5452 -- Check the components of a record type or array of records for
5453 -- anonymous access-to-task pointers.
5455 elsif Ada_Version >= Ada_2005
5456 and then (Is_Record_Type (Def_Id)
5458 (Is_Array_Type (Def_Id)
5459 and then Is_Record_Type (Component_Type (Def_Id))))
5468 if Is_Array_Type (Def_Id) then
5469 Comp := First_Entity (Component_Type (Def_Id));
5471 Comp := First_Entity (Def_Id);
5474 -- Examine all components looking for anonymous access-to-task
5478 while Present (Comp) loop
5479 Typ := Etype (Comp);
5481 if Ekind (Typ) = E_Anonymous_Access_Type
5482 and then Has_Task (Available_View (Designated_Type (Typ)))
5483 and then No (Master_Id (Typ))
5485 -- Ensure that the record or array type have a _master
5488 Build_Master_Entity (Def_Id);
5489 Build_Master_Renaming (Typ);
5490 M_Id := Master_Id (Typ);
5494 -- Reuse the same master to service any additional types
5497 Set_Master_Id (Typ, M_Id);
5506 Par_Id := Etype (B_Id);
5508 -- The parent type is private then we need to inherit any TSS operations
5509 -- from the full view.
5511 if Ekind (Par_Id) in Private_Kind
5512 and then Present (Full_View (Par_Id))
5514 Par_Id := Base_Type (Full_View (Par_Id));
5517 if Nkind (Type_Definition (Original_Node (N))) =
5518 N_Derived_Type_Definition
5519 and then not Is_Tagged_Type (Def_Id)
5520 and then Present (Freeze_Node (Par_Id))
5521 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
5523 Ensure_Freeze_Node (B_Id);
5524 FN := Freeze_Node (B_Id);
5526 if No (TSS_Elist (FN)) then
5527 Set_TSS_Elist (FN, New_Elmt_List);
5531 T_E : constant Elist_Id := TSS_Elist (FN);
5535 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
5536 while Present (Elmt) loop
5537 if Chars (Node (Elmt)) /= Name_uInit then
5538 Append_Elmt (Node (Elmt), T_E);
5544 -- If the derived type itself is private with a full view, then
5545 -- associate the full view with the inherited TSS_Elist as well.
5547 if Ekind (B_Id) in Private_Kind
5548 and then Present (Full_View (B_Id))
5550 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
5552 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
5556 end Expand_N_Full_Type_Declaration;
5558 ---------------------------------
5559 -- Expand_N_Object_Declaration --
5560 ---------------------------------
5562 procedure Expand_N_Object_Declaration (N : Node_Id) is
5563 Loc : constant Source_Ptr := Sloc (N);
5564 Def_Id : constant Entity_Id := Defining_Identifier (N);
5565 Expr : constant Node_Id := Expression (N);
5566 Obj_Def : constant Node_Id := Object_Definition (N);
5567 Typ : constant Entity_Id := Etype (Def_Id);
5568 Base_Typ : constant Entity_Id := Base_Type (Typ);
5571 function Build_Equivalent_Aggregate return Boolean;
5572 -- If the object has a constrained discriminated type and no initial
5573 -- value, it may be possible to build an equivalent aggregate instead,
5574 -- and prevent an actual call to the initialization procedure.
5576 procedure Check_Large_Modular_Array;
5577 -- Check that the size of the array can be computed without overflow,
5578 -- and generate a Storage_Error otherwise. This is only relevant for
5579 -- array types whose index in a (mod 2**64) type, where wrap-around
5580 -- arithmetic might yield a meaningless value for the length of the
5581 -- array, or its corresponding attribute.
5583 procedure Default_Initialize_Object (After : Node_Id);
5584 -- Generate all default initialization actions for object Def_Id. Any
5585 -- new code is inserted after node After.
5587 function Rewrite_As_Renaming return Boolean;
5588 -- Indicate whether to rewrite a declaration with initialization into an
5589 -- object renaming declaration (see below).
5591 --------------------------------
5592 -- Build_Equivalent_Aggregate --
5593 --------------------------------
5595 function Build_Equivalent_Aggregate return Boolean is
5599 Full_Type : Entity_Id;
5604 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
5605 Full_Type := Full_View (Typ);
5608 -- Only perform this transformation if Elaboration_Code is forbidden
5609 -- or undesirable, and if this is a global entity of a constrained
5612 -- If Initialize_Scalars might be active this transformation cannot
5613 -- be performed either, because it will lead to different semantics
5614 -- or because elaboration code will in fact be created.
5616 if Ekind (Full_Type) /= E_Record_Subtype
5617 or else not Has_Discriminants (Full_Type)
5618 or else not Is_Constrained (Full_Type)
5619 or else Is_Controlled (Full_Type)
5620 or else Is_Limited_Type (Full_Type)
5621 or else not Restriction_Active (No_Initialize_Scalars)
5626 if Ekind (Current_Scope) = E_Package
5628 (Restriction_Active (No_Elaboration_Code)
5629 or else Is_Preelaborated (Current_Scope))
5631 -- Building a static aggregate is possible if the discriminants
5632 -- have static values and the other components have static
5633 -- defaults or none.
5635 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5636 while Present (Discr) loop
5637 if not Is_OK_Static_Expression (Node (Discr)) then
5644 -- Check that initialized components are OK, and that non-
5645 -- initialized components do not require a call to their own
5646 -- initialization procedure.
5648 Comp := First_Component (Full_Type);
5649 while Present (Comp) loop
5650 if Ekind (Comp) = E_Component
5651 and then Present (Expression (Parent (Comp)))
5653 not Is_OK_Static_Expression (Expression (Parent (Comp)))
5657 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
5662 Next_Component (Comp);
5665 -- Everything is static, assemble the aggregate, discriminant
5669 Make_Aggregate (Loc,
5670 Expressions => New_List,
5671 Component_Associations => New_List);
5673 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5674 while Present (Discr) loop
5675 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
5679 -- Now collect values of initialized components
5681 Comp := First_Component (Full_Type);
5682 while Present (Comp) loop
5683 if Ekind (Comp) = E_Component
5684 and then Present (Expression (Parent (Comp)))
5686 Append_To (Component_Associations (Aggr),
5687 Make_Component_Association (Loc,
5688 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
5689 Expression => New_Copy_Tree
5690 (Expression (Parent (Comp)))));
5693 Next_Component (Comp);
5696 -- Finally, box-initialize remaining components
5698 Append_To (Component_Associations (Aggr),
5699 Make_Component_Association (Loc,
5700 Choices => New_List (Make_Others_Choice (Loc)),
5701 Expression => Empty));
5702 Set_Box_Present (Last (Component_Associations (Aggr)));
5703 Set_Expression (N, Aggr);
5705 if Typ /= Full_Type then
5706 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
5707 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
5708 Analyze_And_Resolve (Aggr, Typ);
5710 Analyze_And_Resolve (Aggr, Full_Type);
5718 end Build_Equivalent_Aggregate;
5720 -------------------------------
5721 -- Check_Large_Modular_Array --
5722 -------------------------------
5724 procedure Check_Large_Modular_Array is
5725 Index_Typ : Entity_Id;
5728 if Is_Array_Type (Typ)
5729 and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
5731 -- To prevent arithmetic overflow with large values, we raise
5732 -- Storage_Error under the following guard:
5734 -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
5736 -- This takes care of the boundary case, but it is preferable to
5737 -- use a smaller limit, because even on 64-bit architectures an
5738 -- array of more than 2 ** 30 bytes is likely to raise
5741 Index_Typ := Etype (First_Index (Typ));
5743 if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
5745 Make_Raise_Storage_Error (Loc,
5749 Make_Op_Subtract (Loc,
5751 Make_Op_Divide (Loc,
5753 Make_Attribute_Reference (Loc,
5755 New_Occurrence_Of (Typ, Loc),
5756 Attribute_Name => Name_Last),
5758 Make_Integer_Literal (Loc, Uint_2)),
5760 Make_Op_Divide (Loc,
5762 Make_Attribute_Reference (Loc,
5764 New_Occurrence_Of (Typ, Loc),
5765 Attribute_Name => Name_First),
5767 Make_Integer_Literal (Loc, Uint_2))),
5769 Make_Integer_Literal (Loc, (Uint_2 ** 30))),
5770 Reason => SE_Object_Too_Large));
5773 end Check_Large_Modular_Array;
5775 -------------------------------
5776 -- Default_Initialize_Object --
5777 -------------------------------
5779 procedure Default_Initialize_Object (After : Node_Id) is
5780 function New_Object_Reference return Node_Id;
5781 -- Return a new reference to Def_Id with attributes Assignment_OK and
5782 -- Must_Not_Freeze already set.
5784 --------------------------
5785 -- New_Object_Reference --
5786 --------------------------
5788 function New_Object_Reference return Node_Id is
5789 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
5792 -- The call to the type init proc or [Deep_]Finalize must not
5793 -- freeze the related object as the call is internally generated.
5794 -- This way legal rep clauses that apply to the object will not be
5795 -- flagged. Note that the initialization call may be removed if
5796 -- pragma Import is encountered or moved to the freeze actions of
5797 -- the object because of an address clause.
5799 Set_Assignment_OK (Obj_Ref);
5800 Set_Must_Not_Freeze (Obj_Ref);
5803 end New_Object_Reference;
5807 Exceptions_OK : constant Boolean :=
5808 not Restriction_Active (No_Exception_Propagation);
5810 Aggr_Init : Node_Id;
5811 Comp_Init : List_Id := No_List;
5812 Fin_Block : Node_Id;
5814 Init_Stmts : List_Id := No_List;
5815 Obj_Init : Node_Id := Empty;
5818 -- Start of processing for Default_Initialize_Object
5821 -- Default initialization is suppressed for objects that are already
5822 -- known to be imported (i.e. whose declaration specifies the Import
5823 -- aspect). Note that for objects with a pragma Import, we generate
5824 -- initialization here, and then remove it downstream when processing
5825 -- the pragma. It is also suppressed for variables for which a pragma
5826 -- Suppress_Initialization has been explicitly given
5828 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
5831 -- Nothing to do if the object being initialized is of a task type
5832 -- and restriction No_Tasking is in effect, because this is a direct
5833 -- violation of the restriction.
5835 elsif Is_Task_Type (Base_Typ)
5836 and then Restriction_Active (No_Tasking)
5841 -- The expansion performed by this routine is as follows:
5845 -- Type_Init_Proc (Obj);
5848 -- [Deep_]Initialize (Obj);
5852 -- [Deep_]Finalize (Obj, Self => False);
5856 -- Abort_Undefer_Direct;
5859 -- Initialize the components of the object
5861 if Has_Non_Null_Base_Init_Proc (Typ)
5862 and then not No_Initialization (N)
5863 and then not Initialization_Suppressed (Typ)
5865 -- Do not initialize the components if No_Default_Initialization
5866 -- applies as the actual restriction check will occur later
5867 -- when the object is frozen as it is not known yet whether the
5868 -- object is imported or not.
5870 if not Restriction_Active (No_Default_Initialization) then
5872 -- If the values of the components are compile-time known, use
5873 -- their prebuilt aggregate form directly.
5875 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
5877 if Present (Aggr_Init) then
5879 (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
5881 -- If type has discriminants, try to build an equivalent
5882 -- aggregate using discriminant values from the declaration.
5883 -- This is a useful optimization, in particular if restriction
5884 -- No_Elaboration_Code is active.
5886 elsif Build_Equivalent_Aggregate then
5889 -- Otherwise invoke the type init proc, generate:
5890 -- Type_Init_Proc (Obj);
5893 Obj_Ref := New_Object_Reference;
5895 if Comes_From_Source (Def_Id) then
5896 Initialization_Warning (Obj_Ref);
5899 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
5903 -- Provide a default value if the object needs simple initialization
5904 -- and does not already have an initial value. A generated temporary
5905 -- does not require initialization because it will be assigned later.
5907 elsif Needs_Simple_Initialization
5908 (Typ, Initialize_Scalars
5909 and then No (Following_Address_Clause (N)))
5910 and then not Is_Internal (Def_Id)
5911 and then not Has_Init_Expression (N)
5913 Set_No_Initialization (N, False);
5914 Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
5915 Analyze_And_Resolve (Expression (N), Typ);
5918 -- Initialize the object, generate:
5919 -- [Deep_]Initialize (Obj);
5921 if Needs_Finalization (Typ) and then not No_Initialization (N) then
5924 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5928 -- Build a special finalization block when both the object and its
5929 -- controlled components are to be initialized. The block finalizes
5930 -- the components if the object initialization fails. Generate:
5941 if Has_Controlled_Component (Typ)
5942 and then Present (Comp_Init)
5943 and then Present (Obj_Init)
5944 and then Exceptions_OK
5946 Init_Stmts := Comp_Init;
5950 (Obj_Ref => New_Object_Reference,
5954 if Present (Fin_Call) then
5956 Make_Block_Statement (Loc,
5957 Declarations => No_List,
5959 Handled_Statement_Sequence =>
5960 Make_Handled_Sequence_Of_Statements (Loc,
5961 Statements => New_List (Obj_Init),
5963 Exception_Handlers => New_List (
5964 Make_Exception_Handler (Loc,
5965 Exception_Choices => New_List (
5966 Make_Others_Choice (Loc)),
5968 Statements => New_List (
5970 Make_Raise_Statement (Loc))))));
5972 -- Signal the ABE mechanism that the block carries out
5973 -- initialization actions.
5975 Set_Is_Initialization_Block (Fin_Block);
5977 Append_To (Init_Stmts, Fin_Block);
5980 -- Otherwise finalization is not required, the initialization calls
5981 -- are passed to the abort block building circuitry, generate:
5983 -- Type_Init_Proc (Obj);
5984 -- [Deep_]Initialize (Obj);
5987 if Present (Comp_Init) then
5988 Init_Stmts := Comp_Init;
5991 if Present (Obj_Init) then
5992 if No (Init_Stmts) then
5993 Init_Stmts := New_List;
5996 Append_To (Init_Stmts, Obj_Init);
6000 -- Build an abort block to protect the initialization calls
6003 and then Present (Comp_Init)
6004 and then Present (Obj_Init)
6009 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
6011 -- When exceptions are propagated, abort deferral must take place
6012 -- in the presence of initialization or finalization exceptions.
6019 -- Abort_Undefer_Direct;
6022 if Exceptions_OK then
6023 Init_Stmts := New_List (
6024 Build_Abort_Undefer_Block (Loc,
6025 Stmts => Init_Stmts,
6028 -- Otherwise exceptions are not propagated. Generate:
6035 Append_To (Init_Stmts,
6036 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6040 -- Insert the whole initialization sequence into the tree. If the
6041 -- object has a delayed freeze, as will be the case when it has
6042 -- aspect specifications, the initialization sequence is part of
6043 -- the freeze actions.
6045 if Present (Init_Stmts) then
6046 if Has_Delayed_Freeze (Def_Id) then
6047 Append_Freeze_Actions (Def_Id, Init_Stmts);
6049 Insert_Actions_After (After, Init_Stmts);
6052 end Default_Initialize_Object;
6054 -------------------------
6055 -- Rewrite_As_Renaming --
6056 -------------------------
6058 function Rewrite_As_Renaming return Boolean is
6060 -- If the object declaration appears in the form
6062 -- Obj : Ctrl_Typ := Func (...);
6064 -- where Ctrl_Typ is controlled but not immutably limited type, then
6065 -- the expansion of the function call should use a dereference of the
6066 -- result to reference the value on the secondary stack.
6068 -- Obj : Ctrl_Typ renames Func (...).all;
6070 -- As a result, the call avoids an extra copy. This an optimization,
6071 -- but it is required for passing ACATS tests in some cases where it
6072 -- would otherwise make two copies. The RM allows removing redunant
6073 -- Adjust/Finalize calls, but does not allow insertion of extra ones.
6075 -- This part is disabled for now, because it breaks GPS builds
6077 return (False -- ???
6078 and then Nkind (Expr_Q) = N_Explicit_Dereference
6079 and then not Comes_From_Source (Expr_Q)
6080 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
6081 and then Nkind (Object_Definition (N)) in N_Has_Entity
6082 and then (Needs_Finalization (Entity (Object_Definition (N)))))
6084 -- If the initializing expression is for a variable with attribute
6085 -- OK_To_Rename set, then transform:
6087 -- Obj : Typ := Expr;
6091 -- Obj : Typ renames Expr;
6093 -- provided that Obj is not aliased. The aliased case has to be
6094 -- excluded in general because Expr will not be aliased in
6098 (not Aliased_Present (N)
6099 and then Is_Entity_Name (Expr_Q)
6100 and then Ekind (Entity (Expr_Q)) = E_Variable
6101 and then OK_To_Rename (Entity (Expr_Q))
6102 and then Is_Entity_Name (Obj_Def));
6103 end Rewrite_As_Renaming;
6107 Next_N : constant Node_Id := Next (N);
6111 Tag_Assign : Node_Id;
6113 Init_After : Node_Id := N;
6114 -- Node after which the initialization actions are to be inserted. This
6115 -- is normally N, except for the case of a shared passive variable, in
6116 -- which case the init proc call must be inserted only after the bodies
6117 -- of the shared variable procedures have been seen.
6119 -- Start of processing for Expand_N_Object_Declaration
6122 -- Don't do anything for deferred constants. All proper actions will be
6123 -- expanded during the full declaration.
6125 if No (Expr) and Constant_Present (N) then
6129 -- The type of the object cannot be abstract. This is diagnosed at the
6130 -- point the object is frozen, which happens after the declaration is
6131 -- fully expanded, so simply return now.
6133 if Is_Abstract_Type (Typ) then
6137 -- No action needed for the internal imported dummy object added by
6138 -- Make_DT to compute the offset of the components that reference
6139 -- secondary dispatch tables; required to avoid never-ending loop
6140 -- processing this internal object declaration.
6142 if Tagged_Type_Expansion
6143 and then Is_Internal (Def_Id)
6144 and then Is_Imported (Def_Id)
6145 and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
6150 -- First we do special processing for objects of a tagged type where
6151 -- this is the point at which the type is frozen. The creation of the
6152 -- dispatch table and the initialization procedure have to be deferred
6153 -- to this point, since we reference previously declared primitive
6156 -- Force construction of dispatch tables of library level tagged types
6158 if Tagged_Type_Expansion
6159 and then Static_Dispatch_Tables
6160 and then Is_Library_Level_Entity (Def_Id)
6161 and then Is_Library_Level_Tagged_Type (Base_Typ)
6162 and then Ekind_In (Base_Typ, E_Record_Type,
6165 and then not Has_Dispatch_Table (Base_Typ)
6168 New_Nodes : List_Id := No_List;
6171 if Is_Concurrent_Type (Base_Typ) then
6172 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
6174 New_Nodes := Make_DT (Base_Typ, N);
6177 if not Is_Empty_List (New_Nodes) then
6178 Insert_List_Before (N, New_Nodes);
6183 -- Make shared memory routines for shared passive variable
6185 if Is_Shared_Passive (Def_Id) then
6186 Init_After := Make_Shared_Var_Procs (N);
6189 -- If tasks being declared, make sure we have an activation chain
6190 -- defined for the tasks (has no effect if we already have one), and
6191 -- also that a Master variable is established and that the appropriate
6192 -- enclosing construct is established as a task master.
6194 if Has_Task (Typ) then
6195 Build_Activation_Chain_Entity (N);
6196 Build_Master_Entity (Def_Id);
6199 Check_Large_Modular_Array;
6201 -- Default initialization required, and no expression present
6205 -- If we have a type with a variant part, the initialization proc
6206 -- will contain implicit tests of the discriminant values, which
6207 -- counts as a violation of the restriction No_Implicit_Conditionals.
6209 if Has_Variant_Part (Typ) then
6214 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
6218 ("\initialization of variant record tests discriminants",
6225 -- For the default initialization case, if we have a private type
6226 -- with invariants, and invariant checks are enabled, then insert an
6227 -- invariant check after the object declaration. Note that it is OK
6228 -- to clobber the object with an invalid value since if the exception
6229 -- is raised, then the object will go out of scope. In the case where
6230 -- an array object is initialized with an aggregate, the expression
6231 -- is removed. Check flag Has_Init_Expression to avoid generating a
6232 -- junk invariant check and flag No_Initialization to avoid checking
6233 -- an uninitialized object such as a compiler temporary used for an
6236 if Has_Invariants (Base_Typ)
6237 and then Present (Invariant_Procedure (Base_Typ))
6238 and then not Has_Init_Expression (N)
6239 and then not No_Initialization (N)
6241 -- If entity has an address clause or aspect, make invariant
6242 -- call into a freeze action for the explicit freeze node for
6243 -- object. Otherwise insert invariant check after declaration.
6245 if Present (Following_Address_Clause (N))
6246 or else Has_Aspect (Def_Id, Aspect_Address)
6248 Ensure_Freeze_Node (Def_Id);
6249 Set_Has_Delayed_Freeze (Def_Id);
6250 Set_Is_Frozen (Def_Id, False);
6252 if not Partial_View_Has_Unknown_Discr (Typ) then
6253 Append_Freeze_Action (Def_Id,
6254 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6257 elsif not Partial_View_Has_Unknown_Discr (Typ) then
6259 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6263 Default_Initialize_Object (Init_After);
6265 -- Generate attribute for Persistent_BSS if needed
6267 if Persistent_BSS_Mode
6268 and then Comes_From_Source (N)
6269 and then Is_Potentially_Persistent_Type (Typ)
6270 and then not Has_Init_Expression (N)
6271 and then Is_Library_Level_Entity (Def_Id)
6277 Make_Linker_Section_Pragma
6278 (Def_Id, Sloc (N), ".persistent.bss");
6279 Insert_After (N, Prag);
6284 -- If access type, then we know it is null if not initialized
6286 if Is_Access_Type (Typ) then
6287 Set_Is_Known_Null (Def_Id);
6290 -- Explicit initialization present
6293 -- Obtain actual expression from qualified expression
6295 if Nkind (Expr) = N_Qualified_Expression then
6296 Expr_Q := Expression (Expr);
6301 -- When we have the appropriate type of aggregate in the expression
6302 -- (it has been determined during analysis of the aggregate by
6303 -- setting the delay flag), let's perform in place assignment and
6304 -- thus avoid creating a temporary.
6306 if Is_Delayed_Aggregate (Expr_Q) then
6307 Convert_Aggr_In_Object_Decl (N);
6309 -- Ada 2005 (AI-318-02): If the initialization expression is a call
6310 -- to a build-in-place function, then access to the declared object
6311 -- must be passed to the function. Currently we limit such functions
6312 -- to those with constrained limited result subtypes, but eventually
6313 -- plan to expand the allowed forms of functions that are treated as
6316 elsif Is_Build_In_Place_Function_Call (Expr_Q) then
6317 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
6319 -- The previous call expands the expression initializing the
6320 -- built-in-place object into further code that will be analyzed
6321 -- later. No further expansion needed here.
6325 -- This is the same as the previous 'elsif', except that the call has
6326 -- been transformed by other expansion activities into something like
6327 -- F(...)'Reference.
6329 elsif Nkind (Expr_Q) = N_Reference
6330 and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
6331 and then not Is_Expanded_Build_In_Place_Call
6332 (Unqual_Conv (Prefix (Expr_Q)))
6334 Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
6336 -- The previous call expands the expression initializing the
6337 -- built-in-place object into further code that will be analyzed
6338 -- later. No further expansion needed here.
6342 -- Ada 2005 (AI-318-02): Specialization of the previous case for
6343 -- expressions containing a build-in-place function call whose
6344 -- returned object covers interface types, and Expr_Q has calls to
6345 -- Ada.Tags.Displace to displace the pointer to the returned build-
6346 -- in-place object to reference the secondary dispatch table of a
6347 -- covered interface type.
6349 elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
6350 Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
6352 -- The previous call expands the expression initializing the
6353 -- built-in-place object into further code that will be analyzed
6354 -- later. No further expansion needed here.
6358 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
6359 -- class-wide interface object to ensure that we copy the full
6360 -- object, unless we are targetting a VM where interfaces are handled
6361 -- by VM itself. Note that if the root type of Typ is an ancestor of
6362 -- Expr's type, both types share the same dispatch table and there is
6363 -- no need to displace the pointer.
6365 elsif Is_Interface (Typ)
6367 -- Avoid never-ending recursion because if Equivalent_Type is set
6368 -- then we've done it already and must not do it again.
6371 (Nkind (Obj_Def) = N_Identifier
6372 and then Present (Equivalent_Type (Entity (Obj_Def))))
6374 pragma Assert (Is_Class_Wide_Type (Typ));
6376 -- If the object is a return object of an inherently limited type,
6377 -- which implies build-in-place treatment, bypass the special
6378 -- treatment of class-wide interface initialization below. In this
6379 -- case, the expansion of the return statement will take care of
6380 -- creating the object (via allocator) and initializing it.
6382 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
6385 elsif Tagged_Type_Expansion then
6387 Iface : constant Entity_Id := Root_Type (Typ);
6388 Expr_N : Node_Id := Expr;
6389 Expr_Typ : Entity_Id;
6395 -- If the original node of the expression was a conversion
6396 -- to this specific class-wide interface type then restore
6397 -- the original node because we must copy the object before
6398 -- displacing the pointer to reference the secondary tag
6399 -- component. This code must be kept synchronized with the
6400 -- expansion done by routine Expand_Interface_Conversion
6402 if not Comes_From_Source (Expr_N)
6403 and then Nkind (Expr_N) = N_Explicit_Dereference
6404 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
6405 and then Etype (Original_Node (Expr_N)) = Typ
6407 Rewrite (Expr_N, Original_Node (Expression (N)));
6410 -- Avoid expansion of redundant interface conversion
6412 if Is_Interface (Etype (Expr_N))
6413 and then Nkind (Expr_N) = N_Type_Conversion
6414 and then Etype (Expr_N) = Typ
6416 Expr_N := Expression (Expr_N);
6417 Set_Expression (N, Expr_N);
6420 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
6421 Expr_Typ := Base_Type (Etype (Expr_N));
6423 if Is_Class_Wide_Type (Expr_Typ) then
6424 Expr_Typ := Root_Type (Expr_Typ);
6428 -- CW : I'Class := Obj;
6431 -- type Ityp is not null access I'Class;
6432 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
6434 if Comes_From_Source (Expr_N)
6435 and then Nkind (Expr_N) = N_Identifier
6436 and then not Is_Interface (Expr_Typ)
6437 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
6438 and then (Expr_Typ = Etype (Expr_Typ)
6440 Is_Variable_Size_Record (Etype (Expr_Typ)))
6445 Make_Object_Declaration (Loc,
6446 Defining_Identifier => Obj_Id,
6447 Object_Definition =>
6448 New_Occurrence_Of (Expr_Typ, Loc),
6449 Expression => Relocate_Node (Expr_N)));
6451 -- Statically reference the tag associated with the
6455 Make_Selected_Component (Loc,
6456 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6459 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
6462 -- IW : I'Class := Obj;
6464 -- type Equiv_Record is record ... end record;
6465 -- implicit subtype CW is <Class_Wide_Subtype>;
6466 -- Tmp : CW := CW!(Obj);
6467 -- type Ityp is not null access I'Class;
6468 -- IW : I'Class renames
6469 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
6472 -- Generate the equivalent record type and update the
6473 -- subtype indication to reference it.
6475 Expand_Subtype_From_Expr
6478 Subtype_Indic => Obj_Def,
6481 if not Is_Interface (Etype (Expr_N)) then
6482 New_Expr := Relocate_Node (Expr_N);
6484 -- For interface types we use 'Address which displaces
6485 -- the pointer to the base of the object (if required)
6489 Unchecked_Convert_To (Etype (Obj_Def),
6490 Make_Explicit_Dereference (Loc,
6491 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6492 Make_Attribute_Reference (Loc,
6493 Prefix => Relocate_Node (Expr_N),
6494 Attribute_Name => Name_Address))));
6499 if not Is_Limited_Record (Expr_Typ) then
6501 Make_Object_Declaration (Loc,
6502 Defining_Identifier => Obj_Id,
6503 Object_Definition =>
6504 New_Occurrence_Of (Etype (Obj_Def), Loc),
6505 Expression => New_Expr));
6507 -- Rename limited type object since they cannot be copied
6508 -- This case occurs when the initialization expression
6509 -- has been previously expanded into a temporary object.
6511 else pragma Assert (not Comes_From_Source (Expr_Q));
6513 Make_Object_Renaming_Declaration (Loc,
6514 Defining_Identifier => Obj_Id,
6516 New_Occurrence_Of (Etype (Obj_Def), Loc),
6518 Unchecked_Convert_To
6519 (Etype (Obj_Def), New_Expr)));
6522 -- Dynamically reference the tag associated with the
6526 Make_Function_Call (Loc,
6527 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
6528 Parameter_Associations => New_List (
6529 Make_Attribute_Reference (Loc,
6530 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6531 Attribute_Name => Name_Address),
6533 (Node (First_Elmt (Access_Disp_Table (Iface))),
6538 Make_Object_Renaming_Declaration (Loc,
6539 Defining_Identifier => Make_Temporary (Loc, 'D'),
6540 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
6542 Convert_Tag_To_Interface (Typ, Tag_Comp)));
6544 -- If the original entity comes from source, then mark the
6545 -- new entity as needing debug information, even though it's
6546 -- defined by a generated renaming that does not come from
6547 -- source, so that Materialize_Entity will be set on the
6548 -- entity when Debug_Renaming_Declaration is called during
6551 if Comes_From_Source (Def_Id) then
6552 Set_Debug_Info_Needed (Defining_Identifier (N));
6555 Analyze (N, Suppress => All_Checks);
6557 -- Replace internal identifier of rewritten node by the
6558 -- identifier found in the sources. We also have to exchange
6559 -- entities containing their defining identifiers to ensure
6560 -- the correct replacement of the object declaration by this
6561 -- object renaming declaration because these identifiers
6562 -- were previously added by Enter_Name to the current scope.
6563 -- We must preserve the homonym chain of the source entity
6564 -- as well. We must also preserve the kind of the entity,
6565 -- which may be a constant. Preserve entity chain because
6566 -- itypes may have been generated already, and the full
6567 -- chain must be preserved for final freezing. Finally,
6568 -- preserve Comes_From_Source setting, so that debugging
6569 -- and cross-referencing information is properly kept, and
6570 -- preserve source location, to prevent spurious errors when
6571 -- entities are declared (they must have their own Sloc).
6574 New_Id : constant Entity_Id := Defining_Identifier (N);
6575 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
6576 S_Flag : constant Boolean :=
6577 Comes_From_Source (Def_Id);
6580 Set_Next_Entity (New_Id, Next_Entity (Def_Id));
6581 Set_Next_Entity (Def_Id, Next_Temp);
6583 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
6584 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
6585 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
6586 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
6588 Set_Comes_From_Source (Def_Id, False);
6589 Exchange_Entities (Defining_Identifier (N), Def_Id);
6590 Set_Comes_From_Source (Def_Id, S_Flag);
6597 -- Common case of explicit object initialization
6600 -- In most cases, we must check that the initial value meets any
6601 -- constraint imposed by the declared type. However, there is one
6602 -- very important exception to this rule. If the entity has an
6603 -- unconstrained nominal subtype, then it acquired its constraints
6604 -- from the expression in the first place, and not only does this
6605 -- mean that the constraint check is not needed, but an attempt to
6606 -- perform the constraint check can cause order of elaboration
6609 if not Is_Constr_Subt_For_U_Nominal (Typ) then
6611 -- If this is an allocator for an aggregate that has been
6612 -- allocated in place, delay checks until assignments are
6613 -- made, because the discriminants are not initialized.
6615 if Nkind (Expr) = N_Allocator
6616 and then No_Initialization (Expr)
6620 -- Otherwise apply a constraint check now if no prev error
6622 elsif Nkind (Expr) /= N_Error then
6623 Apply_Constraint_Check (Expr, Typ);
6625 -- Deal with possible range check
6627 if Do_Range_Check (Expr) then
6629 -- If assignment checks are suppressed, turn off flag
6631 if Suppress_Assignment_Checks (N) then
6632 Set_Do_Range_Check (Expr, False);
6634 -- Otherwise generate the range check
6637 Generate_Range_Check
6638 (Expr, Typ, CE_Range_Check_Failed);
6644 -- If the type is controlled and not inherently limited, then
6645 -- the target is adjusted after the copy and attached to the
6646 -- finalization list. However, no adjustment is done in the case
6647 -- where the object was initialized by a call to a function whose
6648 -- result is built in place, since no copy occurred. Similarly, no
6649 -- adjustment is required if we are going to rewrite the object
6650 -- declaration into a renaming declaration.
6652 if Is_Build_In_Place_Result_Type (Typ)
6653 and then Nkind (Parent (N)) = N_Extended_Return_Statement
6655 not Is_Definite_Subtype (Etype (Return_Applies_To
6656 (Return_Statement_Entity (Parent (N)))))
6660 elsif Needs_Finalization (Typ)
6661 and then not Is_Limited_View (Typ)
6662 and then not Rewrite_As_Renaming
6666 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
6669 -- Guard against a missing [Deep_]Adjust when the base type
6670 -- was not properly frozen.
6672 if Present (Adj_Call) then
6673 Insert_Action_After (Init_After, Adj_Call);
6677 -- For tagged types, when an init value is given, the tag has to
6678 -- be re-initialized separately in order to avoid the propagation
6679 -- of a wrong tag coming from a view conversion unless the type
6680 -- is class wide (in this case the tag comes from the init value).
6681 -- Suppress the tag assignment when not Tagged_Type_Expansion
6682 -- because tags are represented implicitly in objects. Ditto for
6683 -- types that are CPP_CLASS, and for initializations that are
6684 -- aggregates, because they have to have the right tag.
6686 -- The re-assignment of the tag has to be done even if the object
6687 -- is a constant. The assignment must be analyzed after the
6688 -- declaration. If an address clause follows, this is handled as
6689 -- part of the freeze actions for the object, otherwise insert
6690 -- tag assignment here.
6692 Tag_Assign := Make_Tag_Assignment (N);
6694 if Present (Tag_Assign) then
6695 if Present (Following_Address_Clause (N)) then
6696 Ensure_Freeze_Node (Def_Id);
6699 Insert_Action_After (Init_After, Tag_Assign);
6702 -- Handle C++ constructor calls. Note that we do not check that
6703 -- Typ is a tagged type since the equivalent Ada type of a C++
6704 -- class that has no virtual methods is an untagged limited
6707 elsif Is_CPP_Constructor_Call (Expr) then
6709 -- The call to the initialization procedure does NOT freeze the
6710 -- object being initialized.
6712 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
6713 Set_Must_Not_Freeze (Id_Ref);
6714 Set_Assignment_OK (Id_Ref);
6716 Insert_Actions_After (Init_After,
6717 Build_Initialization_Call (Loc, Id_Ref, Typ,
6718 Constructor_Ref => Expr));
6720 -- We remove here the original call to the constructor
6721 -- to avoid its management in the backend
6723 Set_Expression (N, Empty);
6726 -- Handle initialization of limited tagged types
6728 elsif Is_Tagged_Type (Typ)
6729 and then Is_Class_Wide_Type (Typ)
6730 and then Is_Limited_Record (Typ)
6731 and then not Is_Limited_Interface (Typ)
6733 -- Given that the type is limited we cannot perform a copy. If
6734 -- Expr_Q is the reference to a variable we mark the variable
6735 -- as OK_To_Rename to expand this declaration into a renaming
6736 -- declaration (see bellow).
6738 if Is_Entity_Name (Expr_Q) then
6739 Set_OK_To_Rename (Entity (Expr_Q));
6741 -- If we cannot convert the expression into a renaming we must
6742 -- consider it an internal error because the backend does not
6743 -- have support to handle it.
6746 pragma Assert (False);
6747 raise Program_Error;
6750 -- For discrete types, set the Is_Known_Valid flag if the
6751 -- initializing value is known to be valid. Only do this for
6752 -- source assignments, since otherwise we can end up turning
6753 -- on the known valid flag prematurely from inserted code.
6755 elsif Comes_From_Source (N)
6756 and then Is_Discrete_Type (Typ)
6757 and then Expr_Known_Valid (Expr)
6759 Set_Is_Known_Valid (Def_Id);
6761 elsif Is_Access_Type (Typ) then
6763 -- For access types set the Is_Known_Non_Null flag if the
6764 -- initializing value is known to be non-null. We can also set
6765 -- Can_Never_Be_Null if this is a constant.
6767 if Known_Non_Null (Expr) then
6768 Set_Is_Known_Non_Null (Def_Id, True);
6770 if Constant_Present (N) then
6771 Set_Can_Never_Be_Null (Def_Id);
6776 -- If validity checking on copies, validate initial expression.
6777 -- But skip this if declaration is for a generic type, since it
6778 -- makes no sense to validate generic types. Not clear if this
6779 -- can happen for legal programs, but it definitely can arise
6780 -- from previous instantiation errors.
6782 if Validity_Checks_On
6783 and then Comes_From_Source (N)
6784 and then Validity_Check_Copies
6785 and then not Is_Generic_Type (Etype (Def_Id))
6787 Ensure_Valid (Expr);
6788 Set_Is_Known_Valid (Def_Id);
6792 -- Cases where the back end cannot handle the initialization
6793 -- directly. In such cases, we expand an assignment that will
6794 -- be appropriately handled by Expand_N_Assignment_Statement.
6796 -- The exclusion of the unconstrained case is wrong, but for now it
6797 -- is too much trouble ???
6799 if (Is_Possibly_Unaligned_Slice (Expr)
6800 or else (Is_Possibly_Unaligned_Object (Expr)
6801 and then not Represented_As_Scalar (Etype (Expr))))
6802 and then not (Is_Array_Type (Etype (Expr))
6803 and then not Is_Constrained (Etype (Expr)))
6806 Stat : constant Node_Id :=
6807 Make_Assignment_Statement (Loc,
6808 Name => New_Occurrence_Of (Def_Id, Loc),
6809 Expression => Relocate_Node (Expr));
6811 Set_Expression (N, Empty);
6812 Set_No_Initialization (N);
6813 Set_Assignment_OK (Name (Stat));
6814 Set_No_Ctrl_Actions (Stat);
6815 Insert_After_And_Analyze (Init_After, Stat);
6820 if Nkind (Obj_Def) = N_Access_Definition
6821 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
6823 -- An Ada 2012 stand-alone object of an anonymous access type
6826 Loc : constant Source_Ptr := Sloc (N);
6828 Level : constant Entity_Id :=
6829 Make_Defining_Identifier (Sloc (N),
6831 New_External_Name (Chars (Def_Id), Suffix => "L"));
6833 Level_Expr : Node_Id;
6834 Level_Decl : Node_Id;
6837 Set_Ekind (Level, Ekind (Def_Id));
6838 Set_Etype (Level, Standard_Natural);
6839 Set_Scope (Level, Scope (Def_Id));
6843 -- Set accessibility level of null
6846 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
6849 Level_Expr := Dynamic_Accessibility_Level (Expr);
6853 Make_Object_Declaration (Loc,
6854 Defining_Identifier => Level,
6855 Object_Definition =>
6856 New_Occurrence_Of (Standard_Natural, Loc),
6857 Expression => Level_Expr,
6858 Constant_Present => Constant_Present (N),
6859 Has_Init_Expression => True);
6861 Insert_Action_After (Init_After, Level_Decl);
6863 Set_Extra_Accessibility (Def_Id, Level);
6867 -- If the object is default initialized and its type is subject to
6868 -- pragma Default_Initial_Condition, add a runtime check to verify
6869 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
6871 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
6873 -- Note that the check is generated for source objects only
6875 if Comes_From_Source (Def_Id)
6876 and then Has_DIC (Typ)
6877 and then Present (DIC_Procedure (Typ))
6878 and then not Has_Init_Expression (N)
6881 DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
6884 if Present (Next_N) then
6885 Insert_Before_And_Analyze (Next_N, DIC_Call);
6887 -- The object declaration is the last node in a declarative or a
6891 Append_To (List_Containing (N), DIC_Call);
6897 -- Final transformation - turn the object declaration into a renaming
6898 -- if appropriate. If this is the completion of a deferred constant
6899 -- declaration, then this transformation generates what would be
6900 -- illegal code if written by hand, but that's OK.
6902 if Present (Expr) then
6903 if Rewrite_As_Renaming then
6905 Make_Object_Renaming_Declaration (Loc,
6906 Defining_Identifier => Defining_Identifier (N),
6907 Subtype_Mark => Obj_Def,
6910 -- We do not analyze this renaming declaration, because all its
6911 -- components have already been analyzed, and if we were to go
6912 -- ahead and analyze it, we would in effect be trying to generate
6913 -- another declaration of X, which won't do.
6915 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
6918 -- We do need to deal with debug issues for this renaming
6920 -- First, if entity comes from source, then mark it as needing
6921 -- debug information, even though it is defined by a generated
6922 -- renaming that does not come from source.
6924 if Comes_From_Source (Defining_Identifier (N)) then
6925 Set_Debug_Info_Needed (Defining_Identifier (N));
6928 -- Now call the routine to generate debug info for the renaming
6931 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
6933 if Present (Decl) then
6934 Insert_Action (N, Decl);
6940 -- Exception on library entity not available
6943 when RE_Not_Available =>
6945 end Expand_N_Object_Declaration;
6947 ---------------------------------
6948 -- Expand_N_Subtype_Indication --
6949 ---------------------------------
6951 -- Add a check on the range of the subtype. The static case is partially
6952 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
6953 -- to check here for the static case in order to avoid generating
6954 -- extraneous expanded code. Also deal with validity checking.
6956 procedure Expand_N_Subtype_Indication (N : Node_Id) is
6957 Ran : constant Node_Id := Range_Expression (Constraint (N));
6958 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
6961 if Nkind (Constraint (N)) = N_Range_Constraint then
6962 Validity_Check_Range (Range_Expression (Constraint (N)));
6965 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
6966 Apply_Range_Check (Ran, Typ);
6968 end Expand_N_Subtype_Indication;
6970 ---------------------------
6971 -- Expand_N_Variant_Part --
6972 ---------------------------
6974 -- Note: this procedure no longer has any effect. It used to be that we
6975 -- would replace the choices in the last variant by a when others, and
6976 -- also expanded static predicates in variant choices here, but both of
6977 -- those activities were being done too early, since we can't check the
6978 -- choices until the statically predicated subtypes are frozen, which can
6979 -- happen as late as the free point of the record, and we can't change the
6980 -- last choice to an others before checking the choices, which is now done
6981 -- at the freeze point of the record.
6983 procedure Expand_N_Variant_Part (N : Node_Id) is
6986 end Expand_N_Variant_Part;
6988 ---------------------------------
6989 -- Expand_Previous_Access_Type --
6990 ---------------------------------
6992 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
6993 Ptr_Typ : Entity_Id;
6996 -- Find all access types in the current scope whose designated type is
6997 -- Def_Id and build master renamings for them.
6999 Ptr_Typ := First_Entity (Current_Scope);
7000 while Present (Ptr_Typ) loop
7001 if Is_Access_Type (Ptr_Typ)
7002 and then Designated_Type (Ptr_Typ) = Def_Id
7003 and then No (Master_Id (Ptr_Typ))
7005 -- Ensure that the designated type has a master
7007 Build_Master_Entity (Def_Id);
7009 -- Private and incomplete types complicate the insertion of master
7010 -- renamings because the access type may precede the full view of
7011 -- the designated type. For this reason, the master renamings are
7012 -- inserted relative to the designated type.
7014 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
7017 Next_Entity (Ptr_Typ);
7019 end Expand_Previous_Access_Type;
7021 -----------------------------
7022 -- Expand_Record_Extension --
7023 -----------------------------
7025 -- Add a field _parent at the beginning of the record extension. This is
7026 -- used to implement inheritance. Here are some examples of expansion:
7028 -- 1. no discriminants
7029 -- type T2 is new T1 with null record;
7031 -- type T2 is new T1 with record
7035 -- 2. renamed discriminants
7036 -- type T2 (B, C : Int) is new T1 (A => B) with record
7037 -- _Parent : T1 (A => B);
7041 -- 3. inherited discriminants
7042 -- type T2 is new T1 with record -- discriminant A inherited
7043 -- _Parent : T1 (A);
7047 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
7048 Indic : constant Node_Id := Subtype_Indication (Def);
7049 Loc : constant Source_Ptr := Sloc (Def);
7050 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
7051 Par_Subtype : Entity_Id;
7052 Comp_List : Node_Id;
7053 Comp_Decl : Node_Id;
7056 List_Constr : constant List_Id := New_List;
7059 -- Expand_Record_Extension is called directly from the semantics, so
7060 -- we must check to see whether expansion is active before proceeding,
7061 -- because this affects the visibility of selected components in bodies
7064 if not Expander_Active then
7068 -- This may be a derivation of an untagged private type whose full
7069 -- view is tagged, in which case the Derived_Type_Definition has no
7070 -- extension part. Build an empty one now.
7072 if No (Rec_Ext_Part) then
7074 Make_Record_Definition (Loc,
7076 Component_List => Empty,
7077 Null_Present => True);
7079 Set_Record_Extension_Part (Def, Rec_Ext_Part);
7080 Mark_Rewrite_Insertion (Rec_Ext_Part);
7083 Comp_List := Component_List (Rec_Ext_Part);
7085 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
7087 -- If the derived type inherits its discriminants the type of the
7088 -- _parent field must be constrained by the inherited discriminants
7090 if Has_Discriminants (T)
7091 and then Nkind (Indic) /= N_Subtype_Indication
7092 and then not Is_Constrained (Entity (Indic))
7094 D := First_Discriminant (T);
7095 while Present (D) loop
7096 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
7097 Next_Discriminant (D);
7102 Make_Subtype_Indication (Loc,
7103 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
7105 Make_Index_Or_Discriminant_Constraint (Loc,
7106 Constraints => List_Constr)),
7109 -- Otherwise the original subtype_indication is just what is needed
7112 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
7115 Set_Parent_Subtype (T, Par_Subtype);
7118 Make_Component_Declaration (Loc,
7119 Defining_Identifier => Parent_N,
7120 Component_Definition =>
7121 Make_Component_Definition (Loc,
7122 Aliased_Present => False,
7123 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
7125 if Null_Present (Rec_Ext_Part) then
7126 Set_Component_List (Rec_Ext_Part,
7127 Make_Component_List (Loc,
7128 Component_Items => New_List (Comp_Decl),
7129 Variant_Part => Empty,
7130 Null_Present => False));
7131 Set_Null_Present (Rec_Ext_Part, False);
7133 elsif Null_Present (Comp_List)
7134 or else Is_Empty_List (Component_Items (Comp_List))
7136 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7137 Set_Null_Present (Comp_List, False);
7140 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7143 Analyze (Comp_Decl);
7144 end Expand_Record_Extension;
7146 ------------------------
7147 -- Expand_Tagged_Root --
7148 ------------------------
7150 procedure Expand_Tagged_Root (T : Entity_Id) is
7151 Def : constant Node_Id := Type_Definition (Parent (T));
7152 Comp_List : Node_Id;
7153 Comp_Decl : Node_Id;
7154 Sloc_N : Source_Ptr;
7157 if Null_Present (Def) then
7158 Set_Component_List (Def,
7159 Make_Component_List (Sloc (Def),
7160 Component_Items => Empty_List,
7161 Variant_Part => Empty,
7162 Null_Present => True));
7165 Comp_List := Component_List (Def);
7167 if Null_Present (Comp_List)
7168 or else Is_Empty_List (Component_Items (Comp_List))
7170 Sloc_N := Sloc (Comp_List);
7172 Sloc_N := Sloc (First (Component_Items (Comp_List)));
7176 Make_Component_Declaration (Sloc_N,
7177 Defining_Identifier => First_Tag_Component (T),
7178 Component_Definition =>
7179 Make_Component_Definition (Sloc_N,
7180 Aliased_Present => False,
7181 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
7183 if Null_Present (Comp_List)
7184 or else Is_Empty_List (Component_Items (Comp_List))
7186 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7187 Set_Null_Present (Comp_List, False);
7190 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7193 -- We don't Analyze the whole expansion because the tag component has
7194 -- already been analyzed previously. Here we just insure that the tree
7195 -- is coherent with the semantic decoration
7197 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
7200 when RE_Not_Available =>
7202 end Expand_Tagged_Root;
7204 ------------------------------
7205 -- Freeze_Stream_Operations --
7206 ------------------------------
7208 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
7209 Names : constant array (1 .. 4) of TSS_Name_Type :=
7214 Stream_Op : Entity_Id;
7217 -- Primitive operations of tagged types are frozen when the dispatch
7218 -- table is constructed.
7220 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
7224 for J in Names'Range loop
7225 Stream_Op := TSS (Typ, Names (J));
7227 if Present (Stream_Op)
7228 and then Is_Subprogram (Stream_Op)
7229 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
7230 N_Subprogram_Declaration
7231 and then not Is_Frozen (Stream_Op)
7233 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
7236 end Freeze_Stream_Operations;
7242 -- Full type declarations are expanded at the point at which the type is
7243 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
7244 -- declarations generated by the freezing (e.g. the procedure generated
7245 -- for initialization) are chained in the Actions field list of the freeze
7246 -- node using Append_Freeze_Actions.
7248 -- WARNING: This routine manages Ghost regions. Return statements must be
7249 -- replaced by gotos which jump to the end of the routine and restore the
7252 function Freeze_Type (N : Node_Id) return Boolean is
7253 procedure Process_RACW_Types (Typ : Entity_Id);
7254 -- Validate and generate stubs for all RACW types associated with type
7257 procedure Process_Pending_Access_Types (Typ : Entity_Id);
7258 -- Associate type Typ's Finalize_Address primitive with the finalization
7259 -- masters of pending access-to-Typ types.
7261 ------------------------
7262 -- Process_RACW_Types --
7263 ------------------------
7265 procedure Process_RACW_Types (Typ : Entity_Id) is
7266 List : constant Elist_Id := Access_Types_To_Process (N);
7268 Seen : Boolean := False;
7271 if Present (List) then
7272 E := First_Elmt (List);
7273 while Present (E) loop
7274 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
7275 Validate_RACW_Primitives (Node (E));
7283 -- If there are RACWs designating this type, make stubs now
7286 Remote_Types_Tagged_Full_View_Encountered (Typ);
7288 end Process_RACW_Types;
7290 ----------------------------------
7291 -- Process_Pending_Access_Types --
7292 ----------------------------------
7294 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
7298 -- Finalize_Address is not generated in CodePeer mode because the
7299 -- body contains address arithmetic. This processing is disabled.
7301 if CodePeer_Mode then
7304 -- Certain itypes are generated for contexts that cannot allocate
7305 -- objects and should not set primitive Finalize_Address.
7307 elsif Is_Itype (Typ)
7308 and then Nkind (Associated_Node_For_Itype (Typ)) =
7309 N_Explicit_Dereference
7313 -- When an access type is declared after the incomplete view of a
7314 -- Taft-amendment type, the access type is considered pending in
7315 -- case the full view of the Taft-amendment type is controlled. If
7316 -- this is indeed the case, associate the Finalize_Address routine
7317 -- of the full view with the finalization masters of all pending
7318 -- access types. This scenario applies to anonymous access types as
7321 elsif Needs_Finalization (Typ)
7322 and then Present (Pending_Access_Types (Typ))
7324 E := First_Elmt (Pending_Access_Types (Typ));
7325 while Present (E) loop
7328 -- Set_Finalize_Address
7329 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
7331 Append_Freeze_Action (Typ,
7332 Make_Set_Finalize_Address_Call
7334 Ptr_Typ => Node (E)));
7339 end Process_Pending_Access_Types;
7343 Def_Id : constant Entity_Id := Entity (N);
7345 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
7346 -- Save the Ghost mode to restore on exit
7348 Result : Boolean := False;
7350 -- Start of processing for Freeze_Type
7353 -- The type being frozen may be subject to pragma Ghost. Set the mode
7354 -- now to ensure that any nodes generated during freezing are properly
7357 Set_Ghost_Mode (Def_Id);
7359 -- Process any remote access-to-class-wide types designating the type
7362 Process_RACW_Types (Def_Id);
7364 -- Freeze processing for record types
7366 if Is_Record_Type (Def_Id) then
7367 if Ekind (Def_Id) = E_Record_Type then
7368 Expand_Freeze_Record_Type (N);
7369 elsif Is_Class_Wide_Type (Def_Id) then
7370 Expand_Freeze_Class_Wide_Type (N);
7373 -- Freeze processing for array types
7375 elsif Is_Array_Type (Def_Id) then
7376 Expand_Freeze_Array_Type (N);
7378 -- Freeze processing for access types
7380 -- For pool-specific access types, find out the pool object used for
7381 -- this type, needs actual expansion of it in some cases. Here are the
7382 -- different cases :
7384 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
7385 -- ---> don't use any storage pool
7387 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
7389 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
7391 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7392 -- ---> Storage Pool is the specified one
7394 -- See GNAT Pool packages in the Run-Time for more details
7396 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
7398 Loc : constant Source_Ptr := Sloc (N);
7399 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
7401 Freeze_Action_Typ : Entity_Id;
7402 Pool_Object : Entity_Id;
7407 -- Rep Clause "for Def_Id'Storage_Size use 0;"
7408 -- ---> don't use any storage pool
7410 if No_Pool_Assigned (Def_Id) then
7415 -- Rep Clause : for Def_Id'Storage_Size use Expr.
7417 -- Def_Id__Pool : Stack_Bounded_Pool
7418 -- (Expr, DT'Size, DT'Alignment);
7420 elsif Has_Storage_Size_Clause (Def_Id) then
7426 -- For unconstrained composite types we give a size of zero
7427 -- so that the pool knows that it needs a special algorithm
7428 -- for variable size object allocation.
7430 if Is_Composite_Type (Desig_Type)
7431 and then not Is_Constrained (Desig_Type)
7433 DT_Size := Make_Integer_Literal (Loc, 0);
7434 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
7438 Make_Attribute_Reference (Loc,
7439 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7440 Attribute_Name => Name_Max_Size_In_Storage_Elements);
7443 Make_Attribute_Reference (Loc,
7444 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7445 Attribute_Name => Name_Alignment);
7449 Make_Defining_Identifier (Loc,
7450 Chars => New_External_Name (Chars (Def_Id), 'P'));
7452 -- We put the code associated with the pools in the entity
7453 -- that has the later freeze node, usually the access type
7454 -- but it can also be the designated_type; because the pool
7455 -- code requires both those types to be frozen
7457 if Is_Frozen (Desig_Type)
7458 and then (No (Freeze_Node (Desig_Type))
7459 or else Analyzed (Freeze_Node (Desig_Type)))
7461 Freeze_Action_Typ := Def_Id;
7463 -- A Taft amendment type cannot get the freeze actions
7464 -- since the full view is not there.
7466 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
7467 and then No (Full_View (Desig_Type))
7469 Freeze_Action_Typ := Def_Id;
7472 Freeze_Action_Typ := Desig_Type;
7475 Append_Freeze_Action (Freeze_Action_Typ,
7476 Make_Object_Declaration (Loc,
7477 Defining_Identifier => Pool_Object,
7478 Object_Definition =>
7479 Make_Subtype_Indication (Loc,
7482 (RTE (RE_Stack_Bounded_Pool), Loc),
7485 Make_Index_Or_Discriminant_Constraint (Loc,
7486 Constraints => New_List (
7488 -- First discriminant is the Pool Size
7491 Storage_Size_Variable (Def_Id), Loc),
7493 -- Second discriminant is the element size
7497 -- Third discriminant is the alignment
7502 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
7506 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7507 -- ---> Storage Pool is the specified one
7509 -- When compiling in Ada 2012 mode, ensure that the accessibility
7510 -- level of the subpool access type is not deeper than that of the
7511 -- pool_with_subpools.
7513 elsif Ada_Version >= Ada_2012
7514 and then Present (Associated_Storage_Pool (Def_Id))
7516 -- Omit this check for the case of a configurable run-time that
7517 -- does not provide package System.Storage_Pools.Subpools.
7519 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
7522 Loc : constant Source_Ptr := Sloc (Def_Id);
7523 Pool : constant Entity_Id :=
7524 Associated_Storage_Pool (Def_Id);
7525 RSPWS : constant Entity_Id :=
7526 RTE (RE_Root_Storage_Pool_With_Subpools);
7529 -- It is known that the accessibility level of the access
7530 -- type is deeper than that of the pool.
7532 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
7533 and then not Accessibility_Checks_Suppressed (Def_Id)
7534 and then not Accessibility_Checks_Suppressed (Pool)
7536 -- Static case: the pool is known to be a descendant of
7537 -- Root_Storage_Pool_With_Subpools.
7539 if Is_Ancestor (RSPWS, Etype (Pool)) then
7541 ("??subpool access type has deeper accessibility "
7542 & "level than pool", Def_Id);
7544 Append_Freeze_Action (Def_Id,
7545 Make_Raise_Program_Error (Loc,
7546 Reason => PE_Accessibility_Check_Failed));
7548 -- Dynamic case: when the pool is of a class-wide type,
7549 -- it may or may not support subpools depending on the
7550 -- path of derivation. Generate:
7552 -- if Def_Id in RSPWS'Class then
7553 -- raise Program_Error;
7556 elsif Is_Class_Wide_Type (Etype (Pool)) then
7557 Append_Freeze_Action (Def_Id,
7558 Make_If_Statement (Loc,
7561 Left_Opnd => New_Occurrence_Of (Pool, Loc),
7564 (Class_Wide_Type (RSPWS), Loc)),
7566 Then_Statements => New_List (
7567 Make_Raise_Program_Error (Loc,
7568 Reason => PE_Accessibility_Check_Failed))));
7574 -- For access-to-controlled types (including class-wide types and
7575 -- Taft-amendment types, which potentially have controlled
7576 -- components), expand the list controller object that will store
7577 -- the dynamically allocated objects. Don't do this transformation
7578 -- for expander-generated access types, but do it for types that
7579 -- are the full view of types derived from other private types.
7580 -- Also suppress the list controller in the case of a designated
7581 -- type with convention Java, since this is used when binding to
7582 -- Java API specs, where there's no equivalent of a finalization
7583 -- list and we don't want to pull in the finalization support if
7586 if not Comes_From_Source (Def_Id)
7587 and then not Has_Private_Declaration (Def_Id)
7591 -- An exception is made for types defined in the run-time because
7592 -- Ada.Tags.Tag itself is such a type and cannot afford this
7593 -- unnecessary overhead that would generates a loop in the
7594 -- expansion scheme. Another exception is if Restrictions
7595 -- (No_Finalization) is active, since then we know nothing is
7598 elsif Restriction_Active (No_Finalization)
7599 or else In_Runtime (Def_Id)
7603 -- Create a finalization master for an access-to-controlled type
7604 -- or an access-to-incomplete type. It is assumed that the full
7605 -- view will be controlled.
7607 elsif Needs_Finalization (Desig_Type)
7608 or else (Is_Incomplete_Type (Desig_Type)
7609 and then No (Full_View (Desig_Type)))
7611 Build_Finalization_Master (Def_Id);
7613 -- Create a finalization master when the designated type contains
7614 -- a private component. It is assumed that the full view will be
7617 elsif Has_Private_Component (Desig_Type) then
7618 Build_Finalization_Master
7620 For_Private => True,
7621 Context_Scope => Scope (Def_Id),
7622 Insertion_Node => Declaration_Node (Desig_Type));
7626 -- Freeze processing for enumeration types
7628 elsif Ekind (Def_Id) = E_Enumeration_Type then
7630 -- We only have something to do if we have a non-standard
7631 -- representation (i.e. at least one literal whose pos value
7632 -- is not the same as its representation)
7634 if Has_Non_Standard_Rep (Def_Id) then
7635 Expand_Freeze_Enumeration_Type (N);
7638 -- Private types that are completed by a derivation from a private
7639 -- type have an internally generated full view, that needs to be
7640 -- frozen. This must be done explicitly because the two views share
7641 -- the freeze node, and the underlying full view is not visible when
7642 -- the freeze node is analyzed.
7644 elsif Is_Private_Type (Def_Id)
7645 and then Is_Derived_Type (Def_Id)
7646 and then Present (Full_View (Def_Id))
7647 and then Is_Itype (Full_View (Def_Id))
7648 and then Has_Private_Declaration (Full_View (Def_Id))
7649 and then Freeze_Node (Full_View (Def_Id)) = N
7651 Set_Entity (N, Full_View (Def_Id));
7652 Result := Freeze_Type (N);
7653 Set_Entity (N, Def_Id);
7655 -- All other types require no expander action. There are such cases
7656 -- (e.g. task types and protected types). In such cases, the freeze
7657 -- nodes are there for use by Gigi.
7661 -- Complete the initialization of all pending access types' finalization
7662 -- masters now that the designated type has been is frozen and primitive
7663 -- Finalize_Address generated.
7665 Process_Pending_Access_Types (Def_Id);
7666 Freeze_Stream_Operations (N, Def_Id);
7668 -- Generate the [spec and] body of the procedure tasked with the runtime
7669 -- verification of pragma Default_Initial_Condition's expression.
7671 if Has_DIC (Def_Id) then
7672 Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
7675 -- Generate the [spec and] body of the invariant procedure tasked with
7676 -- the runtime verification of all invariants that pertain to the type.
7677 -- This includes invariants on the partial and full view, inherited
7678 -- class-wide invariants from parent types or interfaces, and invariants
7679 -- on array elements or record components.
7681 if Is_Interface (Def_Id) then
7683 -- Interfaces are treated as the partial view of a private type in
7684 -- order to achieve uniformity with the general case. As a result, an
7685 -- interface receives only a "partial" invariant procedure which is
7688 if Has_Own_Invariants (Def_Id) then
7689 Build_Invariant_Procedure_Body
7691 Partial_Invariant => Is_Interface (Def_Id));
7694 -- Non-interface types
7696 -- Do not generate invariant procedure within other assertion
7697 -- subprograms, which may involve local declarations of local
7698 -- subtypes to which these checks do not apply.
7700 elsif Has_Invariants (Def_Id) then
7701 if Within_Internal_Subprogram
7702 or else (Ekind (Current_Scope) = E_Function
7703 and then Is_Predicate_Function (Current_Scope))
7707 Build_Invariant_Procedure_Body (Def_Id);
7711 Restore_Ghost_Mode (Saved_GM);
7716 when RE_Not_Available =>
7717 Restore_Ghost_Mode (Saved_GM);
7722 -------------------------
7723 -- Get_Simple_Init_Val --
7724 -------------------------
7726 function Get_Simple_Init_Val
7729 Size : Uint := No_Uint) return Node_Id
7731 Loc : constant Source_Ptr := Sloc (N);
7737 -- This is the size to be used for computation of the appropriate
7738 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
7740 IV_Attribute : constant Boolean :=
7741 Nkind (N) = N_Attribute_Reference
7742 and then Attribute_Name (N) = Name_Invalid_Value;
7746 -- These are the values computed by the procedure Check_Subtype_Bounds
7748 procedure Check_Subtype_Bounds;
7749 -- This procedure examines the subtype T, and its ancestor subtypes and
7750 -- derived types to determine the best known information about the
7751 -- bounds of the subtype. After the call Lo_Bound is set either to
7752 -- No_Uint if no information can be determined, or to a value which
7753 -- represents a known low bound, i.e. a valid value of the subtype can
7754 -- not be less than this value. Hi_Bound is similarly set to a known
7755 -- high bound (valid value cannot be greater than this).
7757 --------------------------
7758 -- Check_Subtype_Bounds --
7759 --------------------------
7761 procedure Check_Subtype_Bounds is
7770 Lo_Bound := No_Uint;
7771 Hi_Bound := No_Uint;
7773 -- Loop to climb ancestor subtypes and derived types
7777 if not Is_Discrete_Type (ST1) then
7781 Lo := Type_Low_Bound (ST1);
7782 Hi := Type_High_Bound (ST1);
7784 if Compile_Time_Known_Value (Lo) then
7785 Loval := Expr_Value (Lo);
7787 if Lo_Bound = No_Uint or else Lo_Bound < Loval then
7792 if Compile_Time_Known_Value (Hi) then
7793 Hival := Expr_Value (Hi);
7795 if Hi_Bound = No_Uint or else Hi_Bound > Hival then
7800 ST2 := Ancestor_Subtype (ST1);
7806 exit when ST1 = ST2;
7809 end Check_Subtype_Bounds;
7811 -- Start of processing for Get_Simple_Init_Val
7814 -- For a private type, we should always have an underlying type (because
7815 -- this was already checked in Needs_Simple_Initialization). What we do
7816 -- is to get the value for the underlying type and then do an unchecked
7817 -- conversion to the private type.
7819 if Is_Private_Type (T) then
7820 Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
7822 -- A special case, if the underlying value is null, then qualify it
7823 -- with the underlying type, so that the null is properly typed.
7824 -- Similarly, if it is an aggregate it must be qualified, because an
7825 -- unchecked conversion does not provide a context for it.
7827 if Nkind_In (Val, N_Null, N_Aggregate) then
7829 Make_Qualified_Expression (Loc,
7831 New_Occurrence_Of (Underlying_Type (T), Loc),
7835 Result := Unchecked_Convert_To (T, Val);
7837 -- Don't truncate result (important for Initialize/Normalize_Scalars)
7839 if Nkind (Result) = N_Unchecked_Type_Conversion
7840 and then Is_Scalar_Type (Underlying_Type (T))
7842 Set_No_Truncation (Result);
7847 -- Scalars with Default_Value aspect. The first subtype may now be
7848 -- private, so retrieve value from underlying type.
7850 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
7851 if Is_Private_Type (First_Subtype (T)) then
7852 return Unchecked_Convert_To (T,
7853 Default_Aspect_Value (Full_View (First_Subtype (T))));
7856 Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
7859 -- Otherwise, for scalars, we must have normalize/initialize scalars
7860 -- case, or if the node N is an 'Invalid_Value attribute node.
7862 elsif Is_Scalar_Type (T) then
7863 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
7865 -- Compute size of object. If it is given by the caller, we can use
7866 -- it directly, otherwise we use Esize (T) as an estimate. As far as
7867 -- we know this covers all cases correctly.
7869 if Size = No_Uint or else Size <= Uint_0 then
7870 Size_To_Use := UI_Max (Uint_1, Esize (T));
7872 Size_To_Use := Size;
7875 -- Maximum size to use is 64 bits, since we will create values of
7876 -- type Unsigned_64 and the range must fit this type.
7878 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
7879 Size_To_Use := Uint_64;
7882 -- Check known bounds of subtype
7884 Check_Subtype_Bounds;
7886 -- Processing for Normalize_Scalars case
7888 if Normalize_Scalars and then not IV_Attribute then
7890 -- If zero is invalid, it is a convenient value to use that is
7891 -- for sure an appropriate invalid value in all situations.
7893 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7894 Val := Make_Integer_Literal (Loc, 0);
7896 -- Cases where all one bits is the appropriate invalid value
7898 -- For modular types, all 1 bits is either invalid or valid. If
7899 -- it is valid, then there is nothing that can be done since there
7900 -- are no invalid values (we ruled out zero already).
7902 -- For signed integer types that have no negative values, either
7903 -- there is room for negative values, or there is not. If there
7904 -- is, then all 1-bits may be interpreted as minus one, which is
7905 -- certainly invalid. Alternatively it is treated as the largest
7906 -- positive value, in which case the observation for modular types
7909 -- For float types, all 1-bits is a NaN (not a number), which is
7910 -- certainly an appropriately invalid value.
7912 elsif Is_Unsigned_Type (T)
7913 or else Is_Floating_Point_Type (T)
7914 or else Is_Enumeration_Type (T)
7916 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
7918 -- Resolve as Unsigned_64, because the largest number we can
7919 -- generate is out of range of universal integer.
7921 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
7923 -- Case of signed types
7927 Signed_Size : constant Uint :=
7928 UI_Min (Uint_63, Size_To_Use - 1);
7931 -- Normally we like to use the most negative number. The one
7932 -- exception is when this number is in the known subtype
7933 -- range and the largest positive number is not in the known
7936 -- For this exceptional case, use largest positive value
7938 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
7939 and then Lo_Bound <= (-(2 ** Signed_Size))
7940 and then Hi_Bound < 2 ** Signed_Size
7942 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
7944 -- Normal case of largest negative value
7947 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
7952 -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
7955 -- For float types, use float values from System.Scalar_Values
7957 if Is_Floating_Point_Type (T) then
7958 if Root_Type (T) = Standard_Short_Float then
7959 Val_RE := RE_IS_Isf;
7960 elsif Root_Type (T) = Standard_Float then
7961 Val_RE := RE_IS_Ifl;
7962 elsif Root_Type (T) = Standard_Long_Float then
7963 Val_RE := RE_IS_Ilf;
7964 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
7965 Val_RE := RE_IS_Ill;
7968 -- If zero is invalid, use zero values from System.Scalar_Values
7970 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7971 if Size_To_Use <= 8 then
7972 Val_RE := RE_IS_Iz1;
7973 elsif Size_To_Use <= 16 then
7974 Val_RE := RE_IS_Iz2;
7975 elsif Size_To_Use <= 32 then
7976 Val_RE := RE_IS_Iz4;
7978 Val_RE := RE_IS_Iz8;
7981 -- For unsigned, use unsigned values from System.Scalar_Values
7983 elsif Is_Unsigned_Type (T) then
7984 if Size_To_Use <= 8 then
7985 Val_RE := RE_IS_Iu1;
7986 elsif Size_To_Use <= 16 then
7987 Val_RE := RE_IS_Iu2;
7988 elsif Size_To_Use <= 32 then
7989 Val_RE := RE_IS_Iu4;
7991 Val_RE := RE_IS_Iu8;
7994 -- For signed, use signed values from System.Scalar_Values
7997 if Size_To_Use <= 8 then
7998 Val_RE := RE_IS_Is1;
7999 elsif Size_To_Use <= 16 then
8000 Val_RE := RE_IS_Is2;
8001 elsif Size_To_Use <= 32 then
8002 Val_RE := RE_IS_Is4;
8004 Val_RE := RE_IS_Is8;
8008 Val := New_Occurrence_Of (RTE (Val_RE), Loc);
8011 -- The final expression is obtained by doing an unchecked conversion
8012 -- of this result to the base type of the required subtype. Use the
8013 -- base type to prevent the unchecked conversion from chopping bits,
8014 -- and then we set Kill_Range_Check to preserve the "bad" value.
8016 Result := Unchecked_Convert_To (Base_Type (T), Val);
8018 -- Ensure result is not truncated, since we want the "bad" bits, and
8019 -- also kill range check on result.
8021 if Nkind (Result) = N_Unchecked_Type_Conversion then
8022 Set_No_Truncation (Result);
8023 Set_Kill_Range_Check (Result, True);
8028 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
8030 elsif Is_Standard_String_Type (T) then
8031 pragma Assert (Init_Or_Norm_Scalars);
8034 Make_Aggregate (Loc,
8035 Component_Associations => New_List (
8036 Make_Component_Association (Loc,
8037 Choices => New_List (
8038 Make_Others_Choice (Loc)),
8041 (Component_Type (T), N, Esize (Root_Type (T))))));
8043 -- Access type is initialized to null
8045 elsif Is_Access_Type (T) then
8046 return Make_Null (Loc);
8048 -- No other possibilities should arise, since we should only be calling
8049 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
8050 -- indicating one of the above cases held.
8053 raise Program_Error;
8057 when RE_Not_Available =>
8059 end Get_Simple_Init_Val;
8061 ------------------------------
8062 -- Has_New_Non_Standard_Rep --
8063 ------------------------------
8065 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
8067 if not Is_Derived_Type (T) then
8068 return Has_Non_Standard_Rep (T)
8069 or else Has_Non_Standard_Rep (Root_Type (T));
8071 -- If Has_Non_Standard_Rep is not set on the derived type, the
8072 -- representation is fully inherited.
8074 elsif not Has_Non_Standard_Rep (T) then
8078 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
8080 -- May need a more precise check here: the First_Rep_Item may be a
8081 -- stream attribute, which does not affect the representation of the
8085 end Has_New_Non_Standard_Rep;
8087 ----------------------
8088 -- Inline_Init_Proc --
8089 ----------------------
8091 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
8093 -- The initialization proc of protected records is not worth inlining.
8094 -- In addition, when compiled for another unit for inlining purposes,
8095 -- it may make reference to entities that have not been elaborated yet.
8096 -- The initialization proc of records that need finalization contains
8097 -- a nested clean-up procedure that makes it impractical to inline as
8098 -- well, except for simple controlled types themselves. And similar
8099 -- considerations apply to task types.
8101 if Is_Concurrent_Type (Typ) then
8104 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
8107 elsif Has_Task (Typ) then
8113 end Inline_Init_Proc;
8119 function In_Runtime (E : Entity_Id) return Boolean is
8124 while Scope (S1) /= Standard_Standard loop
8128 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
8131 ----------------------------
8132 -- Initialization_Warning --
8133 ----------------------------
8135 procedure Initialization_Warning (E : Entity_Id) is
8136 Warning_Needed : Boolean;
8139 Warning_Needed := False;
8141 if Ekind (Current_Scope) = E_Package
8142 and then Static_Elaboration_Desired (Current_Scope)
8145 if Is_Record_Type (E) then
8146 if Has_Discriminants (E)
8147 or else Is_Limited_Type (E)
8148 or else Has_Non_Standard_Rep (E)
8150 Warning_Needed := True;
8153 -- Verify that at least one component has an initialization
8154 -- expression. No need for a warning on a type if all its
8155 -- components have no initialization.
8161 Comp := First_Component (E);
8162 while Present (Comp) loop
8163 if Ekind (Comp) = E_Discriminant
8165 (Nkind (Parent (Comp)) = N_Component_Declaration
8166 and then Present (Expression (Parent (Comp))))
8168 Warning_Needed := True;
8172 Next_Component (Comp);
8177 if Warning_Needed then
8179 ("Objects of the type cannot be initialized statically "
8180 & "by default??", Parent (E));
8185 Error_Msg_N ("Object cannot be initialized statically??", E);
8188 end Initialization_Warning;
8194 function Init_Formals (Typ : Entity_Id) return List_Id is
8195 Loc : constant Source_Ptr := Sloc (Typ);
8199 -- First parameter is always _Init : in out typ. Note that we need this
8200 -- to be in/out because in the case of the task record value, there
8201 -- are default record fields (_Priority, _Size, -Task_Info) that may
8202 -- be referenced in the generated initialization routine.
8204 Formals := New_List (
8205 Make_Parameter_Specification (Loc,
8206 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
8208 Out_Present => True,
8209 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
8211 -- For task record value, or type that contains tasks, add two more
8212 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
8213 -- We also add these parameters for the task record type case.
8216 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
8219 Make_Parameter_Specification (Loc,
8220 Defining_Identifier =>
8221 Make_Defining_Identifier (Loc, Name_uMaster),
8223 New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
8225 -- Add _Chain (not done for sequential elaboration policy, see
8226 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
8228 if Partition_Elaboration_Policy /= 'S' then
8230 Make_Parameter_Specification (Loc,
8231 Defining_Identifier =>
8232 Make_Defining_Identifier (Loc, Name_uChain),
8234 Out_Present => True,
8236 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
8240 Make_Parameter_Specification (Loc,
8241 Defining_Identifier =>
8242 Make_Defining_Identifier (Loc, Name_uTask_Name),
8244 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
8250 when RE_Not_Available =>
8254 -------------------------
8255 -- Init_Secondary_Tags --
8256 -------------------------
8258 procedure Init_Secondary_Tags
8261 Init_Tags_List : List_Id;
8262 Stmts_List : List_Id;
8263 Fixed_Comps : Boolean := True;
8264 Variable_Comps : Boolean := True)
8266 Loc : constant Source_Ptr := Sloc (Target);
8268 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
8269 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8271 procedure Initialize_Tag
8274 Tag_Comp : Entity_Id;
8275 Iface_Tag : Node_Id);
8276 -- Initialize the tag of the secondary dispatch table of Typ associated
8277 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8278 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
8279 -- of Typ CPP tagged type we generate code to inherit the contents of
8280 -- the dispatch table directly from the ancestor.
8282 --------------------
8283 -- Initialize_Tag --
8284 --------------------
8286 procedure Initialize_Tag
8289 Tag_Comp : Entity_Id;
8290 Iface_Tag : Node_Id)
8292 Comp_Typ : Entity_Id;
8293 Offset_To_Top_Comp : Entity_Id := Empty;
8296 -- Initialize pointer to secondary DT associated with the interface
8298 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8299 Append_To (Init_Tags_List,
8300 Make_Assignment_Statement (Loc,
8302 Make_Selected_Component (Loc,
8303 Prefix => New_Copy_Tree (Target),
8304 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8306 New_Occurrence_Of (Iface_Tag, Loc)));
8309 Comp_Typ := Scope (Tag_Comp);
8311 -- Initialize the entries of the table of interfaces. We generate a
8312 -- different call when the parent of the type has variable size
8315 if Comp_Typ /= Etype (Comp_Typ)
8316 and then Is_Variable_Size_Record (Etype (Comp_Typ))
8317 and then Chars (Tag_Comp) /= Name_uTag
8319 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
8321 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
8322 -- configurable run-time environment.
8324 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
8326 ("variable size record with interface types", Typ);
8331 -- Set_Dynamic_Offset_To_Top
8333 -- Prim_T => Typ'Tag,
8334 -- Interface_T => Iface'Tag,
8335 -- Offset_Value => n,
8336 -- Offset_Func => Fn'Address)
8338 Append_To (Stmts_List,
8339 Make_Procedure_Call_Statement (Loc,
8341 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
8342 Parameter_Associations => New_List (
8343 Make_Attribute_Reference (Loc,
8344 Prefix => New_Copy_Tree (Target),
8345 Attribute_Name => Name_Address),
8347 Unchecked_Convert_To (RTE (RE_Tag),
8349 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
8351 Unchecked_Convert_To (RTE (RE_Tag),
8353 (Node (First_Elmt (Access_Disp_Table (Iface))),
8356 Unchecked_Convert_To
8357 (RTE (RE_Storage_Offset),
8358 Make_Attribute_Reference (Loc,
8360 Make_Selected_Component (Loc,
8361 Prefix => New_Copy_Tree (Target),
8363 New_Occurrence_Of (Tag_Comp, Loc)),
8364 Attribute_Name => Name_Position)),
8366 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
8367 Make_Attribute_Reference (Loc,
8368 Prefix => New_Occurrence_Of
8369 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
8370 Attribute_Name => Name_Address)))));
8372 -- In this case the next component stores the value of the offset
8375 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
8376 pragma Assert (Present (Offset_To_Top_Comp));
8378 Append_To (Init_Tags_List,
8379 Make_Assignment_Statement (Loc,
8381 Make_Selected_Component (Loc,
8382 Prefix => New_Copy_Tree (Target),
8384 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
8387 Make_Attribute_Reference (Loc,
8389 Make_Selected_Component (Loc,
8390 Prefix => New_Copy_Tree (Target),
8391 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8392 Attribute_Name => Name_Position)));
8394 -- Normal case: No discriminants in the parent type
8397 -- Don't need to set any value if the offset-to-top field is
8398 -- statically set or if this interface shares the primary
8401 if not Building_Static_Secondary_DT (Typ)
8402 and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
8404 Append_To (Stmts_List,
8405 Build_Set_Static_Offset_To_Top (Loc,
8406 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
8408 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8409 Make_Attribute_Reference (Loc,
8411 Make_Selected_Component (Loc,
8412 Prefix => New_Copy_Tree (Target),
8414 New_Occurrence_Of (Tag_Comp, Loc)),
8415 Attribute_Name => Name_Position))));
8419 -- Register_Interface_Offset
8420 -- (Prim_T => Typ'Tag,
8421 -- Interface_T => Iface'Tag,
8422 -- Is_Constant => True,
8423 -- Offset_Value => n,
8424 -- Offset_Func => null);
8426 if RTE_Available (RE_Register_Interface_Offset) then
8427 Append_To (Stmts_List,
8428 Make_Procedure_Call_Statement (Loc,
8431 (RTE (RE_Register_Interface_Offset), Loc),
8432 Parameter_Associations => New_List (
8433 Unchecked_Convert_To (RTE (RE_Tag),
8435 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
8437 Unchecked_Convert_To (RTE (RE_Tag),
8439 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
8441 New_Occurrence_Of (Standard_True, Loc),
8443 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8444 Make_Attribute_Reference (Loc,
8446 Make_Selected_Component (Loc,
8447 Prefix => New_Copy_Tree (Target),
8449 New_Occurrence_Of (Tag_Comp, Loc)),
8450 Attribute_Name => Name_Position)),
8459 Full_Typ : Entity_Id;
8460 Ifaces_List : Elist_Id;
8461 Ifaces_Comp_List : Elist_Id;
8462 Ifaces_Tag_List : Elist_Id;
8463 Iface_Elmt : Elmt_Id;
8464 Iface_Comp_Elmt : Elmt_Id;
8465 Iface_Tag_Elmt : Elmt_Id;
8467 In_Variable_Pos : Boolean;
8469 -- Start of processing for Init_Secondary_Tags
8472 -- Handle private types
8474 if Present (Full_View (Typ)) then
8475 Full_Typ := Full_View (Typ);
8480 Collect_Interfaces_Info
8481 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
8483 Iface_Elmt := First_Elmt (Ifaces_List);
8484 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
8485 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
8486 while Present (Iface_Elmt) loop
8487 Tag_Comp := Node (Iface_Comp_Elmt);
8489 -- Check if parent of record type has variable size components
8491 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
8492 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
8494 -- If we are compiling under the CPP full ABI compatibility mode and
8495 -- the ancestor is a CPP_Pragma tagged type then we generate code to
8496 -- initialize the secondary tag components from tags that reference
8497 -- secondary tables filled with copy of parent slots.
8499 if Is_CPP_Class (Root_Type (Full_Typ)) then
8501 -- Reject interface components located at variable offset in
8502 -- C++ derivations. This is currently unsupported.
8504 if not Fixed_Comps and then In_Variable_Pos then
8506 -- Locate the first dynamic component of the record. Done to
8507 -- improve the text of the warning.
8511 Comp_Typ : Entity_Id;
8514 Comp := First_Entity (Typ);
8515 while Present (Comp) loop
8516 Comp_Typ := Etype (Comp);
8518 if Ekind (Comp) /= E_Discriminant
8519 and then not Is_Tag (Comp)
8522 (Is_Record_Type (Comp_Typ)
8524 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
8526 (Is_Array_Type (Comp_Typ)
8527 and then Is_Variable_Size_Array (Comp_Typ));
8533 pragma Assert (Present (Comp));
8534 Error_Msg_Node_2 := Comp;
8536 ("parent type & with dynamic component & cannot be parent"
8537 & " of 'C'P'P derivation if new interfaces are present",
8538 Typ, Scope (Original_Record_Component (Comp)));
8541 Sloc (Scope (Original_Record_Component (Comp)));
8543 ("type derived from 'C'P'P type & defined #",
8544 Typ, Scope (Original_Record_Component (Comp)));
8546 -- Avoid duplicated warnings
8551 -- Initialize secondary tags
8554 Append_To (Init_Tags_List,
8555 Make_Assignment_Statement (Loc,
8557 Make_Selected_Component (Loc,
8558 Prefix => New_Copy_Tree (Target),
8560 New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
8562 New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
8565 -- Otherwise generate code to initialize the tag
8568 if (In_Variable_Pos and then Variable_Comps)
8569 or else (not In_Variable_Pos and then Fixed_Comps)
8571 Initialize_Tag (Full_Typ,
8572 Iface => Node (Iface_Elmt),
8573 Tag_Comp => Tag_Comp,
8574 Iface_Tag => Node (Iface_Tag_Elmt));
8578 Next_Elmt (Iface_Elmt);
8579 Next_Elmt (Iface_Comp_Elmt);
8580 Next_Elmt (Iface_Tag_Elmt);
8582 end Init_Secondary_Tags;
8584 ------------------------
8585 -- Is_User_Defined_Eq --
8586 ------------------------
8588 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
8590 return Chars (Prim) = Name_Op_Eq
8591 and then Etype (First_Formal (Prim)) =
8592 Etype (Next_Formal (First_Formal (Prim)))
8593 and then Base_Type (Etype (Prim)) = Standard_Boolean;
8594 end Is_User_Defined_Equality;
8596 ----------------------------------------
8597 -- Make_Controlling_Function_Wrappers --
8598 ----------------------------------------
8600 procedure Make_Controlling_Function_Wrappers
8601 (Tag_Typ : Entity_Id;
8602 Decl_List : out List_Id;
8603 Body_List : out List_Id)
8605 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8606 Prim_Elmt : Elmt_Id;
8608 Actual_List : List_Id;
8609 Formal_List : List_Id;
8611 Par_Formal : Entity_Id;
8612 Formal_Node : Node_Id;
8613 Func_Body : Node_Id;
8614 Func_Decl : Node_Id;
8615 Func_Spec : Node_Id;
8616 Return_Stmt : Node_Id;
8619 Decl_List := New_List;
8620 Body_List := New_List;
8622 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8623 while Present (Prim_Elmt) loop
8624 Subp := Node (Prim_Elmt);
8626 -- If a primitive function with a controlling result of the type has
8627 -- not been overridden by the user, then we must create a wrapper
8628 -- function here that effectively overrides it and invokes the
8629 -- (non-abstract) parent function. This can only occur for a null
8630 -- extension. Note that functions with anonymous controlling access
8631 -- results don't qualify and must be overridden. We also exclude
8632 -- Input attributes, since each type will have its own version of
8633 -- Input constructed by the expander. The test for Comes_From_Source
8634 -- is needed to distinguish inherited operations from renamings
8635 -- (which also have Alias set). We exclude internal entities with
8636 -- Interface_Alias to avoid generating duplicated wrappers since
8637 -- the primitive which covers the interface is also available in
8638 -- the list of primitive operations.
8640 -- The function may be abstract, or require_Overriding may be set
8641 -- for it, because tests for null extensions may already have reset
8642 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
8643 -- set, functions that need wrappers are recognized by having an
8644 -- alias that returns the parent type.
8646 if Comes_From_Source (Subp)
8647 or else No (Alias (Subp))
8648 or else Present (Interface_Alias (Subp))
8649 or else Ekind (Subp) /= E_Function
8650 or else not Has_Controlling_Result (Subp)
8651 or else Is_Access_Type (Etype (Subp))
8652 or else Is_Abstract_Subprogram (Alias (Subp))
8653 or else Is_TSS (Subp, TSS_Stream_Input)
8657 elsif Is_Abstract_Subprogram (Subp)
8658 or else Requires_Overriding (Subp)
8660 (Is_Null_Extension (Etype (Subp))
8661 and then Etype (Alias (Subp)) /= Etype (Subp))
8663 Formal_List := No_List;
8664 Formal := First_Formal (Subp);
8666 if Present (Formal) then
8667 Formal_List := New_List;
8669 while Present (Formal) loop
8671 (Make_Parameter_Specification
8673 Defining_Identifier =>
8674 Make_Defining_Identifier (Sloc (Formal),
8675 Chars => Chars (Formal)),
8676 In_Present => In_Present (Parent (Formal)),
8677 Out_Present => Out_Present (Parent (Formal)),
8678 Null_Exclusion_Present =>
8679 Null_Exclusion_Present (Parent (Formal)),
8681 New_Occurrence_Of (Etype (Formal), Loc),
8683 New_Copy_Tree (Expression (Parent (Formal)))),
8686 Next_Formal (Formal);
8691 Make_Function_Specification (Loc,
8692 Defining_Unit_Name =>
8693 Make_Defining_Identifier (Loc,
8694 Chars => Chars (Subp)),
8695 Parameter_Specifications => Formal_List,
8696 Result_Definition =>
8697 New_Occurrence_Of (Etype (Subp), Loc));
8699 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
8700 Append_To (Decl_List, Func_Decl);
8702 -- Build a wrapper body that calls the parent function. The body
8703 -- contains a single return statement that returns an extension
8704 -- aggregate whose ancestor part is a call to the parent function,
8705 -- passing the formals as actuals (with any controlling arguments
8706 -- converted to the types of the corresponding formals of the
8707 -- parent function, which might be anonymous access types), and
8708 -- having a null extension.
8710 Formal := First_Formal (Subp);
8711 Par_Formal := First_Formal (Alias (Subp));
8712 Formal_Node := First (Formal_List);
8714 if Present (Formal) then
8715 Actual_List := New_List;
8717 Actual_List := No_List;
8720 while Present (Formal) loop
8721 if Is_Controlling_Formal (Formal) then
8722 Append_To (Actual_List,
8723 Make_Type_Conversion (Loc,
8725 New_Occurrence_Of (Etype (Par_Formal), Loc),
8728 (Defining_Identifier (Formal_Node), Loc)));
8733 (Defining_Identifier (Formal_Node), Loc));
8736 Next_Formal (Formal);
8737 Next_Formal (Par_Formal);
8742 Make_Simple_Return_Statement (Loc,
8744 Make_Extension_Aggregate (Loc,
8746 Make_Function_Call (Loc,
8748 New_Occurrence_Of (Alias (Subp), Loc),
8749 Parameter_Associations => Actual_List),
8750 Null_Record_Present => True));
8753 Make_Subprogram_Body (Loc,
8754 Specification => New_Copy_Tree (Func_Spec),
8755 Declarations => Empty_List,
8756 Handled_Statement_Sequence =>
8757 Make_Handled_Sequence_Of_Statements (Loc,
8758 Statements => New_List (Return_Stmt)));
8760 Set_Defining_Unit_Name
8761 (Specification (Func_Body),
8762 Make_Defining_Identifier (Loc, Chars (Subp)));
8764 Append_To (Body_List, Func_Body);
8766 -- Replace the inherited function with the wrapper function in the
8767 -- primitive operations list. We add the minimum decoration needed
8768 -- to override interface primitives.
8770 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
8772 Override_Dispatching_Operation
8773 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
8774 Is_Wrapper => True);
8778 Next_Elmt (Prim_Elmt);
8780 end Make_Controlling_Function_Wrappers;
8786 function Make_Eq_Body
8788 Eq_Name : Name_Id) return Node_Id
8790 Loc : constant Source_Ptr := Sloc (Parent (Typ));
8792 Def : constant Node_Id := Parent (Typ);
8793 Stmts : constant List_Id := New_List;
8794 Variant_Case : Boolean := Has_Discriminants (Typ);
8795 Comps : Node_Id := Empty;
8796 Typ_Def : Node_Id := Type_Definition (Def);
8800 Predef_Spec_Or_Body (Loc,
8803 Profile => New_List (
8804 Make_Parameter_Specification (Loc,
8805 Defining_Identifier =>
8806 Make_Defining_Identifier (Loc, Name_X),
8807 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8809 Make_Parameter_Specification (Loc,
8810 Defining_Identifier =>
8811 Make_Defining_Identifier (Loc, Name_Y),
8812 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8814 Ret_Type => Standard_Boolean,
8817 if Variant_Case then
8818 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8819 Typ_Def := Record_Extension_Part (Typ_Def);
8822 if Present (Typ_Def) then
8823 Comps := Component_List (Typ_Def);
8827 Present (Comps) and then Present (Variant_Part (Comps));
8830 if Variant_Case then
8832 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
8833 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
8835 Make_Simple_Return_Statement (Loc,
8836 Expression => New_Occurrence_Of (Standard_True, Loc)));
8840 Make_Simple_Return_Statement (Loc,
8842 Expand_Record_Equality
8845 Lhs => Make_Identifier (Loc, Name_X),
8846 Rhs => Make_Identifier (Loc, Name_Y),
8847 Bodies => Declarations (Decl))));
8850 Set_Handled_Statement_Sequence
8851 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8859 -- <Make_Eq_If shared components>
8862 -- when V1 => <Make_Eq_Case> on subcomponents
8864 -- when Vn => <Make_Eq_Case> on subcomponents
8867 function Make_Eq_Case
8870 Discrs : Elist_Id := New_Elmt_List) return List_Id
8872 Loc : constant Source_Ptr := Sloc (E);
8873 Result : constant List_Id := New_List;
8877 function Corresponding_Formal (C : Node_Id) return Entity_Id;
8878 -- Given the discriminant that controls a given variant of an unchecked
8879 -- union, find the formal of the equality function that carries the
8880 -- inferred value of the discriminant.
8882 function External_Name (E : Entity_Id) return Name_Id;
8883 -- The value of a given discriminant is conveyed in the corresponding
8884 -- formal parameter of the equality routine. The name of this formal
8885 -- parameter carries a one-character suffix which is removed here.
8887 --------------------------
8888 -- Corresponding_Formal --
8889 --------------------------
8891 function Corresponding_Formal (C : Node_Id) return Entity_Id is
8892 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
8896 Elm := First_Elmt (Discrs);
8897 while Present (Elm) loop
8898 if Chars (Discr) = External_Name (Node (Elm)) then
8905 -- A formal of the proper name must be found
8907 raise Program_Error;
8908 end Corresponding_Formal;
8914 function External_Name (E : Entity_Id) return Name_Id is
8916 Get_Name_String (Chars (E));
8917 Name_Len := Name_Len - 1;
8921 -- Start of processing for Make_Eq_Case
8924 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
8926 if No (Variant_Part (CL)) then
8930 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
8932 if No (Variant) then
8936 Alt_List := New_List;
8937 while Present (Variant) loop
8938 Append_To (Alt_List,
8939 Make_Case_Statement_Alternative (Loc,
8940 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
8942 Make_Eq_Case (E, Component_List (Variant), Discrs)));
8943 Next_Non_Pragma (Variant);
8946 -- If we have an Unchecked_Union, use one of the parameters of the
8947 -- enclosing equality routine that captures the discriminant, to use
8948 -- as the expression in the generated case statement.
8950 if Is_Unchecked_Union (E) then
8952 Make_Case_Statement (Loc,
8954 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
8955 Alternatives => Alt_List));
8959 Make_Case_Statement (Loc,
8961 Make_Selected_Component (Loc,
8962 Prefix => Make_Identifier (Loc, Name_X),
8963 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
8964 Alternatives => Alt_List));
8985 -- or a null statement if the list L is empty
8989 L : List_Id) return Node_Id
8991 Loc : constant Source_Ptr := Sloc (E);
8993 Field_Name : Name_Id;
8998 return Make_Null_Statement (Loc);
9003 C := First_Non_Pragma (L);
9004 while Present (C) loop
9005 Field_Name := Chars (Defining_Identifier (C));
9007 -- The tags must not be compared: they are not part of the value.
9008 -- Ditto for parent interfaces because their equality operator is
9011 -- Note also that in the following, we use Make_Identifier for
9012 -- the component names. Use of New_Occurrence_Of to identify the
9013 -- components would be incorrect because the wrong entities for
9014 -- discriminants could be picked up in the private type case.
9016 if Field_Name = Name_uParent
9017 and then Is_Interface (Etype (Defining_Identifier (C)))
9021 elsif Field_Name /= Name_uTag then
9022 Evolve_Or_Else (Cond,
9025 Make_Selected_Component (Loc,
9026 Prefix => Make_Identifier (Loc, Name_X),
9027 Selector_Name => Make_Identifier (Loc, Field_Name)),
9030 Make_Selected_Component (Loc,
9031 Prefix => Make_Identifier (Loc, Name_Y),
9032 Selector_Name => Make_Identifier (Loc, Field_Name))));
9035 Next_Non_Pragma (C);
9039 return Make_Null_Statement (Loc);
9043 Make_Implicit_If_Statement (E,
9045 Then_Statements => New_List (
9046 Make_Simple_Return_Statement (Loc,
9047 Expression => New_Occurrence_Of (Standard_False, Loc))));
9056 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
9058 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
9059 -- Returns true if Prim is a renaming of an unresolved predefined
9060 -- inequality operation.
9062 --------------------------------
9063 -- Is_Predefined_Neq_Renaming --
9064 --------------------------------
9066 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
9068 return Chars (Prim) /= Name_Op_Ne
9069 and then Present (Alias (Prim))
9070 and then Comes_From_Source (Prim)
9071 and then Is_Intrinsic_Subprogram (Alias (Prim))
9072 and then Chars (Alias (Prim)) = Name_Op_Ne;
9073 end Is_Predefined_Neq_Renaming;
9077 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
9078 Stmts : constant List_Id := New_List;
9080 Eq_Prim : Entity_Id;
9081 Left_Op : Entity_Id;
9082 Renaming_Prim : Entity_Id;
9083 Right_Op : Entity_Id;
9086 -- Start of processing for Make_Neq_Body
9089 -- For a call on a renaming of a dispatching subprogram that is
9090 -- overridden, if the overriding occurred before the renaming, then
9091 -- the body executed is that of the overriding declaration, even if the
9092 -- overriding declaration is not visible at the place of the renaming;
9093 -- otherwise, the inherited or predefined subprogram is called, see
9096 -- Stage 1: Search for a renaming of the inequality primitive and also
9097 -- search for an overriding of the equality primitive located before the
9098 -- renaming declaration.
9106 Renaming_Prim := Empty;
9108 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9109 while Present (Elmt) loop
9110 Prim := Node (Elmt);
9112 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
9113 if No (Renaming_Prim) then
9114 pragma Assert (No (Eq_Prim));
9118 elsif Is_Predefined_Neq_Renaming (Prim) then
9119 Renaming_Prim := Prim;
9126 -- No further action needed if no renaming was found
9128 if No (Renaming_Prim) then
9132 -- Stage 2: Replace the renaming declaration by a subprogram declaration
9133 -- (required to add its body)
9135 Decl := Parent (Parent (Renaming_Prim));
9137 Make_Subprogram_Declaration (Loc,
9138 Specification => Specification (Decl)));
9139 Set_Analyzed (Decl);
9141 -- Remove the decoration of intrinsic renaming subprogram
9143 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
9144 Set_Convention (Renaming_Prim, Convention_Ada);
9145 Set_Alias (Renaming_Prim, Empty);
9146 Set_Has_Completion (Renaming_Prim, False);
9148 -- Stage 3: Build the corresponding body
9150 Left_Op := First_Formal (Renaming_Prim);
9151 Right_Op := Next_Formal (Left_Op);
9154 Predef_Spec_Or_Body (Loc,
9156 Name => Chars (Renaming_Prim),
9157 Profile => New_List (
9158 Make_Parameter_Specification (Loc,
9159 Defining_Identifier =>
9160 Make_Defining_Identifier (Loc, Chars (Left_Op)),
9161 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9163 Make_Parameter_Specification (Loc,
9164 Defining_Identifier =>
9165 Make_Defining_Identifier (Loc, Chars (Right_Op)),
9166 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9168 Ret_Type => Standard_Boolean,
9171 -- If the overriding of the equality primitive occurred before the
9172 -- renaming, then generate:
9174 -- function <Neq_Name> (X : Y : Typ) return Boolean is
9176 -- return not Oeq (X, Y);
9179 if Present (Eq_Prim) then
9182 -- Otherwise build a nested subprogram which performs the predefined
9183 -- evaluation of the equality operator. That is, generate:
9185 -- function <Neq_Name> (X : Y : Typ) return Boolean is
9186 -- function Oeq (X : Y) return Boolean is
9188 -- <<body of default implementation>>
9191 -- return not Oeq (X, Y);
9196 Local_Subp : Node_Id;
9198 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
9199 Set_Declarations (Decl, New_List (Local_Subp));
9200 Target := Defining_Entity (Local_Subp);
9205 Make_Simple_Return_Statement (Loc,
9208 Make_Function_Call (Loc,
9209 Name => New_Occurrence_Of (Target, Loc),
9210 Parameter_Associations => New_List (
9211 Make_Identifier (Loc, Chars (Left_Op)),
9212 Make_Identifier (Loc, Chars (Right_Op)))))));
9214 Set_Handled_Statement_Sequence
9215 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
9219 -------------------------------
9220 -- Make_Null_Procedure_Specs --
9221 -------------------------------
9223 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
9224 Decl_List : constant List_Id := New_List;
9225 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9227 Formal_List : List_Id;
9228 New_Param_Spec : Node_Id;
9229 Parent_Subp : Entity_Id;
9230 Prim_Elmt : Elmt_Id;
9234 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9235 while Present (Prim_Elmt) loop
9236 Subp := Node (Prim_Elmt);
9238 -- If a null procedure inherited from an interface has not been
9239 -- overridden, then we build a null procedure declaration to
9240 -- override the inherited procedure.
9242 Parent_Subp := Alias (Subp);
9244 if Present (Parent_Subp)
9245 and then Is_Null_Interface_Primitive (Parent_Subp)
9247 Formal_List := No_List;
9248 Formal := First_Formal (Subp);
9250 if Present (Formal) then
9251 Formal_List := New_List;
9253 while Present (Formal) loop
9255 -- Copy the parameter spec including default expressions
9258 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
9260 -- Generate a new defining identifier for the new formal.
9261 -- required because New_Copy_Tree does not duplicate
9262 -- semantic fields (except itypes).
9264 Set_Defining_Identifier (New_Param_Spec,
9265 Make_Defining_Identifier (Sloc (Formal),
9266 Chars => Chars (Formal)));
9268 -- For controlling arguments we must change their
9269 -- parameter type to reference the tagged type (instead
9270 -- of the interface type)
9272 if Is_Controlling_Formal (Formal) then
9273 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
9275 Set_Parameter_Type (New_Param_Spec,
9276 New_Occurrence_Of (Tag_Typ, Loc));
9279 (Nkind (Parameter_Type (Parent (Formal))) =
9280 N_Access_Definition);
9281 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
9282 New_Occurrence_Of (Tag_Typ, Loc));
9286 Append (New_Param_Spec, Formal_List);
9288 Next_Formal (Formal);
9292 Append_To (Decl_List,
9293 Make_Subprogram_Declaration (Loc,
9294 Make_Procedure_Specification (Loc,
9295 Defining_Unit_Name =>
9296 Make_Defining_Identifier (Loc, Chars (Subp)),
9297 Parameter_Specifications => Formal_List,
9298 Null_Present => True)));
9301 Next_Elmt (Prim_Elmt);
9305 end Make_Null_Procedure_Specs;
9307 -------------------------------------
9308 -- Make_Predefined_Primitive_Specs --
9309 -------------------------------------
9311 procedure Make_Predefined_Primitive_Specs
9312 (Tag_Typ : Entity_Id;
9313 Predef_List : out List_Id;
9314 Renamed_Eq : out Entity_Id)
9316 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
9317 -- Returns true if Prim is a renaming of an unresolved predefined
9318 -- equality operation.
9320 -------------------------------
9321 -- Is_Predefined_Eq_Renaming --
9322 -------------------------------
9324 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
9326 return Chars (Prim) /= Name_Op_Eq
9327 and then Present (Alias (Prim))
9328 and then Comes_From_Source (Prim)
9329 and then Is_Intrinsic_Subprogram (Alias (Prim))
9330 and then Chars (Alias (Prim)) = Name_Op_Eq;
9331 end Is_Predefined_Eq_Renaming;
9335 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9336 Res : constant List_Id := New_List;
9337 Eq_Name : Name_Id := Name_Op_Eq;
9338 Eq_Needed : Boolean;
9342 Has_Predef_Eq_Renaming : Boolean := False;
9343 -- Set to True if Tag_Typ has a primitive that renames the predefined
9344 -- equality operator. Used to implement (RM 8-5-4(8)).
9346 -- Start of processing for Make_Predefined_Primitive_Specs
9349 Renamed_Eq := Empty;
9353 Append_To (Res, Predef_Spec_Or_Body (Loc,
9356 Profile => New_List (
9357 Make_Parameter_Specification (Loc,
9358 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9359 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9361 Ret_Type => Standard_Long_Long_Integer));
9363 -- Specs for dispatching stream attributes
9366 Stream_Op_TSS_Names :
9367 constant array (Positive range <>) of TSS_Name_Type :=
9374 for Op in Stream_Op_TSS_Names'Range loop
9375 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
9377 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
9378 Stream_Op_TSS_Names (Op)));
9383 -- Spec of "=" is expanded if the type is not limited and if a user
9384 -- defined "=" was not already declared for the non-full view of a
9385 -- private extension
9387 if not Is_Limited_Type (Tag_Typ) then
9389 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9390 while Present (Prim) loop
9392 -- If a primitive is encountered that renames the predefined
9393 -- equality operator before reaching any explicit equality
9394 -- primitive, then we still need to create a predefined equality
9395 -- function, because calls to it can occur via the renaming. A
9396 -- new name is created for the equality to avoid conflicting with
9397 -- any user-defined equality. (Note that this doesn't account for
9398 -- renamings of equality nested within subpackages???)
9400 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9401 Has_Predef_Eq_Renaming := True;
9402 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
9404 -- User-defined equality
9406 elsif Is_User_Defined_Equality (Node (Prim)) then
9407 if No (Alias (Node (Prim)))
9408 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
9409 N_Subprogram_Renaming_Declaration
9414 -- If the parent is not an interface type and has an abstract
9415 -- equality function explicitly defined in the sources, then
9416 -- the inherited equality is abstract as well, and no body can
9417 -- be created for it.
9419 elsif not Is_Interface (Etype (Tag_Typ))
9420 and then Present (Alias (Node (Prim)))
9421 and then Comes_From_Source (Alias (Node (Prim)))
9422 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
9427 -- If the type has an equality function corresponding with
9428 -- a primitive defined in an interface type, the inherited
9429 -- equality is abstract as well, and no body can be created
9432 elsif Present (Alias (Node (Prim)))
9433 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
9436 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
9446 -- If a renaming of predefined equality was found but there was no
9447 -- user-defined equality (so Eq_Needed is still true), then set the
9448 -- name back to Name_Op_Eq. But in the case where a user-defined
9449 -- equality was located after such a renaming, then the predefined
9450 -- equality function is still needed, so Eq_Needed must be set back
9453 if Eq_Name /= Name_Op_Eq then
9455 Eq_Name := Name_Op_Eq;
9462 Eq_Spec := Predef_Spec_Or_Body (Loc,
9465 Profile => New_List (
9466 Make_Parameter_Specification (Loc,
9467 Defining_Identifier =>
9468 Make_Defining_Identifier (Loc, Name_X),
9469 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9471 Make_Parameter_Specification (Loc,
9472 Defining_Identifier =>
9473 Make_Defining_Identifier (Loc, Name_Y),
9474 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9475 Ret_Type => Standard_Boolean);
9476 Append_To (Res, Eq_Spec);
9478 if Has_Predef_Eq_Renaming then
9479 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
9481 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9482 while Present (Prim) loop
9484 -- Any renamings of equality that appeared before an
9485 -- overriding equality must be updated to refer to the
9486 -- entity for the predefined equality, otherwise calls via
9487 -- the renaming would get incorrectly resolved to call the
9488 -- user-defined equality function.
9490 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9491 Set_Alias (Node (Prim), Renamed_Eq);
9493 -- Exit upon encountering a user-defined equality
9495 elsif Chars (Node (Prim)) = Name_Op_Eq
9496 and then No (Alias (Node (Prim)))
9506 -- Spec for dispatching assignment
9508 Append_To (Res, Predef_Spec_Or_Body (Loc,
9510 Name => Name_uAssign,
9511 Profile => New_List (
9512 Make_Parameter_Specification (Loc,
9513 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9514 Out_Present => True,
9515 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9517 Make_Parameter_Specification (Loc,
9518 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9519 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
9522 -- Ada 2005: Generate declarations for the following primitive
9523 -- operations for limited interfaces and synchronized types that
9524 -- implement a limited interface.
9526 -- Disp_Asynchronous_Select
9527 -- Disp_Conditional_Select
9528 -- Disp_Get_Prim_Op_Kind
9531 -- Disp_Timed_Select
9533 -- Disable the generation of these bodies if No_Dispatching_Calls,
9534 -- Ravenscar or ZFP is active.
9536 if Ada_Version >= Ada_2005
9537 and then not Restriction_Active (No_Dispatching_Calls)
9538 and then not Restriction_Active (No_Select_Statements)
9539 and then RTE_Available (RE_Select_Specific_Data)
9541 -- These primitives are defined abstract in interface types
9543 if Is_Interface (Tag_Typ)
9544 and then Is_Limited_Record (Tag_Typ)
9547 Make_Abstract_Subprogram_Declaration (Loc,
9549 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9552 Make_Abstract_Subprogram_Declaration (Loc,
9554 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9557 Make_Abstract_Subprogram_Declaration (Loc,
9559 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9562 Make_Abstract_Subprogram_Declaration (Loc,
9564 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9567 Make_Abstract_Subprogram_Declaration (Loc,
9569 Make_Disp_Requeue_Spec (Tag_Typ)));
9572 Make_Abstract_Subprogram_Declaration (Loc,
9574 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9576 -- If ancestor is an interface type, declare non-abstract primitives
9577 -- to override the abstract primitives of the interface type.
9579 -- In VM targets we define these primitives in all root tagged types
9580 -- that are not interface types. Done because in VM targets we don't
9581 -- have secondary dispatch tables and any derivation of Tag_Typ may
9582 -- cover limited interfaces (which always have these primitives since
9583 -- they may be ancestors of synchronized interface types).
9585 elsif (not Is_Interface (Tag_Typ)
9586 and then Is_Interface (Etype (Tag_Typ))
9587 and then Is_Limited_Record (Etype (Tag_Typ)))
9589 (Is_Concurrent_Record_Type (Tag_Typ)
9590 and then Has_Interfaces (Tag_Typ))
9592 (not Tagged_Type_Expansion
9593 and then not Is_Interface (Tag_Typ)
9594 and then Tag_Typ = Root_Type (Tag_Typ))
9597 Make_Subprogram_Declaration (Loc,
9599 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9602 Make_Subprogram_Declaration (Loc,
9604 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9607 Make_Subprogram_Declaration (Loc,
9609 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9612 Make_Subprogram_Declaration (Loc,
9614 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9617 Make_Subprogram_Declaration (Loc,
9619 Make_Disp_Requeue_Spec (Tag_Typ)));
9622 Make_Subprogram_Declaration (Loc,
9624 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9628 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
9629 -- regardless of whether they are controlled or may contain controlled
9632 -- Do not generate the routines if finalization is disabled
9634 if Restriction_Active (No_Finalization) then
9638 if not Is_Limited_Type (Tag_Typ) then
9639 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
9642 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
9646 end Make_Predefined_Primitive_Specs;
9648 -------------------------
9649 -- Make_Tag_Assignment --
9650 -------------------------
9652 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
9653 Loc : constant Source_Ptr := Sloc (N);
9654 Def_If : constant Entity_Id := Defining_Identifier (N);
9655 Expr : constant Node_Id := Expression (N);
9656 Typ : constant Entity_Id := Etype (Def_If);
9657 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
9661 -- This expansion activity is called during analysis, but cannot
9662 -- be applied in ASIS mode when other expansion is disabled.
9664 if Is_Tagged_Type (Typ)
9665 and then not Is_Class_Wide_Type (Typ)
9666 and then not Is_CPP_Class (Typ)
9667 and then Tagged_Type_Expansion
9668 and then Nkind (Expr) /= N_Aggregate
9669 and then not ASIS_Mode
9670 and then (Nkind (Expr) /= N_Qualified_Expression
9671 or else Nkind (Expression (Expr)) /= N_Aggregate)
9674 Make_Selected_Component (Loc,
9675 Prefix => New_Occurrence_Of (Def_If, Loc),
9677 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
9678 Set_Assignment_OK (New_Ref);
9681 Make_Assignment_Statement (Loc,
9684 Unchecked_Convert_To (RTE (RE_Tag),
9685 New_Occurrence_Of (Node
9686 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
9690 end Make_Tag_Assignment;
9692 ---------------------------------
9693 -- Needs_Simple_Initialization --
9694 ---------------------------------
9696 function Needs_Simple_Initialization
9698 Consider_IS : Boolean := True) return Boolean
9700 Consider_IS_NS : constant Boolean :=
9701 Normalize_Scalars or (Initialize_Scalars and Consider_IS);
9704 -- Never need initialization if it is suppressed
9706 if Initialization_Suppressed (T) then
9710 -- Check for private type, in which case test applies to the underlying
9711 -- type of the private type.
9713 if Is_Private_Type (T) then
9715 RT : constant Entity_Id := Underlying_Type (T);
9717 if Present (RT) then
9718 return Needs_Simple_Initialization (RT);
9724 -- Scalar type with Default_Value aspect requires initialization
9726 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
9729 -- Cases needing simple initialization are access types, and, if pragma
9730 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
9733 elsif Is_Access_Type (T)
9734 or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
9738 -- If Initialize/Normalize_Scalars is in effect, string objects also
9739 -- need initialization, unless they are created in the course of
9740 -- expanding an aggregate (since in the latter case they will be
9741 -- filled with appropriate initializing values before they are used).
9743 elsif Consider_IS_NS
9744 and then Is_Standard_String_Type (T)
9747 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
9754 end Needs_Simple_Initialization;
9756 ----------------------
9757 -- Predef_Deep_Spec --
9758 ----------------------
9760 function Predef_Deep_Spec
9762 Tag_Typ : Entity_Id;
9763 Name : TSS_Name_Type;
9764 For_Body : Boolean := False) return Node_Id
9769 -- V : in out Tag_Typ
9771 Formals := New_List (
9772 Make_Parameter_Specification (Loc,
9773 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9775 Out_Present => True,
9776 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
9778 -- F : Boolean := True
9780 if Name = TSS_Deep_Adjust
9781 or else Name = TSS_Deep_Finalize
9784 Make_Parameter_Specification (Loc,
9785 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9786 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9787 Expression => New_Occurrence_Of (Standard_True, Loc)));
9791 Predef_Spec_Or_Body (Loc,
9792 Name => Make_TSS_Name (Tag_Typ, Name),
9795 For_Body => For_Body);
9798 when RE_Not_Available =>
9800 end Predef_Deep_Spec;
9802 -------------------------
9803 -- Predef_Spec_Or_Body --
9804 -------------------------
9806 function Predef_Spec_Or_Body
9808 Tag_Typ : Entity_Id;
9811 Ret_Type : Entity_Id := Empty;
9812 For_Body : Boolean := False) return Node_Id
9814 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
9818 Set_Is_Public (Id, Is_Public (Tag_Typ));
9820 -- The internal flag is set to mark these declarations because they have
9821 -- specific properties. First, they are primitives even if they are not
9822 -- defined in the type scope (the freezing point is not necessarily in
9823 -- the same scope). Second, the predefined equality can be overridden by
9824 -- a user-defined equality, no body will be generated in this case.
9826 Set_Is_Internal (Id);
9828 if not Debug_Generated_Code then
9829 Set_Debug_Info_Off (Id);
9832 if No (Ret_Type) then
9834 Make_Procedure_Specification (Loc,
9835 Defining_Unit_Name => Id,
9836 Parameter_Specifications => Profile);
9839 Make_Function_Specification (Loc,
9840 Defining_Unit_Name => Id,
9841 Parameter_Specifications => Profile,
9842 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
9845 if Is_Interface (Tag_Typ) then
9846 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9848 -- If body case, return empty subprogram body. Note that this is ill-
9849 -- formed, because there is not even a null statement, and certainly not
9850 -- a return in the function case. The caller is expected to do surgery
9851 -- on the body to add the appropriate stuff.
9854 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
9856 -- For the case of an Input attribute predefined for an abstract type,
9857 -- generate an abstract specification. This will never be called, but we
9858 -- need the slot allocated in the dispatching table so that attributes
9859 -- typ'Class'Input and typ'Class'Output will work properly.
9861 elsif Is_TSS (Name, TSS_Stream_Input)
9862 and then Is_Abstract_Type (Tag_Typ)
9864 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9866 -- Normal spec case, where we return a subprogram declaration
9869 return Make_Subprogram_Declaration (Loc, Spec);
9871 end Predef_Spec_Or_Body;
9873 -----------------------------
9874 -- Predef_Stream_Attr_Spec --
9875 -----------------------------
9877 function Predef_Stream_Attr_Spec
9879 Tag_Typ : Entity_Id;
9880 Name : TSS_Name_Type;
9881 For_Body : Boolean := False) return Node_Id
9883 Ret_Type : Entity_Id;
9886 if Name = TSS_Stream_Input then
9887 Ret_Type := Tag_Typ;
9895 Name => Make_TSS_Name (Tag_Typ, Name),
9897 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
9898 Ret_Type => Ret_Type,
9899 For_Body => For_Body);
9900 end Predef_Stream_Attr_Spec;
9902 ---------------------------------
9903 -- Predefined_Primitive_Bodies --
9904 ---------------------------------
9906 function Predefined_Primitive_Bodies
9907 (Tag_Typ : Entity_Id;
9908 Renamed_Eq : Entity_Id) return List_Id
9910 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9911 Res : constant List_Id := New_List;
9916 Eq_Needed : Boolean;
9920 pragma Warnings (Off, Ent);
9923 pragma Assert (not Is_Interface (Tag_Typ));
9925 -- See if we have a predefined "=" operator
9927 if Present (Renamed_Eq) then
9929 Eq_Name := Chars (Renamed_Eq);
9931 -- If the parent is an interface type then it has defined all the
9932 -- predefined primitives abstract and we need to check if the type
9933 -- has some user defined "=" function which matches the profile of
9934 -- the Ada predefined equality operator to avoid generating it.
9936 elsif Is_Interface (Etype (Tag_Typ)) then
9938 Eq_Name := Name_Op_Eq;
9940 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9941 while Present (Prim) loop
9942 if Chars (Node (Prim)) = Name_Op_Eq
9943 and then not Is_Internal (Node (Prim))
9944 and then Present (First_Entity (Node (Prim)))
9946 -- The predefined equality primitive must have exactly two
9947 -- formals whose type is this tagged type
9949 and then Present (Last_Entity (Node (Prim)))
9950 and then Next_Entity (First_Entity (Node (Prim)))
9951 = Last_Entity (Node (Prim))
9952 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
9953 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
9967 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9968 while Present (Prim) loop
9969 if Chars (Node (Prim)) = Name_Op_Eq
9970 and then Is_Internal (Node (Prim))
9973 Eq_Name := Name_Op_Eq;
9983 Decl := Predef_Spec_Or_Body (Loc,
9986 Profile => New_List (
9987 Make_Parameter_Specification (Loc,
9988 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9989 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9991 Ret_Type => Standard_Long_Long_Integer,
9994 Set_Handled_Statement_Sequence (Decl,
9995 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9996 Make_Simple_Return_Statement (Loc,
9998 Make_Attribute_Reference (Loc,
9999 Prefix => Make_Identifier (Loc, Name_X),
10000 Attribute_Name => Name_Size)))));
10002 Append_To (Res, Decl);
10004 -- Bodies for Dispatching stream IO routines. We need these only for
10005 -- non-limited types (in the limited case there is no dispatching).
10006 -- We also skip them if dispatching or finalization are not available
10007 -- or if stream operations are prohibited by restriction No_Streams or
10008 -- from use of pragma/aspect No_Tagged_Streams.
10010 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
10011 and then No (TSS (Tag_Typ, TSS_Stream_Read))
10013 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
10014 Append_To (Res, Decl);
10017 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
10018 and then No (TSS (Tag_Typ, TSS_Stream_Write))
10020 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
10021 Append_To (Res, Decl);
10024 -- Skip body of _Input for the abstract case, since the corresponding
10025 -- spec is abstract (see Predef_Spec_Or_Body).
10027 if not Is_Abstract_Type (Tag_Typ)
10028 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
10029 and then No (TSS (Tag_Typ, TSS_Stream_Input))
10031 Build_Record_Or_Elementary_Input_Function
10032 (Loc, Tag_Typ, Decl, Ent);
10033 Append_To (Res, Decl);
10036 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
10037 and then No (TSS (Tag_Typ, TSS_Stream_Output))
10039 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
10040 Append_To (Res, Decl);
10043 -- Ada 2005: Generate bodies for the following primitive operations for
10044 -- limited interfaces and synchronized types that implement a limited
10047 -- disp_asynchronous_select
10048 -- disp_conditional_select
10049 -- disp_get_prim_op_kind
10050 -- disp_get_task_id
10051 -- disp_timed_select
10053 -- The interface versions will have null bodies
10055 -- Disable the generation of these bodies if No_Dispatching_Calls,
10056 -- Ravenscar or ZFP is active.
10058 -- In VM targets we define these primitives in all root tagged types
10059 -- that are not interface types. Done because in VM targets we don't
10060 -- have secondary dispatch tables and any derivation of Tag_Typ may
10061 -- cover limited interfaces (which always have these primitives since
10062 -- they may be ancestors of synchronized interface types).
10064 if Ada_Version >= Ada_2005
10065 and then not Is_Interface (Tag_Typ)
10067 ((Is_Interface (Etype (Tag_Typ))
10068 and then Is_Limited_Record (Etype (Tag_Typ)))
10070 (Is_Concurrent_Record_Type (Tag_Typ)
10071 and then Has_Interfaces (Tag_Typ))
10073 (not Tagged_Type_Expansion
10074 and then Tag_Typ = Root_Type (Tag_Typ)))
10075 and then not Restriction_Active (No_Dispatching_Calls)
10076 and then not Restriction_Active (No_Select_Statements)
10077 and then RTE_Available (RE_Select_Specific_Data)
10079 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
10080 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
10081 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
10082 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
10083 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
10084 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
10087 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
10089 -- Body for equality
10092 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
10093 Append_To (Res, Decl);
10096 -- Body for inequality (if required)
10098 Decl := Make_Neq_Body (Tag_Typ);
10100 if Present (Decl) then
10101 Append_To (Res, Decl);
10104 -- Body for dispatching assignment
10107 Predef_Spec_Or_Body (Loc,
10108 Tag_Typ => Tag_Typ,
10109 Name => Name_uAssign,
10110 Profile => New_List (
10111 Make_Parameter_Specification (Loc,
10112 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10113 Out_Present => True,
10114 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10116 Make_Parameter_Specification (Loc,
10117 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
10118 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10121 Set_Handled_Statement_Sequence (Decl,
10122 Make_Handled_Sequence_Of_Statements (Loc, New_List (
10123 Make_Assignment_Statement (Loc,
10124 Name => Make_Identifier (Loc, Name_X),
10125 Expression => Make_Identifier (Loc, Name_Y)))));
10127 Append_To (Res, Decl);
10130 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
10131 -- tagged types which do not contain controlled components.
10133 -- Do not generate the routines if finalization is disabled
10135 if Restriction_Active (No_Finalization) then
10138 elsif not Has_Controlled_Component (Tag_Typ) then
10139 if not Is_Limited_Type (Tag_Typ) then
10141 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
10143 if Is_Controlled (Tag_Typ) then
10146 Obj_Ref => Make_Identifier (Loc, Name_V),
10150 if No (Adj_Call) then
10151 Adj_Call := Make_Null_Statement (Loc);
10154 Set_Handled_Statement_Sequence (Decl,
10155 Make_Handled_Sequence_Of_Statements (Loc,
10156 Statements => New_List (Adj_Call)));
10158 Append_To (Res, Decl);
10162 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
10164 if Is_Controlled (Tag_Typ) then
10167 (Obj_Ref => Make_Identifier (Loc, Name_V),
10171 if No (Fin_Call) then
10172 Fin_Call := Make_Null_Statement (Loc);
10175 Set_Handled_Statement_Sequence (Decl,
10176 Make_Handled_Sequence_Of_Statements (Loc,
10177 Statements => New_List (Fin_Call)));
10179 Append_To (Res, Decl);
10183 end Predefined_Primitive_Bodies;
10185 ---------------------------------
10186 -- Predefined_Primitive_Freeze --
10187 ---------------------------------
10189 function Predefined_Primitive_Freeze
10190 (Tag_Typ : Entity_Id) return List_Id
10192 Res : constant List_Id := New_List;
10197 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10198 while Present (Prim) loop
10199 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
10200 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
10202 if Present (Frnodes) then
10203 Append_List_To (Res, Frnodes);
10211 end Predefined_Primitive_Freeze;
10213 -------------------------
10214 -- Stream_Operation_OK --
10215 -------------------------
10217 function Stream_Operation_OK
10219 Operation : TSS_Name_Type) return Boolean
10221 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
10224 -- Special case of a limited type extension: a default implementation
10225 -- of the stream attributes Read or Write exists if that attribute
10226 -- has been specified or is available for an ancestor type; a default
10227 -- implementation of the attribute Output (resp. Input) exists if the
10228 -- attribute has been specified or Write (resp. Read) is available for
10229 -- an ancestor type. The last condition only applies under Ada 2005.
10231 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
10232 if Operation = TSS_Stream_Read then
10233 Has_Predefined_Or_Specified_Stream_Attribute :=
10234 Has_Specified_Stream_Read (Typ);
10236 elsif Operation = TSS_Stream_Write then
10237 Has_Predefined_Or_Specified_Stream_Attribute :=
10238 Has_Specified_Stream_Write (Typ);
10240 elsif Operation = TSS_Stream_Input then
10241 Has_Predefined_Or_Specified_Stream_Attribute :=
10242 Has_Specified_Stream_Input (Typ)
10244 (Ada_Version >= Ada_2005
10245 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
10247 elsif Operation = TSS_Stream_Output then
10248 Has_Predefined_Or_Specified_Stream_Attribute :=
10249 Has_Specified_Stream_Output (Typ)
10251 (Ada_Version >= Ada_2005
10252 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
10255 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
10257 if not Has_Predefined_Or_Specified_Stream_Attribute
10258 and then Is_Derived_Type (Typ)
10259 and then (Operation = TSS_Stream_Read
10260 or else Operation = TSS_Stream_Write)
10262 Has_Predefined_Or_Specified_Stream_Attribute :=
10264 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
10268 -- If the type is not limited, or else is limited but the attribute is
10269 -- explicitly specified or is predefined for the type, then return True,
10270 -- unless other conditions prevail, such as restrictions prohibiting
10271 -- streams or dispatching operations. We also return True for limited
10272 -- interfaces, because they may be extended by nonlimited types and
10273 -- permit inheritance in this case (addresses cases where an abstract
10274 -- extension doesn't get 'Input declared, as per comments below, but
10275 -- 'Class'Input must still be allowed). Note that attempts to apply
10276 -- stream attributes to a limited interface or its class-wide type
10277 -- (or limited extensions thereof) will still get properly rejected
10278 -- by Check_Stream_Attribute.
10280 -- We exclude the Input operation from being a predefined subprogram in
10281 -- the case where the associated type is an abstract extension, because
10282 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
10283 -- we don't want an abstract version created because types derived from
10284 -- the abstract type may not even have Input available (for example if
10285 -- derived from a private view of the abstract type that doesn't have
10286 -- a visible Input).
10288 -- Do not generate stream routines for type Finalization_Master because
10289 -- a master may never appear in types and therefore cannot be read or
10293 (not Is_Limited_Type (Typ)
10294 or else Is_Interface (Typ)
10295 or else Has_Predefined_Or_Specified_Stream_Attribute)
10297 (Operation /= TSS_Stream_Input
10298 or else not Is_Abstract_Type (Typ)
10299 or else not Is_Derived_Type (Typ))
10300 and then not Has_Unknown_Discriminants (Typ)
10302 (Is_Interface (Typ)
10304 (Is_Task_Interface (Typ)
10305 or else Is_Protected_Interface (Typ)
10306 or else Is_Synchronized_Interface (Typ)))
10307 and then not Restriction_Active (No_Streams)
10308 and then not Restriction_Active (No_Dispatch)
10309 and then No (No_Tagged_Streams_Pragma (Typ))
10310 and then not No_Run_Time_Mode
10311 and then RTE_Available (RE_Tag)
10312 and then No (Type_Without_Stream_Operation (Typ))
10313 and then RTE_Available (RE_Root_Stream_Type)
10314 and then not Is_RTE (Typ, RE_Finalization_Master);
10315 end Stream_Operation_OK;