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
1715 (Id : Entity_Id; Default : Node_Id) return List_Id;
1716 -- Build an assignment statement that assigns the default expression to
1717 -- its corresponding record component if defined. The left-hand side of
1718 -- the assignment is marked Assignment_OK so that initialization of
1719 -- limited private records works correctly. This routine may also build
1720 -- an adjustment call if the component is controlled.
1722 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1723 -- If the record has discriminants, add assignment statements to
1724 -- Statement_List to initialize the discriminant values from the
1725 -- arguments of the initialization procedure.
1727 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1728 -- Build a list representing a sequence of statements which initialize
1729 -- components of the given component list. This may involve building
1730 -- case statements for the variant parts. Append any locally declared
1731 -- objects on list Decls.
1733 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1734 -- Given an untagged type-derivation that declares discriminants, e.g.
1736 -- type R (R1, R2 : Integer) is record ... end record;
1737 -- type D (D1 : Integer) is new R (1, D1);
1739 -- we make the _init_proc of D be
1741 -- procedure _init_proc (X : D; D1 : Integer) is
1743 -- _init_proc (R (X), 1, D1);
1746 -- This function builds the call statement in this _init_proc.
1748 procedure Build_CPP_Init_Procedure;
1749 -- Build the tree corresponding to the procedure specification and body
1750 -- of the IC procedure that initializes the C++ part of the dispatch
1751 -- table of an Ada tagged type that is a derivation of a CPP type.
1752 -- Install it as the CPP_Init TSS.
1754 procedure Build_Init_Procedure;
1755 -- Build the tree corresponding to the procedure specification and body
1756 -- of the initialization procedure and install it as the _init TSS.
1758 procedure Build_Offset_To_Top_Functions;
1759 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1760 -- and body of Offset_To_Top, a function used in conjuction with types
1761 -- having secondary dispatch tables.
1763 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1764 -- Add range checks to components of discriminated records. S is a
1765 -- subtype indication of a record component. Check_List is a list
1766 -- to which the check actions are appended.
1768 function Component_Needs_Simple_Initialization
1769 (T : Entity_Id) return Boolean;
1770 -- Determine if a component needs simple initialization, given its type
1771 -- T. This routine is the same as Needs_Simple_Initialization except for
1772 -- components of type Tag and Interface_Tag. These two access types do
1773 -- not require initialization since they are explicitly initialized by
1776 function Parent_Subtype_Renaming_Discrims return Boolean;
1777 -- Returns True for base types N that rename discriminants, else False
1779 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1780 -- Determine whether a record initialization procedure needs to be
1781 -- generated for the given record type.
1783 ----------------------
1784 -- Build_Assignment --
1785 ----------------------
1787 function Build_Assignment
1788 (Id : Entity_Id; Default : Node_Id) return List_Id
1790 Default_Loc : constant Source_Ptr := Sloc (Default);
1791 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1794 Exp : Node_Id := Default;
1795 Kind : Node_Kind := Nkind (Default);
1799 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
1800 -- Analysis of the aggregate has replaced discriminants by their
1801 -- corresponding discriminals, but these are irrelevant when the
1802 -- component has a mutable type and is initialized with an aggregate.
1803 -- Instead, they must be replaced by the values supplied in the
1804 -- aggregate, that will be assigned during the expansion of the
1807 -----------------------
1808 -- Replace_Discr_Ref --
1809 -----------------------
1811 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
1815 if Is_Entity_Name (N)
1816 and then Present (Entity (N))
1817 and then Is_Formal (Entity (N))
1818 and then Present (Discriminal_Link (Entity (N)))
1821 Make_Selected_Component (Default_Loc,
1822 Prefix => New_Copy_Tree (Lhs),
1825 (Discriminal_Link (Entity (N)), Default_Loc));
1827 if Present (Val) then
1828 Rewrite (N, New_Copy_Tree (Val));
1833 end Replace_Discr_Ref;
1835 procedure Replace_Discriminant_References is
1836 new Traverse_Proc (Replace_Discr_Ref);
1838 -- Start of processing for Build_Assignment
1842 Make_Selected_Component (Default_Loc,
1843 Prefix => Make_Identifier (Loc, Name_uInit),
1844 Selector_Name => New_Occurrence_Of (Id, Default_Loc));
1845 Set_Assignment_OK (Lhs);
1847 if Nkind (Exp) = N_Aggregate
1848 and then Has_Discriminants (Typ)
1849 and then not Is_Constrained (Base_Type (Typ))
1851 -- The aggregate may provide new values for the discriminants
1852 -- of the component, and other components may depend on those
1853 -- discriminants. Previous analysis of those expressions have
1854 -- replaced the discriminants by the formals of the initialization
1855 -- procedure for the type, but these are irrelevant in the
1856 -- enclosing initialization procedure: those discriminant
1857 -- references must be replaced by the values provided in the
1860 Replace_Discriminant_References (Exp);
1863 -- Case of an access attribute applied to the current instance.
1864 -- Replace the reference to the type by a reference to the actual
1865 -- object. (Note that this handles the case of the top level of
1866 -- the expression being given by such an attribute, but does not
1867 -- cover uses nested within an initial value expression. Nested
1868 -- uses are unlikely to occur in practice, but are theoretically
1869 -- possible.) It is not clear how to handle them without fully
1870 -- traversing the expression. ???
1872 if Kind = N_Attribute_Reference
1873 and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
1874 Name_Unrestricted_Access)
1875 and then Is_Entity_Name (Prefix (Default))
1876 and then Is_Type (Entity (Prefix (Default)))
1877 and then Entity (Prefix (Default)) = Rec_Type
1880 Make_Attribute_Reference (Default_Loc,
1882 Make_Identifier (Default_Loc, Name_uInit),
1883 Attribute_Name => Name_Unrestricted_Access);
1886 -- Take a copy of Exp to ensure that later copies of this component
1887 -- declaration in derived types see the original tree, not a node
1888 -- rewritten during expansion of the init_proc. If the copy contains
1889 -- itypes, the scope of the new itypes is the init_proc being built.
1891 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1894 Make_Assignment_Statement (Loc,
1896 Expression => Exp));
1898 Set_No_Ctrl_Actions (First (Res));
1900 -- Adjust the tag if tagged (because of possible view conversions).
1901 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
1902 -- tags are represented implicitly in objects.
1904 if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
1906 Make_Assignment_Statement (Default_Loc,
1908 Make_Selected_Component (Default_Loc,
1910 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1913 (First_Tag_Component (Typ), Default_Loc)),
1916 Unchecked_Convert_To (RTE (RE_Tag),
1920 (Access_Disp_Table (Underlying_Type (Typ)))),
1924 -- Adjust the component if controlled except if it is an aggregate
1925 -- that will be expanded inline.
1927 if Kind = N_Qualified_Expression then
1928 Kind := Nkind (Expression (Default));
1931 if Needs_Finalization (Typ)
1932 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1933 and then not Is_Build_In_Place_Function_Call (Exp)
1937 (Obj_Ref => New_Copy_Tree (Lhs),
1940 -- Guard against a missing [Deep_]Adjust when the component type
1941 -- was not properly frozen.
1943 if Present (Adj_Call) then
1944 Append_To (Res, Adj_Call);
1948 -- If a component type has a predicate, add check to the component
1949 -- assignment. Discriminants are handled at the point of the call,
1950 -- which provides for a better error message.
1952 if Comes_From_Source (Exp)
1953 and then Has_Predicates (Typ)
1954 and then not Predicate_Checks_Suppressed (Empty)
1955 and then not Predicates_Ignored (Typ)
1957 Append (Make_Predicate_Check (Typ, Exp), Res);
1963 when RE_Not_Available =>
1965 end Build_Assignment;
1967 ------------------------------------
1968 -- Build_Discriminant_Assignments --
1969 ------------------------------------
1971 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1972 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1977 if Has_Discriminants (Rec_Type)
1978 and then not Is_Unchecked_Union (Rec_Type)
1980 D := First_Discriminant (Rec_Type);
1981 while Present (D) loop
1983 -- Don't generate the assignment for discriminants in derived
1984 -- tagged types if the discriminant is a renaming of some
1985 -- ancestor discriminant. This initialization will be done
1986 -- when initializing the _parent field of the derived record.
1989 and then Present (Corresponding_Discriminant (D))
1995 Append_List_To (Statement_List,
1996 Build_Assignment (D,
1997 New_Occurrence_Of (Discriminal (D), D_Loc)));
2000 Next_Discriminant (D);
2003 end Build_Discriminant_Assignments;
2005 --------------------------
2006 -- Build_Init_Call_Thru --
2007 --------------------------
2009 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
2010 Parent_Proc : constant Entity_Id :=
2011 Base_Init_Proc (Etype (Rec_Type));
2013 Parent_Type : constant Entity_Id :=
2014 Etype (First_Formal (Parent_Proc));
2016 Uparent_Type : constant Entity_Id :=
2017 Underlying_Type (Parent_Type);
2019 First_Discr_Param : Node_Id;
2023 First_Arg : Node_Id;
2024 Parent_Discr : Entity_Id;
2028 -- First argument (_Init) is the object to be initialized.
2029 -- ??? not sure where to get a reasonable Loc for First_Arg
2032 OK_Convert_To (Parent_Type,
2034 (Defining_Identifier (First (Parameters)), Loc));
2036 Set_Etype (First_Arg, Parent_Type);
2038 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
2040 -- In the tasks case,
2041 -- add _Master as the value of the _Master parameter
2042 -- add _Chain as the value of the _Chain parameter.
2043 -- add _Task_Name as the value of the _Task_Name parameter.
2044 -- At the outer level, these will be variables holding the
2045 -- corresponding values obtained from GNARL or the expander.
2047 -- At inner levels, they will be the parameters passed down through
2048 -- the outer routines.
2050 First_Discr_Param := Next (First (Parameters));
2052 if Has_Task (Rec_Type) then
2053 if Restriction_Active (No_Task_Hierarchy) then
2055 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
2057 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2060 -- Add _Chain (not done for sequential elaboration policy, see
2061 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2063 if Partition_Elaboration_Policy /= 'S' then
2064 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2067 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2068 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2071 -- Append discriminant values
2073 if Has_Discriminants (Uparent_Type) then
2074 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2076 Parent_Discr := First_Discriminant (Uparent_Type);
2077 while Present (Parent_Discr) loop
2079 -- Get the initial value for this discriminant
2080 -- ??? needs to be cleaned up to use parent_Discr_Constr
2084 Discr : Entity_Id :=
2085 First_Stored_Discriminant (Uparent_Type);
2087 Discr_Value : Elmt_Id :=
2088 First_Elmt (Stored_Constraint (Rec_Type));
2091 while Original_Record_Component (Parent_Discr) /= Discr loop
2092 Next_Stored_Discriminant (Discr);
2093 Next_Elmt (Discr_Value);
2096 Arg := Node (Discr_Value);
2099 -- Append it to the list
2101 if Nkind (Arg) = N_Identifier
2102 and then Ekind (Entity (Arg)) = E_Discriminant
2105 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2107 -- Case of access discriminants. We replace the reference
2108 -- to the type by a reference to the actual object.
2110 -- Is above comment right??? Use of New_Copy below seems mighty
2114 Append_To (Args, New_Copy (Arg));
2117 Next_Discriminant (Parent_Discr);
2123 Make_Procedure_Call_Statement (Loc,
2125 New_Occurrence_Of (Parent_Proc, Loc),
2126 Parameter_Associations => Args));
2129 end Build_Init_Call_Thru;
2131 -----------------------------------
2132 -- Build_Offset_To_Top_Functions --
2133 -----------------------------------
2135 procedure Build_Offset_To_Top_Functions is
2137 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2139 -- function Fxx (O : Address) return Storage_Offset is
2140 -- type Acc is access all <Typ>;
2142 -- return Acc!(O).Iface_Comp'Position;
2145 ----------------------------------
2146 -- Build_Offset_To_Top_Function --
2147 ----------------------------------
2149 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2150 Body_Node : Node_Id;
2151 Func_Id : Entity_Id;
2152 Spec_Node : Node_Id;
2153 Acc_Type : Entity_Id;
2156 Func_Id := Make_Temporary (Loc, 'F');
2157 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2160 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2162 Spec_Node := New_Node (N_Function_Specification, Loc);
2163 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2164 Set_Parameter_Specifications (Spec_Node, New_List (
2165 Make_Parameter_Specification (Loc,
2166 Defining_Identifier =>
2167 Make_Defining_Identifier (Loc, Name_uO),
2170 New_Occurrence_Of (RTE (RE_Address), Loc))));
2171 Set_Result_Definition (Spec_Node,
2172 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2175 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2177 -- return O.Iface_Comp'Position;
2180 Body_Node := New_Node (N_Subprogram_Body, Loc);
2181 Set_Specification (Body_Node, Spec_Node);
2183 Acc_Type := Make_Temporary (Loc, 'T');
2184 Set_Declarations (Body_Node, New_List (
2185 Make_Full_Type_Declaration (Loc,
2186 Defining_Identifier => Acc_Type,
2188 Make_Access_To_Object_Definition (Loc,
2189 All_Present => True,
2190 Null_Exclusion_Present => False,
2191 Constant_Present => False,
2192 Subtype_Indication =>
2193 New_Occurrence_Of (Rec_Type, Loc)))));
2195 Set_Handled_Statement_Sequence (Body_Node,
2196 Make_Handled_Sequence_Of_Statements (Loc,
2197 Statements => New_List (
2198 Make_Simple_Return_Statement (Loc,
2200 Make_Attribute_Reference (Loc,
2202 Make_Selected_Component (Loc,
2204 Unchecked_Convert_To (Acc_Type,
2205 Make_Identifier (Loc, Name_uO)),
2207 New_Occurrence_Of (Iface_Comp, Loc)),
2208 Attribute_Name => Name_Position)))));
2210 Set_Ekind (Func_Id, E_Function);
2211 Set_Mechanism (Func_Id, Default_Mechanism);
2212 Set_Is_Internal (Func_Id, True);
2214 if not Debug_Generated_Code then
2215 Set_Debug_Info_Off (Func_Id);
2218 Analyze (Body_Node);
2220 Append_Freeze_Action (Rec_Type, Body_Node);
2221 end Build_Offset_To_Top_Function;
2225 Iface_Comp : Node_Id;
2226 Iface_Comp_Elmt : Elmt_Id;
2227 Ifaces_Comp_List : Elist_Id;
2229 -- Start of processing for Build_Offset_To_Top_Functions
2232 -- Offset_To_Top_Functions are built only for derivations of types
2233 -- with discriminants that cover interface types.
2234 -- Nothing is needed either in case of virtual targets, since
2235 -- interfaces are handled directly by the target.
2237 if not Is_Tagged_Type (Rec_Type)
2238 or else Etype (Rec_Type) = Rec_Type
2239 or else not Has_Discriminants (Etype (Rec_Type))
2240 or else not Tagged_Type_Expansion
2245 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2247 -- For each interface type with secondary dispatch table we generate
2248 -- the Offset_To_Top_Functions (required to displace the pointer in
2249 -- interface conversions)
2251 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2252 while Present (Iface_Comp_Elmt) loop
2253 Iface_Comp := Node (Iface_Comp_Elmt);
2254 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2256 -- If the interface is a parent of Rec_Type it shares the primary
2257 -- dispatch table and hence there is no need to build the function
2259 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2260 Use_Full_View => True)
2262 Build_Offset_To_Top_Function (Iface_Comp);
2265 Next_Elmt (Iface_Comp_Elmt);
2267 end Build_Offset_To_Top_Functions;
2269 ------------------------------
2270 -- Build_CPP_Init_Procedure --
2271 ------------------------------
2273 procedure Build_CPP_Init_Procedure is
2274 Body_Node : Node_Id;
2275 Body_Stmts : List_Id;
2276 Flag_Id : Entity_Id;
2277 Handled_Stmt_Node : Node_Id;
2278 Init_Tags_List : List_Id;
2279 Proc_Id : Entity_Id;
2280 Proc_Spec_Node : Node_Id;
2283 -- Check cases requiring no IC routine
2285 if not Is_CPP_Class (Root_Type (Rec_Type))
2286 or else Is_CPP_Class (Rec_Type)
2287 or else CPP_Num_Prims (Rec_Type) = 0
2288 or else not Tagged_Type_Expansion
2289 or else No_Run_Time_Mode
2296 -- Flag : Boolean := False;
2298 -- procedure Typ_IC is
2301 -- Copy C++ dispatch table slots from parent
2302 -- Update C++ slots of overridden primitives
2306 Flag_Id := Make_Temporary (Loc, 'F');
2308 Append_Freeze_Action (Rec_Type,
2309 Make_Object_Declaration (Loc,
2310 Defining_Identifier => Flag_Id,
2311 Object_Definition =>
2312 New_Occurrence_Of (Standard_Boolean, Loc),
2314 New_Occurrence_Of (Standard_True, Loc)));
2316 Body_Stmts := New_List;
2317 Body_Node := New_Node (N_Subprogram_Body, Loc);
2319 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2322 Make_Defining_Identifier (Loc,
2323 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2325 Set_Ekind (Proc_Id, E_Procedure);
2326 Set_Is_Internal (Proc_Id);
2328 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2330 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2331 Set_Specification (Body_Node, Proc_Spec_Node);
2332 Set_Declarations (Body_Node, New_List);
2334 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2336 Append_To (Init_Tags_List,
2337 Make_Assignment_Statement (Loc,
2339 New_Occurrence_Of (Flag_Id, Loc),
2341 New_Occurrence_Of (Standard_False, Loc)));
2343 Append_To (Body_Stmts,
2344 Make_If_Statement (Loc,
2345 Condition => New_Occurrence_Of (Flag_Id, Loc),
2346 Then_Statements => Init_Tags_List));
2348 Handled_Stmt_Node :=
2349 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2350 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2351 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2352 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2354 if not Debug_Generated_Code then
2355 Set_Debug_Info_Off (Proc_Id);
2358 -- Associate CPP_Init_Proc with type
2360 Set_Init_Proc (Rec_Type, Proc_Id);
2361 end Build_CPP_Init_Procedure;
2363 --------------------------
2364 -- Build_Init_Procedure --
2365 --------------------------
2367 procedure Build_Init_Procedure is
2368 Body_Stmts : List_Id;
2369 Body_Node : Node_Id;
2370 Handled_Stmt_Node : Node_Id;
2371 Init_Tags_List : List_Id;
2372 Parameters : List_Id;
2373 Proc_Spec_Node : Node_Id;
2374 Record_Extension_Node : Node_Id;
2377 Body_Stmts := New_List;
2378 Body_Node := New_Node (N_Subprogram_Body, Loc);
2379 Set_Ekind (Proc_Id, E_Procedure);
2381 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2382 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2384 Parameters := Init_Formals (Rec_Type);
2385 Append_List_To (Parameters,
2386 Build_Discriminant_Formals (Rec_Type, True));
2388 -- For tagged types, we add a flag to indicate whether the routine
2389 -- is called to initialize a parent component in the init_proc of
2390 -- a type extension. If the flag is false, we do not set the tag
2391 -- because it has been set already in the extension.
2393 if Is_Tagged_Type (Rec_Type) then
2394 Set_Tag := Make_Temporary (Loc, 'P');
2396 Append_To (Parameters,
2397 Make_Parameter_Specification (Loc,
2398 Defining_Identifier => Set_Tag,
2400 New_Occurrence_Of (Standard_Boolean, Loc),
2402 New_Occurrence_Of (Standard_True, Loc)));
2405 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2406 Set_Specification (Body_Node, Proc_Spec_Node);
2407 Set_Declarations (Body_Node, Decls);
2409 -- N is a Derived_Type_Definition that renames the parameters of the
2410 -- ancestor type. We initialize it by expanding our discriminants and
2411 -- call the ancestor _init_proc with a type-converted object.
2413 if Parent_Subtype_Renaming_Discrims then
2414 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2416 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2417 Build_Discriminant_Assignments (Body_Stmts);
2419 if not Null_Present (Type_Definition (N)) then
2420 Append_List_To (Body_Stmts,
2421 Build_Init_Statements (Component_List (Type_Definition (N))));
2424 -- N is a Derived_Type_Definition with a possible non-empty
2425 -- extension. The initialization of a type extension consists in the
2426 -- initialization of the components in the extension.
2429 Build_Discriminant_Assignments (Body_Stmts);
2431 Record_Extension_Node :=
2432 Record_Extension_Part (Type_Definition (N));
2434 if not Null_Present (Record_Extension_Node) then
2436 Stmts : constant List_Id :=
2437 Build_Init_Statements (
2438 Component_List (Record_Extension_Node));
2441 -- The parent field must be initialized first because the
2442 -- offset of the new discriminants may depend on it. This is
2443 -- not needed if the parent is an interface type because in
2444 -- such case the initialization of the _parent field was not
2447 if not Is_Interface (Etype (Rec_Ent)) then
2449 Parent_IP : constant Name_Id :=
2450 Make_Init_Proc_Name (Etype (Rec_Ent));
2456 -- Look for a call to the parent IP at the beginning
2457 -- of Stmts associated with the record extension
2459 Stmt := First (Stmts);
2461 while Present (Stmt) loop
2462 if Nkind (Stmt) = N_Procedure_Call_Statement
2463 and then Chars (Name (Stmt)) = Parent_IP
2472 -- If found then move it to the beginning of the
2473 -- statements of this IP routine
2475 if Present (IP_Call) then
2476 IP_Stmts := New_List;
2478 Stmt := Remove_Head (Stmts);
2479 Append_To (IP_Stmts, Stmt);
2480 exit when Stmt = IP_Call;
2483 Prepend_List_To (Body_Stmts, IP_Stmts);
2488 Append_List_To (Body_Stmts, Stmts);
2493 -- Add here the assignment to instantiate the Tag
2495 -- The assignment corresponds to the code:
2497 -- _Init._Tag := Typ'Tag;
2499 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2500 -- tags are represented implicitly in objects. It is also suppressed
2501 -- in case of CPP_Class types because in this case the tag is
2502 -- initialized in the C++ side.
2504 if Is_Tagged_Type (Rec_Type)
2505 and then Tagged_Type_Expansion
2506 and then not No_Run_Time_Mode
2508 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2509 -- the actual object and invoke the IP of the parent (in this
2510 -- order). The tag must be initialized before the call to the IP
2511 -- of the parent and the assignments to other components because
2512 -- the initial value of the components may depend on the tag (eg.
2513 -- through a dispatching operation on an access to the current
2514 -- type). The tag assignment is not done when initializing the
2515 -- parent component of a type extension, because in that case the
2516 -- tag is set in the extension.
2518 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2520 -- Initialize the primary tag component
2522 Init_Tags_List := New_List (
2523 Make_Assignment_Statement (Loc,
2525 Make_Selected_Component (Loc,
2526 Prefix => Make_Identifier (Loc, Name_uInit),
2529 (First_Tag_Component (Rec_Type), Loc)),
2533 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2535 -- Ada 2005 (AI-251): Initialize the secondary tags components
2536 -- located at fixed positions (tags whose position depends on
2537 -- variable size components are initialized later ---see below)
2539 if Ada_Version >= Ada_2005
2540 and then not Is_Interface (Rec_Type)
2541 and then Has_Interfaces (Rec_Type)
2544 Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
2549 Target => Make_Identifier (Loc, Name_uInit),
2550 Init_Tags_List => Init_Tags_List,
2551 Stmts_List => Elab_Sec_DT_Stmts_List,
2552 Fixed_Comps => True,
2553 Variable_Comps => False);
2555 Append_To (Elab_Sec_DT_Stmts_List,
2556 Make_Assignment_Statement (Loc,
2559 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2561 New_Occurrence_Of (Standard_False, Loc)));
2563 Prepend_List_To (Body_Stmts, New_List (
2564 Make_If_Statement (Loc,
2565 Condition => New_Occurrence_Of (Set_Tag, Loc),
2566 Then_Statements => Init_Tags_List),
2568 Make_If_Statement (Loc,
2571 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2572 Then_Statements => Elab_Sec_DT_Stmts_List)));
2575 Prepend_To (Body_Stmts,
2576 Make_If_Statement (Loc,
2577 Condition => New_Occurrence_Of (Set_Tag, Loc),
2578 Then_Statements => Init_Tags_List));
2581 -- Case 2: CPP type. The imported C++ constructor takes care of
2582 -- tags initialization. No action needed here because the IP
2583 -- is built by Set_CPP_Constructors; in this case the IP is a
2584 -- wrapper that invokes the C++ constructor and copies the C++
2585 -- tags locally. Done to inherit the C++ slots in Ada derivations
2588 elsif Is_CPP_Class (Rec_Type) then
2589 pragma Assert (False);
2592 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2593 -- type derivations. Derivations of imported C++ classes add a
2594 -- complication, because we cannot inhibit tag setting in the
2595 -- constructor for the parent. Hence we initialize the tag after
2596 -- the call to the parent IP (that is, in reverse order compared
2597 -- with pure Ada hierarchies ---see comment on case 1).
2600 -- Initialize the primary tag
2602 Init_Tags_List := New_List (
2603 Make_Assignment_Statement (Loc,
2605 Make_Selected_Component (Loc,
2606 Prefix => Make_Identifier (Loc, Name_uInit),
2609 (First_Tag_Component (Rec_Type), Loc)),
2613 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2615 -- Ada 2005 (AI-251): Initialize the secondary tags components
2616 -- located at fixed positions (tags whose position depends on
2617 -- variable size components are initialized later ---see below)
2619 if Ada_Version >= Ada_2005
2620 and then not Is_Interface (Rec_Type)
2621 and then Has_Interfaces (Rec_Type)
2625 Target => Make_Identifier (Loc, Name_uInit),
2626 Init_Tags_List => Init_Tags_List,
2627 Stmts_List => Init_Tags_List,
2628 Fixed_Comps => True,
2629 Variable_Comps => False);
2632 -- Initialize the tag component after invocation of parent IP.
2635 -- parent_IP(_init.parent); // Invokes the C++ constructor
2636 -- [ typIC; ] // Inherit C++ slots from parent
2643 -- Search for the call to the IP of the parent. We assume
2644 -- that the first init_proc call is for the parent.
2646 Ins_Nod := First (Body_Stmts);
2647 while Present (Next (Ins_Nod))
2648 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2649 or else not Is_Init_Proc (Name (Ins_Nod)))
2654 -- The IC routine copies the inherited slots of the C+ part
2655 -- of the dispatch table from the parent and updates the
2656 -- overridden C++ slots.
2658 if CPP_Num_Prims (Rec_Type) > 0 then
2660 Init_DT : Entity_Id;
2664 Init_DT := CPP_Init_Proc (Rec_Type);
2665 pragma Assert (Present (Init_DT));
2668 Make_Procedure_Call_Statement (Loc,
2669 New_Occurrence_Of (Init_DT, Loc));
2670 Insert_After (Ins_Nod, New_Nod);
2672 -- Update location of init tag statements
2678 Insert_List_After (Ins_Nod, Init_Tags_List);
2682 -- Ada 2005 (AI-251): Initialize the secondary tag components
2683 -- located at variable positions. We delay the generation of this
2684 -- code until here because the value of the attribute 'Position
2685 -- applied to variable size components of the parent type that
2686 -- depend on discriminants is only safely read at runtime after
2687 -- the parent components have been initialized.
2689 if Ada_Version >= Ada_2005
2690 and then not Is_Interface (Rec_Type)
2691 and then Has_Interfaces (Rec_Type)
2692 and then Has_Discriminants (Etype (Rec_Type))
2693 and then Is_Variable_Size_Record (Etype (Rec_Type))
2695 Init_Tags_List := New_List;
2699 Target => Make_Identifier (Loc, Name_uInit),
2700 Init_Tags_List => Init_Tags_List,
2701 Stmts_List => Init_Tags_List,
2702 Fixed_Comps => False,
2703 Variable_Comps => True);
2705 if Is_Non_Empty_List (Init_Tags_List) then
2706 Append_List_To (Body_Stmts, Init_Tags_List);
2711 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2712 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2715 -- Deep_Finalize (_init, C1, ..., CN);
2719 and then Needs_Finalization (Rec_Type)
2720 and then not Is_Abstract_Type (Rec_Type)
2721 and then not Restriction_Active (No_Exception_Propagation)
2728 -- Create a local version of Deep_Finalize which has indication
2729 -- of partial initialization state.
2731 DF_Id := Make_Temporary (Loc, 'F');
2733 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2736 Make_Procedure_Call_Statement (Loc,
2737 Name => New_Occurrence_Of (DF_Id, Loc),
2738 Parameter_Associations => New_List (
2739 Make_Identifier (Loc, Name_uInit),
2740 New_Occurrence_Of (Standard_False, Loc)));
2742 -- Do not emit warnings related to the elaboration order when a
2743 -- controlled object is declared before the body of Finalize is
2746 Set_No_Elaboration_Check (DF_Call);
2748 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2749 Make_Exception_Handler (Loc,
2750 Exception_Choices => New_List (
2751 Make_Others_Choice (Loc)),
2752 Statements => New_List (
2754 Make_Raise_Statement (Loc)))));
2757 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2760 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2762 if not Debug_Generated_Code then
2763 Set_Debug_Info_Off (Proc_Id);
2766 -- Associate Init_Proc with type, and determine if the procedure
2767 -- is null (happens because of the Initialize_Scalars pragma case,
2768 -- where we have to generate a null procedure in case it is called
2769 -- by a client with Initialize_Scalars set). Such procedures have
2770 -- to be generated, but do not have to be called, so we mark them
2771 -- as null to suppress the call.
2773 Set_Init_Proc (Rec_Type, Proc_Id);
2775 if List_Length (Body_Stmts) = 1
2777 -- We must skip SCIL nodes because they may have been added to this
2778 -- list by Insert_Actions.
2780 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2782 Set_Is_Null_Init_Proc (Proc_Id);
2784 end Build_Init_Procedure;
2786 ---------------------------
2787 -- Build_Init_Statements --
2788 ---------------------------
2790 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2791 Checks : constant List_Id := New_List;
2792 Actions : List_Id := No_List;
2793 Counter_Id : Entity_Id := Empty;
2794 Comp_Loc : Source_Ptr;
2798 Parent_Stmts : List_Id;
2802 procedure Increment_Counter (Loc : Source_Ptr);
2803 -- Generate an "increment by one" statement for the current counter
2804 -- and append it to the list Stmts.
2806 procedure Make_Counter (Loc : Source_Ptr);
2807 -- Create a new counter for the current component list. The routine
2808 -- creates a new defining Id, adds an object declaration and sets
2809 -- the Id generator for the next variant.
2811 -----------------------
2812 -- Increment_Counter --
2813 -----------------------
2815 procedure Increment_Counter (Loc : Source_Ptr) is
2818 -- Counter := Counter + 1;
2821 Make_Assignment_Statement (Loc,
2822 Name => New_Occurrence_Of (Counter_Id, Loc),
2825 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
2826 Right_Opnd => Make_Integer_Literal (Loc, 1))));
2827 end Increment_Counter;
2833 procedure Make_Counter (Loc : Source_Ptr) is
2835 -- Increment the Id generator
2837 Counter := Counter + 1;
2839 -- Create the entity and declaration
2842 Make_Defining_Identifier (Loc,
2843 Chars => New_External_Name ('C', Counter));
2846 -- Cnn : Integer := 0;
2849 Make_Object_Declaration (Loc,
2850 Defining_Identifier => Counter_Id,
2851 Object_Definition =>
2852 New_Occurrence_Of (Standard_Integer, Loc),
2854 Make_Integer_Literal (Loc, 0)));
2857 -- Start of processing for Build_Init_Statements
2860 if Null_Present (Comp_List) then
2861 return New_List (Make_Null_Statement (Loc));
2864 Parent_Stmts := New_List;
2867 -- Loop through visible declarations of task types and protected
2868 -- types moving any expanded code from the spec to the body of the
2871 if Is_Task_Record_Type (Rec_Type)
2872 or else Is_Protected_Record_Type (Rec_Type)
2875 Decl : constant Node_Id :=
2876 Parent (Corresponding_Concurrent_Type (Rec_Type));
2882 if Is_Task_Record_Type (Rec_Type) then
2883 Def := Task_Definition (Decl);
2885 Def := Protected_Definition (Decl);
2888 if Present (Def) then
2889 N1 := First (Visible_Declarations (Def));
2890 while Present (N1) loop
2894 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2895 or else Nkind (N2) in N_Raise_xxx_Error
2896 or else Nkind (N2) = N_Procedure_Call_Statement
2899 New_Copy_Tree (N2, New_Scope => Proc_Id));
2900 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2908 -- Loop through components, skipping pragmas, in 2 steps. The first
2909 -- step deals with regular components. The second step deals with
2910 -- components that have per object constraints and no explicit
2915 -- First pass : regular components
2917 Decl := First_Non_Pragma (Component_Items (Comp_List));
2918 while Present (Decl) loop
2919 Comp_Loc := Sloc (Decl);
2921 (Subtype_Indication (Component_Definition (Decl)), Checks);
2923 Id := Defining_Identifier (Decl);
2926 -- Leave any processing of per-object constrained component for
2929 if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
2932 -- Regular component cases
2935 -- In the context of the init proc, references to discriminants
2936 -- resolve to denote the discriminals: this is where we can
2937 -- freeze discriminant dependent component subtypes.
2939 if not Is_Frozen (Typ) then
2940 Append_List_To (Stmts, Freeze_Entity (Typ, N));
2943 -- Explicit initialization
2945 if Present (Expression (Decl)) then
2946 if Is_CPP_Constructor_Call (Expression (Decl)) then
2948 Build_Initialization_Call
2951 Make_Selected_Component (Comp_Loc,
2953 Make_Identifier (Comp_Loc, Name_uInit),
2955 New_Occurrence_Of (Id, Comp_Loc)),
2957 In_Init_Proc => True,
2958 Enclos_Type => Rec_Type,
2959 Discr_Map => Discr_Map,
2960 Constructor_Ref => Expression (Decl));
2962 Actions := Build_Assignment (Id, Expression (Decl));
2965 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
2966 -- components are filled in with the corresponding rep-item
2967 -- expression of the concurrent type (if any).
2969 elsif Ekind (Scope (Id)) = E_Record_Type
2970 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
2971 and then Nam_In (Chars (Id), Name_uCPU,
2972 Name_uDispatching_Domain,
2974 Name_uSecondary_Stack_Size)
2979 pragma Warnings (Off, Nam);
2983 if Chars (Id) = Name_uCPU then
2986 elsif Chars (Id) = Name_uDispatching_Domain then
2987 Nam := Name_Dispatching_Domain;
2989 elsif Chars (Id) = Name_uPriority then
2990 Nam := Name_Priority;
2992 elsif Chars (Id) = Name_uSecondary_Stack_Size then
2993 Nam := Name_Secondary_Stack_Size;
2996 -- Get the Rep Item (aspect specification, attribute
2997 -- definition clause or pragma) of the corresponding
3002 (Corresponding_Concurrent_Type (Scope (Id)),
3004 Check_Parents => False);
3006 if Present (Ritem) then
3010 if Nkind (Ritem) = N_Pragma then
3011 Exp := First (Pragma_Argument_Associations (Ritem));
3013 if Nkind (Exp) = N_Pragma_Argument_Association then
3014 Exp := Expression (Exp);
3017 -- Conversion for Priority expression
3019 if Nam = Name_Priority then
3020 if Pragma_Name (Ritem) = Name_Priority
3021 and then not GNAT_Mode
3023 Exp := Convert_To (RTE (RE_Priority), Exp);
3026 Convert_To (RTE (RE_Any_Priority), Exp);
3030 -- Aspect/Attribute definition clause case
3033 Exp := Expression (Ritem);
3035 -- Conversion for Priority expression
3037 if Nam = Name_Priority then
3038 if Chars (Ritem) = Name_Priority
3039 and then not GNAT_Mode
3041 Exp := Convert_To (RTE (RE_Priority), Exp);
3044 Convert_To (RTE (RE_Any_Priority), Exp);
3049 -- Conversion for Dispatching_Domain value
3051 if Nam = Name_Dispatching_Domain then
3053 Unchecked_Convert_To
3054 (RTE (RE_Dispatching_Domain_Access), Exp);
3056 -- Conversion for Secondary_Stack_Size value
3058 elsif Nam = Name_Secondary_Stack_Size then
3059 Exp := Convert_To (RTE (RE_Size_Type), Exp);
3062 Actions := Build_Assignment (Id, Exp);
3064 -- Nothing needed if no Rep Item
3071 -- Composite component with its own Init_Proc
3073 elsif not Is_Interface (Typ)
3074 and then Has_Non_Null_Base_Init_Proc (Typ)
3077 Build_Initialization_Call
3079 Make_Selected_Component (Comp_Loc,
3081 Make_Identifier (Comp_Loc, Name_uInit),
3082 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3084 In_Init_Proc => True,
3085 Enclos_Type => Rec_Type,
3086 Discr_Map => Discr_Map);
3088 Clean_Task_Names (Typ, Proc_Id);
3090 -- Simple initialization
3092 elsif Component_Needs_Simple_Initialization (Typ) then
3095 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
3097 -- Nothing needed for this case
3103 if Present (Checks) then
3104 if Chars (Id) = Name_uParent then
3105 Append_List_To (Parent_Stmts, Checks);
3107 Append_List_To (Stmts, Checks);
3111 if Present (Actions) then
3112 if Chars (Id) = Name_uParent then
3113 Append_List_To (Parent_Stmts, Actions);
3116 Append_List_To (Stmts, Actions);
3118 -- Preserve initialization state in the current counter
3120 if Needs_Finalization (Typ) then
3121 if No (Counter_Id) then
3122 Make_Counter (Comp_Loc);
3125 Increment_Counter (Comp_Loc);
3131 Next_Non_Pragma (Decl);
3134 -- The parent field must be initialized first because variable
3135 -- size components of the parent affect the location of all the
3138 Prepend_List_To (Stmts, Parent_Stmts);
3140 -- Set up tasks and protected object support. This needs to be done
3141 -- before any component with a per-object access discriminant
3142 -- constraint, or any variant part (which may contain such
3143 -- components) is initialized, because the initialization of these
3144 -- components may reference the enclosing concurrent object.
3146 -- For a task record type, add the task create call and calls to bind
3147 -- any interrupt (signal) entries.
3149 if Is_Task_Record_Type (Rec_Type) then
3151 -- In the case of the restricted run time the ATCB has already
3152 -- been preallocated.
3154 if Restricted_Profile then
3156 Make_Assignment_Statement (Loc,
3158 Make_Selected_Component (Loc,
3159 Prefix => Make_Identifier (Loc, Name_uInit),
3160 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3162 Make_Attribute_Reference (Loc,
3164 Make_Selected_Component (Loc,
3165 Prefix => Make_Identifier (Loc, Name_uInit),
3166 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3167 Attribute_Name => Name_Unchecked_Access)));
3170 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3173 Task_Type : constant Entity_Id :=
3174 Corresponding_Concurrent_Type (Rec_Type);
3175 Task_Decl : constant Node_Id := Parent (Task_Type);
3176 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3177 Decl_Loc : Source_Ptr;
3182 if Present (Task_Def) then
3183 Vis_Decl := First (Visible_Declarations (Task_Def));
3184 while Present (Vis_Decl) loop
3185 Decl_Loc := Sloc (Vis_Decl);
3187 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3188 if Get_Attribute_Id (Chars (Vis_Decl)) =
3191 Ent := Entity (Name (Vis_Decl));
3193 if Ekind (Ent) = E_Entry then
3195 Make_Procedure_Call_Statement (Decl_Loc,
3197 New_Occurrence_Of (RTE (
3198 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3199 Parameter_Associations => New_List (
3200 Make_Selected_Component (Decl_Loc,
3202 Make_Identifier (Decl_Loc, Name_uInit),
3205 (Decl_Loc, Name_uTask_Id)),
3206 Entry_Index_Expression
3207 (Decl_Loc, Ent, Empty, Task_Type),
3208 Expression (Vis_Decl))));
3219 -- For a protected type, add statements generated by
3220 -- Make_Initialize_Protection.
3222 if Is_Protected_Record_Type (Rec_Type) then
3223 Append_List_To (Stmts,
3224 Make_Initialize_Protection (Rec_Type));
3227 -- Second pass: components with per-object constraints
3230 Decl := First_Non_Pragma (Component_Items (Comp_List));
3231 while Present (Decl) loop
3232 Comp_Loc := Sloc (Decl);
3233 Id := Defining_Identifier (Decl);
3236 if Has_Access_Constraint (Id)
3237 and then No (Expression (Decl))
3239 if Has_Non_Null_Base_Init_Proc (Typ) then
3240 Append_List_To (Stmts,
3241 Build_Initialization_Call (Comp_Loc,
3242 Make_Selected_Component (Comp_Loc,
3244 Make_Identifier (Comp_Loc, Name_uInit),
3245 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3247 In_Init_Proc => True,
3248 Enclos_Type => Rec_Type,
3249 Discr_Map => Discr_Map));
3251 Clean_Task_Names (Typ, Proc_Id);
3253 -- Preserve initialization state in the current counter
3255 if Needs_Finalization (Typ) then
3256 if No (Counter_Id) then
3257 Make_Counter (Comp_Loc);
3260 Increment_Counter (Comp_Loc);
3263 elsif Component_Needs_Simple_Initialization (Typ) then
3264 Append_List_To (Stmts,
3266 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
3270 Next_Non_Pragma (Decl);
3274 -- Process the variant part
3276 if Present (Variant_Part (Comp_List)) then
3278 Variant_Alts : constant List_Id := New_List;
3279 Var_Loc : Source_Ptr := No_Location;
3284 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3285 while Present (Variant) loop
3286 Var_Loc := Sloc (Variant);
3287 Append_To (Variant_Alts,
3288 Make_Case_Statement_Alternative (Var_Loc,
3290 New_Copy_List (Discrete_Choices (Variant)),
3292 Build_Init_Statements (Component_List (Variant))));
3293 Next_Non_Pragma (Variant);
3296 -- The expression of the case statement which is a reference
3297 -- to one of the discriminants is replaced by the appropriate
3298 -- formal parameter of the initialization procedure.
3301 Make_Case_Statement (Var_Loc,
3303 New_Occurrence_Of (Discriminal (
3304 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3305 Alternatives => Variant_Alts));
3309 -- If no initializations when generated for component declarations
3310 -- corresponding to this Stmts, append a null statement to Stmts to
3311 -- to make it a valid Ada tree.
3313 if Is_Empty_List (Stmts) then
3314 Append (Make_Null_Statement (Loc), Stmts);
3320 when RE_Not_Available =>
3322 end Build_Init_Statements;
3324 -------------------------
3325 -- Build_Record_Checks --
3326 -------------------------
3328 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3329 Subtype_Mark_Id : Entity_Id;
3331 procedure Constrain_Array
3333 Check_List : List_Id);
3334 -- Apply a list of index constraints to an unconstrained array type.
3335 -- The first parameter is the entity for the resulting subtype.
3336 -- Check_List is a list to which the check actions are appended.
3338 ---------------------
3339 -- Constrain_Array --
3340 ---------------------
3342 procedure Constrain_Array
3344 Check_List : List_Id)
3346 C : constant Node_Id := Constraint (SI);
3347 Number_Of_Constraints : Nat := 0;
3351 procedure Constrain_Index
3354 Check_List : List_Id);
3355 -- Process an index constraint in a constrained array declaration.
3356 -- The constraint can be either a subtype name or a range with or
3357 -- without an explicit subtype mark. Index is the corresponding
3358 -- index of the unconstrained array. S is the range expression.
3359 -- Check_List is a list to which the check actions are appended.
3361 ---------------------
3362 -- Constrain_Index --
3363 ---------------------
3365 procedure Constrain_Index
3368 Check_List : List_Id)
3370 T : constant Entity_Id := Etype (Index);
3373 if Nkind (S) = N_Range then
3374 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3376 end Constrain_Index;
3378 -- Start of processing for Constrain_Array
3381 T := Entity (Subtype_Mark (SI));
3383 if Is_Access_Type (T) then
3384 T := Designated_Type (T);
3387 S := First (Constraints (C));
3388 while Present (S) loop
3389 Number_Of_Constraints := Number_Of_Constraints + 1;
3393 -- In either case, the index constraint must provide a discrete
3394 -- range for each index of the array type and the type of each
3395 -- discrete range must be the same as that of the corresponding
3396 -- index. (RM 3.6.1)
3398 S := First (Constraints (C));
3399 Index := First_Index (T);
3402 -- Apply constraints to each index type
3404 for J in 1 .. Number_Of_Constraints loop
3405 Constrain_Index (Index, S, Check_List);
3409 end Constrain_Array;
3411 -- Start of processing for Build_Record_Checks
3414 if Nkind (S) = N_Subtype_Indication then
3415 Find_Type (Subtype_Mark (S));
3416 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3418 -- Remaining processing depends on type
3420 case Ekind (Subtype_Mark_Id) is
3422 Constrain_Array (S, Check_List);
3428 end Build_Record_Checks;
3430 -------------------------------------------
3431 -- Component_Needs_Simple_Initialization --
3432 -------------------------------------------
3434 function Component_Needs_Simple_Initialization
3435 (T : Entity_Id) return Boolean
3439 Needs_Simple_Initialization (T)
3440 and then not Is_RTE (T, RE_Tag)
3442 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3444 and then not Is_RTE (T, RE_Interface_Tag);
3445 end Component_Needs_Simple_Initialization;
3447 --------------------------------------
3448 -- Parent_Subtype_Renaming_Discrims --
3449 --------------------------------------
3451 function Parent_Subtype_Renaming_Discrims return Boolean is
3456 if Base_Type (Rec_Ent) /= Rec_Ent then
3460 if Etype (Rec_Ent) = Rec_Ent
3461 or else not Has_Discriminants (Rec_Ent)
3462 or else Is_Constrained (Rec_Ent)
3463 or else Is_Tagged_Type (Rec_Ent)
3468 -- If there are no explicit stored discriminants we have inherited
3469 -- the root type discriminants so far, so no renamings occurred.
3471 if First_Discriminant (Rec_Ent) =
3472 First_Stored_Discriminant (Rec_Ent)
3477 -- Check if we have done some trivial renaming of the parent
3478 -- discriminants, i.e. something like
3480 -- type DT (X1, X2: int) is new PT (X1, X2);
3482 De := First_Discriminant (Rec_Ent);
3483 Dp := First_Discriminant (Etype (Rec_Ent));
3484 while Present (De) loop
3485 pragma Assert (Present (Dp));
3487 if Corresponding_Discriminant (De) /= Dp then
3491 Next_Discriminant (De);
3492 Next_Discriminant (Dp);
3495 return Present (Dp);
3496 end Parent_Subtype_Renaming_Discrims;
3498 ------------------------
3499 -- Requires_Init_Proc --
3500 ------------------------
3502 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3503 Comp_Decl : Node_Id;
3508 -- Definitely do not need one if specifically suppressed
3510 if Initialization_Suppressed (Rec_Id) then
3514 -- If it is a type derived from a type with unknown discriminants,
3515 -- we cannot build an initialization procedure for it.
3517 if Has_Unknown_Discriminants (Rec_Id)
3518 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3523 -- Otherwise we need to generate an initialization procedure if
3524 -- Is_CPP_Class is False and at least one of the following applies:
3526 -- 1. Discriminants are present, since they need to be initialized
3527 -- with the appropriate discriminant constraint expressions.
3528 -- However, the discriminant of an unchecked union does not
3529 -- count, since the discriminant is not present.
3531 -- 2. The type is a tagged type, since the implicit Tag component
3532 -- needs to be initialized with a pointer to the dispatch table.
3534 -- 3. The type contains tasks
3536 -- 4. One or more components has an initial value
3538 -- 5. One or more components is for a type which itself requires
3539 -- an initialization procedure.
3541 -- 6. One or more components is a type that requires simple
3542 -- initialization (see Needs_Simple_Initialization), except
3543 -- that types Tag and Interface_Tag are excluded, since fields
3544 -- of these types are initialized by other means.
3546 -- 7. The type is the record type built for a task type (since at
3547 -- the very least, Create_Task must be called)
3549 -- 8. The type is the record type built for a protected type (since
3550 -- at least Initialize_Protection must be called)
3552 -- 9. The type is marked as a public entity. The reason we add this
3553 -- case (even if none of the above apply) is to properly handle
3554 -- Initialize_Scalars. If a package is compiled without an IS
3555 -- pragma, and the client is compiled with an IS pragma, then
3556 -- the client will think an initialization procedure is present
3557 -- and call it, when in fact no such procedure is required, but
3558 -- since the call is generated, there had better be a routine
3559 -- at the other end of the call, even if it does nothing).
3561 -- Note: the reason we exclude the CPP_Class case is because in this
3562 -- case the initialization is performed by the C++ constructors, and
3563 -- the IP is built by Set_CPP_Constructors.
3565 if Is_CPP_Class (Rec_Id) then
3568 elsif Is_Interface (Rec_Id) then
3571 elsif (Has_Discriminants (Rec_Id)
3572 and then not Is_Unchecked_Union (Rec_Id))
3573 or else Is_Tagged_Type (Rec_Id)
3574 or else Is_Concurrent_Record_Type (Rec_Id)
3575 or else Has_Task (Rec_Id)
3580 Id := First_Component (Rec_Id);
3581 while Present (Id) loop
3582 Comp_Decl := Parent (Id);
3585 if Present (Expression (Comp_Decl))
3586 or else Has_Non_Null_Base_Init_Proc (Typ)
3587 or else Component_Needs_Simple_Initialization (Typ)
3592 Next_Component (Id);
3595 -- As explained above, a record initialization procedure is needed
3596 -- for public types in case Initialize_Scalars applies to a client.
3597 -- However, such a procedure is not needed in the case where either
3598 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3599 -- applies. No_Initialize_Scalars excludes the possibility of using
3600 -- Initialize_Scalars in any partition, and No_Default_Initialization
3601 -- implies that no initialization should ever be done for objects of
3602 -- the type, so is incompatible with Initialize_Scalars.
3604 if not Restriction_Active (No_Initialize_Scalars)
3605 and then not Restriction_Active (No_Default_Initialization)
3606 and then Is_Public (Rec_Id)
3612 end Requires_Init_Proc;
3614 -- Start of processing for Build_Record_Init_Proc
3617 Rec_Type := Defining_Identifier (N);
3619 -- This may be full declaration of a private type, in which case
3620 -- the visible entity is a record, and the private entity has been
3621 -- exchanged with it in the private part of the current package.
3622 -- The initialization procedure is built for the record type, which
3623 -- is retrievable from the private entity.
3625 if Is_Incomplete_Or_Private_Type (Rec_Type) then
3626 Rec_Type := Underlying_Type (Rec_Type);
3629 -- If we have a variant record with restriction No_Implicit_Conditionals
3630 -- in effect, then we skip building the procedure. This is safe because
3631 -- if we can see the restriction, so can any caller, calls to initialize
3632 -- such records are not allowed for variant records if this restriction
3635 if Has_Variant_Part (Rec_Type)
3636 and then Restriction_Active (No_Implicit_Conditionals)
3641 -- If there are discriminants, build the discriminant map to replace
3642 -- discriminants by their discriminals in complex bound expressions.
3643 -- These only arise for the corresponding records of synchronized types.
3645 if Is_Concurrent_Record_Type (Rec_Type)
3646 and then Has_Discriminants (Rec_Type)
3651 Disc := First_Discriminant (Rec_Type);
3652 while Present (Disc) loop
3653 Append_Elmt (Disc, Discr_Map);
3654 Append_Elmt (Discriminal (Disc), Discr_Map);
3655 Next_Discriminant (Disc);
3660 -- Derived types that have no type extension can use the initialization
3661 -- procedure of their parent and do not need a procedure of their own.
3662 -- This is only correct if there are no representation clauses for the
3663 -- type or its parent, and if the parent has in fact been frozen so
3664 -- that its initialization procedure exists.
3666 if Is_Derived_Type (Rec_Type)
3667 and then not Is_Tagged_Type (Rec_Type)
3668 and then not Is_Unchecked_Union (Rec_Type)
3669 and then not Has_New_Non_Standard_Rep (Rec_Type)
3670 and then not Parent_Subtype_Renaming_Discrims
3671 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
3673 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3675 -- Otherwise if we need an initialization procedure, then build one,
3676 -- mark it as public and inlinable and as having a completion.
3678 elsif Requires_Init_Proc (Rec_Type)
3679 or else Is_Unchecked_Union (Rec_Type)
3682 Make_Defining_Identifier (Loc,
3683 Chars => Make_Init_Proc_Name (Rec_Type));
3685 -- If No_Default_Initialization restriction is active, then we don't
3686 -- want to build an init_proc, but we need to mark that an init_proc
3687 -- would be needed if this restriction was not active (so that we can
3688 -- detect attempts to call it), so set a dummy init_proc in place.
3690 if Restriction_Active (No_Default_Initialization) then
3691 Set_Init_Proc (Rec_Type, Proc_Id);
3695 Build_Offset_To_Top_Functions;
3696 Build_CPP_Init_Procedure;
3697 Build_Init_Procedure;
3699 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
3700 Set_Is_Internal (Proc_Id);
3701 Set_Has_Completion (Proc_Id);
3703 if not Debug_Generated_Code then
3704 Set_Debug_Info_Off (Proc_Id);
3707 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
3709 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
3710 -- needed and may generate early references to non frozen types
3711 -- since we expand aggregate much more systematically.
3713 if Modify_Tree_For_C then
3718 Agg : constant Node_Id :=
3719 Build_Equivalent_Record_Aggregate (Rec_Type);
3721 procedure Collect_Itypes (Comp : Node_Id);
3722 -- Generate references to itypes in the aggregate, because
3723 -- the first use of the aggregate may be in a nested scope.
3725 --------------------
3726 -- Collect_Itypes --
3727 --------------------
3729 procedure Collect_Itypes (Comp : Node_Id) is
3732 Typ : constant Entity_Id := Etype (Comp);
3735 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
3736 Ref := Make_Itype_Reference (Loc);
3737 Set_Itype (Ref, Typ);
3738 Append_Freeze_Action (Rec_Type, Ref);
3740 Ref := Make_Itype_Reference (Loc);
3741 Set_Itype (Ref, Etype (First_Index (Typ)));
3742 Append_Freeze_Action (Rec_Type, Ref);
3744 -- Recurse on nested arrays
3746 Sub_Aggr := First (Expressions (Comp));
3747 while Present (Sub_Aggr) loop
3748 Collect_Itypes (Sub_Aggr);
3755 -- If there is a static initialization aggregate for the type,
3756 -- generate itype references for the types of its (sub)components,
3757 -- to prevent out-of-scope errors in the resulting tree.
3758 -- The aggregate may have been rewritten as a Raise node, in which
3759 -- case there are no relevant itypes.
3761 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
3762 Set_Static_Initialization (Proc_Id, Agg);
3767 Comp := First (Component_Associations (Agg));
3768 while Present (Comp) loop
3769 Collect_Itypes (Expression (Comp));
3776 end Build_Record_Init_Proc;
3778 ----------------------------
3779 -- Build_Slice_Assignment --
3780 ----------------------------
3782 -- Generates the following subprogram:
3785 -- (Source, Target : Array_Type,
3786 -- Left_Lo, Left_Hi : Index;
3787 -- Right_Lo, Right_Hi : Index;
3795 -- if Left_Hi < Left_Lo then
3808 -- Target (Li1) := Source (Ri1);
3811 -- exit when Li1 = Left_Lo;
3812 -- Li1 := Index'pred (Li1);
3813 -- Ri1 := Index'pred (Ri1);
3815 -- exit when Li1 = Left_Hi;
3816 -- Li1 := Index'succ (Li1);
3817 -- Ri1 := Index'succ (Ri1);
3822 procedure Build_Slice_Assignment (Typ : Entity_Id) is
3823 Loc : constant Source_Ptr := Sloc (Typ);
3824 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
3826 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
3827 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
3828 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
3829 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
3830 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
3831 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
3832 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
3833 -- Formal parameters of procedure
3835 Proc_Name : constant Entity_Id :=
3836 Make_Defining_Identifier (Loc,
3837 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
3839 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
3840 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
3841 -- Subscripts for left and right sides
3848 -- Build declarations for indexes
3853 Make_Object_Declaration (Loc,
3854 Defining_Identifier => Lnn,
3855 Object_Definition =>
3856 New_Occurrence_Of (Index, Loc)));
3859 Make_Object_Declaration (Loc,
3860 Defining_Identifier => Rnn,
3861 Object_Definition =>
3862 New_Occurrence_Of (Index, Loc)));
3866 -- Build test for empty slice case
3869 Make_If_Statement (Loc,
3872 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
3873 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
3874 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
3876 -- Build initializations for indexes
3879 F_Init : constant List_Id := New_List;
3880 B_Init : constant List_Id := New_List;
3884 Make_Assignment_Statement (Loc,
3885 Name => New_Occurrence_Of (Lnn, Loc),
3886 Expression => New_Occurrence_Of (Left_Lo, Loc)));
3889 Make_Assignment_Statement (Loc,
3890 Name => New_Occurrence_Of (Rnn, Loc),
3891 Expression => New_Occurrence_Of (Right_Lo, Loc)));
3894 Make_Assignment_Statement (Loc,
3895 Name => New_Occurrence_Of (Lnn, Loc),
3896 Expression => New_Occurrence_Of (Left_Hi, Loc)));
3899 Make_Assignment_Statement (Loc,
3900 Name => New_Occurrence_Of (Rnn, Loc),
3901 Expression => New_Occurrence_Of (Right_Hi, Loc)));
3904 Make_If_Statement (Loc,
3905 Condition => New_Occurrence_Of (Rev, Loc),
3906 Then_Statements => B_Init,
3907 Else_Statements => F_Init));
3910 -- Now construct the assignment statement
3913 Make_Loop_Statement (Loc,
3914 Statements => New_List (
3915 Make_Assignment_Statement (Loc,
3917 Make_Indexed_Component (Loc,
3918 Prefix => New_Occurrence_Of (Larray, Loc),
3919 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
3921 Make_Indexed_Component (Loc,
3922 Prefix => New_Occurrence_Of (Rarray, Loc),
3923 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
3924 End_Label => Empty);
3926 -- Build the exit condition and increment/decrement statements
3929 F_Ass : constant List_Id := New_List;
3930 B_Ass : constant List_Id := New_List;
3934 Make_Exit_Statement (Loc,
3937 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3938 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
3941 Make_Assignment_Statement (Loc,
3942 Name => New_Occurrence_Of (Lnn, Loc),
3944 Make_Attribute_Reference (Loc,
3946 New_Occurrence_Of (Index, Loc),
3947 Attribute_Name => Name_Succ,
3948 Expressions => New_List (
3949 New_Occurrence_Of (Lnn, Loc)))));
3952 Make_Assignment_Statement (Loc,
3953 Name => New_Occurrence_Of (Rnn, Loc),
3955 Make_Attribute_Reference (Loc,
3957 New_Occurrence_Of (Index, Loc),
3958 Attribute_Name => Name_Succ,
3959 Expressions => New_List (
3960 New_Occurrence_Of (Rnn, Loc)))));
3963 Make_Exit_Statement (Loc,
3966 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3967 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
3970 Make_Assignment_Statement (Loc,
3971 Name => New_Occurrence_Of (Lnn, Loc),
3973 Make_Attribute_Reference (Loc,
3975 New_Occurrence_Of (Index, Loc),
3976 Attribute_Name => Name_Pred,
3977 Expressions => New_List (
3978 New_Occurrence_Of (Lnn, Loc)))));
3981 Make_Assignment_Statement (Loc,
3982 Name => New_Occurrence_Of (Rnn, Loc),
3984 Make_Attribute_Reference (Loc,
3986 New_Occurrence_Of (Index, Loc),
3987 Attribute_Name => Name_Pred,
3988 Expressions => New_List (
3989 New_Occurrence_Of (Rnn, Loc)))));
3991 Append_To (Statements (Loops),
3992 Make_If_Statement (Loc,
3993 Condition => New_Occurrence_Of (Rev, Loc),
3994 Then_Statements => B_Ass,
3995 Else_Statements => F_Ass));
3998 Append_To (Stats, Loops);
4002 Formals : List_Id := New_List;
4005 Formals := New_List (
4006 Make_Parameter_Specification (Loc,
4007 Defining_Identifier => Larray,
4008 Out_Present => True,
4010 New_Occurrence_Of (Base_Type (Typ), Loc)),
4012 Make_Parameter_Specification (Loc,
4013 Defining_Identifier => Rarray,
4015 New_Occurrence_Of (Base_Type (Typ), Loc)),
4017 Make_Parameter_Specification (Loc,
4018 Defining_Identifier => Left_Lo,
4020 New_Occurrence_Of (Index, Loc)),
4022 Make_Parameter_Specification (Loc,
4023 Defining_Identifier => Left_Hi,
4025 New_Occurrence_Of (Index, Loc)),
4027 Make_Parameter_Specification (Loc,
4028 Defining_Identifier => Right_Lo,
4030 New_Occurrence_Of (Index, Loc)),
4032 Make_Parameter_Specification (Loc,
4033 Defining_Identifier => Right_Hi,
4035 New_Occurrence_Of (Index, Loc)));
4038 Make_Parameter_Specification (Loc,
4039 Defining_Identifier => Rev,
4041 New_Occurrence_Of (Standard_Boolean, Loc)));
4044 Make_Procedure_Specification (Loc,
4045 Defining_Unit_Name => Proc_Name,
4046 Parameter_Specifications => Formals);
4049 Make_Subprogram_Body (Loc,
4050 Specification => Spec,
4051 Declarations => Decls,
4052 Handled_Statement_Sequence =>
4053 Make_Handled_Sequence_Of_Statements (Loc,
4054 Statements => Stats)));
4057 Set_TSS (Typ, Proc_Name);
4058 Set_Is_Pure (Proc_Name);
4059 end Build_Slice_Assignment;
4061 -----------------------------
4062 -- Build_Untagged_Equality --
4063 -----------------------------
4065 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4073 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4074 -- Check whether the type T has a user-defined primitive equality. If so
4075 -- return it, else return Empty. If true for a component of Typ, we have
4076 -- to build the primitive equality for it.
4078 ---------------------
4079 -- User_Defined_Eq --
4080 ---------------------
4082 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4087 Op := TSS (T, TSS_Composite_Equality);
4089 if Present (Op) then
4093 Prim := First_Elmt (Collect_Primitive_Operations (T));
4094 while Present (Prim) loop
4097 if Chars (Op) = Name_Op_Eq
4098 and then Etype (Op) = Standard_Boolean
4099 and then Etype (First_Formal (Op)) = T
4100 and then Etype (Next_Formal (First_Formal (Op))) = T
4109 end User_Defined_Eq;
4111 -- Start of processing for Build_Untagged_Equality
4114 -- If a record component has a primitive equality operation, we must
4115 -- build the corresponding one for the current type.
4118 Comp := First_Component (Typ);
4119 while Present (Comp) loop
4120 if Is_Record_Type (Etype (Comp))
4121 and then Present (User_Defined_Eq (Etype (Comp)))
4126 Next_Component (Comp);
4129 -- If there is a user-defined equality for the type, we do not create
4130 -- the implicit one.
4132 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
4134 while Present (Prim) loop
4135 if Chars (Node (Prim)) = Name_Op_Eq
4136 and then Comes_From_Source (Node (Prim))
4138 -- Don't we also need to check formal types and return type as in
4139 -- User_Defined_Eq above???
4142 Eq_Op := Node (Prim);
4150 -- If the type is derived, inherit the operation, if present, from the
4151 -- parent type. It may have been declared after the type derivation. If
4152 -- the parent type itself is derived, it may have inherited an operation
4153 -- that has itself been overridden, so update its alias and related
4154 -- flags. Ditto for inequality.
4156 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4157 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
4158 while Present (Prim) loop
4159 if Chars (Node (Prim)) = Name_Op_Eq then
4160 Copy_TSS (Node (Prim), Typ);
4164 Op : constant Entity_Id := User_Defined_Eq (Typ);
4165 Eq_Op : constant Entity_Id := Node (Prim);
4166 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4169 if Present (Op) then
4170 Set_Alias (Op, Eq_Op);
4171 Set_Is_Abstract_Subprogram
4172 (Op, Is_Abstract_Subprogram (Eq_Op));
4174 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4175 Set_Is_Abstract_Subprogram
4176 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4188 -- If not inherited and not user-defined, build body as for a type with
4189 -- tagged components.
4193 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4194 Op := Defining_Entity (Decl);
4198 if Is_Library_Level_Entity (Typ) then
4202 end Build_Untagged_Equality;
4204 -----------------------------------
4205 -- Build_Variant_Record_Equality --
4206 -----------------------------------
4210 -- function _Equality (X, Y : T) return Boolean is
4212 -- -- Compare discriminants
4214 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4218 -- -- Compare components
4220 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4224 -- -- Compare variant part
4228 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4233 -- if X.Cn /= Y.Cn or else ... then
4241 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
4242 Loc : constant Source_Ptr := Sloc (Typ);
4244 F : constant Entity_Id :=
4245 Make_Defining_Identifier (Loc,
4246 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
4248 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
4249 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
4251 Def : constant Node_Id := Parent (Typ);
4252 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4253 Stmts : constant List_Id := New_List;
4254 Pspecs : constant List_Id := New_List;
4257 -- If we have a variant record with restriction No_Implicit_Conditionals
4258 -- in effect, then we skip building the procedure. This is safe because
4259 -- if we can see the restriction, so can any caller, calls to equality
4260 -- test routines are not allowed for variant records if this restriction
4263 if Restriction_Active (No_Implicit_Conditionals) then
4267 -- Derived Unchecked_Union types no longer inherit the equality function
4270 if Is_Derived_Type (Typ)
4271 and then not Is_Unchecked_Union (Typ)
4272 and then not Has_New_Non_Standard_Rep (Typ)
4275 Parent_Eq : constant Entity_Id :=
4276 TSS (Root_Type (Typ), TSS_Composite_Equality);
4278 if Present (Parent_Eq) then
4279 Copy_TSS (Parent_Eq, Typ);
4286 Make_Subprogram_Body (Loc,
4288 Make_Function_Specification (Loc,
4289 Defining_Unit_Name => F,
4290 Parameter_Specifications => Pspecs,
4291 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
4292 Declarations => New_List,
4293 Handled_Statement_Sequence =>
4294 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
4297 Make_Parameter_Specification (Loc,
4298 Defining_Identifier => X,
4299 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4302 Make_Parameter_Specification (Loc,
4303 Defining_Identifier => Y,
4304 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4306 -- Unchecked_Unions require additional machinery to support equality.
4307 -- Two extra parameters (A and B) are added to the equality function
4308 -- parameter list for each discriminant of the type, in order to
4309 -- capture the inferred values of the discriminants in equality calls.
4310 -- The names of the parameters match the names of the corresponding
4311 -- discriminant, with an added suffix.
4313 if Is_Unchecked_Union (Typ) then
4316 Discr_Type : Entity_Id;
4318 New_Discrs : Elist_Id;
4321 New_Discrs := New_Elmt_List;
4323 Discr := First_Discriminant (Typ);
4324 while Present (Discr) loop
4325 Discr_Type := Etype (Discr);
4326 A := Make_Defining_Identifier (Loc,
4327 Chars => New_External_Name (Chars (Discr), 'A'));
4329 B := Make_Defining_Identifier (Loc,
4330 Chars => New_External_Name (Chars (Discr), 'B'));
4332 -- Add new parameters to the parameter list
4335 Make_Parameter_Specification (Loc,
4336 Defining_Identifier => A,
4338 New_Occurrence_Of (Discr_Type, Loc)));
4341 Make_Parameter_Specification (Loc,
4342 Defining_Identifier => B,
4344 New_Occurrence_Of (Discr_Type, Loc)));
4346 Append_Elmt (A, New_Discrs);
4348 -- Generate the following code to compare each of the inferred
4356 Make_If_Statement (Loc,
4359 Left_Opnd => New_Occurrence_Of (A, Loc),
4360 Right_Opnd => New_Occurrence_Of (B, Loc)),
4361 Then_Statements => New_List (
4362 Make_Simple_Return_Statement (Loc,
4364 New_Occurrence_Of (Standard_False, Loc)))));
4365 Next_Discriminant (Discr);
4368 -- Generate component-by-component comparison. Note that we must
4369 -- propagate the inferred discriminants formals to act as
4370 -- the case statement switch. Their value is added when an
4371 -- equality call on unchecked unions is expanded.
4373 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4376 -- Normal case (not unchecked union)
4380 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4381 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4385 Make_Simple_Return_Statement (Loc,
4386 Expression => New_Occurrence_Of (Standard_True, Loc)));
4391 if not Debug_Generated_Code then
4392 Set_Debug_Info_Off (F);
4394 end Build_Variant_Record_Equality;
4396 -----------------------------
4397 -- Check_Stream_Attributes --
4398 -----------------------------
4400 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4402 Par_Read : constant Boolean :=
4403 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4404 and then not Has_Specified_Stream_Read (Typ);
4405 Par_Write : constant Boolean :=
4406 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4407 and then not Has_Specified_Stream_Write (Typ);
4409 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4410 -- Check that Comp has a user-specified Nam stream attribute
4416 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4418 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4419 Error_Msg_Name_1 := Nam;
4421 ("|component& in limited extension must have% attribute", Comp);
4425 -- Start of processing for Check_Stream_Attributes
4428 if Par_Read or else Par_Write then
4429 Comp := First_Component (Typ);
4430 while Present (Comp) loop
4431 if Comes_From_Source (Comp)
4432 and then Original_Record_Component (Comp) = Comp
4433 and then Is_Limited_Type (Etype (Comp))
4436 Check_Attr (Name_Read, TSS_Stream_Read);
4440 Check_Attr (Name_Write, TSS_Stream_Write);
4444 Next_Component (Comp);
4447 end Check_Stream_Attributes;
4449 ----------------------
4450 -- Clean_Task_Names --
4451 ----------------------
4453 procedure Clean_Task_Names
4455 Proc_Id : Entity_Id)
4459 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4460 and then not Global_Discard_Names
4461 and then Tagged_Type_Expansion
4463 Set_Uses_Sec_Stack (Proc_Id);
4465 end Clean_Task_Names;
4467 ------------------------------
4468 -- Expand_Freeze_Array_Type --
4469 ------------------------------
4471 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4472 Typ : constant Entity_Id := Entity (N);
4473 Base : constant Entity_Id := Base_Type (Typ);
4474 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4477 if not Is_Bit_Packed_Array (Typ) then
4479 -- If the component contains tasks, so does the array type. This may
4480 -- not be indicated in the array type because the component may have
4481 -- been a private type at the point of definition. Same if component
4482 -- type is controlled or contains protected objects.
4484 Propagate_Concurrent_Flags (Base, Comp_Typ);
4485 Set_Has_Controlled_Component
4486 (Base, Has_Controlled_Component (Comp_Typ)
4487 or else Is_Controlled (Comp_Typ));
4489 if No (Init_Proc (Base)) then
4491 -- If this is an anonymous array created for a declaration with
4492 -- an initial value, its init_proc will never be called. The
4493 -- initial value itself may have been expanded into assignments,
4494 -- in which case the object declaration is carries the
4495 -- No_Initialization flag.
4498 and then Nkind (Associated_Node_For_Itype (Base)) =
4499 N_Object_Declaration
4501 (Present (Expression (Associated_Node_For_Itype (Base)))
4502 or else No_Initialization (Associated_Node_For_Itype (Base)))
4506 -- We do not need an init proc for string or wide [wide] string,
4507 -- since the only time these need initialization in normalize or
4508 -- initialize scalars mode, and these types are treated specially
4509 -- and do not need initialization procedures.
4511 elsif Is_Standard_String_Type (Base) then
4514 -- Otherwise we have to build an init proc for the subtype
4517 Build_Array_Init_Proc (Base, N);
4521 if Typ = Base and then Has_Controlled_Component (Base) then
4522 Build_Controlling_Procs (Base);
4524 if not Is_Limited_Type (Comp_Typ)
4525 and then Number_Dimensions (Typ) = 1
4527 Build_Slice_Assignment (Typ);
4531 -- For packed case, default initialization, except if the component type
4532 -- is itself a packed structure with an initialization procedure, or
4533 -- initialize/normalize scalars active, and we have a base type, or the
4534 -- type is public, because in that case a client might specify
4535 -- Normalize_Scalars and there better be a public Init_Proc for it.
4537 elsif (Present (Init_Proc (Component_Type (Base)))
4538 and then No (Base_Init_Proc (Base)))
4539 or else (Init_Or_Norm_Scalars and then Base = Typ)
4540 or else Is_Public (Typ)
4542 Build_Array_Init_Proc (Base, N);
4544 end Expand_Freeze_Array_Type;
4546 -----------------------------------
4547 -- Expand_Freeze_Class_Wide_Type --
4548 -----------------------------------
4550 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4551 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4552 -- Given a type, determine whether it is derived from a C or C++ root
4554 ---------------------
4555 -- Is_C_Derivation --
4556 ---------------------
4558 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4565 or else Convention (T) = Convention_C
4566 or else Convention (T) = Convention_CPP
4571 exit when T = Etype (T);
4577 end Is_C_Derivation;
4581 Typ : constant Entity_Id := Entity (N);
4582 Root : constant Entity_Id := Root_Type (Typ);
4584 -- Start of processing for Expand_Freeze_Class_Wide_Type
4587 -- Certain run-time configurations and targets do not provide support
4588 -- for controlled types.
4590 if Restriction_Active (No_Finalization) then
4593 -- Do not create TSS routine Finalize_Address when dispatching calls are
4594 -- disabled since the core of the routine is a dispatching call.
4596 elsif Restriction_Active (No_Dispatching_Calls) then
4599 -- Do not create TSS routine Finalize_Address for concurrent class-wide
4600 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
4601 -- non-Ada side will handle their destruction.
4603 elsif Is_Concurrent_Type (Root)
4604 or else Is_C_Derivation (Root)
4605 or else Convention (Typ) = Convention_CPP
4609 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
4610 -- mode since the routine contains an Unchecked_Conversion.
4612 elsif CodePeer_Mode then
4616 -- Create the body of TSS primitive Finalize_Address. This automatically
4617 -- sets the TSS entry for the class-wide type.
4619 Make_Finalize_Address_Body (Typ);
4620 end Expand_Freeze_Class_Wide_Type;
4622 ------------------------------------
4623 -- Expand_Freeze_Enumeration_Type --
4624 ------------------------------------
4626 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
4627 Typ : constant Entity_Id := Entity (N);
4628 Loc : constant Source_Ptr := Sloc (Typ);
4633 Is_Contiguous : Boolean;
4641 pragma Warnings (Off, Func);
4644 -- Various optimizations possible if given representation is contiguous
4646 Is_Contiguous := True;
4648 Ent := First_Literal (Typ);
4649 Last_Repval := Enumeration_Rep (Ent);
4652 while Present (Ent) loop
4653 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4654 Is_Contiguous := False;
4657 Last_Repval := Enumeration_Rep (Ent);
4663 if Is_Contiguous then
4664 Set_Has_Contiguous_Rep (Typ);
4665 Ent := First_Literal (Typ);
4667 Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
4670 -- Build list of literal references
4675 Ent := First_Literal (Typ);
4676 while Present (Ent) loop
4677 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
4683 -- Now build an array declaration
4685 -- typA : array (Natural range 0 .. num - 1) of ctype :=
4686 -- (v, v, v, v, v, ....)
4688 -- where ctype is the corresponding integer type. If the representation
4689 -- is contiguous, we only keep the first literal, which provides the
4690 -- offset for Pos_To_Rep computations.
4693 Make_Defining_Identifier (Loc,
4694 Chars => New_External_Name (Chars (Typ), 'A'));
4696 Append_Freeze_Action (Typ,
4697 Make_Object_Declaration (Loc,
4698 Defining_Identifier => Arr,
4699 Constant_Present => True,
4701 Object_Definition =>
4702 Make_Constrained_Array_Definition (Loc,
4703 Discrete_Subtype_Definitions => New_List (
4704 Make_Subtype_Indication (Loc,
4705 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
4707 Make_Range_Constraint (Loc,
4711 Make_Integer_Literal (Loc, 0),
4713 Make_Integer_Literal (Loc, Num - 1))))),
4715 Component_Definition =>
4716 Make_Component_Definition (Loc,
4717 Aliased_Present => False,
4718 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
4721 Make_Aggregate (Loc,
4722 Expressions => Lst)));
4724 Set_Enum_Pos_To_Rep (Typ, Arr);
4726 -- Now we build the function that converts representation values to
4727 -- position values. This function has the form:
4729 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4732 -- when enum-lit'Enum_Rep => return posval;
4733 -- when enum-lit'Enum_Rep => return posval;
4736 -- [raise Constraint_Error when F "invalid data"]
4741 -- Note: the F parameter determines whether the others case (no valid
4742 -- representation) raises Constraint_Error or returns a unique value
4743 -- of minus one. The latter case is used, e.g. in 'Valid code.
4745 -- Note: the reason we use Enum_Rep values in the case here is to avoid
4746 -- the code generator making inappropriate assumptions about the range
4747 -- of the values in the case where the value is invalid. ityp is a
4748 -- signed or unsigned integer type of appropriate width.
4750 -- Note: if exceptions are not supported, then we suppress the raise
4751 -- and return -1 unconditionally (this is an erroneous program in any
4752 -- case and there is no obligation to raise Constraint_Error here). We
4753 -- also do this if pragma Restrictions (No_Exceptions) is active.
4755 -- Is this right??? What about No_Exception_Propagation???
4757 -- Representations are signed
4759 if Enumeration_Rep (First_Literal (Typ)) < 0 then
4761 -- The underlying type is signed. Reset the Is_Unsigned_Type
4762 -- explicitly, because it might have been inherited from
4765 Set_Is_Unsigned_Type (Typ, False);
4767 if Esize (Typ) <= Standard_Integer_Size then
4768 Ityp := Standard_Integer;
4770 Ityp := Universal_Integer;
4773 -- Representations are unsigned
4776 if Esize (Typ) <= Standard_Integer_Size then
4777 Ityp := RTE (RE_Unsigned);
4779 Ityp := RTE (RE_Long_Long_Unsigned);
4783 -- The body of the function is a case statement. First collect case
4784 -- alternatives, or optimize the contiguous case.
4788 -- If representation is contiguous, Pos is computed by subtracting
4789 -- the representation of the first literal.
4791 if Is_Contiguous then
4792 Ent := First_Literal (Typ);
4794 if Enumeration_Rep (Ent) = Last_Repval then
4796 -- Another special case: for a single literal, Pos is zero
4798 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4802 Convert_To (Standard_Integer,
4803 Make_Op_Subtract (Loc,
4805 Unchecked_Convert_To
4806 (Ityp, Make_Identifier (Loc, Name_uA)),
4808 Make_Integer_Literal (Loc,
4809 Intval => Enumeration_Rep (First_Literal (Typ)))));
4813 Make_Case_Statement_Alternative (Loc,
4814 Discrete_Choices => New_List (
4815 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4817 Make_Integer_Literal (Loc,
4818 Intval => Enumeration_Rep (Ent)),
4820 Make_Integer_Literal (Loc, Intval => Last_Repval))),
4822 Statements => New_List (
4823 Make_Simple_Return_Statement (Loc,
4824 Expression => Pos_Expr))));
4827 Ent := First_Literal (Typ);
4828 while Present (Ent) loop
4830 Make_Case_Statement_Alternative (Loc,
4831 Discrete_Choices => New_List (
4832 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4833 Intval => Enumeration_Rep (Ent))),
4835 Statements => New_List (
4836 Make_Simple_Return_Statement (Loc,
4838 Make_Integer_Literal (Loc,
4839 Intval => Enumeration_Pos (Ent))))));
4845 -- In normal mode, add the others clause with the test.
4846 -- If Predicates_Ignored is True, validity checks do not apply to
4849 if not No_Exception_Handlers_Set
4850 and then not Predicates_Ignored (Typ)
4853 Make_Case_Statement_Alternative (Loc,
4854 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4855 Statements => New_List (
4856 Make_Raise_Constraint_Error (Loc,
4857 Condition => Make_Identifier (Loc, Name_uF),
4858 Reason => CE_Invalid_Data),
4859 Make_Simple_Return_Statement (Loc,
4860 Expression => Make_Integer_Literal (Loc, -1)))));
4862 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
4863 -- active then return -1 (we cannot usefully raise Constraint_Error in
4864 -- this case). See description above for further details.
4868 Make_Case_Statement_Alternative (Loc,
4869 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4870 Statements => New_List (
4871 Make_Simple_Return_Statement (Loc,
4872 Expression => Make_Integer_Literal (Loc, -1)))));
4875 -- Now we can build the function body
4878 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4881 Make_Subprogram_Body (Loc,
4883 Make_Function_Specification (Loc,
4884 Defining_Unit_Name => Fent,
4885 Parameter_Specifications => New_List (
4886 Make_Parameter_Specification (Loc,
4887 Defining_Identifier =>
4888 Make_Defining_Identifier (Loc, Name_uA),
4889 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
4890 Make_Parameter_Specification (Loc,
4891 Defining_Identifier =>
4892 Make_Defining_Identifier (Loc, Name_uF),
4894 New_Occurrence_Of (Standard_Boolean, Loc))),
4896 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
4898 Declarations => Empty_List,
4900 Handled_Statement_Sequence =>
4901 Make_Handled_Sequence_Of_Statements (Loc,
4902 Statements => New_List (
4903 Make_Case_Statement (Loc,
4905 Unchecked_Convert_To
4906 (Ityp, Make_Identifier (Loc, Name_uA)),
4907 Alternatives => Lst))));
4909 Set_TSS (Typ, Fent);
4911 -- Set Pure flag (it will be reset if the current context is not Pure).
4912 -- We also pretend there was a pragma Pure_Function so that for purposes
4913 -- of optimization and constant-folding, we will consider the function
4914 -- Pure even if we are not in a Pure context).
4917 Set_Has_Pragma_Pure_Function (Fent);
4919 -- Unless we are in -gnatD mode, where we are debugging generated code,
4920 -- this is an internal entity for which we don't need debug info.
4922 if not Debug_Generated_Code then
4923 Set_Debug_Info_Off (Fent);
4926 Set_Is_Inlined (Fent);
4929 when RE_Not_Available =>
4931 end Expand_Freeze_Enumeration_Type;
4933 -------------------------------
4934 -- Expand_Freeze_Record_Type --
4935 -------------------------------
4937 procedure Expand_Freeze_Record_Type (N : Node_Id) is
4938 Typ : constant Node_Id := Entity (N);
4939 Typ_Decl : constant Node_Id := Parent (Typ);
4942 Comp_Typ : Entity_Id;
4943 Predef_List : List_Id;
4945 Wrapper_Decl_List : List_Id := No_List;
4946 Wrapper_Body_List : List_Id := No_List;
4948 Renamed_Eq : Node_Id := Empty;
4949 -- Defining unit name for the predefined equality function in the case
4950 -- where the type has a primitive operation that is a renaming of
4951 -- predefined equality (but only if there is also an overriding
4952 -- user-defined equality function). Used to pass this entity from
4953 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
4955 -- Start of processing for Expand_Freeze_Record_Type
4958 -- Build discriminant checking functions if not a derived type (for
4959 -- derived types that are not tagged types, always use the discriminant
4960 -- checking functions of the parent type). However, for untagged types
4961 -- the derivation may have taken place before the parent was frozen, so
4962 -- we copy explicitly the discriminant checking functions from the
4963 -- parent into the components of the derived type.
4965 if not Is_Derived_Type (Typ)
4966 or else Has_New_Non_Standard_Rep (Typ)
4967 or else Is_Tagged_Type (Typ)
4969 Build_Discr_Checking_Funcs (Typ_Decl);
4971 elsif Is_Derived_Type (Typ)
4972 and then not Is_Tagged_Type (Typ)
4974 -- If we have a derived Unchecked_Union, we do not inherit the
4975 -- discriminant checking functions from the parent type since the
4976 -- discriminants are non existent.
4978 and then not Is_Unchecked_Union (Typ)
4979 and then Has_Discriminants (Typ)
4982 Old_Comp : Entity_Id;
4986 First_Component (Base_Type (Underlying_Type (Etype (Typ))));
4987 Comp := First_Component (Typ);
4988 while Present (Comp) loop
4989 if Ekind (Comp) = E_Component
4990 and then Chars (Comp) = Chars (Old_Comp)
4992 Set_Discriminant_Checking_Func
4993 (Comp, Discriminant_Checking_Func (Old_Comp));
4996 Next_Component (Old_Comp);
4997 Next_Component (Comp);
5002 if Is_Derived_Type (Typ)
5003 and then Is_Limited_Type (Typ)
5004 and then Is_Tagged_Type (Typ)
5006 Check_Stream_Attributes (Typ);
5009 -- Update task, protected, and controlled component flags, because some
5010 -- of the component types may have been private at the point of the
5011 -- record declaration. Detect anonymous access-to-controlled components.
5013 Comp := First_Component (Typ);
5014 while Present (Comp) loop
5015 Comp_Typ := Etype (Comp);
5017 Propagate_Concurrent_Flags (Typ, Comp_Typ);
5019 -- Do not set Has_Controlled_Component on a class-wide equivalent
5020 -- type. See Make_CW_Equivalent_Type.
5022 if not Is_Class_Wide_Equivalent_Type (Typ)
5024 (Has_Controlled_Component (Comp_Typ)
5025 or else (Chars (Comp) /= Name_uParent
5026 and then Is_Controlled (Comp_Typ)))
5028 Set_Has_Controlled_Component (Typ);
5031 Next_Component (Comp);
5034 -- Handle constructors of untagged CPP_Class types
5036 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
5037 Set_CPP_Constructors (Typ);
5040 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5041 -- for regular tagged types as well as for Ada types deriving from a C++
5042 -- Class, but not for tagged types directly corresponding to C++ classes
5043 -- In the later case we assume that it is created in the C++ side and we
5046 if Is_Tagged_Type (Typ) then
5048 -- Add the _Tag component
5050 if Underlying_Type (Etype (Typ)) = Typ then
5051 Expand_Tagged_Root (Typ);
5054 if Is_CPP_Class (Typ) then
5055 Set_All_DT_Position (Typ);
5057 -- Create the tag entities with a minimum decoration
5059 if Tagged_Type_Expansion then
5060 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5063 Set_CPP_Constructors (Typ);
5066 if not Building_Static_DT (Typ) then
5068 -- Usually inherited primitives are not delayed but the first
5069 -- Ada extension of a CPP_Class is an exception since the
5070 -- address of the inherited subprogram has to be inserted in
5071 -- the new Ada Dispatch Table and this is a freezing action.
5073 -- Similarly, if this is an inherited operation whose parent is
5074 -- not frozen yet, it is not in the DT of the parent, and we
5075 -- generate an explicit freeze node for the inherited operation
5076 -- so it is properly inserted in the DT of the current type.
5083 Elmt := First_Elmt (Primitive_Operations (Typ));
5084 while Present (Elmt) loop
5085 Subp := Node (Elmt);
5087 if Present (Alias (Subp)) then
5088 if Is_CPP_Class (Etype (Typ)) then
5089 Set_Has_Delayed_Freeze (Subp);
5091 elsif Has_Delayed_Freeze (Alias (Subp))
5092 and then not Is_Frozen (Alias (Subp))
5094 Set_Is_Frozen (Subp, False);
5095 Set_Has_Delayed_Freeze (Subp);
5104 -- Unfreeze momentarily the type to add the predefined primitives
5105 -- operations. The reason we unfreeze is so that these predefined
5106 -- operations will indeed end up as primitive operations (which
5107 -- must be before the freeze point).
5109 Set_Is_Frozen (Typ, False);
5111 -- Do not add the spec of predefined primitives in case of
5112 -- CPP tagged type derivations that have convention CPP.
5114 if Is_CPP_Class (Root_Type (Typ))
5115 and then Convention (Typ) = Convention_CPP
5119 -- Do not add the spec of the predefined primitives if we are
5120 -- compiling under restriction No_Dispatching_Calls.
5122 elsif not Restriction_Active (No_Dispatching_Calls) then
5123 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
5124 Insert_List_Before_And_Analyze (N, Predef_List);
5127 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5128 -- wrapper functions for each nonoverridden inherited function
5129 -- with a controlling result of the type. The wrapper for such
5130 -- a function returns an extension aggregate that invokes the
5133 if Ada_Version >= Ada_2005
5134 and then not Is_Abstract_Type (Typ)
5135 and then Is_Null_Extension (Typ)
5137 Make_Controlling_Function_Wrappers
5138 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
5139 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5142 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5143 -- null procedure declarations for each set of homographic null
5144 -- procedures that are inherited from interface types but not
5145 -- overridden. This is done to ensure that the dispatch table
5146 -- entry associated with such null primitives are properly filled.
5148 if Ada_Version >= Ada_2005
5149 and then Etype (Typ) /= Typ
5150 and then not Is_Abstract_Type (Typ)
5151 and then Has_Interfaces (Typ)
5153 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
5156 Set_Is_Frozen (Typ);
5158 if not Is_Derived_Type (Typ)
5159 or else Is_Tagged_Type (Etype (Typ))
5161 Set_All_DT_Position (Typ);
5163 -- If this is a type derived from an untagged private type whose
5164 -- full view is tagged, the type is marked tagged for layout
5165 -- reasons, but it has no dispatch table.
5167 elsif Is_Derived_Type (Typ)
5168 and then Is_Private_Type (Etype (Typ))
5169 and then not Is_Tagged_Type (Etype (Typ))
5174 -- Create and decorate the tags. Suppress their creation when
5175 -- not Tagged_Type_Expansion because the dispatching mechanism is
5176 -- handled internally by the virtual target.
5178 if Tagged_Type_Expansion then
5179 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5181 -- Generate dispatch table of locally defined tagged type.
5182 -- Dispatch tables of library level tagged types are built
5183 -- later (see Analyze_Declarations).
5185 if not Building_Static_DT (Typ) then
5186 Append_Freeze_Actions (Typ, Make_DT (Typ));
5190 -- If the type has unknown discriminants, propagate dispatching
5191 -- information to its underlying record view, which does not get
5192 -- its own dispatch table.
5194 if Is_Derived_Type (Typ)
5195 and then Has_Unknown_Discriminants (Typ)
5196 and then Present (Underlying_Record_View (Typ))
5199 Rep : constant Entity_Id := Underlying_Record_View (Typ);
5201 Set_Access_Disp_Table
5202 (Rep, Access_Disp_Table (Typ));
5203 Set_Dispatch_Table_Wrappers
5204 (Rep, Dispatch_Table_Wrappers (Typ));
5205 Set_Direct_Primitive_Operations
5206 (Rep, Direct_Primitive_Operations (Typ));
5210 -- Make sure that the primitives Initialize, Adjust and Finalize
5211 -- are Frozen before other TSS subprograms. We don't want them
5214 if Is_Controlled (Typ) then
5215 if not Is_Limited_Type (Typ) then
5216 Append_Freeze_Actions (Typ,
5217 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
5220 Append_Freeze_Actions (Typ,
5221 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
5223 Append_Freeze_Actions (Typ,
5224 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
5227 -- Freeze rest of primitive operations. There is no need to handle
5228 -- the predefined primitives if we are compiling under restriction
5229 -- No_Dispatching_Calls.
5231 if not Restriction_Active (No_Dispatching_Calls) then
5232 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5236 -- In the untagged case, ever since Ada 83 an equality function must
5237 -- be provided for variant records that are not unchecked unions.
5238 -- In Ada 2012 the equality function composes, and thus must be built
5239 -- explicitly just as for tagged records.
5241 elsif Has_Discriminants (Typ)
5242 and then not Is_Limited_Type (Typ)
5245 Comps : constant Node_Id :=
5246 Component_List (Type_Definition (Typ_Decl));
5249 and then Present (Variant_Part (Comps))
5251 Build_Variant_Record_Equality (Typ);
5255 -- Otherwise create primitive equality operation (AI05-0123)
5257 -- This is done unconditionally to ensure that tools can be linked
5258 -- properly with user programs compiled with older language versions.
5259 -- In addition, this is needed because "=" composes for bounded strings
5260 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5262 elsif Comes_From_Source (Typ)
5263 and then Convention (Typ) = Convention_Ada
5264 and then not Is_Limited_Type (Typ)
5266 Build_Untagged_Equality (Typ);
5269 -- Before building the record initialization procedure, if we are
5270 -- dealing with a concurrent record value type, then we must go through
5271 -- the discriminants, exchanging discriminals between the concurrent
5272 -- type and the concurrent record value type. See the section "Handling
5273 -- of Discriminants" in the Einfo spec for details.
5275 if Is_Concurrent_Record_Type (Typ)
5276 and then Has_Discriminants (Typ)
5279 Ctyp : constant Entity_Id :=
5280 Corresponding_Concurrent_Type (Typ);
5281 Conc_Discr : Entity_Id;
5282 Rec_Discr : Entity_Id;
5286 Conc_Discr := First_Discriminant (Ctyp);
5287 Rec_Discr := First_Discriminant (Typ);
5288 while Present (Conc_Discr) loop
5289 Temp := Discriminal (Conc_Discr);
5290 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5291 Set_Discriminal (Rec_Discr, Temp);
5293 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5294 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5296 Next_Discriminant (Conc_Discr);
5297 Next_Discriminant (Rec_Discr);
5302 if Has_Controlled_Component (Typ) then
5303 Build_Controlling_Procs (Typ);
5306 Adjust_Discriminants (Typ);
5308 -- Do not need init for interfaces on virtual targets since they're
5311 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5312 Build_Record_Init_Proc (Typ_Decl, Typ);
5315 -- For tagged type that are not interfaces, build bodies of primitive
5316 -- operations. Note: do this after building the record initialization
5317 -- procedure, since the primitive operations may need the initialization
5318 -- routine. There is no need to add predefined primitives of interfaces
5319 -- because all their predefined primitives are abstract.
5321 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5323 -- Do not add the body of predefined primitives in case of CPP tagged
5324 -- type derivations that have convention CPP.
5326 if Is_CPP_Class (Root_Type (Typ))
5327 and then Convention (Typ) = Convention_CPP
5331 -- Do not add the body of the predefined primitives if we are
5332 -- compiling under restriction No_Dispatching_Calls or if we are
5333 -- compiling a CPP tagged type.
5335 elsif not Restriction_Active (No_Dispatching_Calls) then
5337 -- Create the body of TSS primitive Finalize_Address. This must
5338 -- be done before the bodies of all predefined primitives are
5339 -- created. If Typ is limited, Stream_Input and Stream_Read may
5340 -- produce build-in-place allocations and for those the expander
5341 -- needs Finalize_Address.
5343 Make_Finalize_Address_Body (Typ);
5344 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5345 Append_Freeze_Actions (Typ, Predef_List);
5348 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5349 -- inherited functions, then add their bodies to the freeze actions.
5351 if Present (Wrapper_Body_List) then
5352 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5355 -- Create extra formals for the primitive operations of the type.
5356 -- This must be done before analyzing the body of the initialization
5357 -- procedure, because a self-referential type might call one of these
5358 -- primitives in the body of the init_proc itself.
5365 Elmt := First_Elmt (Primitive_Operations (Typ));
5366 while Present (Elmt) loop
5367 Subp := Node (Elmt);
5368 if not Has_Foreign_Convention (Subp)
5369 and then not Is_Predefined_Dispatching_Operation (Subp)
5371 Create_Extra_Formals (Subp);
5378 end Expand_Freeze_Record_Type;
5380 ------------------------------------
5381 -- Expand_N_Full_Type_Declaration --
5382 ------------------------------------
5384 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5385 procedure Build_Master (Ptr_Typ : Entity_Id);
5386 -- Create the master associated with Ptr_Typ
5392 procedure Build_Master (Ptr_Typ : Entity_Id) is
5393 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5396 -- If the designated type is an incomplete view coming from a
5397 -- limited-with'ed package, we need to use the nonlimited view in
5398 -- case it has tasks.
5400 if Ekind (Desig_Typ) in Incomplete_Kind
5401 and then Present (Non_Limited_View (Desig_Typ))
5403 Desig_Typ := Non_Limited_View (Desig_Typ);
5406 -- Anonymous access types are created for the components of the
5407 -- record parameter for an entry declaration. No master is created
5410 if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
5411 Build_Master_Entity (Ptr_Typ);
5412 Build_Master_Renaming (Ptr_Typ);
5414 -- Create a class-wide master because a Master_Id must be generated
5415 -- for access-to-limited-class-wide types whose root may be extended
5416 -- with task components.
5418 -- Note: This code covers access-to-limited-interfaces because they
5419 -- can be used to reference tasks implementing them.
5421 elsif Is_Limited_Class_Wide_Type (Desig_Typ)
5422 and then Tasking_Allowed
5424 Build_Class_Wide_Master (Ptr_Typ);
5428 -- Local declarations
5430 Def_Id : constant Entity_Id := Defining_Identifier (N);
5431 B_Id : constant Entity_Id := Base_Type (Def_Id);
5435 -- Start of processing for Expand_N_Full_Type_Declaration
5438 if Is_Access_Type (Def_Id) then
5439 Build_Master (Def_Id);
5441 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5442 Expand_Access_Protected_Subprogram_Type (N);
5445 -- Array of anonymous access-to-task pointers
5447 elsif Ada_Version >= Ada_2005
5448 and then Is_Array_Type (Def_Id)
5449 and then Is_Access_Type (Component_Type (Def_Id))
5450 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5452 Build_Master (Component_Type (Def_Id));
5454 elsif Has_Task (Def_Id) then
5455 Expand_Previous_Access_Type (Def_Id);
5457 -- Check the components of a record type or array of records for
5458 -- anonymous access-to-task pointers.
5460 elsif Ada_Version >= Ada_2005
5461 and then (Is_Record_Type (Def_Id)
5463 (Is_Array_Type (Def_Id)
5464 and then Is_Record_Type (Component_Type (Def_Id))))
5473 if Is_Array_Type (Def_Id) then
5474 Comp := First_Entity (Component_Type (Def_Id));
5476 Comp := First_Entity (Def_Id);
5479 -- Examine all components looking for anonymous access-to-task
5483 while Present (Comp) loop
5484 Typ := Etype (Comp);
5486 if Ekind (Typ) = E_Anonymous_Access_Type
5487 and then Has_Task (Available_View (Designated_Type (Typ)))
5488 and then No (Master_Id (Typ))
5490 -- Ensure that the record or array type have a _master
5493 Build_Master_Entity (Def_Id);
5494 Build_Master_Renaming (Typ);
5495 M_Id := Master_Id (Typ);
5499 -- Reuse the same master to service any additional types
5502 Set_Master_Id (Typ, M_Id);
5511 Par_Id := Etype (B_Id);
5513 -- The parent type is private then we need to inherit any TSS operations
5514 -- from the full view.
5516 if Ekind (Par_Id) in Private_Kind
5517 and then Present (Full_View (Par_Id))
5519 Par_Id := Base_Type (Full_View (Par_Id));
5522 if Nkind (Type_Definition (Original_Node (N))) =
5523 N_Derived_Type_Definition
5524 and then not Is_Tagged_Type (Def_Id)
5525 and then Present (Freeze_Node (Par_Id))
5526 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
5528 Ensure_Freeze_Node (B_Id);
5529 FN := Freeze_Node (B_Id);
5531 if No (TSS_Elist (FN)) then
5532 Set_TSS_Elist (FN, New_Elmt_List);
5536 T_E : constant Elist_Id := TSS_Elist (FN);
5540 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
5541 while Present (Elmt) loop
5542 if Chars (Node (Elmt)) /= Name_uInit then
5543 Append_Elmt (Node (Elmt), T_E);
5549 -- If the derived type itself is private with a full view, then
5550 -- associate the full view with the inherited TSS_Elist as well.
5552 if Ekind (B_Id) in Private_Kind
5553 and then Present (Full_View (B_Id))
5555 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
5557 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
5561 end Expand_N_Full_Type_Declaration;
5563 ---------------------------------
5564 -- Expand_N_Object_Declaration --
5565 ---------------------------------
5567 procedure Expand_N_Object_Declaration (N : Node_Id) is
5568 Loc : constant Source_Ptr := Sloc (N);
5569 Def_Id : constant Entity_Id := Defining_Identifier (N);
5570 Expr : constant Node_Id := Expression (N);
5571 Obj_Def : constant Node_Id := Object_Definition (N);
5572 Typ : constant Entity_Id := Etype (Def_Id);
5573 Base_Typ : constant Entity_Id := Base_Type (Typ);
5576 function Build_Equivalent_Aggregate return Boolean;
5577 -- If the object has a constrained discriminated type and no initial
5578 -- value, it may be possible to build an equivalent aggregate instead,
5579 -- and prevent an actual call to the initialization procedure.
5581 procedure Check_Large_Modular_Array;
5582 -- Check that the size of the array can be computed without overflow,
5583 -- and generate a Storage_Error otherwise. This is only relevant for
5584 -- array types whose index in a (mod 2**64) type, where wrap-around
5585 -- arithmetic might yield a meaningless value for the length of the
5586 -- array, or its corresponding attribute.
5588 procedure Default_Initialize_Object (After : Node_Id);
5589 -- Generate all default initialization actions for object Def_Id. Any
5590 -- new code is inserted after node After.
5592 function Rewrite_As_Renaming return Boolean;
5593 -- Indicate whether to rewrite a declaration with initialization into an
5594 -- object renaming declaration (see below).
5596 --------------------------------
5597 -- Build_Equivalent_Aggregate --
5598 --------------------------------
5600 function Build_Equivalent_Aggregate return Boolean is
5604 Full_Type : Entity_Id;
5609 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
5610 Full_Type := Full_View (Typ);
5613 -- Only perform this transformation if Elaboration_Code is forbidden
5614 -- or undesirable, and if this is a global entity of a constrained
5617 -- If Initialize_Scalars might be active this transformation cannot
5618 -- be performed either, because it will lead to different semantics
5619 -- or because elaboration code will in fact be created.
5621 if Ekind (Full_Type) /= E_Record_Subtype
5622 or else not Has_Discriminants (Full_Type)
5623 or else not Is_Constrained (Full_Type)
5624 or else Is_Controlled (Full_Type)
5625 or else Is_Limited_Type (Full_Type)
5626 or else not Restriction_Active (No_Initialize_Scalars)
5631 if Ekind (Current_Scope) = E_Package
5633 (Restriction_Active (No_Elaboration_Code)
5634 or else Is_Preelaborated (Current_Scope))
5636 -- Building a static aggregate is possible if the discriminants
5637 -- have static values and the other components have static
5638 -- defaults or none.
5640 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5641 while Present (Discr) loop
5642 if not Is_OK_Static_Expression (Node (Discr)) then
5649 -- Check that initialized components are OK, and that non-
5650 -- initialized components do not require a call to their own
5651 -- initialization procedure.
5653 Comp := First_Component (Full_Type);
5654 while Present (Comp) loop
5655 if Ekind (Comp) = E_Component
5656 and then Present (Expression (Parent (Comp)))
5658 not Is_OK_Static_Expression (Expression (Parent (Comp)))
5662 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
5667 Next_Component (Comp);
5670 -- Everything is static, assemble the aggregate, discriminant
5674 Make_Aggregate (Loc,
5675 Expressions => New_List,
5676 Component_Associations => New_List);
5678 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5679 while Present (Discr) loop
5680 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
5684 -- Now collect values of initialized components
5686 Comp := First_Component (Full_Type);
5687 while Present (Comp) loop
5688 if Ekind (Comp) = E_Component
5689 and then Present (Expression (Parent (Comp)))
5691 Append_To (Component_Associations (Aggr),
5692 Make_Component_Association (Loc,
5693 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
5694 Expression => New_Copy_Tree
5695 (Expression (Parent (Comp)))));
5698 Next_Component (Comp);
5701 -- Finally, box-initialize remaining components
5703 Append_To (Component_Associations (Aggr),
5704 Make_Component_Association (Loc,
5705 Choices => New_List (Make_Others_Choice (Loc)),
5706 Expression => Empty));
5707 Set_Box_Present (Last (Component_Associations (Aggr)));
5708 Set_Expression (N, Aggr);
5710 if Typ /= Full_Type then
5711 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
5712 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
5713 Analyze_And_Resolve (Aggr, Typ);
5715 Analyze_And_Resolve (Aggr, Full_Type);
5723 end Build_Equivalent_Aggregate;
5725 -------------------------------
5726 -- Check_Large_Modular_Array --
5727 -------------------------------
5729 procedure Check_Large_Modular_Array is
5730 Index_Typ : Entity_Id;
5733 if Is_Array_Type (Typ)
5734 and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
5736 -- To prevent arithmetic overflow with large values, we raise
5737 -- Storage_Error under the following guard:
5739 -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
5741 -- This takes care of the boundary case, but it is preferable to
5742 -- use a smaller limit, because even on 64-bit architectures an
5743 -- array of more than 2 ** 30 bytes is likely to raise
5746 Index_Typ := Etype (First_Index (Typ));
5748 if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
5750 Make_Raise_Storage_Error (Loc,
5754 Make_Op_Subtract (Loc,
5756 Make_Op_Divide (Loc,
5758 Make_Attribute_Reference (Loc,
5760 New_Occurrence_Of (Typ, Loc),
5761 Attribute_Name => Name_Last),
5763 Make_Integer_Literal (Loc, Uint_2)),
5765 Make_Op_Divide (Loc,
5767 Make_Attribute_Reference (Loc,
5769 New_Occurrence_Of (Typ, Loc),
5770 Attribute_Name => Name_First),
5772 Make_Integer_Literal (Loc, Uint_2))),
5774 Make_Integer_Literal (Loc, (Uint_2 ** 30))),
5775 Reason => SE_Object_Too_Large));
5778 end Check_Large_Modular_Array;
5780 -------------------------------
5781 -- Default_Initialize_Object --
5782 -------------------------------
5784 procedure Default_Initialize_Object (After : Node_Id) is
5785 function New_Object_Reference return Node_Id;
5786 -- Return a new reference to Def_Id with attributes Assignment_OK and
5787 -- Must_Not_Freeze already set.
5789 --------------------------
5790 -- New_Object_Reference --
5791 --------------------------
5793 function New_Object_Reference return Node_Id is
5794 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
5797 -- The call to the type init proc or [Deep_]Finalize must not
5798 -- freeze the related object as the call is internally generated.
5799 -- This way legal rep clauses that apply to the object will not be
5800 -- flagged. Note that the initialization call may be removed if
5801 -- pragma Import is encountered or moved to the freeze actions of
5802 -- the object because of an address clause.
5804 Set_Assignment_OK (Obj_Ref);
5805 Set_Must_Not_Freeze (Obj_Ref);
5808 end New_Object_Reference;
5812 Exceptions_OK : constant Boolean :=
5813 not Restriction_Active (No_Exception_Propagation);
5815 Aggr_Init : Node_Id;
5816 Comp_Init : List_Id := No_List;
5818 Init_Stmts : List_Id := No_List;
5819 Obj_Init : Node_Id := Empty;
5822 -- Start of processing for Default_Initialize_Object
5825 -- Default initialization is suppressed for objects that are already
5826 -- known to be imported (i.e. whose declaration specifies the Import
5827 -- aspect). Note that for objects with a pragma Import, we generate
5828 -- initialization here, and then remove it downstream when processing
5829 -- the pragma. It is also suppressed for variables for which a pragma
5830 -- Suppress_Initialization has been explicitly given
5832 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
5835 -- Nothing to do if the object being initialized is of a task type
5836 -- and restriction No_Tasking is in effect, because this is a direct
5837 -- violation of the restriction.
5839 elsif Is_Task_Type (Base_Typ)
5840 and then Restriction_Active (No_Tasking)
5845 -- The expansion performed by this routine is as follows:
5849 -- Type_Init_Proc (Obj);
5852 -- [Deep_]Initialize (Obj);
5856 -- [Deep_]Finalize (Obj, Self => False);
5860 -- Abort_Undefer_Direct;
5863 -- Initialize the components of the object
5865 if Has_Non_Null_Base_Init_Proc (Typ)
5866 and then not No_Initialization (N)
5867 and then not Initialization_Suppressed (Typ)
5869 -- Do not initialize the components if No_Default_Initialization
5870 -- applies as the actual restriction check will occur later
5871 -- when the object is frozen as it is not known yet whether the
5872 -- object is imported or not.
5874 if not Restriction_Active (No_Default_Initialization) then
5876 -- If the values of the components are compile-time known, use
5877 -- their prebuilt aggregate form directly.
5879 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
5881 if Present (Aggr_Init) then
5883 (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
5885 -- If type has discriminants, try to build an equivalent
5886 -- aggregate using discriminant values from the declaration.
5887 -- This is a useful optimization, in particular if restriction
5888 -- No_Elaboration_Code is active.
5890 elsif Build_Equivalent_Aggregate then
5893 -- Otherwise invoke the type init proc, generate:
5894 -- Type_Init_Proc (Obj);
5897 Obj_Ref := New_Object_Reference;
5899 if Comes_From_Source (Def_Id) then
5900 Initialization_Warning (Obj_Ref);
5903 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
5907 -- Provide a default value if the object needs simple initialization
5908 -- and does not already have an initial value. A generated temporary
5909 -- does not require initialization because it will be assigned later.
5911 elsif Needs_Simple_Initialization
5912 (Typ, Initialize_Scalars
5913 and then No (Following_Address_Clause (N)))
5914 and then not Is_Internal (Def_Id)
5915 and then not Has_Init_Expression (N)
5917 Set_No_Initialization (N, False);
5918 Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
5919 Analyze_And_Resolve (Expression (N), Typ);
5922 -- Initialize the object, generate:
5923 -- [Deep_]Initialize (Obj);
5925 if Needs_Finalization (Typ) and then not No_Initialization (N) then
5928 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5932 -- Build a special finalization block when both the object and its
5933 -- controlled components are to be initialized. The block finalizes
5934 -- the components if the object initialization fails. Generate:
5945 if Has_Controlled_Component (Typ)
5946 and then Present (Comp_Init)
5947 and then Present (Obj_Init)
5948 and then Exceptions_OK
5950 Init_Stmts := Comp_Init;
5954 (Obj_Ref => New_Object_Reference,
5958 if Present (Fin_Call) then
5960 -- Do not emit warnings related to the elaboration order when a
5961 -- controlled object is declared before the body of Finalize is
5964 Set_No_Elaboration_Check (Fin_Call);
5966 Append_To (Init_Stmts,
5967 Make_Block_Statement (Loc,
5968 Declarations => No_List,
5970 Handled_Statement_Sequence =>
5971 Make_Handled_Sequence_Of_Statements (Loc,
5972 Statements => New_List (Obj_Init),
5974 Exception_Handlers => New_List (
5975 Make_Exception_Handler (Loc,
5976 Exception_Choices => New_List (
5977 Make_Others_Choice (Loc)),
5979 Statements => New_List (
5981 Make_Raise_Statement (Loc)))))));
5984 -- Otherwise finalization is not required, the initialization calls
5985 -- are passed to the abort block building circuitry, generate:
5987 -- Type_Init_Proc (Obj);
5988 -- [Deep_]Initialize (Obj);
5991 if Present (Comp_Init) then
5992 Init_Stmts := Comp_Init;
5995 if Present (Obj_Init) then
5996 if No (Init_Stmts) then
5997 Init_Stmts := New_List;
6000 Append_To (Init_Stmts, Obj_Init);
6004 -- Build an abort block to protect the initialization calls
6007 and then Present (Comp_Init)
6008 and then Present (Obj_Init)
6013 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
6015 -- When exceptions are propagated, abort deferral must take place
6016 -- in the presence of initialization or finalization exceptions.
6023 -- Abort_Undefer_Direct;
6026 if Exceptions_OK then
6027 Init_Stmts := New_List (
6028 Build_Abort_Undefer_Block (Loc,
6029 Stmts => Init_Stmts,
6032 -- Otherwise exceptions are not propagated. Generate:
6039 Append_To (Init_Stmts,
6040 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6044 -- Insert the whole initialization sequence into the tree. If the
6045 -- object has a delayed freeze, as will be the case when it has
6046 -- aspect specifications, the initialization sequence is part of
6047 -- the freeze actions.
6049 if Present (Init_Stmts) then
6050 if Has_Delayed_Freeze (Def_Id) then
6051 Append_Freeze_Actions (Def_Id, Init_Stmts);
6053 Insert_Actions_After (After, Init_Stmts);
6056 end Default_Initialize_Object;
6058 -------------------------
6059 -- Rewrite_As_Renaming --
6060 -------------------------
6062 function Rewrite_As_Renaming return Boolean is
6064 -- If the object declaration appears in the form
6066 -- Obj : Ctrl_Typ := Func (...);
6068 -- where Ctrl_Typ is controlled but not immutably limited type, then
6069 -- the expansion of the function call should use a dereference of the
6070 -- result to reference the value on the secondary stack.
6072 -- Obj : Ctrl_Typ renames Func (...).all;
6074 -- As a result, the call avoids an extra copy. This an optimization,
6075 -- but it is required for passing ACATS tests in some cases where it
6076 -- would otherwise make two copies. The RM allows removing redunant
6077 -- Adjust/Finalize calls, but does not allow insertion of extra ones.
6079 -- This part is disabled for now, because it breaks GPS builds
6081 return (False -- ???
6082 and then Nkind (Expr_Q) = N_Explicit_Dereference
6083 and then not Comes_From_Source (Expr_Q)
6084 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
6085 and then Nkind (Object_Definition (N)) in N_Has_Entity
6086 and then (Needs_Finalization (Entity (Object_Definition (N)))))
6088 -- If the initializing expression is for a variable with attribute
6089 -- OK_To_Rename set, then transform:
6091 -- Obj : Typ := Expr;
6095 -- Obj : Typ renames Expr;
6097 -- provided that Obj is not aliased. The aliased case has to be
6098 -- excluded in general because Expr will not be aliased in
6102 (not Aliased_Present (N)
6103 and then Is_Entity_Name (Expr_Q)
6104 and then Ekind (Entity (Expr_Q)) = E_Variable
6105 and then OK_To_Rename (Entity (Expr_Q))
6106 and then Is_Entity_Name (Obj_Def));
6107 end Rewrite_As_Renaming;
6111 Next_N : constant Node_Id := Next (N);
6115 Tag_Assign : Node_Id;
6117 Init_After : Node_Id := N;
6118 -- Node after which the initialization actions are to be inserted. This
6119 -- is normally N, except for the case of a shared passive variable, in
6120 -- which case the init proc call must be inserted only after the bodies
6121 -- of the shared variable procedures have been seen.
6123 -- Start of processing for Expand_N_Object_Declaration
6126 -- Don't do anything for deferred constants. All proper actions will be
6127 -- expanded during the full declaration.
6129 if No (Expr) and Constant_Present (N) then
6133 -- The type of the object cannot be abstract. This is diagnosed at the
6134 -- point the object is frozen, which happens after the declaration is
6135 -- fully expanded, so simply return now.
6137 if Is_Abstract_Type (Typ) then
6141 -- No action needed for the internal imported dummy object added by
6142 -- Make_DT to compute the offset of the components that reference
6143 -- secondary dispatch tables; required to avoid never-ending loop
6144 -- processing this internal object declaration.
6146 if Tagged_Type_Expansion
6147 and then Is_Internal (Def_Id)
6148 and then Is_Imported (Def_Id)
6149 and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
6154 -- First we do special processing for objects of a tagged type where
6155 -- this is the point at which the type is frozen. The creation of the
6156 -- dispatch table and the initialization procedure have to be deferred
6157 -- to this point, since we reference previously declared primitive
6160 -- Force construction of dispatch tables of library level tagged types
6162 if Tagged_Type_Expansion
6163 and then Static_Dispatch_Tables
6164 and then Is_Library_Level_Entity (Def_Id)
6165 and then Is_Library_Level_Tagged_Type (Base_Typ)
6166 and then Ekind_In (Base_Typ, E_Record_Type,
6169 and then not Has_Dispatch_Table (Base_Typ)
6172 New_Nodes : List_Id := No_List;
6175 if Is_Concurrent_Type (Base_Typ) then
6176 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
6178 New_Nodes := Make_DT (Base_Typ, N);
6181 if not Is_Empty_List (New_Nodes) then
6182 Insert_List_Before (N, New_Nodes);
6187 -- Make shared memory routines for shared passive variable
6189 if Is_Shared_Passive (Def_Id) then
6190 Init_After := Make_Shared_Var_Procs (N);
6193 -- If tasks being declared, make sure we have an activation chain
6194 -- defined for the tasks (has no effect if we already have one), and
6195 -- also that a Master variable is established and that the appropriate
6196 -- enclosing construct is established as a task master.
6198 if Has_Task (Typ) then
6199 Build_Activation_Chain_Entity (N);
6200 Build_Master_Entity (Def_Id);
6203 Check_Large_Modular_Array;
6205 -- Default initialization required, and no expression present
6209 -- If we have a type with a variant part, the initialization proc
6210 -- will contain implicit tests of the discriminant values, which
6211 -- counts as a violation of the restriction No_Implicit_Conditionals.
6213 if Has_Variant_Part (Typ) then
6218 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
6222 ("\initialization of variant record tests discriminants",
6229 -- For the default initialization case, if we have a private type
6230 -- with invariants, and invariant checks are enabled, then insert an
6231 -- invariant check after the object declaration. Note that it is OK
6232 -- to clobber the object with an invalid value since if the exception
6233 -- is raised, then the object will go out of scope. In the case where
6234 -- an array object is initialized with an aggregate, the expression
6235 -- is removed. Check flag Has_Init_Expression to avoid generating a
6236 -- junk invariant check and flag No_Initialization to avoid checking
6237 -- an uninitialized object such as a compiler temporary used for an
6240 if Has_Invariants (Base_Typ)
6241 and then Present (Invariant_Procedure (Base_Typ))
6242 and then not Has_Init_Expression (N)
6243 and then not No_Initialization (N)
6245 -- If entity has an address clause or aspect, make invariant
6246 -- call into a freeze action for the explicit freeze node for
6247 -- object. Otherwise insert invariant check after declaration.
6249 if Present (Following_Address_Clause (N))
6250 or else Has_Aspect (Def_Id, Aspect_Address)
6252 Ensure_Freeze_Node (Def_Id);
6253 Set_Has_Delayed_Freeze (Def_Id);
6254 Set_Is_Frozen (Def_Id, False);
6256 if not Partial_View_Has_Unknown_Discr (Typ) then
6257 Append_Freeze_Action (Def_Id,
6258 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6261 elsif not Partial_View_Has_Unknown_Discr (Typ) then
6263 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6267 Default_Initialize_Object (Init_After);
6269 -- Generate attribute for Persistent_BSS if needed
6271 if Persistent_BSS_Mode
6272 and then Comes_From_Source (N)
6273 and then Is_Potentially_Persistent_Type (Typ)
6274 and then not Has_Init_Expression (N)
6275 and then Is_Library_Level_Entity (Def_Id)
6281 Make_Linker_Section_Pragma
6282 (Def_Id, Sloc (N), ".persistent.bss");
6283 Insert_After (N, Prag);
6288 -- If access type, then we know it is null if not initialized
6290 if Is_Access_Type (Typ) then
6291 Set_Is_Known_Null (Def_Id);
6294 -- Explicit initialization present
6297 -- Obtain actual expression from qualified expression
6299 if Nkind (Expr) = N_Qualified_Expression then
6300 Expr_Q := Expression (Expr);
6305 -- When we have the appropriate type of aggregate in the expression
6306 -- (it has been determined during analysis of the aggregate by
6307 -- setting the delay flag), let's perform in place assignment and
6308 -- thus avoid creating a temporary.
6310 if Is_Delayed_Aggregate (Expr_Q) then
6311 Convert_Aggr_In_Object_Decl (N);
6313 -- Ada 2005 (AI-318-02): If the initialization expression is a call
6314 -- to a build-in-place function, then access to the declared object
6315 -- must be passed to the function. Currently we limit such functions
6316 -- to those with constrained limited result subtypes, but eventually
6317 -- plan to expand the allowed forms of functions that are treated as
6320 elsif Is_Build_In_Place_Function_Call (Expr_Q) then
6321 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
6323 -- The previous call expands the expression initializing the
6324 -- built-in-place object into further code that will be analyzed
6325 -- later. No further expansion needed here.
6329 -- This is the same as the previous 'elsif', except that the call has
6330 -- been transformed by other expansion activities into something like
6331 -- F(...)'Reference.
6333 elsif Nkind (Expr_Q) = N_Reference
6334 and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
6335 and then not Is_Expanded_Build_In_Place_Call
6336 (Unqual_Conv (Prefix (Expr_Q)))
6338 Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
6340 -- The previous call expands the expression initializing the
6341 -- built-in-place object into further code that will be analyzed
6342 -- later. No further expansion needed here.
6346 -- Ada 2005 (AI-318-02): Specialization of the previous case for
6347 -- expressions containing a build-in-place function call whose
6348 -- returned object covers interface types, and Expr_Q has calls to
6349 -- Ada.Tags.Displace to displace the pointer to the returned build-
6350 -- in-place object to reference the secondary dispatch table of a
6351 -- covered interface type.
6353 elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
6354 Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
6356 -- The previous call expands the expression initializing the
6357 -- built-in-place object into further code that will be analyzed
6358 -- later. No further expansion needed here.
6362 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
6363 -- class-wide interface object to ensure that we copy the full
6364 -- object, unless we are targetting a VM where interfaces are handled
6365 -- by VM itself. Note that if the root type of Typ is an ancestor of
6366 -- Expr's type, both types share the same dispatch table and there is
6367 -- no need to displace the pointer.
6369 elsif Is_Interface (Typ)
6371 -- Avoid never-ending recursion because if Equivalent_Type is set
6372 -- then we've done it already and must not do it again.
6375 (Nkind (Obj_Def) = N_Identifier
6376 and then Present (Equivalent_Type (Entity (Obj_Def))))
6378 pragma Assert (Is_Class_Wide_Type (Typ));
6380 -- If the object is a return object of an inherently limited type,
6381 -- which implies build-in-place treatment, bypass the special
6382 -- treatment of class-wide interface initialization below. In this
6383 -- case, the expansion of the return statement will take care of
6384 -- creating the object (via allocator) and initializing it.
6386 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
6389 elsif Tagged_Type_Expansion then
6391 Iface : constant Entity_Id := Root_Type (Typ);
6392 Expr_N : Node_Id := Expr;
6393 Expr_Typ : Entity_Id;
6399 -- If the original node of the expression was a conversion
6400 -- to this specific class-wide interface type then restore
6401 -- the original node because we must copy the object before
6402 -- displacing the pointer to reference the secondary tag
6403 -- component. This code must be kept synchronized with the
6404 -- expansion done by routine Expand_Interface_Conversion
6406 if not Comes_From_Source (Expr_N)
6407 and then Nkind (Expr_N) = N_Explicit_Dereference
6408 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
6409 and then Etype (Original_Node (Expr_N)) = Typ
6411 Rewrite (Expr_N, Original_Node (Expression (N)));
6414 -- Avoid expansion of redundant interface conversion
6416 if Is_Interface (Etype (Expr_N))
6417 and then Nkind (Expr_N) = N_Type_Conversion
6418 and then Etype (Expr_N) = Typ
6420 Expr_N := Expression (Expr_N);
6421 Set_Expression (N, Expr_N);
6424 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
6425 Expr_Typ := Base_Type (Etype (Expr_N));
6427 if Is_Class_Wide_Type (Expr_Typ) then
6428 Expr_Typ := Root_Type (Expr_Typ);
6432 -- CW : I'Class := Obj;
6435 -- type Ityp is not null access I'Class;
6436 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
6438 if Comes_From_Source (Expr_N)
6439 and then Nkind (Expr_N) = N_Identifier
6440 and then not Is_Interface (Expr_Typ)
6441 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
6442 and then (Expr_Typ = Etype (Expr_Typ)
6444 Is_Variable_Size_Record (Etype (Expr_Typ)))
6449 Make_Object_Declaration (Loc,
6450 Defining_Identifier => Obj_Id,
6451 Object_Definition =>
6452 New_Occurrence_Of (Expr_Typ, Loc),
6453 Expression => Relocate_Node (Expr_N)));
6455 -- Statically reference the tag associated with the
6459 Make_Selected_Component (Loc,
6460 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6463 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
6466 -- IW : I'Class := Obj;
6468 -- type Equiv_Record is record ... end record;
6469 -- implicit subtype CW is <Class_Wide_Subtype>;
6470 -- Tmp : CW := CW!(Obj);
6471 -- type Ityp is not null access I'Class;
6472 -- IW : I'Class renames
6473 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
6476 -- Generate the equivalent record type and update the
6477 -- subtype indication to reference it.
6479 Expand_Subtype_From_Expr
6482 Subtype_Indic => Obj_Def,
6485 if not Is_Interface (Etype (Expr_N)) then
6486 New_Expr := Relocate_Node (Expr_N);
6488 -- For interface types we use 'Address which displaces
6489 -- the pointer to the base of the object (if required)
6493 Unchecked_Convert_To (Etype (Obj_Def),
6494 Make_Explicit_Dereference (Loc,
6495 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6496 Make_Attribute_Reference (Loc,
6497 Prefix => Relocate_Node (Expr_N),
6498 Attribute_Name => Name_Address))));
6503 if not Is_Limited_Record (Expr_Typ) then
6505 Make_Object_Declaration (Loc,
6506 Defining_Identifier => Obj_Id,
6507 Object_Definition =>
6508 New_Occurrence_Of (Etype (Obj_Def), Loc),
6509 Expression => New_Expr));
6511 -- Rename limited type object since they cannot be copied
6512 -- This case occurs when the initialization expression
6513 -- has been previously expanded into a temporary object.
6515 else pragma Assert (not Comes_From_Source (Expr_Q));
6517 Make_Object_Renaming_Declaration (Loc,
6518 Defining_Identifier => Obj_Id,
6520 New_Occurrence_Of (Etype (Obj_Def), Loc),
6522 Unchecked_Convert_To
6523 (Etype (Obj_Def), New_Expr)));
6526 -- Dynamically reference the tag associated with the
6530 Make_Function_Call (Loc,
6531 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
6532 Parameter_Associations => New_List (
6533 Make_Attribute_Reference (Loc,
6534 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6535 Attribute_Name => Name_Address),
6537 (Node (First_Elmt (Access_Disp_Table (Iface))),
6542 Make_Object_Renaming_Declaration (Loc,
6543 Defining_Identifier => Make_Temporary (Loc, 'D'),
6544 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
6546 Convert_Tag_To_Interface (Typ, Tag_Comp)));
6548 -- If the original entity comes from source, then mark the
6549 -- new entity as needing debug information, even though it's
6550 -- defined by a generated renaming that does not come from
6551 -- source, so that Materialize_Entity will be set on the
6552 -- entity when Debug_Renaming_Declaration is called during
6555 if Comes_From_Source (Def_Id) then
6556 Set_Debug_Info_Needed (Defining_Identifier (N));
6559 Analyze (N, Suppress => All_Checks);
6561 -- Replace internal identifier of rewritten node by the
6562 -- identifier found in the sources. We also have to exchange
6563 -- entities containing their defining identifiers to ensure
6564 -- the correct replacement of the object declaration by this
6565 -- object renaming declaration because these identifiers
6566 -- were previously added by Enter_Name to the current scope.
6567 -- We must preserve the homonym chain of the source entity
6568 -- as well. We must also preserve the kind of the entity,
6569 -- which may be a constant. Preserve entity chain because
6570 -- itypes may have been generated already, and the full
6571 -- chain must be preserved for final freezing. Finally,
6572 -- preserve Comes_From_Source setting, so that debugging
6573 -- and cross-referencing information is properly kept, and
6574 -- preserve source location, to prevent spurious errors when
6575 -- entities are declared (they must have their own Sloc).
6578 New_Id : constant Entity_Id := Defining_Identifier (N);
6579 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
6580 S_Flag : constant Boolean :=
6581 Comes_From_Source (Def_Id);
6584 Set_Next_Entity (New_Id, Next_Entity (Def_Id));
6585 Set_Next_Entity (Def_Id, Next_Temp);
6587 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
6588 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
6589 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
6590 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
6592 Set_Comes_From_Source (Def_Id, False);
6593 Exchange_Entities (Defining_Identifier (N), Def_Id);
6594 Set_Comes_From_Source (Def_Id, S_Flag);
6601 -- Common case of explicit object initialization
6604 -- In most cases, we must check that the initial value meets any
6605 -- constraint imposed by the declared type. However, there is one
6606 -- very important exception to this rule. If the entity has an
6607 -- unconstrained nominal subtype, then it acquired its constraints
6608 -- from the expression in the first place, and not only does this
6609 -- mean that the constraint check is not needed, but an attempt to
6610 -- perform the constraint check can cause order of elaboration
6613 if not Is_Constr_Subt_For_U_Nominal (Typ) then
6615 -- If this is an allocator for an aggregate that has been
6616 -- allocated in place, delay checks until assignments are
6617 -- made, because the discriminants are not initialized.
6619 if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
6623 -- Otherwise apply a constraint check now if no prev error
6625 elsif Nkind (Expr) /= N_Error then
6626 Apply_Constraint_Check (Expr, Typ);
6628 -- Deal with possible range check
6630 if Do_Range_Check (Expr) then
6632 -- If assignment checks are suppressed, turn off flag
6634 if Suppress_Assignment_Checks (N) then
6635 Set_Do_Range_Check (Expr, False);
6637 -- Otherwise generate the range check
6640 Generate_Range_Check
6641 (Expr, Typ, CE_Range_Check_Failed);
6647 -- If the type is controlled and not inherently limited, then
6648 -- the target is adjusted after the copy and attached to the
6649 -- finalization list. However, no adjustment is done in the case
6650 -- where the object was initialized by a call to a function whose
6651 -- result is built in place, since no copy occurred. Similarly, no
6652 -- adjustment is required if we are going to rewrite the object
6653 -- declaration into a renaming declaration.
6655 if Is_Build_In_Place_Result_Type (Typ)
6656 and then Nkind (Parent (N)) = N_Extended_Return_Statement
6657 and then not Is_Definite_Subtype
6658 (Etype (Return_Applies_To
6659 (Return_Statement_Entity (Parent (N)))))
6663 elsif Needs_Finalization (Typ)
6664 and then not Is_Limited_View (Typ)
6665 and then not Rewrite_As_Renaming
6669 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
6672 -- Guard against a missing [Deep_]Adjust when the base type
6673 -- was not properly frozen.
6675 if Present (Adj_Call) then
6676 Insert_Action_After (Init_After, Adj_Call);
6680 -- For tagged types, when an init value is given, the tag has to
6681 -- be re-initialized separately in order to avoid the propagation
6682 -- of a wrong tag coming from a view conversion unless the type
6683 -- is class wide (in this case the tag comes from the init value).
6684 -- Suppress the tag assignment when not Tagged_Type_Expansion
6685 -- because tags are represented implicitly in objects. Ditto for
6686 -- types that are CPP_CLASS, and for initializations that are
6687 -- aggregates, because they have to have the right tag.
6689 -- The re-assignment of the tag has to be done even if the object
6690 -- is a constant. The assignment must be analyzed after the
6691 -- declaration. If an address clause follows, this is handled as
6692 -- part of the freeze actions for the object, otherwise insert
6693 -- tag assignment here.
6695 Tag_Assign := Make_Tag_Assignment (N);
6697 if Present (Tag_Assign) then
6698 if Present (Following_Address_Clause (N)) then
6699 Ensure_Freeze_Node (Def_Id);
6702 Insert_Action_After (Init_After, Tag_Assign);
6705 -- Handle C++ constructor calls. Note that we do not check that
6706 -- Typ is a tagged type since the equivalent Ada type of a C++
6707 -- class that has no virtual methods is an untagged limited
6710 elsif Is_CPP_Constructor_Call (Expr) then
6712 -- The call to the initialization procedure does NOT freeze the
6713 -- object being initialized.
6715 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
6716 Set_Must_Not_Freeze (Id_Ref);
6717 Set_Assignment_OK (Id_Ref);
6719 Insert_Actions_After (Init_After,
6720 Build_Initialization_Call (Loc, Id_Ref, Typ,
6721 Constructor_Ref => Expr));
6723 -- We remove here the original call to the constructor
6724 -- to avoid its management in the backend
6726 Set_Expression (N, Empty);
6729 -- Handle initialization of limited tagged types
6731 elsif Is_Tagged_Type (Typ)
6732 and then Is_Class_Wide_Type (Typ)
6733 and then Is_Limited_Record (Typ)
6734 and then not Is_Limited_Interface (Typ)
6736 -- Given that the type is limited we cannot perform a copy. If
6737 -- Expr_Q is the reference to a variable we mark the variable
6738 -- as OK_To_Rename to expand this declaration into a renaming
6739 -- declaration (see bellow).
6741 if Is_Entity_Name (Expr_Q) then
6742 Set_OK_To_Rename (Entity (Expr_Q));
6744 -- If we cannot convert the expression into a renaming we must
6745 -- consider it an internal error because the backend does not
6746 -- have support to handle it.
6749 pragma Assert (False);
6750 raise Program_Error;
6753 -- For discrete types, set the Is_Known_Valid flag if the
6754 -- initializing value is known to be valid. Only do this for
6755 -- source assignments, since otherwise we can end up turning
6756 -- on the known valid flag prematurely from inserted code.
6758 elsif Comes_From_Source (N)
6759 and then Is_Discrete_Type (Typ)
6760 and then Expr_Known_Valid (Expr)
6762 Set_Is_Known_Valid (Def_Id);
6764 elsif Is_Access_Type (Typ) then
6766 -- For access types set the Is_Known_Non_Null flag if the
6767 -- initializing value is known to be non-null. We can also set
6768 -- Can_Never_Be_Null if this is a constant.
6770 if Known_Non_Null (Expr) then
6771 Set_Is_Known_Non_Null (Def_Id, True);
6773 if Constant_Present (N) then
6774 Set_Can_Never_Be_Null (Def_Id);
6779 -- If validity checking on copies, validate initial expression.
6780 -- But skip this if declaration is for a generic type, since it
6781 -- makes no sense to validate generic types. Not clear if this
6782 -- can happen for legal programs, but it definitely can arise
6783 -- from previous instantiation errors.
6785 if Validity_Checks_On
6786 and then Comes_From_Source (N)
6787 and then Validity_Check_Copies
6788 and then not Is_Generic_Type (Etype (Def_Id))
6790 Ensure_Valid (Expr);
6791 Set_Is_Known_Valid (Def_Id);
6795 -- Cases where the back end cannot handle the initialization
6796 -- directly. In such cases, we expand an assignment that will
6797 -- be appropriately handled by Expand_N_Assignment_Statement.
6799 -- The exclusion of the unconstrained case is wrong, but for now it
6800 -- is too much trouble ???
6802 if (Is_Possibly_Unaligned_Slice (Expr)
6803 or else (Is_Possibly_Unaligned_Object (Expr)
6804 and then not Represented_As_Scalar (Etype (Expr))))
6805 and then not (Is_Array_Type (Etype (Expr))
6806 and then not Is_Constrained (Etype (Expr)))
6809 Stat : constant Node_Id :=
6810 Make_Assignment_Statement (Loc,
6811 Name => New_Occurrence_Of (Def_Id, Loc),
6812 Expression => Relocate_Node (Expr));
6814 Set_Expression (N, Empty);
6815 Set_No_Initialization (N);
6816 Set_Assignment_OK (Name (Stat));
6817 Set_No_Ctrl_Actions (Stat);
6818 Insert_After_And_Analyze (Init_After, Stat);
6823 if Nkind (Obj_Def) = N_Access_Definition
6824 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
6826 -- An Ada 2012 stand-alone object of an anonymous access type
6829 Loc : constant Source_Ptr := Sloc (N);
6831 Level : constant Entity_Id :=
6832 Make_Defining_Identifier (Sloc (N),
6834 New_External_Name (Chars (Def_Id), Suffix => "L"));
6836 Level_Expr : Node_Id;
6837 Level_Decl : Node_Id;
6840 Set_Ekind (Level, Ekind (Def_Id));
6841 Set_Etype (Level, Standard_Natural);
6842 Set_Scope (Level, Scope (Def_Id));
6846 -- Set accessibility level of null
6849 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
6852 Level_Expr := Dynamic_Accessibility_Level (Expr);
6856 Make_Object_Declaration (Loc,
6857 Defining_Identifier => Level,
6858 Object_Definition =>
6859 New_Occurrence_Of (Standard_Natural, Loc),
6860 Expression => Level_Expr,
6861 Constant_Present => Constant_Present (N),
6862 Has_Init_Expression => True);
6864 Insert_Action_After (Init_After, Level_Decl);
6866 Set_Extra_Accessibility (Def_Id, Level);
6870 -- If the object is default initialized and its type is subject to
6871 -- pragma Default_Initial_Condition, add a runtime check to verify
6872 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
6874 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
6876 -- Note that the check is generated for source objects only
6878 if Comes_From_Source (Def_Id)
6879 and then Has_DIC (Typ)
6880 and then Present (DIC_Procedure (Typ))
6881 and then not Has_Init_Expression (N)
6884 DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
6887 if Present (Next_N) then
6888 Insert_Before_And_Analyze (Next_N, DIC_Call);
6890 -- The object declaration is the last node in a declarative or a
6894 Append_To (List_Containing (N), DIC_Call);
6900 -- Final transformation - turn the object declaration into a renaming
6901 -- if appropriate. If this is the completion of a deferred constant
6902 -- declaration, then this transformation generates what would be
6903 -- illegal code if written by hand, but that's OK.
6905 if Present (Expr) then
6906 if Rewrite_As_Renaming then
6908 Make_Object_Renaming_Declaration (Loc,
6909 Defining_Identifier => Defining_Identifier (N),
6910 Subtype_Mark => Obj_Def,
6913 -- We do not analyze this renaming declaration, because all its
6914 -- components have already been analyzed, and if we were to go
6915 -- ahead and analyze it, we would in effect be trying to generate
6916 -- another declaration of X, which won't do.
6918 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
6921 -- We do need to deal with debug issues for this renaming
6923 -- First, if entity comes from source, then mark it as needing
6924 -- debug information, even though it is defined by a generated
6925 -- renaming that does not come from source.
6927 if Comes_From_Source (Defining_Identifier (N)) then
6928 Set_Debug_Info_Needed (Defining_Identifier (N));
6931 -- Now call the routine to generate debug info for the renaming
6934 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
6936 if Present (Decl) then
6937 Insert_Action (N, Decl);
6943 -- Exception on library entity not available
6946 when RE_Not_Available =>
6948 end Expand_N_Object_Declaration;
6950 ---------------------------------
6951 -- Expand_N_Subtype_Indication --
6952 ---------------------------------
6954 -- Add a check on the range of the subtype. The static case is partially
6955 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
6956 -- to check here for the static case in order to avoid generating
6957 -- extraneous expanded code. Also deal with validity checking.
6959 procedure Expand_N_Subtype_Indication (N : Node_Id) is
6960 Ran : constant Node_Id := Range_Expression (Constraint (N));
6961 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
6964 if Nkind (Constraint (N)) = N_Range_Constraint then
6965 Validity_Check_Range (Range_Expression (Constraint (N)));
6968 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
6969 Apply_Range_Check (Ran, Typ);
6971 end Expand_N_Subtype_Indication;
6973 ---------------------------
6974 -- Expand_N_Variant_Part --
6975 ---------------------------
6977 -- Note: this procedure no longer has any effect. It used to be that we
6978 -- would replace the choices in the last variant by a when others, and
6979 -- also expanded static predicates in variant choices here, but both of
6980 -- those activities were being done too early, since we can't check the
6981 -- choices until the statically predicated subtypes are frozen, which can
6982 -- happen as late as the free point of the record, and we can't change the
6983 -- last choice to an others before checking the choices, which is now done
6984 -- at the freeze point of the record.
6986 procedure Expand_N_Variant_Part (N : Node_Id) is
6989 end Expand_N_Variant_Part;
6991 ---------------------------------
6992 -- Expand_Previous_Access_Type --
6993 ---------------------------------
6995 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
6996 Ptr_Typ : Entity_Id;
6999 -- Find all access types in the current scope whose designated type is
7000 -- Def_Id and build master renamings for them.
7002 Ptr_Typ := First_Entity (Current_Scope);
7003 while Present (Ptr_Typ) loop
7004 if Is_Access_Type (Ptr_Typ)
7005 and then Designated_Type (Ptr_Typ) = Def_Id
7006 and then No (Master_Id (Ptr_Typ))
7008 -- Ensure that the designated type has a master
7010 Build_Master_Entity (Def_Id);
7012 -- Private and incomplete types complicate the insertion of master
7013 -- renamings because the access type may precede the full view of
7014 -- the designated type. For this reason, the master renamings are
7015 -- inserted relative to the designated type.
7017 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
7020 Next_Entity (Ptr_Typ);
7022 end Expand_Previous_Access_Type;
7024 -----------------------------
7025 -- Expand_Record_Extension --
7026 -----------------------------
7028 -- Add a field _parent at the beginning of the record extension. This is
7029 -- used to implement inheritance. Here are some examples of expansion:
7031 -- 1. no discriminants
7032 -- type T2 is new T1 with null record;
7034 -- type T2 is new T1 with record
7038 -- 2. renamed discriminants
7039 -- type T2 (B, C : Int) is new T1 (A => B) with record
7040 -- _Parent : T1 (A => B);
7044 -- 3. inherited discriminants
7045 -- type T2 is new T1 with record -- discriminant A inherited
7046 -- _Parent : T1 (A);
7050 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
7051 Indic : constant Node_Id := Subtype_Indication (Def);
7052 Loc : constant Source_Ptr := Sloc (Def);
7053 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
7054 Par_Subtype : Entity_Id;
7055 Comp_List : Node_Id;
7056 Comp_Decl : Node_Id;
7059 List_Constr : constant List_Id := New_List;
7062 -- Expand_Record_Extension is called directly from the semantics, so
7063 -- we must check to see whether expansion is active before proceeding,
7064 -- because this affects the visibility of selected components in bodies
7067 if not Expander_Active then
7071 -- This may be a derivation of an untagged private type whose full
7072 -- view is tagged, in which case the Derived_Type_Definition has no
7073 -- extension part. Build an empty one now.
7075 if No (Rec_Ext_Part) then
7077 Make_Record_Definition (Loc,
7079 Component_List => Empty,
7080 Null_Present => True);
7082 Set_Record_Extension_Part (Def, Rec_Ext_Part);
7083 Mark_Rewrite_Insertion (Rec_Ext_Part);
7086 Comp_List := Component_List (Rec_Ext_Part);
7088 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
7090 -- If the derived type inherits its discriminants the type of the
7091 -- _parent field must be constrained by the inherited discriminants
7093 if Has_Discriminants (T)
7094 and then Nkind (Indic) /= N_Subtype_Indication
7095 and then not Is_Constrained (Entity (Indic))
7097 D := First_Discriminant (T);
7098 while Present (D) loop
7099 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
7100 Next_Discriminant (D);
7105 Make_Subtype_Indication (Loc,
7106 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
7108 Make_Index_Or_Discriminant_Constraint (Loc,
7109 Constraints => List_Constr)),
7112 -- Otherwise the original subtype_indication is just what is needed
7115 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
7118 Set_Parent_Subtype (T, Par_Subtype);
7121 Make_Component_Declaration (Loc,
7122 Defining_Identifier => Parent_N,
7123 Component_Definition =>
7124 Make_Component_Definition (Loc,
7125 Aliased_Present => False,
7126 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
7128 if Null_Present (Rec_Ext_Part) then
7129 Set_Component_List (Rec_Ext_Part,
7130 Make_Component_List (Loc,
7131 Component_Items => New_List (Comp_Decl),
7132 Variant_Part => Empty,
7133 Null_Present => False));
7134 Set_Null_Present (Rec_Ext_Part, False);
7136 elsif Null_Present (Comp_List)
7137 or else Is_Empty_List (Component_Items (Comp_List))
7139 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7140 Set_Null_Present (Comp_List, False);
7143 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7146 Analyze (Comp_Decl);
7147 end Expand_Record_Extension;
7149 ------------------------
7150 -- Expand_Tagged_Root --
7151 ------------------------
7153 procedure Expand_Tagged_Root (T : Entity_Id) is
7154 Def : constant Node_Id := Type_Definition (Parent (T));
7155 Comp_List : Node_Id;
7156 Comp_Decl : Node_Id;
7157 Sloc_N : Source_Ptr;
7160 if Null_Present (Def) then
7161 Set_Component_List (Def,
7162 Make_Component_List (Sloc (Def),
7163 Component_Items => Empty_List,
7164 Variant_Part => Empty,
7165 Null_Present => True));
7168 Comp_List := Component_List (Def);
7170 if Null_Present (Comp_List)
7171 or else Is_Empty_List (Component_Items (Comp_List))
7173 Sloc_N := Sloc (Comp_List);
7175 Sloc_N := Sloc (First (Component_Items (Comp_List)));
7179 Make_Component_Declaration (Sloc_N,
7180 Defining_Identifier => First_Tag_Component (T),
7181 Component_Definition =>
7182 Make_Component_Definition (Sloc_N,
7183 Aliased_Present => False,
7184 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
7186 if Null_Present (Comp_List)
7187 or else Is_Empty_List (Component_Items (Comp_List))
7189 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7190 Set_Null_Present (Comp_List, False);
7193 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7196 -- We don't Analyze the whole expansion because the tag component has
7197 -- already been analyzed previously. Here we just insure that the tree
7198 -- is coherent with the semantic decoration
7200 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
7203 when RE_Not_Available =>
7205 end Expand_Tagged_Root;
7207 ------------------------------
7208 -- Freeze_Stream_Operations --
7209 ------------------------------
7211 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
7212 Names : constant array (1 .. 4) of TSS_Name_Type :=
7217 Stream_Op : Entity_Id;
7220 -- Primitive operations of tagged types are frozen when the dispatch
7221 -- table is constructed.
7223 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
7227 for J in Names'Range loop
7228 Stream_Op := TSS (Typ, Names (J));
7230 if Present (Stream_Op)
7231 and then Is_Subprogram (Stream_Op)
7232 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
7233 N_Subprogram_Declaration
7234 and then not Is_Frozen (Stream_Op)
7236 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
7239 end Freeze_Stream_Operations;
7245 -- Full type declarations are expanded at the point at which the type is
7246 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
7247 -- declarations generated by the freezing (e.g. the procedure generated
7248 -- for initialization) are chained in the Actions field list of the freeze
7249 -- node using Append_Freeze_Actions.
7251 -- WARNING: This routine manages Ghost regions. Return statements must be
7252 -- replaced by gotos which jump to the end of the routine and restore the
7255 function Freeze_Type (N : Node_Id) return Boolean is
7256 procedure Process_RACW_Types (Typ : Entity_Id);
7257 -- Validate and generate stubs for all RACW types associated with type
7260 procedure Process_Pending_Access_Types (Typ : Entity_Id);
7261 -- Associate type Typ's Finalize_Address primitive with the finalization
7262 -- masters of pending access-to-Typ types.
7264 ------------------------
7265 -- Process_RACW_Types --
7266 ------------------------
7268 procedure Process_RACW_Types (Typ : Entity_Id) is
7269 List : constant Elist_Id := Access_Types_To_Process (N);
7271 Seen : Boolean := False;
7274 if Present (List) then
7275 E := First_Elmt (List);
7276 while Present (E) loop
7277 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
7278 Validate_RACW_Primitives (Node (E));
7286 -- If there are RACWs designating this type, make stubs now
7289 Remote_Types_Tagged_Full_View_Encountered (Typ);
7291 end Process_RACW_Types;
7293 ----------------------------------
7294 -- Process_Pending_Access_Types --
7295 ----------------------------------
7297 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
7301 -- Finalize_Address is not generated in CodePeer mode because the
7302 -- body contains address arithmetic. This processing is disabled.
7304 if CodePeer_Mode then
7307 -- Certain itypes are generated for contexts that cannot allocate
7308 -- objects and should not set primitive Finalize_Address.
7310 elsif Is_Itype (Typ)
7311 and then Nkind (Associated_Node_For_Itype (Typ)) =
7312 N_Explicit_Dereference
7316 -- When an access type is declared after the incomplete view of a
7317 -- Taft-amendment type, the access type is considered pending in
7318 -- case the full view of the Taft-amendment type is controlled. If
7319 -- this is indeed the case, associate the Finalize_Address routine
7320 -- of the full view with the finalization masters of all pending
7321 -- access types. This scenario applies to anonymous access types as
7324 elsif Needs_Finalization (Typ)
7325 and then Present (Pending_Access_Types (Typ))
7327 E := First_Elmt (Pending_Access_Types (Typ));
7328 while Present (E) loop
7331 -- Set_Finalize_Address
7332 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
7334 Append_Freeze_Action (Typ,
7335 Make_Set_Finalize_Address_Call
7337 Ptr_Typ => Node (E)));
7342 end Process_Pending_Access_Types;
7346 Def_Id : constant Entity_Id := Entity (N);
7348 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
7349 -- Save the Ghost mode to restore on exit
7351 Result : Boolean := False;
7353 -- Start of processing for Freeze_Type
7356 -- The type being frozen may be subject to pragma Ghost. Set the mode
7357 -- now to ensure that any nodes generated during freezing are properly
7360 Set_Ghost_Mode (Def_Id);
7362 -- Process any remote access-to-class-wide types designating the type
7365 Process_RACW_Types (Def_Id);
7367 -- Freeze processing for record types
7369 if Is_Record_Type (Def_Id) then
7370 if Ekind (Def_Id) = E_Record_Type then
7371 Expand_Freeze_Record_Type (N);
7372 elsif Is_Class_Wide_Type (Def_Id) then
7373 Expand_Freeze_Class_Wide_Type (N);
7376 -- Freeze processing for array types
7378 elsif Is_Array_Type (Def_Id) then
7379 Expand_Freeze_Array_Type (N);
7381 -- Freeze processing for access types
7383 -- For pool-specific access types, find out the pool object used for
7384 -- this type, needs actual expansion of it in some cases. Here are the
7385 -- different cases :
7387 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
7388 -- ---> don't use any storage pool
7390 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
7392 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
7394 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7395 -- ---> Storage Pool is the specified one
7397 -- See GNAT Pool packages in the Run-Time for more details
7399 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
7401 Loc : constant Source_Ptr := Sloc (N);
7402 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
7404 Freeze_Action_Typ : Entity_Id;
7405 Pool_Object : Entity_Id;
7410 -- Rep Clause "for Def_Id'Storage_Size use 0;"
7411 -- ---> don't use any storage pool
7413 if No_Pool_Assigned (Def_Id) then
7418 -- Rep Clause : for Def_Id'Storage_Size use Expr.
7420 -- Def_Id__Pool : Stack_Bounded_Pool
7421 -- (Expr, DT'Size, DT'Alignment);
7423 elsif Has_Storage_Size_Clause (Def_Id) then
7429 -- For unconstrained composite types we give a size of zero
7430 -- so that the pool knows that it needs a special algorithm
7431 -- for variable size object allocation.
7433 if Is_Composite_Type (Desig_Type)
7434 and then not Is_Constrained (Desig_Type)
7436 DT_Size := Make_Integer_Literal (Loc, 0);
7437 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
7441 Make_Attribute_Reference (Loc,
7442 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7443 Attribute_Name => Name_Max_Size_In_Storage_Elements);
7446 Make_Attribute_Reference (Loc,
7447 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7448 Attribute_Name => Name_Alignment);
7452 Make_Defining_Identifier (Loc,
7453 Chars => New_External_Name (Chars (Def_Id), 'P'));
7455 -- We put the code associated with the pools in the entity
7456 -- that has the later freeze node, usually the access type
7457 -- but it can also be the designated_type; because the pool
7458 -- code requires both those types to be frozen
7460 if Is_Frozen (Desig_Type)
7461 and then (No (Freeze_Node (Desig_Type))
7462 or else Analyzed (Freeze_Node (Desig_Type)))
7464 Freeze_Action_Typ := Def_Id;
7466 -- A Taft amendment type cannot get the freeze actions
7467 -- since the full view is not there.
7469 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
7470 and then No (Full_View (Desig_Type))
7472 Freeze_Action_Typ := Def_Id;
7475 Freeze_Action_Typ := Desig_Type;
7478 Append_Freeze_Action (Freeze_Action_Typ,
7479 Make_Object_Declaration (Loc,
7480 Defining_Identifier => Pool_Object,
7481 Object_Definition =>
7482 Make_Subtype_Indication (Loc,
7485 (RTE (RE_Stack_Bounded_Pool), Loc),
7488 Make_Index_Or_Discriminant_Constraint (Loc,
7489 Constraints => New_List (
7491 -- First discriminant is the Pool Size
7494 Storage_Size_Variable (Def_Id), Loc),
7496 -- Second discriminant is the element size
7500 -- Third discriminant is the alignment
7505 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
7509 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7510 -- ---> Storage Pool is the specified one
7512 -- When compiling in Ada 2012 mode, ensure that the accessibility
7513 -- level of the subpool access type is not deeper than that of the
7514 -- pool_with_subpools.
7516 elsif Ada_Version >= Ada_2012
7517 and then Present (Associated_Storage_Pool (Def_Id))
7519 -- Omit this check for the case of a configurable run-time that
7520 -- does not provide package System.Storage_Pools.Subpools.
7522 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
7525 Loc : constant Source_Ptr := Sloc (Def_Id);
7526 Pool : constant Entity_Id :=
7527 Associated_Storage_Pool (Def_Id);
7528 RSPWS : constant Entity_Id :=
7529 RTE (RE_Root_Storage_Pool_With_Subpools);
7532 -- It is known that the accessibility level of the access
7533 -- type is deeper than that of the pool.
7535 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
7536 and then not Accessibility_Checks_Suppressed (Def_Id)
7537 and then not Accessibility_Checks_Suppressed (Pool)
7539 -- Static case: the pool is known to be a descendant of
7540 -- Root_Storage_Pool_With_Subpools.
7542 if Is_Ancestor (RSPWS, Etype (Pool)) then
7544 ("??subpool access type has deeper accessibility "
7545 & "level than pool", Def_Id);
7547 Append_Freeze_Action (Def_Id,
7548 Make_Raise_Program_Error (Loc,
7549 Reason => PE_Accessibility_Check_Failed));
7551 -- Dynamic case: when the pool is of a class-wide type,
7552 -- it may or may not support subpools depending on the
7553 -- path of derivation. Generate:
7555 -- if Def_Id in RSPWS'Class then
7556 -- raise Program_Error;
7559 elsif Is_Class_Wide_Type (Etype (Pool)) then
7560 Append_Freeze_Action (Def_Id,
7561 Make_If_Statement (Loc,
7564 Left_Opnd => New_Occurrence_Of (Pool, Loc),
7567 (Class_Wide_Type (RSPWS), Loc)),
7569 Then_Statements => New_List (
7570 Make_Raise_Program_Error (Loc,
7571 Reason => PE_Accessibility_Check_Failed))));
7577 -- For access-to-controlled types (including class-wide types and
7578 -- Taft-amendment types, which potentially have controlled
7579 -- components), expand the list controller object that will store
7580 -- the dynamically allocated objects. Don't do this transformation
7581 -- for expander-generated access types, but do it for types that
7582 -- are the full view of types derived from other private types.
7583 -- Also suppress the list controller in the case of a designated
7584 -- type with convention Java, since this is used when binding to
7585 -- Java API specs, where there's no equivalent of a finalization
7586 -- list and we don't want to pull in the finalization support if
7589 if not Comes_From_Source (Def_Id)
7590 and then not Has_Private_Declaration (Def_Id)
7594 -- An exception is made for types defined in the run-time because
7595 -- Ada.Tags.Tag itself is such a type and cannot afford this
7596 -- unnecessary overhead that would generates a loop in the
7597 -- expansion scheme. Another exception is if Restrictions
7598 -- (No_Finalization) is active, since then we know nothing is
7601 elsif Restriction_Active (No_Finalization)
7602 or else In_Runtime (Def_Id)
7606 -- Create a finalization master for an access-to-controlled type
7607 -- or an access-to-incomplete type. It is assumed that the full
7608 -- view will be controlled.
7610 elsif Needs_Finalization (Desig_Type)
7611 or else (Is_Incomplete_Type (Desig_Type)
7612 and then No (Full_View (Desig_Type)))
7614 Build_Finalization_Master (Def_Id);
7616 -- Create a finalization master when the designated type contains
7617 -- a private component. It is assumed that the full view will be
7620 elsif Has_Private_Component (Desig_Type) then
7621 Build_Finalization_Master
7623 For_Private => True,
7624 Context_Scope => Scope (Def_Id),
7625 Insertion_Node => Declaration_Node (Desig_Type));
7629 -- Freeze processing for enumeration types
7631 elsif Ekind (Def_Id) = E_Enumeration_Type then
7633 -- We only have something to do if we have a non-standard
7634 -- representation (i.e. at least one literal whose pos value
7635 -- is not the same as its representation)
7637 if Has_Non_Standard_Rep (Def_Id) then
7638 Expand_Freeze_Enumeration_Type (N);
7641 -- Private types that are completed by a derivation from a private
7642 -- type have an internally generated full view, that needs to be
7643 -- frozen. This must be done explicitly because the two views share
7644 -- the freeze node, and the underlying full view is not visible when
7645 -- the freeze node is analyzed.
7647 elsif Is_Private_Type (Def_Id)
7648 and then Is_Derived_Type (Def_Id)
7649 and then Present (Full_View (Def_Id))
7650 and then Is_Itype (Full_View (Def_Id))
7651 and then Has_Private_Declaration (Full_View (Def_Id))
7652 and then Freeze_Node (Full_View (Def_Id)) = N
7654 Set_Entity (N, Full_View (Def_Id));
7655 Result := Freeze_Type (N);
7656 Set_Entity (N, Def_Id);
7658 -- All other types require no expander action. There are such cases
7659 -- (e.g. task types and protected types). In such cases, the freeze
7660 -- nodes are there for use by Gigi.
7664 -- Complete the initialization of all pending access types' finalization
7665 -- masters now that the designated type has been is frozen and primitive
7666 -- Finalize_Address generated.
7668 Process_Pending_Access_Types (Def_Id);
7669 Freeze_Stream_Operations (N, Def_Id);
7671 -- Generate the [spec and] body of the procedure tasked with the runtime
7672 -- verification of pragma Default_Initial_Condition's expression.
7674 if Has_DIC (Def_Id) then
7675 Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
7678 -- Generate the [spec and] body of the invariant procedure tasked with
7679 -- the runtime verification of all invariants that pertain to the type.
7680 -- This includes invariants on the partial and full view, inherited
7681 -- class-wide invariants from parent types or interfaces, and invariants
7682 -- on array elements or record components.
7684 if Is_Interface (Def_Id) then
7686 -- Interfaces are treated as the partial view of a private type in
7687 -- order to achieve uniformity with the general case. As a result, an
7688 -- interface receives only a "partial" invariant procedure which is
7691 if Has_Own_Invariants (Def_Id) then
7692 Build_Invariant_Procedure_Body
7694 Partial_Invariant => Is_Interface (Def_Id));
7697 -- Non-interface types
7699 -- Do not generate invariant procedure within other assertion
7700 -- subprograms, which may involve local declarations of local
7701 -- subtypes to which these checks do not apply.
7703 elsif Has_Invariants (Def_Id) then
7704 if Within_Internal_Subprogram
7705 or else (Ekind (Current_Scope) = E_Function
7706 and then Is_Predicate_Function (Current_Scope))
7710 Build_Invariant_Procedure_Body (Def_Id);
7714 Restore_Ghost_Mode (Saved_GM);
7719 when RE_Not_Available =>
7720 Restore_Ghost_Mode (Saved_GM);
7725 -------------------------
7726 -- Get_Simple_Init_Val --
7727 -------------------------
7729 function Get_Simple_Init_Val
7732 Size : Uint := No_Uint) return Node_Id
7734 Loc : constant Source_Ptr := Sloc (N);
7740 -- This is the size to be used for computation of the appropriate
7741 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
7743 IV_Attribute : constant Boolean :=
7744 Nkind (N) = N_Attribute_Reference
7745 and then Attribute_Name (N) = Name_Invalid_Value;
7749 -- These are the values computed by the procedure Check_Subtype_Bounds
7751 procedure Check_Subtype_Bounds;
7752 -- This procedure examines the subtype T, and its ancestor subtypes and
7753 -- derived types to determine the best known information about the
7754 -- bounds of the subtype. After the call Lo_Bound is set either to
7755 -- No_Uint if no information can be determined, or to a value which
7756 -- represents a known low bound, i.e. a valid value of the subtype can
7757 -- not be less than this value. Hi_Bound is similarly set to a known
7758 -- high bound (valid value cannot be greater than this).
7760 --------------------------
7761 -- Check_Subtype_Bounds --
7762 --------------------------
7764 procedure Check_Subtype_Bounds is
7773 Lo_Bound := No_Uint;
7774 Hi_Bound := No_Uint;
7776 -- Loop to climb ancestor subtypes and derived types
7780 if not Is_Discrete_Type (ST1) then
7784 Lo := Type_Low_Bound (ST1);
7785 Hi := Type_High_Bound (ST1);
7787 if Compile_Time_Known_Value (Lo) then
7788 Loval := Expr_Value (Lo);
7790 if Lo_Bound = No_Uint or else Lo_Bound < Loval then
7795 if Compile_Time_Known_Value (Hi) then
7796 Hival := Expr_Value (Hi);
7798 if Hi_Bound = No_Uint or else Hi_Bound > Hival then
7803 ST2 := Ancestor_Subtype (ST1);
7809 exit when ST1 = ST2;
7812 end Check_Subtype_Bounds;
7814 -- Start of processing for Get_Simple_Init_Val
7817 -- For a private type, we should always have an underlying type (because
7818 -- this was already checked in Needs_Simple_Initialization). What we do
7819 -- is to get the value for the underlying type and then do an unchecked
7820 -- conversion to the private type.
7822 if Is_Private_Type (T) then
7823 Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
7825 -- A special case, if the underlying value is null, then qualify it
7826 -- with the underlying type, so that the null is properly typed.
7827 -- Similarly, if it is an aggregate it must be qualified, because an
7828 -- unchecked conversion does not provide a context for it.
7830 if Nkind_In (Val, N_Null, N_Aggregate) then
7832 Make_Qualified_Expression (Loc,
7834 New_Occurrence_Of (Underlying_Type (T), Loc),
7838 Result := Unchecked_Convert_To (T, Val);
7840 -- Don't truncate result (important for Initialize/Normalize_Scalars)
7842 if Nkind (Result) = N_Unchecked_Type_Conversion
7843 and then Is_Scalar_Type (Underlying_Type (T))
7845 Set_No_Truncation (Result);
7850 -- Scalars with Default_Value aspect. The first subtype may now be
7851 -- private, so retrieve value from underlying type.
7853 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
7854 if Is_Private_Type (First_Subtype (T)) then
7855 return Unchecked_Convert_To (T,
7856 Default_Aspect_Value (Full_View (First_Subtype (T))));
7859 Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
7862 -- Otherwise, for scalars, we must have normalize/initialize scalars
7863 -- case, or if the node N is an 'Invalid_Value attribute node.
7865 elsif Is_Scalar_Type (T) then
7866 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
7868 -- Compute size of object. If it is given by the caller, we can use
7869 -- it directly, otherwise we use Esize (T) as an estimate. As far as
7870 -- we know this covers all cases correctly.
7872 if Size = No_Uint or else Size <= Uint_0 then
7873 Size_To_Use := UI_Max (Uint_1, Esize (T));
7875 Size_To_Use := Size;
7878 -- Maximum size to use is 64 bits, since we will create values of
7879 -- type Unsigned_64 and the range must fit this type.
7881 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
7882 Size_To_Use := Uint_64;
7885 -- Check known bounds of subtype
7887 Check_Subtype_Bounds;
7889 -- Processing for Normalize_Scalars case
7891 if Normalize_Scalars and then not IV_Attribute then
7893 -- If zero is invalid, it is a convenient value to use that is
7894 -- for sure an appropriate invalid value in all situations.
7896 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7897 Val := Make_Integer_Literal (Loc, 0);
7899 -- Cases where all one bits is the appropriate invalid value
7901 -- For modular types, all 1 bits is either invalid or valid. If
7902 -- it is valid, then there is nothing that can be done since there
7903 -- are no invalid values (we ruled out zero already).
7905 -- For signed integer types that have no negative values, either
7906 -- there is room for negative values, or there is not. If there
7907 -- is, then all 1-bits may be interpreted as minus one, which is
7908 -- certainly invalid. Alternatively it is treated as the largest
7909 -- positive value, in which case the observation for modular types
7912 -- For float types, all 1-bits is a NaN (not a number), which is
7913 -- certainly an appropriately invalid value.
7915 elsif Is_Unsigned_Type (T)
7916 or else Is_Floating_Point_Type (T)
7917 or else Is_Enumeration_Type (T)
7919 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
7921 -- Resolve as Unsigned_64, because the largest number we can
7922 -- generate is out of range of universal integer.
7924 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
7926 -- Case of signed types
7930 Signed_Size : constant Uint :=
7931 UI_Min (Uint_63, Size_To_Use - 1);
7934 -- Normally we like to use the most negative number. The one
7935 -- exception is when this number is in the known subtype
7936 -- range and the largest positive number is not in the known
7939 -- For this exceptional case, use largest positive value
7941 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
7942 and then Lo_Bound <= (-(2 ** Signed_Size))
7943 and then Hi_Bound < 2 ** Signed_Size
7945 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
7947 -- Normal case of largest negative value
7950 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
7955 -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
7958 -- For float types, use float values from System.Scalar_Values
7960 if Is_Floating_Point_Type (T) then
7961 if Root_Type (T) = Standard_Short_Float then
7962 Val_RE := RE_IS_Isf;
7963 elsif Root_Type (T) = Standard_Float then
7964 Val_RE := RE_IS_Ifl;
7965 elsif Root_Type (T) = Standard_Long_Float then
7966 Val_RE := RE_IS_Ilf;
7967 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
7968 Val_RE := RE_IS_Ill;
7971 -- If zero is invalid, use zero values from System.Scalar_Values
7973 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7974 if Size_To_Use <= 8 then
7975 Val_RE := RE_IS_Iz1;
7976 elsif Size_To_Use <= 16 then
7977 Val_RE := RE_IS_Iz2;
7978 elsif Size_To_Use <= 32 then
7979 Val_RE := RE_IS_Iz4;
7981 Val_RE := RE_IS_Iz8;
7984 -- For unsigned, use unsigned values from System.Scalar_Values
7986 elsif Is_Unsigned_Type (T) then
7987 if Size_To_Use <= 8 then
7988 Val_RE := RE_IS_Iu1;
7989 elsif Size_To_Use <= 16 then
7990 Val_RE := RE_IS_Iu2;
7991 elsif Size_To_Use <= 32 then
7992 Val_RE := RE_IS_Iu4;
7994 Val_RE := RE_IS_Iu8;
7997 -- For signed, use signed values from System.Scalar_Values
8000 if Size_To_Use <= 8 then
8001 Val_RE := RE_IS_Is1;
8002 elsif Size_To_Use <= 16 then
8003 Val_RE := RE_IS_Is2;
8004 elsif Size_To_Use <= 32 then
8005 Val_RE := RE_IS_Is4;
8007 Val_RE := RE_IS_Is8;
8011 Val := New_Occurrence_Of (RTE (Val_RE), Loc);
8014 -- The final expression is obtained by doing an unchecked conversion
8015 -- of this result to the base type of the required subtype. Use the
8016 -- base type to prevent the unchecked conversion from chopping bits,
8017 -- and then we set Kill_Range_Check to preserve the "bad" value.
8019 Result := Unchecked_Convert_To (Base_Type (T), Val);
8021 -- Ensure result is not truncated, since we want the "bad" bits, and
8022 -- also kill range check on result.
8024 if Nkind (Result) = N_Unchecked_Type_Conversion then
8025 Set_No_Truncation (Result);
8026 Set_Kill_Range_Check (Result, True);
8031 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
8033 elsif Is_Standard_String_Type (T) then
8034 pragma Assert (Init_Or_Norm_Scalars);
8037 Make_Aggregate (Loc,
8038 Component_Associations => New_List (
8039 Make_Component_Association (Loc,
8040 Choices => New_List (
8041 Make_Others_Choice (Loc)),
8044 (Component_Type (T), N, Esize (Root_Type (T))))));
8046 -- Access type is initialized to null
8048 elsif Is_Access_Type (T) then
8049 return Make_Null (Loc);
8051 -- No other possibilities should arise, since we should only be calling
8052 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
8053 -- indicating one of the above cases held.
8056 raise Program_Error;
8060 when RE_Not_Available =>
8062 end Get_Simple_Init_Val;
8064 ------------------------------
8065 -- Has_New_Non_Standard_Rep --
8066 ------------------------------
8068 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
8070 if not Is_Derived_Type (T) then
8071 return Has_Non_Standard_Rep (T)
8072 or else Has_Non_Standard_Rep (Root_Type (T));
8074 -- If Has_Non_Standard_Rep is not set on the derived type, the
8075 -- representation is fully inherited.
8077 elsif not Has_Non_Standard_Rep (T) then
8081 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
8083 -- May need a more precise check here: the First_Rep_Item may be a
8084 -- stream attribute, which does not affect the representation of the
8088 end Has_New_Non_Standard_Rep;
8090 ----------------------
8091 -- Inline_Init_Proc --
8092 ----------------------
8094 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
8096 -- The initialization proc of protected records is not worth inlining.
8097 -- In addition, when compiled for another unit for inlining purposes,
8098 -- it may make reference to entities that have not been elaborated yet.
8099 -- The initialization proc of records that need finalization contains
8100 -- a nested clean-up procedure that makes it impractical to inline as
8101 -- well, except for simple controlled types themselves. And similar
8102 -- considerations apply to task types.
8104 if Is_Concurrent_Type (Typ) then
8107 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
8110 elsif Has_Task (Typ) then
8116 end Inline_Init_Proc;
8122 function In_Runtime (E : Entity_Id) return Boolean is
8127 while Scope (S1) /= Standard_Standard loop
8131 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
8134 ----------------------------
8135 -- Initialization_Warning --
8136 ----------------------------
8138 procedure Initialization_Warning (E : Entity_Id) is
8139 Warning_Needed : Boolean;
8142 Warning_Needed := False;
8144 if Ekind (Current_Scope) = E_Package
8145 and then Static_Elaboration_Desired (Current_Scope)
8148 if Is_Record_Type (E) then
8149 if Has_Discriminants (E)
8150 or else Is_Limited_Type (E)
8151 or else Has_Non_Standard_Rep (E)
8153 Warning_Needed := True;
8156 -- Verify that at least one component has an initialization
8157 -- expression. No need for a warning on a type if all its
8158 -- components have no initialization.
8164 Comp := First_Component (E);
8165 while Present (Comp) loop
8166 if Ekind (Comp) = E_Discriminant
8168 (Nkind (Parent (Comp)) = N_Component_Declaration
8169 and then Present (Expression (Parent (Comp))))
8171 Warning_Needed := True;
8175 Next_Component (Comp);
8180 if Warning_Needed then
8182 ("Objects of the type cannot be initialized statically "
8183 & "by default??", Parent (E));
8188 Error_Msg_N ("Object cannot be initialized statically??", E);
8191 end Initialization_Warning;
8197 function Init_Formals (Typ : Entity_Id) return List_Id is
8198 Loc : constant Source_Ptr := Sloc (Typ);
8202 -- First parameter is always _Init : in out typ. Note that we need this
8203 -- to be in/out because in the case of the task record value, there
8204 -- are default record fields (_Priority, _Size, -Task_Info) that may
8205 -- be referenced in the generated initialization routine.
8207 Formals := New_List (
8208 Make_Parameter_Specification (Loc,
8209 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
8211 Out_Present => True,
8212 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
8214 -- For task record value, or type that contains tasks, add two more
8215 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
8216 -- We also add these parameters for the task record type case.
8219 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
8222 Make_Parameter_Specification (Loc,
8223 Defining_Identifier =>
8224 Make_Defining_Identifier (Loc, Name_uMaster),
8226 New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
8228 -- Add _Chain (not done for sequential elaboration policy, see
8229 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
8231 if Partition_Elaboration_Policy /= 'S' then
8233 Make_Parameter_Specification (Loc,
8234 Defining_Identifier =>
8235 Make_Defining_Identifier (Loc, Name_uChain),
8237 Out_Present => True,
8239 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
8243 Make_Parameter_Specification (Loc,
8244 Defining_Identifier =>
8245 Make_Defining_Identifier (Loc, Name_uTask_Name),
8247 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
8253 when RE_Not_Available =>
8257 -------------------------
8258 -- Init_Secondary_Tags --
8259 -------------------------
8261 procedure Init_Secondary_Tags
8264 Init_Tags_List : List_Id;
8265 Stmts_List : List_Id;
8266 Fixed_Comps : Boolean := True;
8267 Variable_Comps : Boolean := True)
8269 Loc : constant Source_Ptr := Sloc (Target);
8271 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
8272 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8274 procedure Initialize_Tag
8277 Tag_Comp : Entity_Id;
8278 Iface_Tag : Node_Id);
8279 -- Initialize the tag of the secondary dispatch table of Typ associated
8280 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8281 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
8282 -- of Typ CPP tagged type we generate code to inherit the contents of
8283 -- the dispatch table directly from the ancestor.
8285 --------------------
8286 -- Initialize_Tag --
8287 --------------------
8289 procedure Initialize_Tag
8292 Tag_Comp : Entity_Id;
8293 Iface_Tag : Node_Id)
8295 Comp_Typ : Entity_Id;
8296 Offset_To_Top_Comp : Entity_Id := Empty;
8299 -- Initialize pointer to secondary DT associated with the interface
8301 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8302 Append_To (Init_Tags_List,
8303 Make_Assignment_Statement (Loc,
8305 Make_Selected_Component (Loc,
8306 Prefix => New_Copy_Tree (Target),
8307 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8309 New_Occurrence_Of (Iface_Tag, Loc)));
8312 Comp_Typ := Scope (Tag_Comp);
8314 -- Initialize the entries of the table of interfaces. We generate a
8315 -- different call when the parent of the type has variable size
8318 if Comp_Typ /= Etype (Comp_Typ)
8319 and then Is_Variable_Size_Record (Etype (Comp_Typ))
8320 and then Chars (Tag_Comp) /= Name_uTag
8322 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
8324 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
8325 -- configurable run-time environment.
8327 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
8329 ("variable size record with interface types", Typ);
8334 -- Set_Dynamic_Offset_To_Top
8336 -- Prim_T => Typ'Tag,
8337 -- Interface_T => Iface'Tag,
8338 -- Offset_Value => n,
8339 -- Offset_Func => Fn'Address)
8341 Append_To (Stmts_List,
8342 Make_Procedure_Call_Statement (Loc,
8344 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
8345 Parameter_Associations => New_List (
8346 Make_Attribute_Reference (Loc,
8347 Prefix => New_Copy_Tree (Target),
8348 Attribute_Name => Name_Address),
8350 Unchecked_Convert_To (RTE (RE_Tag),
8352 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
8354 Unchecked_Convert_To (RTE (RE_Tag),
8356 (Node (First_Elmt (Access_Disp_Table (Iface))),
8359 Unchecked_Convert_To
8360 (RTE (RE_Storage_Offset),
8361 Make_Attribute_Reference (Loc,
8363 Make_Selected_Component (Loc,
8364 Prefix => New_Copy_Tree (Target),
8366 New_Occurrence_Of (Tag_Comp, Loc)),
8367 Attribute_Name => Name_Position)),
8369 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
8370 Make_Attribute_Reference (Loc,
8371 Prefix => New_Occurrence_Of
8372 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
8373 Attribute_Name => Name_Address)))));
8375 -- In this case the next component stores the value of the offset
8378 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
8379 pragma Assert (Present (Offset_To_Top_Comp));
8381 Append_To (Init_Tags_List,
8382 Make_Assignment_Statement (Loc,
8384 Make_Selected_Component (Loc,
8385 Prefix => New_Copy_Tree (Target),
8387 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
8390 Make_Attribute_Reference (Loc,
8392 Make_Selected_Component (Loc,
8393 Prefix => New_Copy_Tree (Target),
8394 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8395 Attribute_Name => Name_Position)));
8397 -- Normal case: No discriminants in the parent type
8400 -- Don't need to set any value if the offset-to-top field is
8401 -- statically set or if this interface shares the primary
8404 if not Building_Static_Secondary_DT (Typ)
8405 and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
8407 Append_To (Stmts_List,
8408 Build_Set_Static_Offset_To_Top (Loc,
8409 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
8411 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8412 Make_Attribute_Reference (Loc,
8414 Make_Selected_Component (Loc,
8415 Prefix => New_Copy_Tree (Target),
8417 New_Occurrence_Of (Tag_Comp, Loc)),
8418 Attribute_Name => Name_Position))));
8422 -- Register_Interface_Offset
8423 -- (Prim_T => Typ'Tag,
8424 -- Interface_T => Iface'Tag,
8425 -- Is_Constant => True,
8426 -- Offset_Value => n,
8427 -- Offset_Func => null);
8429 if RTE_Available (RE_Register_Interface_Offset) then
8430 Append_To (Stmts_List,
8431 Make_Procedure_Call_Statement (Loc,
8434 (RTE (RE_Register_Interface_Offset), Loc),
8435 Parameter_Associations => New_List (
8436 Unchecked_Convert_To (RTE (RE_Tag),
8438 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
8440 Unchecked_Convert_To (RTE (RE_Tag),
8442 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
8444 New_Occurrence_Of (Standard_True, Loc),
8446 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8447 Make_Attribute_Reference (Loc,
8449 Make_Selected_Component (Loc,
8450 Prefix => New_Copy_Tree (Target),
8452 New_Occurrence_Of (Tag_Comp, Loc)),
8453 Attribute_Name => Name_Position)),
8462 Full_Typ : Entity_Id;
8463 Ifaces_List : Elist_Id;
8464 Ifaces_Comp_List : Elist_Id;
8465 Ifaces_Tag_List : Elist_Id;
8466 Iface_Elmt : Elmt_Id;
8467 Iface_Comp_Elmt : Elmt_Id;
8468 Iface_Tag_Elmt : Elmt_Id;
8470 In_Variable_Pos : Boolean;
8472 -- Start of processing for Init_Secondary_Tags
8475 -- Handle private types
8477 if Present (Full_View (Typ)) then
8478 Full_Typ := Full_View (Typ);
8483 Collect_Interfaces_Info
8484 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
8486 Iface_Elmt := First_Elmt (Ifaces_List);
8487 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
8488 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
8489 while Present (Iface_Elmt) loop
8490 Tag_Comp := Node (Iface_Comp_Elmt);
8492 -- Check if parent of record type has variable size components
8494 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
8495 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
8497 -- If we are compiling under the CPP full ABI compatibility mode and
8498 -- the ancestor is a CPP_Pragma tagged type then we generate code to
8499 -- initialize the secondary tag components from tags that reference
8500 -- secondary tables filled with copy of parent slots.
8502 if Is_CPP_Class (Root_Type (Full_Typ)) then
8504 -- Reject interface components located at variable offset in
8505 -- C++ derivations. This is currently unsupported.
8507 if not Fixed_Comps and then In_Variable_Pos then
8509 -- Locate the first dynamic component of the record. Done to
8510 -- improve the text of the warning.
8514 Comp_Typ : Entity_Id;
8517 Comp := First_Entity (Typ);
8518 while Present (Comp) loop
8519 Comp_Typ := Etype (Comp);
8521 if Ekind (Comp) /= E_Discriminant
8522 and then not Is_Tag (Comp)
8525 (Is_Record_Type (Comp_Typ)
8527 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
8529 (Is_Array_Type (Comp_Typ)
8530 and then Is_Variable_Size_Array (Comp_Typ));
8536 pragma Assert (Present (Comp));
8537 Error_Msg_Node_2 := Comp;
8539 ("parent type & with dynamic component & cannot be parent"
8540 & " of 'C'P'P derivation if new interfaces are present",
8541 Typ, Scope (Original_Record_Component (Comp)));
8544 Sloc (Scope (Original_Record_Component (Comp)));
8546 ("type derived from 'C'P'P type & defined #",
8547 Typ, Scope (Original_Record_Component (Comp)));
8549 -- Avoid duplicated warnings
8554 -- Initialize secondary tags
8557 Append_To (Init_Tags_List,
8558 Make_Assignment_Statement (Loc,
8560 Make_Selected_Component (Loc,
8561 Prefix => New_Copy_Tree (Target),
8563 New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
8565 New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
8568 -- Otherwise generate code to initialize the tag
8571 if (In_Variable_Pos and then Variable_Comps)
8572 or else (not In_Variable_Pos and then Fixed_Comps)
8574 Initialize_Tag (Full_Typ,
8575 Iface => Node (Iface_Elmt),
8576 Tag_Comp => Tag_Comp,
8577 Iface_Tag => Node (Iface_Tag_Elmt));
8581 Next_Elmt (Iface_Elmt);
8582 Next_Elmt (Iface_Comp_Elmt);
8583 Next_Elmt (Iface_Tag_Elmt);
8585 end Init_Secondary_Tags;
8587 ------------------------
8588 -- Is_User_Defined_Eq --
8589 ------------------------
8591 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
8593 return Chars (Prim) = Name_Op_Eq
8594 and then Etype (First_Formal (Prim)) =
8595 Etype (Next_Formal (First_Formal (Prim)))
8596 and then Base_Type (Etype (Prim)) = Standard_Boolean;
8597 end Is_User_Defined_Equality;
8599 ----------------------------------------
8600 -- Make_Controlling_Function_Wrappers --
8601 ----------------------------------------
8603 procedure Make_Controlling_Function_Wrappers
8604 (Tag_Typ : Entity_Id;
8605 Decl_List : out List_Id;
8606 Body_List : out List_Id)
8608 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8609 Prim_Elmt : Elmt_Id;
8611 Actual_List : List_Id;
8612 Formal_List : List_Id;
8614 Par_Formal : Entity_Id;
8615 Formal_Node : Node_Id;
8616 Func_Body : Node_Id;
8617 Func_Decl : Node_Id;
8618 Func_Spec : Node_Id;
8619 Return_Stmt : Node_Id;
8622 Decl_List := New_List;
8623 Body_List := New_List;
8625 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8626 while Present (Prim_Elmt) loop
8627 Subp := Node (Prim_Elmt);
8629 -- If a primitive function with a controlling result of the type has
8630 -- not been overridden by the user, then we must create a wrapper
8631 -- function here that effectively overrides it and invokes the
8632 -- (non-abstract) parent function. This can only occur for a null
8633 -- extension. Note that functions with anonymous controlling access
8634 -- results don't qualify and must be overridden. We also exclude
8635 -- Input attributes, since each type will have its own version of
8636 -- Input constructed by the expander. The test for Comes_From_Source
8637 -- is needed to distinguish inherited operations from renamings
8638 -- (which also have Alias set). We exclude internal entities with
8639 -- Interface_Alias to avoid generating duplicated wrappers since
8640 -- the primitive which covers the interface is also available in
8641 -- the list of primitive operations.
8643 -- The function may be abstract, or require_Overriding may be set
8644 -- for it, because tests for null extensions may already have reset
8645 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
8646 -- set, functions that need wrappers are recognized by having an
8647 -- alias that returns the parent type.
8649 if Comes_From_Source (Subp)
8650 or else No (Alias (Subp))
8651 or else Present (Interface_Alias (Subp))
8652 or else Ekind (Subp) /= E_Function
8653 or else not Has_Controlling_Result (Subp)
8654 or else Is_Access_Type (Etype (Subp))
8655 or else Is_Abstract_Subprogram (Alias (Subp))
8656 or else Is_TSS (Subp, TSS_Stream_Input)
8660 elsif Is_Abstract_Subprogram (Subp)
8661 or else Requires_Overriding (Subp)
8663 (Is_Null_Extension (Etype (Subp))
8664 and then Etype (Alias (Subp)) /= Etype (Subp))
8666 Formal_List := No_List;
8667 Formal := First_Formal (Subp);
8669 if Present (Formal) then
8670 Formal_List := New_List;
8672 while Present (Formal) loop
8674 (Make_Parameter_Specification
8676 Defining_Identifier =>
8677 Make_Defining_Identifier (Sloc (Formal),
8678 Chars => Chars (Formal)),
8679 In_Present => In_Present (Parent (Formal)),
8680 Out_Present => Out_Present (Parent (Formal)),
8681 Null_Exclusion_Present =>
8682 Null_Exclusion_Present (Parent (Formal)),
8684 New_Occurrence_Of (Etype (Formal), Loc),
8686 New_Copy_Tree (Expression (Parent (Formal)))),
8689 Next_Formal (Formal);
8694 Make_Function_Specification (Loc,
8695 Defining_Unit_Name =>
8696 Make_Defining_Identifier (Loc,
8697 Chars => Chars (Subp)),
8698 Parameter_Specifications => Formal_List,
8699 Result_Definition =>
8700 New_Occurrence_Of (Etype (Subp), Loc));
8702 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
8703 Append_To (Decl_List, Func_Decl);
8705 -- Build a wrapper body that calls the parent function. The body
8706 -- contains a single return statement that returns an extension
8707 -- aggregate whose ancestor part is a call to the parent function,
8708 -- passing the formals as actuals (with any controlling arguments
8709 -- converted to the types of the corresponding formals of the
8710 -- parent function, which might be anonymous access types), and
8711 -- having a null extension.
8713 Formal := First_Formal (Subp);
8714 Par_Formal := First_Formal (Alias (Subp));
8715 Formal_Node := First (Formal_List);
8717 if Present (Formal) then
8718 Actual_List := New_List;
8720 Actual_List := No_List;
8723 while Present (Formal) loop
8724 if Is_Controlling_Formal (Formal) then
8725 Append_To (Actual_List,
8726 Make_Type_Conversion (Loc,
8728 New_Occurrence_Of (Etype (Par_Formal), Loc),
8731 (Defining_Identifier (Formal_Node), Loc)));
8736 (Defining_Identifier (Formal_Node), Loc));
8739 Next_Formal (Formal);
8740 Next_Formal (Par_Formal);
8745 Make_Simple_Return_Statement (Loc,
8747 Make_Extension_Aggregate (Loc,
8749 Make_Function_Call (Loc,
8751 New_Occurrence_Of (Alias (Subp), Loc),
8752 Parameter_Associations => Actual_List),
8753 Null_Record_Present => True));
8756 Make_Subprogram_Body (Loc,
8757 Specification => New_Copy_Tree (Func_Spec),
8758 Declarations => Empty_List,
8759 Handled_Statement_Sequence =>
8760 Make_Handled_Sequence_Of_Statements (Loc,
8761 Statements => New_List (Return_Stmt)));
8763 Set_Defining_Unit_Name
8764 (Specification (Func_Body),
8765 Make_Defining_Identifier (Loc, Chars (Subp)));
8767 Append_To (Body_List, Func_Body);
8769 -- Replace the inherited function with the wrapper function in the
8770 -- primitive operations list. We add the minimum decoration needed
8771 -- to override interface primitives.
8773 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
8775 Override_Dispatching_Operation
8776 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
8777 Is_Wrapper => True);
8781 Next_Elmt (Prim_Elmt);
8783 end Make_Controlling_Function_Wrappers;
8789 function Make_Eq_Body
8791 Eq_Name : Name_Id) return Node_Id
8793 Loc : constant Source_Ptr := Sloc (Parent (Typ));
8795 Def : constant Node_Id := Parent (Typ);
8796 Stmts : constant List_Id := New_List;
8797 Variant_Case : Boolean := Has_Discriminants (Typ);
8798 Comps : Node_Id := Empty;
8799 Typ_Def : Node_Id := Type_Definition (Def);
8803 Predef_Spec_Or_Body (Loc,
8806 Profile => New_List (
8807 Make_Parameter_Specification (Loc,
8808 Defining_Identifier =>
8809 Make_Defining_Identifier (Loc, Name_X),
8810 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8812 Make_Parameter_Specification (Loc,
8813 Defining_Identifier =>
8814 Make_Defining_Identifier (Loc, Name_Y),
8815 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8817 Ret_Type => Standard_Boolean,
8820 if Variant_Case then
8821 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8822 Typ_Def := Record_Extension_Part (Typ_Def);
8825 if Present (Typ_Def) then
8826 Comps := Component_List (Typ_Def);
8830 Present (Comps) and then Present (Variant_Part (Comps));
8833 if Variant_Case then
8835 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
8836 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
8838 Make_Simple_Return_Statement (Loc,
8839 Expression => New_Occurrence_Of (Standard_True, Loc)));
8843 Make_Simple_Return_Statement (Loc,
8845 Expand_Record_Equality
8848 Lhs => Make_Identifier (Loc, Name_X),
8849 Rhs => Make_Identifier (Loc, Name_Y),
8850 Bodies => Declarations (Decl))));
8853 Set_Handled_Statement_Sequence
8854 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8862 -- <Make_Eq_If shared components>
8865 -- when V1 => <Make_Eq_Case> on subcomponents
8867 -- when Vn => <Make_Eq_Case> on subcomponents
8870 function Make_Eq_Case
8873 Discrs : Elist_Id := New_Elmt_List) return List_Id
8875 Loc : constant Source_Ptr := Sloc (E);
8876 Result : constant List_Id := New_List;
8880 function Corresponding_Formal (C : Node_Id) return Entity_Id;
8881 -- Given the discriminant that controls a given variant of an unchecked
8882 -- union, find the formal of the equality function that carries the
8883 -- inferred value of the discriminant.
8885 function External_Name (E : Entity_Id) return Name_Id;
8886 -- The value of a given discriminant is conveyed in the corresponding
8887 -- formal parameter of the equality routine. The name of this formal
8888 -- parameter carries a one-character suffix which is removed here.
8890 --------------------------
8891 -- Corresponding_Formal --
8892 --------------------------
8894 function Corresponding_Formal (C : Node_Id) return Entity_Id is
8895 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
8899 Elm := First_Elmt (Discrs);
8900 while Present (Elm) loop
8901 if Chars (Discr) = External_Name (Node (Elm)) then
8908 -- A formal of the proper name must be found
8910 raise Program_Error;
8911 end Corresponding_Formal;
8917 function External_Name (E : Entity_Id) return Name_Id is
8919 Get_Name_String (Chars (E));
8920 Name_Len := Name_Len - 1;
8924 -- Start of processing for Make_Eq_Case
8927 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
8929 if No (Variant_Part (CL)) then
8933 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
8935 if No (Variant) then
8939 Alt_List := New_List;
8940 while Present (Variant) loop
8941 Append_To (Alt_List,
8942 Make_Case_Statement_Alternative (Loc,
8943 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
8945 Make_Eq_Case (E, Component_List (Variant), Discrs)));
8946 Next_Non_Pragma (Variant);
8949 -- If we have an Unchecked_Union, use one of the parameters of the
8950 -- enclosing equality routine that captures the discriminant, to use
8951 -- as the expression in the generated case statement.
8953 if Is_Unchecked_Union (E) then
8955 Make_Case_Statement (Loc,
8957 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
8958 Alternatives => Alt_List));
8962 Make_Case_Statement (Loc,
8964 Make_Selected_Component (Loc,
8965 Prefix => Make_Identifier (Loc, Name_X),
8966 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
8967 Alternatives => Alt_List));
8988 -- or a null statement if the list L is empty
8992 L : List_Id) return Node_Id
8994 Loc : constant Source_Ptr := Sloc (E);
8996 Field_Name : Name_Id;
9001 return Make_Null_Statement (Loc);
9006 C := First_Non_Pragma (L);
9007 while Present (C) loop
9008 Field_Name := Chars (Defining_Identifier (C));
9010 -- The tags must not be compared: they are not part of the value.
9011 -- Ditto for parent interfaces because their equality operator is
9014 -- Note also that in the following, we use Make_Identifier for
9015 -- the component names. Use of New_Occurrence_Of to identify the
9016 -- components would be incorrect because the wrong entities for
9017 -- discriminants could be picked up in the private type case.
9019 if Field_Name = Name_uParent
9020 and then Is_Interface (Etype (Defining_Identifier (C)))
9024 elsif Field_Name /= Name_uTag then
9025 Evolve_Or_Else (Cond,
9028 Make_Selected_Component (Loc,
9029 Prefix => Make_Identifier (Loc, Name_X),
9030 Selector_Name => Make_Identifier (Loc, Field_Name)),
9033 Make_Selected_Component (Loc,
9034 Prefix => Make_Identifier (Loc, Name_Y),
9035 Selector_Name => Make_Identifier (Loc, Field_Name))));
9038 Next_Non_Pragma (C);
9042 return Make_Null_Statement (Loc);
9046 Make_Implicit_If_Statement (E,
9048 Then_Statements => New_List (
9049 Make_Simple_Return_Statement (Loc,
9050 Expression => New_Occurrence_Of (Standard_False, Loc))));
9059 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
9061 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
9062 -- Returns true if Prim is a renaming of an unresolved predefined
9063 -- inequality operation.
9065 --------------------------------
9066 -- Is_Predefined_Neq_Renaming --
9067 --------------------------------
9069 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
9071 return Chars (Prim) /= Name_Op_Ne
9072 and then Present (Alias (Prim))
9073 and then Comes_From_Source (Prim)
9074 and then Is_Intrinsic_Subprogram (Alias (Prim))
9075 and then Chars (Alias (Prim)) = Name_Op_Ne;
9076 end Is_Predefined_Neq_Renaming;
9080 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
9081 Stmts : constant List_Id := New_List;
9083 Eq_Prim : Entity_Id;
9084 Left_Op : Entity_Id;
9085 Renaming_Prim : Entity_Id;
9086 Right_Op : Entity_Id;
9089 -- Start of processing for Make_Neq_Body
9092 -- For a call on a renaming of a dispatching subprogram that is
9093 -- overridden, if the overriding occurred before the renaming, then
9094 -- the body executed is that of the overriding declaration, even if the
9095 -- overriding declaration is not visible at the place of the renaming;
9096 -- otherwise, the inherited or predefined subprogram is called, see
9099 -- Stage 1: Search for a renaming of the inequality primitive and also
9100 -- search for an overriding of the equality primitive located before the
9101 -- renaming declaration.
9109 Renaming_Prim := Empty;
9111 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9112 while Present (Elmt) loop
9113 Prim := Node (Elmt);
9115 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
9116 if No (Renaming_Prim) then
9117 pragma Assert (No (Eq_Prim));
9121 elsif Is_Predefined_Neq_Renaming (Prim) then
9122 Renaming_Prim := Prim;
9129 -- No further action needed if no renaming was found
9131 if No (Renaming_Prim) then
9135 -- Stage 2: Replace the renaming declaration by a subprogram declaration
9136 -- (required to add its body)
9138 Decl := Parent (Parent (Renaming_Prim));
9140 Make_Subprogram_Declaration (Loc,
9141 Specification => Specification (Decl)));
9142 Set_Analyzed (Decl);
9144 -- Remove the decoration of intrinsic renaming subprogram
9146 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
9147 Set_Convention (Renaming_Prim, Convention_Ada);
9148 Set_Alias (Renaming_Prim, Empty);
9149 Set_Has_Completion (Renaming_Prim, False);
9151 -- Stage 3: Build the corresponding body
9153 Left_Op := First_Formal (Renaming_Prim);
9154 Right_Op := Next_Formal (Left_Op);
9157 Predef_Spec_Or_Body (Loc,
9159 Name => Chars (Renaming_Prim),
9160 Profile => New_List (
9161 Make_Parameter_Specification (Loc,
9162 Defining_Identifier =>
9163 Make_Defining_Identifier (Loc, Chars (Left_Op)),
9164 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9166 Make_Parameter_Specification (Loc,
9167 Defining_Identifier =>
9168 Make_Defining_Identifier (Loc, Chars (Right_Op)),
9169 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9171 Ret_Type => Standard_Boolean,
9174 -- If the overriding of the equality primitive occurred before the
9175 -- renaming, then generate:
9177 -- function <Neq_Name> (X : Y : Typ) return Boolean is
9179 -- return not Oeq (X, Y);
9182 if Present (Eq_Prim) then
9185 -- Otherwise build a nested subprogram which performs the predefined
9186 -- evaluation of the equality operator. That is, generate:
9188 -- function <Neq_Name> (X : Y : Typ) return Boolean is
9189 -- function Oeq (X : Y) return Boolean is
9191 -- <<body of default implementation>>
9194 -- return not Oeq (X, Y);
9199 Local_Subp : Node_Id;
9201 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
9202 Set_Declarations (Decl, New_List (Local_Subp));
9203 Target := Defining_Entity (Local_Subp);
9208 Make_Simple_Return_Statement (Loc,
9211 Make_Function_Call (Loc,
9212 Name => New_Occurrence_Of (Target, Loc),
9213 Parameter_Associations => New_List (
9214 Make_Identifier (Loc, Chars (Left_Op)),
9215 Make_Identifier (Loc, Chars (Right_Op)))))));
9217 Set_Handled_Statement_Sequence
9218 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
9222 -------------------------------
9223 -- Make_Null_Procedure_Specs --
9224 -------------------------------
9226 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
9227 Decl_List : constant List_Id := New_List;
9228 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9230 Formal_List : List_Id;
9231 New_Param_Spec : Node_Id;
9232 Parent_Subp : Entity_Id;
9233 Prim_Elmt : Elmt_Id;
9237 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9238 while Present (Prim_Elmt) loop
9239 Subp := Node (Prim_Elmt);
9241 -- If a null procedure inherited from an interface has not been
9242 -- overridden, then we build a null procedure declaration to
9243 -- override the inherited procedure.
9245 Parent_Subp := Alias (Subp);
9247 if Present (Parent_Subp)
9248 and then Is_Null_Interface_Primitive (Parent_Subp)
9250 Formal_List := No_List;
9251 Formal := First_Formal (Subp);
9253 if Present (Formal) then
9254 Formal_List := New_List;
9256 while Present (Formal) loop
9258 -- Copy the parameter spec including default expressions
9261 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
9263 -- Generate a new defining identifier for the new formal.
9264 -- required because New_Copy_Tree does not duplicate
9265 -- semantic fields (except itypes).
9267 Set_Defining_Identifier (New_Param_Spec,
9268 Make_Defining_Identifier (Sloc (Formal),
9269 Chars => Chars (Formal)));
9271 -- For controlling arguments we must change their
9272 -- parameter type to reference the tagged type (instead
9273 -- of the interface type)
9275 if Is_Controlling_Formal (Formal) then
9276 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
9278 Set_Parameter_Type (New_Param_Spec,
9279 New_Occurrence_Of (Tag_Typ, Loc));
9282 (Nkind (Parameter_Type (Parent (Formal))) =
9283 N_Access_Definition);
9284 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
9285 New_Occurrence_Of (Tag_Typ, Loc));
9289 Append (New_Param_Spec, Formal_List);
9291 Next_Formal (Formal);
9295 Append_To (Decl_List,
9296 Make_Subprogram_Declaration (Loc,
9297 Make_Procedure_Specification (Loc,
9298 Defining_Unit_Name =>
9299 Make_Defining_Identifier (Loc, Chars (Subp)),
9300 Parameter_Specifications => Formal_List,
9301 Null_Present => True)));
9304 Next_Elmt (Prim_Elmt);
9308 end Make_Null_Procedure_Specs;
9310 -------------------------------------
9311 -- Make_Predefined_Primitive_Specs --
9312 -------------------------------------
9314 procedure Make_Predefined_Primitive_Specs
9315 (Tag_Typ : Entity_Id;
9316 Predef_List : out List_Id;
9317 Renamed_Eq : out Entity_Id)
9319 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
9320 -- Returns true if Prim is a renaming of an unresolved predefined
9321 -- equality operation.
9323 -------------------------------
9324 -- Is_Predefined_Eq_Renaming --
9325 -------------------------------
9327 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
9329 return Chars (Prim) /= Name_Op_Eq
9330 and then Present (Alias (Prim))
9331 and then Comes_From_Source (Prim)
9332 and then Is_Intrinsic_Subprogram (Alias (Prim))
9333 and then Chars (Alias (Prim)) = Name_Op_Eq;
9334 end Is_Predefined_Eq_Renaming;
9338 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9339 Res : constant List_Id := New_List;
9340 Eq_Name : Name_Id := Name_Op_Eq;
9341 Eq_Needed : Boolean;
9345 Has_Predef_Eq_Renaming : Boolean := False;
9346 -- Set to True if Tag_Typ has a primitive that renames the predefined
9347 -- equality operator. Used to implement (RM 8-5-4(8)).
9349 -- Start of processing for Make_Predefined_Primitive_Specs
9352 Renamed_Eq := Empty;
9356 Append_To (Res, Predef_Spec_Or_Body (Loc,
9359 Profile => New_List (
9360 Make_Parameter_Specification (Loc,
9361 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9362 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9364 Ret_Type => Standard_Long_Long_Integer));
9366 -- Specs for dispatching stream attributes
9369 Stream_Op_TSS_Names :
9370 constant array (Positive range <>) of TSS_Name_Type :=
9377 for Op in Stream_Op_TSS_Names'Range loop
9378 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
9380 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
9381 Stream_Op_TSS_Names (Op)));
9386 -- Spec of "=" is expanded if the type is not limited and if a user
9387 -- defined "=" was not already declared for the non-full view of a
9388 -- private extension
9390 if not Is_Limited_Type (Tag_Typ) then
9392 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9393 while Present (Prim) loop
9395 -- If a primitive is encountered that renames the predefined
9396 -- equality operator before reaching any explicit equality
9397 -- primitive, then we still need to create a predefined equality
9398 -- function, because calls to it can occur via the renaming. A
9399 -- new name is created for the equality to avoid conflicting with
9400 -- any user-defined equality. (Note that this doesn't account for
9401 -- renamings of equality nested within subpackages???)
9403 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9404 Has_Predef_Eq_Renaming := True;
9405 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
9407 -- User-defined equality
9409 elsif Is_User_Defined_Equality (Node (Prim)) then
9410 if No (Alias (Node (Prim)))
9411 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
9412 N_Subprogram_Renaming_Declaration
9417 -- If the parent is not an interface type and has an abstract
9418 -- equality function explicitly defined in the sources, then
9419 -- the inherited equality is abstract as well, and no body can
9420 -- be created for it.
9422 elsif not Is_Interface (Etype (Tag_Typ))
9423 and then Present (Alias (Node (Prim)))
9424 and then Comes_From_Source (Alias (Node (Prim)))
9425 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
9430 -- If the type has an equality function corresponding with
9431 -- a primitive defined in an interface type, the inherited
9432 -- equality is abstract as well, and no body can be created
9435 elsif Present (Alias (Node (Prim)))
9436 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
9439 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
9449 -- If a renaming of predefined equality was found but there was no
9450 -- user-defined equality (so Eq_Needed is still true), then set the
9451 -- name back to Name_Op_Eq. But in the case where a user-defined
9452 -- equality was located after such a renaming, then the predefined
9453 -- equality function is still needed, so Eq_Needed must be set back
9456 if Eq_Name /= Name_Op_Eq then
9458 Eq_Name := Name_Op_Eq;
9465 Eq_Spec := Predef_Spec_Or_Body (Loc,
9468 Profile => New_List (
9469 Make_Parameter_Specification (Loc,
9470 Defining_Identifier =>
9471 Make_Defining_Identifier (Loc, Name_X),
9472 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9474 Make_Parameter_Specification (Loc,
9475 Defining_Identifier =>
9476 Make_Defining_Identifier (Loc, Name_Y),
9477 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9478 Ret_Type => Standard_Boolean);
9479 Append_To (Res, Eq_Spec);
9481 if Has_Predef_Eq_Renaming then
9482 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
9484 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9485 while Present (Prim) loop
9487 -- Any renamings of equality that appeared before an
9488 -- overriding equality must be updated to refer to the
9489 -- entity for the predefined equality, otherwise calls via
9490 -- the renaming would get incorrectly resolved to call the
9491 -- user-defined equality function.
9493 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9494 Set_Alias (Node (Prim), Renamed_Eq);
9496 -- Exit upon encountering a user-defined equality
9498 elsif Chars (Node (Prim)) = Name_Op_Eq
9499 and then No (Alias (Node (Prim)))
9509 -- Spec for dispatching assignment
9511 Append_To (Res, Predef_Spec_Or_Body (Loc,
9513 Name => Name_uAssign,
9514 Profile => New_List (
9515 Make_Parameter_Specification (Loc,
9516 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9517 Out_Present => True,
9518 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9520 Make_Parameter_Specification (Loc,
9521 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9522 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
9525 -- Ada 2005: Generate declarations for the following primitive
9526 -- operations for limited interfaces and synchronized types that
9527 -- implement a limited interface.
9529 -- Disp_Asynchronous_Select
9530 -- Disp_Conditional_Select
9531 -- Disp_Get_Prim_Op_Kind
9534 -- Disp_Timed_Select
9536 -- Disable the generation of these bodies if No_Dispatching_Calls,
9537 -- Ravenscar or ZFP is active.
9539 if Ada_Version >= Ada_2005
9540 and then not Restriction_Active (No_Dispatching_Calls)
9541 and then not Restriction_Active (No_Select_Statements)
9542 and then RTE_Available (RE_Select_Specific_Data)
9544 -- These primitives are defined abstract in interface types
9546 if Is_Interface (Tag_Typ)
9547 and then Is_Limited_Record (Tag_Typ)
9550 Make_Abstract_Subprogram_Declaration (Loc,
9552 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9555 Make_Abstract_Subprogram_Declaration (Loc,
9557 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9560 Make_Abstract_Subprogram_Declaration (Loc,
9562 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9565 Make_Abstract_Subprogram_Declaration (Loc,
9567 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9570 Make_Abstract_Subprogram_Declaration (Loc,
9572 Make_Disp_Requeue_Spec (Tag_Typ)));
9575 Make_Abstract_Subprogram_Declaration (Loc,
9577 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9579 -- If ancestor is an interface type, declare non-abstract primitives
9580 -- to override the abstract primitives of the interface type.
9582 -- In VM targets we define these primitives in all root tagged types
9583 -- that are not interface types. Done because in VM targets we don't
9584 -- have secondary dispatch tables and any derivation of Tag_Typ may
9585 -- cover limited interfaces (which always have these primitives since
9586 -- they may be ancestors of synchronized interface types).
9588 elsif (not Is_Interface (Tag_Typ)
9589 and then Is_Interface (Etype (Tag_Typ))
9590 and then Is_Limited_Record (Etype (Tag_Typ)))
9592 (Is_Concurrent_Record_Type (Tag_Typ)
9593 and then Has_Interfaces (Tag_Typ))
9595 (not Tagged_Type_Expansion
9596 and then not Is_Interface (Tag_Typ)
9597 and then Tag_Typ = Root_Type (Tag_Typ))
9600 Make_Subprogram_Declaration (Loc,
9602 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9605 Make_Subprogram_Declaration (Loc,
9607 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9610 Make_Subprogram_Declaration (Loc,
9612 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9615 Make_Subprogram_Declaration (Loc,
9617 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9620 Make_Subprogram_Declaration (Loc,
9622 Make_Disp_Requeue_Spec (Tag_Typ)));
9625 Make_Subprogram_Declaration (Loc,
9627 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9631 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
9632 -- regardless of whether they are controlled or may contain controlled
9635 -- Do not generate the routines if finalization is disabled
9637 if Restriction_Active (No_Finalization) then
9641 if not Is_Limited_Type (Tag_Typ) then
9642 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
9645 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
9649 end Make_Predefined_Primitive_Specs;
9651 -------------------------
9652 -- Make_Tag_Assignment --
9653 -------------------------
9655 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
9656 Loc : constant Source_Ptr := Sloc (N);
9657 Def_If : constant Entity_Id := Defining_Identifier (N);
9658 Expr : constant Node_Id := Expression (N);
9659 Typ : constant Entity_Id := Etype (Def_If);
9660 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
9664 -- This expansion activity is called during analysis, but cannot
9665 -- be applied in ASIS mode when other expansion is disabled.
9667 if Is_Tagged_Type (Typ)
9668 and then not Is_Class_Wide_Type (Typ)
9669 and then not Is_CPP_Class (Typ)
9670 and then Tagged_Type_Expansion
9671 and then Nkind (Expr) /= N_Aggregate
9672 and then not ASIS_Mode
9673 and then (Nkind (Expr) /= N_Qualified_Expression
9674 or else Nkind (Expression (Expr)) /= N_Aggregate)
9677 Make_Selected_Component (Loc,
9678 Prefix => New_Occurrence_Of (Def_If, Loc),
9680 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
9681 Set_Assignment_OK (New_Ref);
9684 Make_Assignment_Statement (Loc,
9687 Unchecked_Convert_To (RTE (RE_Tag),
9688 New_Occurrence_Of (Node
9689 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
9693 end Make_Tag_Assignment;
9695 ---------------------------------
9696 -- Needs_Simple_Initialization --
9697 ---------------------------------
9699 function Needs_Simple_Initialization
9701 Consider_IS : Boolean := True) return Boolean
9703 Consider_IS_NS : constant Boolean :=
9704 Normalize_Scalars or (Initialize_Scalars and Consider_IS);
9707 -- Never need initialization if it is suppressed
9709 if Initialization_Suppressed (T) then
9713 -- Check for private type, in which case test applies to the underlying
9714 -- type of the private type.
9716 if Is_Private_Type (T) then
9718 RT : constant Entity_Id := Underlying_Type (T);
9720 if Present (RT) then
9721 return Needs_Simple_Initialization (RT);
9727 -- Scalar type with Default_Value aspect requires initialization
9729 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
9732 -- Cases needing simple initialization are access types, and, if pragma
9733 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
9736 elsif Is_Access_Type (T)
9737 or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
9741 -- If Initialize/Normalize_Scalars is in effect, string objects also
9742 -- need initialization, unless they are created in the course of
9743 -- expanding an aggregate (since in the latter case they will be
9744 -- filled with appropriate initializing values before they are used).
9746 elsif Consider_IS_NS
9747 and then Is_Standard_String_Type (T)
9750 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
9757 end Needs_Simple_Initialization;
9759 ----------------------
9760 -- Predef_Deep_Spec --
9761 ----------------------
9763 function Predef_Deep_Spec
9765 Tag_Typ : Entity_Id;
9766 Name : TSS_Name_Type;
9767 For_Body : Boolean := False) return Node_Id
9772 -- V : in out Tag_Typ
9774 Formals := New_List (
9775 Make_Parameter_Specification (Loc,
9776 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9778 Out_Present => True,
9779 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
9781 -- F : Boolean := True
9783 if Name = TSS_Deep_Adjust
9784 or else Name = TSS_Deep_Finalize
9787 Make_Parameter_Specification (Loc,
9788 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9789 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9790 Expression => New_Occurrence_Of (Standard_True, Loc)));
9794 Predef_Spec_Or_Body (Loc,
9795 Name => Make_TSS_Name (Tag_Typ, Name),
9798 For_Body => For_Body);
9801 when RE_Not_Available =>
9803 end Predef_Deep_Spec;
9805 -------------------------
9806 -- Predef_Spec_Or_Body --
9807 -------------------------
9809 function Predef_Spec_Or_Body
9811 Tag_Typ : Entity_Id;
9814 Ret_Type : Entity_Id := Empty;
9815 For_Body : Boolean := False) return Node_Id
9817 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
9821 Set_Is_Public (Id, Is_Public (Tag_Typ));
9823 -- The internal flag is set to mark these declarations because they have
9824 -- specific properties. First, they are primitives even if they are not
9825 -- defined in the type scope (the freezing point is not necessarily in
9826 -- the same scope). Second, the predefined equality can be overridden by
9827 -- a user-defined equality, no body will be generated in this case.
9829 Set_Is_Internal (Id);
9831 if not Debug_Generated_Code then
9832 Set_Debug_Info_Off (Id);
9835 if No (Ret_Type) then
9837 Make_Procedure_Specification (Loc,
9838 Defining_Unit_Name => Id,
9839 Parameter_Specifications => Profile);
9842 Make_Function_Specification (Loc,
9843 Defining_Unit_Name => Id,
9844 Parameter_Specifications => Profile,
9845 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
9848 if Is_Interface (Tag_Typ) then
9849 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9851 -- If body case, return empty subprogram body. Note that this is ill-
9852 -- formed, because there is not even a null statement, and certainly not
9853 -- a return in the function case. The caller is expected to do surgery
9854 -- on the body to add the appropriate stuff.
9857 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
9859 -- For the case of an Input attribute predefined for an abstract type,
9860 -- generate an abstract specification. This will never be called, but we
9861 -- need the slot allocated in the dispatching table so that attributes
9862 -- typ'Class'Input and typ'Class'Output will work properly.
9864 elsif Is_TSS (Name, TSS_Stream_Input)
9865 and then Is_Abstract_Type (Tag_Typ)
9867 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9869 -- Normal spec case, where we return a subprogram declaration
9872 return Make_Subprogram_Declaration (Loc, Spec);
9874 end Predef_Spec_Or_Body;
9876 -----------------------------
9877 -- Predef_Stream_Attr_Spec --
9878 -----------------------------
9880 function Predef_Stream_Attr_Spec
9882 Tag_Typ : Entity_Id;
9883 Name : TSS_Name_Type;
9884 For_Body : Boolean := False) return Node_Id
9886 Ret_Type : Entity_Id;
9889 if Name = TSS_Stream_Input then
9890 Ret_Type := Tag_Typ;
9898 Name => Make_TSS_Name (Tag_Typ, Name),
9900 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
9901 Ret_Type => Ret_Type,
9902 For_Body => For_Body);
9903 end Predef_Stream_Attr_Spec;
9905 ---------------------------------
9906 -- Predefined_Primitive_Bodies --
9907 ---------------------------------
9909 function Predefined_Primitive_Bodies
9910 (Tag_Typ : Entity_Id;
9911 Renamed_Eq : Entity_Id) return List_Id
9913 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9914 Res : constant List_Id := New_List;
9919 Eq_Needed : Boolean;
9923 pragma Warnings (Off, Ent);
9926 pragma Assert (not Is_Interface (Tag_Typ));
9928 -- See if we have a predefined "=" operator
9930 if Present (Renamed_Eq) then
9932 Eq_Name := Chars (Renamed_Eq);
9934 -- If the parent is an interface type then it has defined all the
9935 -- predefined primitives abstract and we need to check if the type
9936 -- has some user defined "=" function which matches the profile of
9937 -- the Ada predefined equality operator to avoid generating it.
9939 elsif Is_Interface (Etype (Tag_Typ)) then
9941 Eq_Name := Name_Op_Eq;
9943 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9944 while Present (Prim) loop
9945 if Chars (Node (Prim)) = Name_Op_Eq
9946 and then not Is_Internal (Node (Prim))
9947 and then Present (First_Entity (Node (Prim)))
9949 -- The predefined equality primitive must have exactly two
9950 -- formals whose type is this tagged type
9952 and then Present (Last_Entity (Node (Prim)))
9953 and then Next_Entity (First_Entity (Node (Prim)))
9954 = Last_Entity (Node (Prim))
9955 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
9956 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
9970 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9971 while Present (Prim) loop
9972 if Chars (Node (Prim)) = Name_Op_Eq
9973 and then Is_Internal (Node (Prim))
9976 Eq_Name := Name_Op_Eq;
9986 Decl := Predef_Spec_Or_Body (Loc,
9989 Profile => New_List (
9990 Make_Parameter_Specification (Loc,
9991 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9992 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9994 Ret_Type => Standard_Long_Long_Integer,
9997 Set_Handled_Statement_Sequence (Decl,
9998 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9999 Make_Simple_Return_Statement (Loc,
10001 Make_Attribute_Reference (Loc,
10002 Prefix => Make_Identifier (Loc, Name_X),
10003 Attribute_Name => Name_Size)))));
10005 Append_To (Res, Decl);
10007 -- Bodies for Dispatching stream IO routines. We need these only for
10008 -- non-limited types (in the limited case there is no dispatching).
10009 -- We also skip them if dispatching or finalization are not available
10010 -- or if stream operations are prohibited by restriction No_Streams or
10011 -- from use of pragma/aspect No_Tagged_Streams.
10013 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
10014 and then No (TSS (Tag_Typ, TSS_Stream_Read))
10016 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
10017 Append_To (Res, Decl);
10020 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
10021 and then No (TSS (Tag_Typ, TSS_Stream_Write))
10023 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
10024 Append_To (Res, Decl);
10027 -- Skip body of _Input for the abstract case, since the corresponding
10028 -- spec is abstract (see Predef_Spec_Or_Body).
10030 if not Is_Abstract_Type (Tag_Typ)
10031 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
10032 and then No (TSS (Tag_Typ, TSS_Stream_Input))
10034 Build_Record_Or_Elementary_Input_Function
10035 (Loc, Tag_Typ, Decl, Ent);
10036 Append_To (Res, Decl);
10039 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
10040 and then No (TSS (Tag_Typ, TSS_Stream_Output))
10042 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
10043 Append_To (Res, Decl);
10046 -- Ada 2005: Generate bodies for the following primitive operations for
10047 -- limited interfaces and synchronized types that implement a limited
10050 -- disp_asynchronous_select
10051 -- disp_conditional_select
10052 -- disp_get_prim_op_kind
10053 -- disp_get_task_id
10054 -- disp_timed_select
10056 -- The interface versions will have null bodies
10058 -- Disable the generation of these bodies if No_Dispatching_Calls,
10059 -- Ravenscar or ZFP is active.
10061 -- In VM targets we define these primitives in all root tagged types
10062 -- that are not interface types. Done because in VM targets we don't
10063 -- have secondary dispatch tables and any derivation of Tag_Typ may
10064 -- cover limited interfaces (which always have these primitives since
10065 -- they may be ancestors of synchronized interface types).
10067 if Ada_Version >= Ada_2005
10068 and then not Is_Interface (Tag_Typ)
10070 ((Is_Interface (Etype (Tag_Typ))
10071 and then Is_Limited_Record (Etype (Tag_Typ)))
10073 (Is_Concurrent_Record_Type (Tag_Typ)
10074 and then Has_Interfaces (Tag_Typ))
10076 (not Tagged_Type_Expansion
10077 and then Tag_Typ = Root_Type (Tag_Typ)))
10078 and then not Restriction_Active (No_Dispatching_Calls)
10079 and then not Restriction_Active (No_Select_Statements)
10080 and then RTE_Available (RE_Select_Specific_Data)
10082 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
10083 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
10084 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
10085 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
10086 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
10087 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
10090 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
10092 -- Body for equality
10095 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
10096 Append_To (Res, Decl);
10099 -- Body for inequality (if required)
10101 Decl := Make_Neq_Body (Tag_Typ);
10103 if Present (Decl) then
10104 Append_To (Res, Decl);
10107 -- Body for dispatching assignment
10110 Predef_Spec_Or_Body (Loc,
10111 Tag_Typ => Tag_Typ,
10112 Name => Name_uAssign,
10113 Profile => New_List (
10114 Make_Parameter_Specification (Loc,
10115 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10116 Out_Present => True,
10117 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10119 Make_Parameter_Specification (Loc,
10120 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
10121 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10124 Set_Handled_Statement_Sequence (Decl,
10125 Make_Handled_Sequence_Of_Statements (Loc, New_List (
10126 Make_Assignment_Statement (Loc,
10127 Name => Make_Identifier (Loc, Name_X),
10128 Expression => Make_Identifier (Loc, Name_Y)))));
10130 Append_To (Res, Decl);
10133 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
10134 -- tagged types which do not contain controlled components.
10136 -- Do not generate the routines if finalization is disabled
10138 if Restriction_Active (No_Finalization) then
10141 elsif not Has_Controlled_Component (Tag_Typ) then
10142 if not Is_Limited_Type (Tag_Typ) then
10144 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
10146 if Is_Controlled (Tag_Typ) then
10149 Obj_Ref => Make_Identifier (Loc, Name_V),
10153 if No (Adj_Call) then
10154 Adj_Call := Make_Null_Statement (Loc);
10157 Set_Handled_Statement_Sequence (Decl,
10158 Make_Handled_Sequence_Of_Statements (Loc,
10159 Statements => New_List (Adj_Call)));
10161 Append_To (Res, Decl);
10165 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
10167 if Is_Controlled (Tag_Typ) then
10170 (Obj_Ref => Make_Identifier (Loc, Name_V),
10174 if No (Fin_Call) then
10175 Fin_Call := Make_Null_Statement (Loc);
10178 Set_Handled_Statement_Sequence (Decl,
10179 Make_Handled_Sequence_Of_Statements (Loc,
10180 Statements => New_List (Fin_Call)));
10182 Append_To (Res, Decl);
10186 end Predefined_Primitive_Bodies;
10188 ---------------------------------
10189 -- Predefined_Primitive_Freeze --
10190 ---------------------------------
10192 function Predefined_Primitive_Freeze
10193 (Tag_Typ : Entity_Id) return List_Id
10195 Res : constant List_Id := New_List;
10200 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10201 while Present (Prim) loop
10202 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
10203 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
10205 if Present (Frnodes) then
10206 Append_List_To (Res, Frnodes);
10214 end Predefined_Primitive_Freeze;
10216 -------------------------
10217 -- Stream_Operation_OK --
10218 -------------------------
10220 function Stream_Operation_OK
10222 Operation : TSS_Name_Type) return Boolean
10224 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
10227 -- Special case of a limited type extension: a default implementation
10228 -- of the stream attributes Read or Write exists if that attribute
10229 -- has been specified or is available for an ancestor type; a default
10230 -- implementation of the attribute Output (resp. Input) exists if the
10231 -- attribute has been specified or Write (resp. Read) is available for
10232 -- an ancestor type. The last condition only applies under Ada 2005.
10234 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
10235 if Operation = TSS_Stream_Read then
10236 Has_Predefined_Or_Specified_Stream_Attribute :=
10237 Has_Specified_Stream_Read (Typ);
10239 elsif Operation = TSS_Stream_Write then
10240 Has_Predefined_Or_Specified_Stream_Attribute :=
10241 Has_Specified_Stream_Write (Typ);
10243 elsif Operation = TSS_Stream_Input then
10244 Has_Predefined_Or_Specified_Stream_Attribute :=
10245 Has_Specified_Stream_Input (Typ)
10247 (Ada_Version >= Ada_2005
10248 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
10250 elsif Operation = TSS_Stream_Output then
10251 Has_Predefined_Or_Specified_Stream_Attribute :=
10252 Has_Specified_Stream_Output (Typ)
10254 (Ada_Version >= Ada_2005
10255 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
10258 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
10260 if not Has_Predefined_Or_Specified_Stream_Attribute
10261 and then Is_Derived_Type (Typ)
10262 and then (Operation = TSS_Stream_Read
10263 or else Operation = TSS_Stream_Write)
10265 Has_Predefined_Or_Specified_Stream_Attribute :=
10267 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
10271 -- If the type is not limited, or else is limited but the attribute is
10272 -- explicitly specified or is predefined for the type, then return True,
10273 -- unless other conditions prevail, such as restrictions prohibiting
10274 -- streams or dispatching operations. We also return True for limited
10275 -- interfaces, because they may be extended by nonlimited types and
10276 -- permit inheritance in this case (addresses cases where an abstract
10277 -- extension doesn't get 'Input declared, as per comments below, but
10278 -- 'Class'Input must still be allowed). Note that attempts to apply
10279 -- stream attributes to a limited interface or its class-wide type
10280 -- (or limited extensions thereof) will still get properly rejected
10281 -- by Check_Stream_Attribute.
10283 -- We exclude the Input operation from being a predefined subprogram in
10284 -- the case where the associated type is an abstract extension, because
10285 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
10286 -- we don't want an abstract version created because types derived from
10287 -- the abstract type may not even have Input available (for example if
10288 -- derived from a private view of the abstract type that doesn't have
10289 -- a visible Input).
10291 -- Do not generate stream routines for type Finalization_Master because
10292 -- a master may never appear in types and therefore cannot be read or
10296 (not Is_Limited_Type (Typ)
10297 or else Is_Interface (Typ)
10298 or else Has_Predefined_Or_Specified_Stream_Attribute)
10300 (Operation /= TSS_Stream_Input
10301 or else not Is_Abstract_Type (Typ)
10302 or else not Is_Derived_Type (Typ))
10303 and then not Has_Unknown_Discriminants (Typ)
10305 (Is_Interface (Typ)
10307 (Is_Task_Interface (Typ)
10308 or else Is_Protected_Interface (Typ)
10309 or else Is_Synchronized_Interface (Typ)))
10310 and then not Restriction_Active (No_Streams)
10311 and then not Restriction_Active (No_Dispatch)
10312 and then No (No_Tagged_Streams_Pragma (Typ))
10313 and then not No_Run_Time_Mode
10314 and then RTE_Available (RE_Tag)
10315 and then No (Type_Without_Stream_Operation (Typ))
10316 and then RTE_Available (RE_Root_Stream_Type)
10317 and then not Is_RTE (Typ, RE_Finalization_Master);
10318 end Stream_Operation_OK;