1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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;
41 with Exp_Smem; use Exp_Smem;
42 with Exp_Strm; use Exp_Strm;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
48 with Namet; use Namet;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Attr; use Sem_Attr;
58 with Sem_Cat; use Sem_Cat;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Mech; use Sem_Mech;
65 with Sem_Res; use Sem_Res;
66 with Sem_SCIL; use Sem_SCIL;
67 with Sem_Type; use Sem_Type;
68 with Sem_Util; use Sem_Util;
69 with Sinfo; use Sinfo;
70 with Stand; use Stand;
71 with Snames; use Snames;
72 with Tbuild; use Tbuild;
73 with Ttypes; use Ttypes;
74 with Validsw; use Validsw;
76 package body Exp_Ch3 is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Adjust_Discriminants (Rtype : Entity_Id);
83 -- This is used when freezing a record type. It attempts to construct
84 -- more restrictive subtypes for discriminants so that the max size of
85 -- the record can be calculated more accurately. See the body of this
86 -- procedure for details.
88 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
89 -- Build initialization procedure for given array type. Nod is a node
90 -- used for attachment of any actions required in its construction.
91 -- It also supplies the source location used for the procedure.
93 function Build_Discriminant_Formals
95 Use_Dl : Boolean) return List_Id;
96 -- This function uses the discriminants of a type to build a list of
97 -- formal parameters, used in Build_Init_Procedure among other places.
98 -- If the flag Use_Dl is set, the list is built using the already
99 -- defined discriminals of the type, as is the case for concurrent
100 -- types with discriminants. Otherwise new identifiers are created,
101 -- with the source names of the discriminants.
103 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
104 -- This function builds a static aggregate that can serve as the initial
105 -- value for an array type whose bounds are static, and whose component
106 -- type is a composite type that has a static equivalent aggregate.
107 -- The equivalent array aggregate is used both for object initialization
108 -- and for component initialization, when used in the following function.
110 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
111 -- This function builds a static aggregate that can serve as the initial
112 -- value for a record type whose components are scalar and initialized
113 -- with compile-time values, or arrays with similar initialization or
114 -- defaults. When possible, initialization of an object of the type can
115 -- be achieved by using a copy of the aggregate as an initial value, thus
116 -- removing the implicit call that would otherwise constitute elaboration
119 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
120 -- Build record initialization procedure. N is the type declaration
121 -- node, and Rec_Ent is the corresponding entity for the record type.
123 procedure Build_Slice_Assignment (Typ : Entity_Id);
124 -- Build assignment procedure for one-dimensional arrays of controlled
125 -- types. Other array and slice assignments are expanded in-line, but
126 -- the code expansion for controlled components (when control actions
127 -- are active) can lead to very large blocks that GCC3 handles poorly.
129 procedure Build_Untagged_Equality (Typ : Entity_Id);
130 -- AI05-0123: Equality on untagged records composes. This procedure
131 -- builds the equality routine for an untagged record that has components
132 -- of a record type that has user-defined primitive equality operations.
133 -- The resulting operation is a TSS subprogram.
135 procedure Check_Stream_Attributes (Typ : Entity_Id);
136 -- Check that if a limited extension has a parent with user-defined stream
137 -- attributes, and does not itself have user-defined stream-attributes,
138 -- then any limited component of the extension also has the corresponding
139 -- user-defined stream attributes.
141 procedure Clean_Task_Names
143 Proc_Id : Entity_Id);
144 -- If an initialization procedure includes calls to generate names
145 -- for task subcomponents, indicate that secondary stack cleanup is
146 -- needed after an initialization. Typ is the component type, and Proc_Id
147 -- the initialization procedure for the enclosing composite type.
149 procedure Expand_Freeze_Array_Type (N : Node_Id);
150 -- Freeze an array type. Deals with building the initialization procedure,
151 -- creating the packed array type for a packed array and also with the
152 -- creation of the controlling procedures for the controlled case. The
153 -- argument N is the N_Freeze_Entity node for the type.
155 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
156 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
157 -- of finalizing controlled derivations from the class-wide's root type.
159 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
160 -- Freeze enumeration type with non-standard representation. Builds the
161 -- array and function needed to convert between enumeration pos and
162 -- enumeration representation values. N is the N_Freeze_Entity node
165 procedure Expand_Freeze_Record_Type (N : Node_Id);
166 -- Freeze record type. Builds all necessary discriminant checking
167 -- and other ancillary functions, and builds dispatch tables where
168 -- needed. The argument N is the N_Freeze_Entity node. This processing
169 -- applies only to E_Record_Type entities, not to class wide types,
170 -- record subtypes, or private types.
172 procedure Expand_Tagged_Root (T : Entity_Id);
173 -- Add a field _Tag at the beginning of the record. This field carries
174 -- the value of the access to the Dispatch table. This procedure is only
175 -- called on root type, the _Tag field being inherited by the descendants.
177 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
178 -- Treat user-defined stream operations as renaming_as_body if the
179 -- subprogram they rename is not frozen when the type is frozen.
181 procedure Initialization_Warning (E : Entity_Id);
182 -- If static elaboration of the package is requested, indicate
183 -- when a type does meet the conditions for static initialization. If
184 -- E is a type, it has components that have no static initialization.
185 -- if E is an entity, its initial expression is not compile-time known.
187 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id;
188 -- This function builds the list of formals for an initialization routine.
189 -- The first formal is always _Init with the given type. For task value
190 -- record types and types containing tasks, three additional formals are
191 -- added and Proc_Id is decorated with attribute Has_Master_Entity:
193 -- _Master : Master_Id
194 -- _Chain : in out Activation_Chain
195 -- _Task_Name : String
197 -- The caller must append additional entries for discriminants if required.
199 function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
200 -- Returns true if the initialization procedure of Typ should be inlined
202 function In_Runtime (E : Entity_Id) return Boolean;
203 -- Check if E is defined in the RTL (in a child of Ada or System). Used
204 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
206 function Is_Null_Statement_List (Stmts : List_Id) return Boolean;
207 -- Returns true if Stmts is made of null statements only, possibly wrapped
208 -- in a case statement, recursively. This latter pattern may occur for the
209 -- initialization procedure of an unchecked union.
211 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
212 -- Returns true if Prim is a user defined equality function
214 function Make_Eq_Body
216 Eq_Name : Name_Id) return Node_Id;
217 -- Build the body of a primitive equality operation for a tagged record
218 -- type, or in Ada 2012 for any record type that has components with a
219 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
221 function Make_Eq_Case
224 Discrs : Elist_Id := New_Elmt_List) return List_Id;
225 -- Building block for variant record equality. Defined to share the code
226 -- between the tagged and untagged case. Given a Component_List node CL,
227 -- it generates an 'if' followed by a 'case' statement that compares all
228 -- components of local temporaries named X and Y (that are declared as
229 -- formals at some upper level). E provides the Sloc to be used for the
232 -- IF E is an unchecked_union, Discrs is the list of formals created for
233 -- the inferred discriminants of one operand. These formals are used in
234 -- the generated case statements for each variant of the unchecked union.
238 L : List_Id) return Node_Id;
239 -- Building block for variant record equality. Defined to share the code
240 -- between the tagged and untagged case. Given the list of components
241 -- (or discriminants) L, it generates a return statement that compares all
242 -- components of local temporaries named X and Y (that are declared as
243 -- formals at some upper level). E provides the Sloc to be used for the
246 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
247 -- Search for a renaming of the inequality dispatching primitive of
248 -- this tagged type. If found then build and return the corresponding
249 -- rename-as-body inequality subprogram; otherwise return Empty.
251 procedure Make_Predefined_Primitive_Specs
252 (Tag_Typ : Entity_Id;
253 Predef_List : out List_Id;
254 Renamed_Eq : out Entity_Id);
255 -- Create a list with the specs of the predefined primitive operations.
256 -- For tagged types that are interfaces all these primitives are defined
259 -- The following entries are present for all tagged types, and provide
260 -- the results of the corresponding attribute applied to the object.
261 -- Dispatching is required in general, since the result of the attribute
262 -- will vary with the actual object subtype.
264 -- _size provides result of 'Size attribute
265 -- typSR provides result of 'Read attribute
266 -- typSW provides result of 'Write attribute
267 -- typSI provides result of 'Input attribute
268 -- typSO provides result of 'Output attribute
269 -- typPI provides result of 'Put_Image attribute
271 -- The following entries are additionally present for non-limited tagged
272 -- types, and implement additional dispatching operations for predefined
275 -- _equality implements "=" operator
276 -- _assign implements assignment operation
277 -- typDF implements deep finalization
278 -- typDA implements deep adjust
280 -- The latter two are empty procedures unless the type contains some
281 -- controlled components that require finalization actions (the deep
282 -- in the name refers to the fact that the action applies to components).
284 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
285 -- returns the value Empty, or else the defining unit name for the
286 -- predefined equality function in the case where the type has a primitive
287 -- operation that is a renaming of predefined equality (but only if there
288 -- is also an overriding user-defined equality function). The returned
289 -- Renamed_Eq will be passed to the corresponding parameter of
290 -- Predefined_Primitive_Bodies.
292 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
293 -- Returns True if there are representation clauses for type T that are not
294 -- inherited. If the result is false, the init_proc and the discriminant
295 -- checking functions of the parent can be reused by a derived type.
297 procedure Make_Controlling_Function_Wrappers
298 (Tag_Typ : Entity_Id;
299 Decl_List : out List_Id;
300 Body_List : out List_Id);
301 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
302 -- associated with inherited functions with controlling results which
303 -- are not overridden. The body of each wrapper function consists solely
304 -- of a return statement whose expression is an extension aggregate
305 -- invoking the inherited subprogram's parent subprogram and extended
306 -- with a null association list.
308 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
309 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
310 -- null procedures inherited from an interface type that have not been
311 -- overridden. Only one null procedure will be created for a given set of
312 -- inherited null procedures with homographic profiles.
314 function Predef_Spec_Or_Body
319 Ret_Type : Entity_Id := Empty;
320 For_Body : Boolean := False) return Node_Id;
321 -- This function generates the appropriate expansion for a predefined
322 -- primitive operation specified by its name, parameter profile and
323 -- return type (Empty means this is a procedure). If For_Body is false,
324 -- then the returned node is a subprogram declaration. If For_Body is
325 -- true, then the returned node is a empty subprogram body containing
326 -- no declarations and no statements.
328 function Predef_Stream_Attr_Spec
331 Name : TSS_Name_Type;
332 For_Body : Boolean := False) return Node_Id;
333 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
334 -- input and output attribute whose specs are constructed in Exp_Strm.
336 function Predef_Deep_Spec
339 Name : TSS_Name_Type;
340 For_Body : Boolean := False) return Node_Id;
341 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
342 -- and _deep_finalize
344 function Predefined_Primitive_Bodies
345 (Tag_Typ : Entity_Id;
346 Renamed_Eq : Entity_Id) return List_Id;
347 -- Create the bodies of the predefined primitives that are described in
348 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
349 -- the defining unit name of the type's predefined equality as returned
350 -- by Make_Predefined_Primitive_Specs.
352 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
353 -- Freeze entities of all predefined primitive operations. This is needed
354 -- because the bodies of these operations do not normally do any freezing.
356 function Stream_Operation_OK
358 Operation : TSS_Name_Type) return Boolean;
359 -- Check whether the named stream operation must be emitted for a given
360 -- type. The rules for inheritance of stream attributes by type extensions
361 -- are enforced by this function. Furthermore, various restrictions prevent
362 -- the generation of these operations, as a useful optimization or for
363 -- certification purposes and to save unnecessary generated code.
365 --------------------------
366 -- Adjust_Discriminants --
367 --------------------------
369 -- This procedure attempts to define subtypes for discriminants that are
370 -- more restrictive than those declared. Such a replacement is possible if
371 -- we can demonstrate that values outside the restricted range would cause
372 -- constraint errors in any case. The advantage of restricting the
373 -- discriminant types in this way is that the maximum size of the variant
374 -- record can be calculated more conservatively.
376 -- An example of a situation in which we can perform this type of
377 -- restriction is the following:
379 -- subtype B is range 1 .. 10;
380 -- type Q is array (B range <>) of Integer;
382 -- type V (N : Natural) is record
386 -- In this situation, we can restrict the upper bound of N to 10, since
387 -- any larger value would cause a constraint error in any case.
389 -- There are many situations in which such restriction is possible, but
390 -- for now, we just look for cases like the above, where the component
391 -- in question is a one dimensional array whose upper bound is one of
392 -- the record discriminants. Also the component must not be part of
393 -- any variant part, since then the component does not always exist.
395 procedure Adjust_Discriminants (Rtype : Entity_Id) is
396 Loc : constant Source_Ptr := Sloc (Rtype);
413 Comp := First_Component (Rtype);
414 while Present (Comp) loop
416 -- If our parent is a variant, quit, we do not look at components
417 -- that are in variant parts, because they may not always exist.
419 P := Parent (Comp); -- component declaration
420 P := Parent (P); -- component list
422 exit when Nkind (Parent (P)) = N_Variant;
424 -- We are looking for a one dimensional array type
426 Ctyp := Etype (Comp);
428 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
432 -- The lower bound must be constant, and the upper bound is a
433 -- discriminant (which is a discriminant of the current record).
435 Ityp := Etype (First_Index (Ctyp));
436 Lo := Type_Low_Bound (Ityp);
437 Hi := Type_High_Bound (Ityp);
439 if not Compile_Time_Known_Value (Lo)
440 or else Nkind (Hi) /= N_Identifier
441 or else No (Entity (Hi))
442 or else Ekind (Entity (Hi)) /= E_Discriminant
447 -- We have an array with appropriate bounds
449 Loval := Expr_Value (Lo);
450 Discr := Entity (Hi);
451 Dtyp := Etype (Discr);
453 -- See if the discriminant has a known upper bound
455 Dhi := Type_High_Bound (Dtyp);
457 if not Compile_Time_Known_Value (Dhi) then
461 Dhiv := Expr_Value (Dhi);
463 -- See if base type of component array has known upper bound
465 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
467 if not Compile_Time_Known_Value (Ahi) then
471 Ahiv := Expr_Value (Ahi);
473 -- The condition for doing the restriction is that the high bound
474 -- of the discriminant is greater than the low bound of the array,
475 -- and is also greater than the high bound of the base type index.
477 if Dhiv > Loval and then Dhiv > Ahiv then
479 -- We can reset the upper bound of the discriminant type to
480 -- whichever is larger, the low bound of the component, or
481 -- the high bound of the base type array index.
483 -- We build a subtype that is declared as
485 -- subtype Tnn is discr_type range discr_type'First .. max;
487 -- And insert this declaration into the tree. The type of the
488 -- discriminant is then reset to this more restricted subtype.
490 Tnn := Make_Temporary (Loc, 'T');
492 Insert_Action (Declaration_Node (Rtype),
493 Make_Subtype_Declaration (Loc,
494 Defining_Identifier => Tnn,
495 Subtype_Indication =>
496 Make_Subtype_Indication (Loc,
497 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
499 Make_Range_Constraint (Loc,
503 Make_Attribute_Reference (Loc,
504 Attribute_Name => Name_First,
505 Prefix => New_Occurrence_Of (Dtyp, Loc)),
507 Make_Integer_Literal (Loc,
508 Intval => UI_Max (Loval, Ahiv)))))));
510 Set_Etype (Discr, Tnn);
514 Next_Component (Comp);
516 end Adjust_Discriminants;
518 ------------------------------------------
519 -- Build_Access_Subprogram_Wrapper_Body --
520 ------------------------------------------
522 procedure Build_Access_Subprogram_Wrapper_Body
526 Loc : constant Source_Ptr := Sloc (Decl);
527 Actuals : constant List_Id := New_List;
528 Type_Def : constant Node_Id := Type_Definition (Decl);
529 Type_Id : constant Entity_Id := Defining_Identifier (Decl);
530 Spec_Node : constant Node_Id :=
531 New_Copy_Tree (Specification (New_Decl));
539 if not Expander_Active then
543 Set_Defining_Unit_Name (Spec_Node,
544 Make_Defining_Identifier
545 (Loc, Chars (Defining_Unit_Name (Spec_Node))));
547 -- Create List of actuals for indirect call. The last parameter of the
548 -- subprogram is the access value itself.
550 Act := First (Parameter_Specifications (Spec_Node));
552 while Present (Act) loop
554 Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
556 exit when Act = Last (Parameter_Specifications (Spec_Node));
561 (Last (Parameter_Specifications (Spec_Node)));
563 if Nkind (Type_Def) = N_Access_Procedure_Definition then
564 Call_Stmt := Make_Procedure_Call_Statement (Loc,
566 Make_Explicit_Dereference
567 (Loc, New_Occurrence_Of (Ptr, Loc)),
568 Parameter_Associations => Actuals);
570 Call_Stmt := Make_Simple_Return_Statement (Loc,
572 Make_Function_Call (Loc,
573 Name => Make_Explicit_Dereference
574 (Loc, New_Occurrence_Of (Ptr, Loc)),
575 Parameter_Associations => Actuals));
578 Body_Node := Make_Subprogram_Body (Loc,
579 Specification => Spec_Node,
580 Declarations => New_List,
581 Handled_Statement_Sequence =>
582 Make_Handled_Sequence_Of_Statements (Loc,
583 Statements => New_List (Call_Stmt)));
585 -- Place body in list of freeze actions for the type.
587 Ensure_Freeze_Node (Type_Id);
588 Append_Freeze_Actions (Type_Id, New_List (Body_Node));
589 end Build_Access_Subprogram_Wrapper_Body;
591 ---------------------------
592 -- Build_Array_Init_Proc --
593 ---------------------------
595 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
596 Comp_Type : constant Entity_Id := Component_Type (A_Type);
597 Comp_Simple_Init : constant Boolean :=
598 Needs_Simple_Initialization
601 not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
602 -- True if the component needs simple initialization, based on its type,
603 -- plus the fact that we do not do simple initialization for components
604 -- of bit-packed arrays when validity checks are enabled, because the
605 -- initialization with deliberately out-of-range values would raise
608 Body_Stmts : List_Id;
609 Has_Default_Init : Boolean;
610 Index_List : List_Id;
612 Parameters : List_Id;
615 function Init_Component return List_Id;
616 -- Create one statement to initialize one array component, designated
617 -- by a full set of indexes.
619 function Init_One_Dimension (N : Int) return List_Id;
620 -- Create loop to initialize one dimension of the array. The single
621 -- statement in the loop body initializes the inner dimensions if any,
622 -- or else the single component. Note that this procedure is called
623 -- recursively, with N being the dimension to be initialized. A call
624 -- with N greater than the number of dimensions simply generates the
625 -- component initialization, terminating the recursion.
631 function Init_Component return List_Id is
636 Make_Indexed_Component (Loc,
637 Prefix => Make_Identifier (Loc, Name_uInit),
638 Expressions => Index_List);
640 if Has_Default_Aspect (A_Type) then
641 Set_Assignment_OK (Comp);
643 Make_Assignment_Statement (Loc,
646 Convert_To (Comp_Type,
647 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
649 elsif Comp_Simple_Init then
650 Set_Assignment_OK (Comp);
652 Make_Assignment_Statement (Loc,
658 Size => Component_Size (A_Type))));
661 Clean_Task_Names (Comp_Type, Proc_Id);
663 Build_Initialization_Call
667 In_Init_Proc => True,
668 Enclos_Type => A_Type);
672 ------------------------
673 -- Init_One_Dimension --
674 ------------------------
676 function Init_One_Dimension (N : Int) return List_Id is
680 -- If the component does not need initializing, then there is nothing
681 -- to do here, so we return a null body. This occurs when generating
682 -- the dummy Init_Proc needed for Initialize_Scalars processing.
684 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
685 and then not Comp_Simple_Init
686 and then not Has_Task (Comp_Type)
687 and then not Has_Default_Aspect (A_Type)
689 return New_List (Make_Null_Statement (Loc));
691 -- If all dimensions dealt with, we simply initialize the component
693 elsif N > Number_Dimensions (A_Type) then
694 return Init_Component;
696 -- Here we generate the required loop
700 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
702 Append (New_Occurrence_Of (Index, Loc), Index_List);
705 Make_Implicit_Loop_Statement (Nod,
708 Make_Iteration_Scheme (Loc,
709 Loop_Parameter_Specification =>
710 Make_Loop_Parameter_Specification (Loc,
711 Defining_Identifier => Index,
712 Discrete_Subtype_Definition =>
713 Make_Attribute_Reference (Loc,
715 Make_Identifier (Loc, Name_uInit),
716 Attribute_Name => Name_Range,
717 Expressions => New_List (
718 Make_Integer_Literal (Loc, N))))),
719 Statements => Init_One_Dimension (N + 1)));
721 end Init_One_Dimension;
723 -- Start of processing for Build_Array_Init_Proc
726 -- The init proc is created when analyzing the freeze node for the type,
727 -- but it properly belongs with the array type declaration. However, if
728 -- the freeze node is for a subtype of a type declared in another unit
729 -- it seems preferable to use the freeze node as the source location of
730 -- the init proc. In any case this is preferable for gcov usage, and
731 -- the Sloc is not otherwise used by the compiler.
733 if In_Open_Scopes (Scope (A_Type)) then
734 Loc := Sloc (A_Type);
739 -- Nothing to generate in the following cases:
741 -- 1. Initialization is suppressed for the type
742 -- 2. An initialization already exists for the base type
744 if Initialization_Suppressed (A_Type)
745 or else Present (Base_Init_Proc (A_Type))
750 Index_List := New_List;
752 -- We need an initialization procedure if any of the following is true:
754 -- 1. The component type has an initialization procedure
755 -- 2. The component type needs simple initialization
756 -- 3. Tasks are present
757 -- 4. The type is marked as a public entity
758 -- 5. The array type has a Default_Component_Value aspect
760 -- The reason for the public entity test is to deal properly with the
761 -- Initialize_Scalars pragma. This pragma can be set in the client and
762 -- not in the declaring package, this means the client will make a call
763 -- to the initialization procedure (because one of conditions 1-3 must
764 -- apply in this case), and we must generate a procedure (even if it is
765 -- null) to satisfy the call in this case.
767 -- Exception: do not build an array init_proc for a type whose root
768 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
769 -- is no place to put the code, and in any case we handle initialization
770 -- of such types (in the Initialize_Scalars case, that's the only time
771 -- the issue arises) in a special manner anyway which does not need an
774 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
775 or else Comp_Simple_Init
776 or else Has_Task (Comp_Type)
777 or else Has_Default_Aspect (A_Type);
780 or else (not Restriction_Active (No_Initialize_Scalars)
781 and then Is_Public (A_Type)
782 and then not Is_Standard_String_Type (A_Type))
785 Make_Defining_Identifier (Loc,
786 Chars => Make_Init_Proc_Name (A_Type));
788 -- If No_Default_Initialization restriction is active, then we don't
789 -- want to build an init_proc, but we need to mark that an init_proc
790 -- would be needed if this restriction was not active (so that we can
791 -- detect attempts to call it), so set a dummy init_proc in place.
792 -- This is only done though when actual default initialization is
793 -- needed (and not done when only Is_Public is True), since otherwise
794 -- objects such as arrays of scalars could be wrongly flagged as
795 -- violating the restriction.
797 if Restriction_Active (No_Default_Initialization) then
798 if Has_Default_Init then
799 Set_Init_Proc (A_Type, Proc_Id);
805 Body_Stmts := Init_One_Dimension (1);
806 Parameters := Init_Formals (A_Type, Proc_Id);
809 Make_Subprogram_Body (Loc,
811 Make_Procedure_Specification (Loc,
812 Defining_Unit_Name => Proc_Id,
813 Parameter_Specifications => Parameters),
814 Declarations => New_List,
815 Handled_Statement_Sequence =>
816 Make_Handled_Sequence_Of_Statements (Loc,
817 Statements => Body_Stmts)));
819 Set_Ekind (Proc_Id, E_Procedure);
820 Set_Is_Public (Proc_Id, Is_Public (A_Type));
821 Set_Is_Internal (Proc_Id);
822 Set_Has_Completion (Proc_Id);
824 if not Debug_Generated_Code then
825 Set_Debug_Info_Off (Proc_Id);
828 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
829 -- component type itself (see also Build_Record_Init_Proc).
831 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
833 -- Associate Init_Proc with type, and determine if the procedure
834 -- is null (happens because of the Initialize_Scalars pragma case,
835 -- where we have to generate a null procedure in case it is called
836 -- by a client with Initialize_Scalars set). Such procedures have
837 -- to be generated, but do not have to be called, so we mark them
838 -- as null to suppress the call. Kill also warnings for the _Init
839 -- out parameter, which is left entirely uninitialized.
841 Set_Init_Proc (A_Type, Proc_Id);
843 if Is_Null_Statement_List (Body_Stmts) then
844 Set_Is_Null_Init_Proc (Proc_Id);
845 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
848 -- Try to build a static aggregate to statically initialize
849 -- objects of the type. This can only be done for constrained
850 -- one-dimensional arrays with static bounds.
852 Set_Static_Initialization
854 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
857 end Build_Array_Init_Proc;
859 --------------------------------
860 -- Build_Discr_Checking_Funcs --
861 --------------------------------
863 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
866 Enclosing_Func_Id : Entity_Id;
871 function Build_Case_Statement
872 (Case_Id : Entity_Id;
873 Variant : Node_Id) return Node_Id;
874 -- Build a case statement containing only two alternatives. The first
875 -- alternative corresponds exactly to the discrete choices given on the
876 -- variant with contains the components that we are generating the
877 -- checks for. If the discriminant is one of these return False. The
878 -- second alternative is an OTHERS choice that will return True
879 -- indicating the discriminant did not match.
881 function Build_Dcheck_Function
882 (Case_Id : Entity_Id;
883 Variant : Node_Id) return Entity_Id;
884 -- Build the discriminant checking function for a given variant
886 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
887 -- Builds the discriminant checking function for each variant of the
888 -- given variant part of the record type.
890 --------------------------
891 -- Build_Case_Statement --
892 --------------------------
894 function Build_Case_Statement
895 (Case_Id : Entity_Id;
896 Variant : Node_Id) return Node_Id
898 Alt_List : constant List_Id := New_List;
899 Actuals_List : List_Id;
901 Case_Alt_Node : Node_Id;
903 Choice_List : List_Id;
905 Return_Node : Node_Id;
908 Case_Node := New_Node (N_Case_Statement, Loc);
910 -- Replace the discriminant which controls the variant with the name
911 -- of the formal of the checking function.
913 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
915 Choice := First (Discrete_Choices (Variant));
917 if Nkind (Choice) = N_Others_Choice then
918 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
920 Choice_List := New_Copy_List (Discrete_Choices (Variant));
923 if not Is_Empty_List (Choice_List) then
924 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
925 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
927 -- In case this is a nested variant, we need to return the result
928 -- of the discriminant checking function for the immediately
929 -- enclosing variant.
931 if Present (Enclosing_Func_Id) then
932 Actuals_List := New_List;
934 D := First_Discriminant (Rec_Id);
935 while Present (D) loop
936 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
937 Next_Discriminant (D);
941 Make_Simple_Return_Statement (Loc,
943 Make_Function_Call (Loc,
945 New_Occurrence_Of (Enclosing_Func_Id, Loc),
946 Parameter_Associations =>
951 Make_Simple_Return_Statement (Loc,
953 New_Occurrence_Of (Standard_False, Loc));
956 Set_Statements (Case_Alt_Node, New_List (Return_Node));
957 Append (Case_Alt_Node, Alt_List);
960 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
961 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
962 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
965 Make_Simple_Return_Statement (Loc,
967 New_Occurrence_Of (Standard_True, Loc));
969 Set_Statements (Case_Alt_Node, New_List (Return_Node));
970 Append (Case_Alt_Node, Alt_List);
972 Set_Alternatives (Case_Node, Alt_List);
974 end Build_Case_Statement;
976 ---------------------------
977 -- Build_Dcheck_Function --
978 ---------------------------
980 function Build_Dcheck_Function
981 (Case_Id : Entity_Id;
982 Variant : Node_Id) return Entity_Id
986 Parameter_List : List_Id;
990 Body_Node := New_Node (N_Subprogram_Body, Loc);
991 Sequence := Sequence + 1;
994 Make_Defining_Identifier (Loc,
995 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
996 Set_Is_Discriminant_Check_Function (Func_Id);
998 Spec_Node := New_Node (N_Function_Specification, Loc);
999 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1001 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
1003 Set_Parameter_Specifications (Spec_Node, Parameter_List);
1004 Set_Result_Definition (Spec_Node,
1005 New_Occurrence_Of (Standard_Boolean, Loc));
1006 Set_Specification (Body_Node, Spec_Node);
1007 Set_Declarations (Body_Node, New_List);
1009 Set_Handled_Statement_Sequence (Body_Node,
1010 Make_Handled_Sequence_Of_Statements (Loc,
1011 Statements => New_List (
1012 Build_Case_Statement (Case_Id, Variant))));
1014 Set_Ekind (Func_Id, E_Function);
1015 Set_Mechanism (Func_Id, Default_Mechanism);
1016 Set_Is_Inlined (Func_Id, True);
1017 Set_Is_Pure (Func_Id, True);
1018 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
1019 Set_Is_Internal (Func_Id, True);
1021 if not Debug_Generated_Code then
1022 Set_Debug_Info_Off (Func_Id);
1025 Analyze (Body_Node);
1027 Append_Freeze_Action (Rec_Id, Body_Node);
1028 Set_Dcheck_Function (Variant, Func_Id);
1030 end Build_Dcheck_Function;
1032 ----------------------------
1033 -- Build_Dcheck_Functions --
1034 ----------------------------
1036 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
1037 Component_List_Node : Node_Id;
1039 Discr_Name : Entity_Id;
1040 Func_Id : Entity_Id;
1042 Saved_Enclosing_Func_Id : Entity_Id;
1045 -- Build the discriminant-checking function for each variant, and
1046 -- label all components of that variant with the function's name.
1047 -- We only Generate a discriminant-checking function when the
1048 -- variant is not empty, to prevent the creation of dead code.
1050 Discr_Name := Entity (Name (Variant_Part_Node));
1051 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
1053 while Present (Variant) loop
1054 Component_List_Node := Component_List (Variant);
1056 if not Null_Present (Component_List_Node) then
1057 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
1060 First_Non_Pragma (Component_Items (Component_List_Node));
1061 while Present (Decl) loop
1062 Set_Discriminant_Checking_Func
1063 (Defining_Identifier (Decl), Func_Id);
1064 Next_Non_Pragma (Decl);
1067 if Present (Variant_Part (Component_List_Node)) then
1068 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
1069 Enclosing_Func_Id := Func_Id;
1070 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
1071 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
1075 Next_Non_Pragma (Variant);
1077 end Build_Dcheck_Functions;
1079 -- Start of processing for Build_Discr_Checking_Funcs
1082 -- Only build if not done already
1084 if not Discr_Check_Funcs_Built (N) then
1085 Type_Def := Type_Definition (N);
1087 if Nkind (Type_Def) = N_Record_Definition then
1088 if No (Component_List (Type_Def)) then -- null record.
1091 V := Variant_Part (Component_List (Type_Def));
1094 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1095 if No (Component_List (Record_Extension_Part (Type_Def))) then
1099 (Component_List (Record_Extension_Part (Type_Def)));
1103 Rec_Id := Defining_Identifier (N);
1105 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1107 Enclosing_Func_Id := Empty;
1108 Build_Dcheck_Functions (V);
1111 Set_Discr_Check_Funcs_Built (N);
1113 end Build_Discr_Checking_Funcs;
1115 --------------------------------
1116 -- Build_Discriminant_Formals --
1117 --------------------------------
1119 function Build_Discriminant_Formals
1120 (Rec_Id : Entity_Id;
1121 Use_Dl : Boolean) return List_Id
1123 Loc : Source_Ptr := Sloc (Rec_Id);
1124 Parameter_List : constant List_Id := New_List;
1127 Formal_Type : Entity_Id;
1128 Param_Spec_Node : Node_Id;
1131 if Has_Discriminants (Rec_Id) then
1132 D := First_Discriminant (Rec_Id);
1133 while Present (D) loop
1137 Formal := Discriminal (D);
1138 Formal_Type := Etype (Formal);
1140 Formal := Make_Defining_Identifier (Loc, Chars (D));
1141 Formal_Type := Etype (D);
1145 Make_Parameter_Specification (Loc,
1146 Defining_Identifier => Formal,
1148 New_Occurrence_Of (Formal_Type, Loc));
1149 Append (Param_Spec_Node, Parameter_List);
1150 Next_Discriminant (D);
1154 return Parameter_List;
1155 end Build_Discriminant_Formals;
1157 --------------------------------------
1158 -- Build_Equivalent_Array_Aggregate --
1159 --------------------------------------
1161 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1162 Loc : constant Source_Ptr := Sloc (T);
1163 Comp_Type : constant Entity_Id := Component_Type (T);
1164 Index_Type : constant Entity_Id := Etype (First_Index (T));
1165 Proc : constant Entity_Id := Base_Init_Proc (T);
1171 if not Is_Constrained (T)
1172 or else Number_Dimensions (T) > 1
1175 Initialization_Warning (T);
1179 Lo := Type_Low_Bound (Index_Type);
1180 Hi := Type_High_Bound (Index_Type);
1182 if not Compile_Time_Known_Value (Lo)
1183 or else not Compile_Time_Known_Value (Hi)
1185 Initialization_Warning (T);
1189 if Is_Record_Type (Comp_Type)
1190 and then Present (Base_Init_Proc (Comp_Type))
1192 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1195 Initialization_Warning (T);
1200 Initialization_Warning (T);
1204 Aggr := Make_Aggregate (Loc, No_List, New_List);
1205 Set_Etype (Aggr, T);
1206 Set_Aggregate_Bounds (Aggr,
1208 Low_Bound => New_Copy (Lo),
1209 High_Bound => New_Copy (Hi)));
1210 Set_Parent (Aggr, Parent (Proc));
1212 Append_To (Component_Associations (Aggr),
1213 Make_Component_Association (Loc,
1217 Low_Bound => New_Copy (Lo),
1218 High_Bound => New_Copy (Hi))),
1219 Expression => Expr));
1221 if Static_Array_Aggregate (Aggr) then
1224 Initialization_Warning (T);
1227 end Build_Equivalent_Array_Aggregate;
1229 ---------------------------------------
1230 -- Build_Equivalent_Record_Aggregate --
1231 ---------------------------------------
1233 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1236 Comp_Type : Entity_Id;
1238 -- Start of processing for Build_Equivalent_Record_Aggregate
1241 if not Is_Record_Type (T)
1242 or else Has_Discriminants (T)
1243 or else Is_Limited_Type (T)
1244 or else Has_Non_Standard_Rep (T)
1246 Initialization_Warning (T);
1250 Comp := First_Component (T);
1252 -- A null record needs no warning
1258 while Present (Comp) loop
1260 -- Array components are acceptable if initialized by a positional
1261 -- aggregate with static components.
1263 if Is_Array_Type (Etype (Comp)) then
1264 Comp_Type := Component_Type (Etype (Comp));
1266 if Nkind (Parent (Comp)) /= N_Component_Declaration
1267 or else No (Expression (Parent (Comp)))
1268 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1270 Initialization_Warning (T);
1273 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1275 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1277 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1279 Initialization_Warning (T);
1283 not Static_Array_Aggregate (Expression (Parent (Comp)))
1285 Initialization_Warning (T);
1288 -- We need to return empty if the type has predicates because
1289 -- this would otherwise duplicate calls to the predicate
1290 -- function. If the type hasn't been frozen before being
1291 -- referenced in the current record, the extraneous call to
1292 -- the predicate function would be inserted somewhere before
1293 -- the predicate function is elaborated, which would result in
1296 elsif Has_Predicates (Etype (Comp)) then
1300 elsif Is_Scalar_Type (Etype (Comp)) then
1301 Comp_Type := Etype (Comp);
1303 if Nkind (Parent (Comp)) /= N_Component_Declaration
1304 or else No (Expression (Parent (Comp)))
1305 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1306 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1308 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1310 Initialization_Warning (T);
1314 -- For now, other types are excluded
1317 Initialization_Warning (T);
1321 Next_Component (Comp);
1324 -- All components have static initialization. Build positional aggregate
1325 -- from the given expressions or defaults.
1327 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1328 Set_Parent (Agg, Parent (T));
1330 Comp := First_Component (T);
1331 while Present (Comp) loop
1333 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1334 Next_Component (Comp);
1337 Analyze_And_Resolve (Agg, T);
1339 end Build_Equivalent_Record_Aggregate;
1341 -------------------------------
1342 -- Build_Initialization_Call --
1343 -------------------------------
1345 -- References to a discriminant inside the record type declaration can
1346 -- appear either in the subtype_indication to constrain a record or an
1347 -- array, or as part of a larger expression given for the initial value
1348 -- of a component. In both of these cases N appears in the record
1349 -- initialization procedure and needs to be replaced by the formal
1350 -- parameter of the initialization procedure which corresponds to that
1353 -- In the example below, references to discriminants D1 and D2 in proc_1
1354 -- are replaced by references to formals with the same name
1357 -- A similar replacement is done for calls to any record initialization
1358 -- procedure for any components that are themselves of a record type.
1360 -- type R (D1, D2 : Integer) is record
1361 -- X : Integer := F * D1;
1362 -- Y : Integer := F * D2;
1365 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1369 -- Out_2.X := F * D1;
1370 -- Out_2.Y := F * D2;
1373 function Build_Initialization_Call
1377 In_Init_Proc : Boolean := False;
1378 Enclos_Type : Entity_Id := Empty;
1379 Discr_Map : Elist_Id := New_Elmt_List;
1380 With_Default_Init : Boolean := False;
1381 Constructor_Ref : Node_Id := Empty) return List_Id
1383 Res : constant List_Id := New_List;
1385 Full_Type : Entity_Id;
1387 procedure Check_Predicated_Discriminant
1390 -- Discriminants whose subtypes have predicates are checked in two
1392 -- a) When an object is default-initialized and assertions are enabled
1393 -- we check that the value of the discriminant obeys the predicate.
1395 -- b) In all cases, if the discriminant controls a variant and the
1396 -- variant has no others_choice, Constraint_Error must be raised if
1397 -- the predicate is violated, because there is no variant covered
1398 -- by the illegal discriminant value.
1400 -----------------------------------
1401 -- Check_Predicated_Discriminant --
1402 -----------------------------------
1404 procedure Check_Predicated_Discriminant
1408 Typ : constant Entity_Id := Etype (Discr);
1410 procedure Check_Missing_Others (V : Node_Id);
1413 --------------------------
1414 -- Check_Missing_Others --
1415 --------------------------
1417 procedure Check_Missing_Others (V : Node_Id) is
1423 Last_Var := Last_Non_Pragma (Variants (V));
1424 Choice := First (Discrete_Choices (Last_Var));
1426 -- An others_choice is added during expansion for gcc use, but
1427 -- does not cover the illegality.
1429 if Entity (Name (V)) = Discr then
1431 and then (Nkind (Choice) /= N_Others_Choice
1432 or else not Comes_From_Source (Choice))
1434 Check_Expression_Against_Static_Predicate (Val, Typ);
1436 if not Is_Static_Expression (Val) then
1438 Make_Raise_Constraint_Error (Loc,
1441 Right_Opnd => Make_Predicate_Call (Typ, Val)),
1442 Reason => CE_Invalid_Data));
1447 -- Check whether some nested variant is ruled by the predicated
1450 Alt := First (Variants (V));
1451 while Present (Alt) loop
1452 if Nkind (Alt) = N_Variant
1453 and then Present (Variant_Part (Component_List (Alt)))
1455 Check_Missing_Others
1456 (Variant_Part (Component_List (Alt)));
1461 end Check_Missing_Others;
1467 -- Start of processing for Check_Predicated_Discriminant
1470 if Ekind (Base_Type (Full_Type)) = E_Record_Type then
1471 Def := Type_Definition (Parent (Base_Type (Full_Type)));
1476 if Policy_In_Effect (Name_Assert) = Name_Check
1477 and then not Predicates_Ignored (Etype (Discr))
1479 Prepend_To (Res, Make_Predicate_Check (Typ, Val));
1482 -- If discriminant controls a variant, verify that predicate is
1483 -- obeyed or else an Others_Choice is present.
1485 if Nkind (Def) = N_Record_Definition
1486 and then Present (Variant_Part (Component_List (Def)))
1487 and then Policy_In_Effect (Name_Assert) = Name_Ignore
1489 Check_Missing_Others (Variant_Part (Component_List (Def)));
1491 end Check_Predicated_Discriminant;
1500 First_Arg : Node_Id;
1501 Full_Init_Type : Entity_Id;
1502 Init_Call : Node_Id;
1503 Init_Type : Entity_Id;
1506 -- Start of processing for Build_Initialization_Call
1509 pragma Assert (Constructor_Ref = Empty
1510 or else Is_CPP_Constructor_Call (Constructor_Ref));
1512 if No (Constructor_Ref) then
1513 Proc := Base_Init_Proc (Typ);
1515 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1518 pragma Assert (Present (Proc));
1519 Init_Type := Etype (First_Formal (Proc));
1520 Full_Init_Type := Underlying_Type (Init_Type);
1522 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1523 -- is active (in which case we make the call anyway, since in the
1524 -- actual compiled client it may be non null).
1526 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1529 -- Nothing to do for an array of controlled components that have only
1530 -- the inherited Initialize primitive. This is a useful optimization
1533 elsif Is_Trivial_Subprogram (Proc)
1534 and then Is_Array_Type (Full_Init_Type)
1536 return New_List (Make_Null_Statement (Loc));
1539 -- Use the [underlying] full view when dealing with a private type. This
1540 -- may require several steps depending on derivations.
1544 if Is_Private_Type (Full_Type) then
1545 if Present (Full_View (Full_Type)) then
1546 Full_Type := Full_View (Full_Type);
1548 elsif Present (Underlying_Full_View (Full_Type)) then
1549 Full_Type := Underlying_Full_View (Full_Type);
1551 -- When a private type acts as a generic actual and lacks a full
1552 -- view, use the base type.
1554 elsif Is_Generic_Actual_Type (Full_Type) then
1555 Full_Type := Base_Type (Full_Type);
1557 elsif Ekind (Full_Type) = E_Private_Subtype
1558 and then (not Has_Discriminants (Full_Type)
1559 or else No (Discriminant_Constraint (Full_Type)))
1561 Full_Type := Etype (Full_Type);
1563 -- The loop has recovered the [underlying] full view, stop the
1570 -- The type is not private, nothing to do
1577 -- If Typ is derived, the procedure is the initialization procedure for
1578 -- the root type. Wrap the argument in an conversion to make it type
1579 -- honest. Actually it isn't quite type honest, because there can be
1580 -- conflicts of views in the private type case. That is why we set
1581 -- Conversion_OK in the conversion node.
1583 if (Is_Record_Type (Typ)
1584 or else Is_Array_Type (Typ)
1585 or else Is_Private_Type (Typ))
1586 and then Init_Type /= Base_Type (Typ)
1588 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1589 Set_Etype (First_Arg, Init_Type);
1592 First_Arg := Id_Ref;
1595 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1597 -- In the tasks case, add _Master as the value of the _Master parameter
1598 -- and _Chain as the value of the _Chain parameter. At the outer level,
1599 -- these will be variables holding the corresponding values obtained
1600 -- from GNARL. At inner levels, they will be the parameters passed down
1601 -- through the outer routines.
1603 if Has_Task (Full_Type) then
1604 if Restriction_Active (No_Task_Hierarchy) then
1606 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1608 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1611 -- Add _Chain (not done for sequential elaboration policy, see
1612 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1614 if Partition_Elaboration_Policy /= 'S' then
1615 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1618 -- Ada 2005 (AI-287): In case of default initialized components
1619 -- with tasks, we generate a null string actual parameter.
1620 -- This is just a workaround that must be improved later???
1622 if With_Default_Init then
1624 Make_String_Literal (Loc,
1629 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1630 Decl := Last (Decls);
1633 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1634 Append_List (Decls, Res);
1642 -- Handle the optionally generated formal *_skip_null_excluding_checks
1644 -- Look at the associated node for the object we are referencing and
1645 -- verify that we are expanding a call to an Init_Proc for an internally
1646 -- generated object declaration before passing True and skipping the
1649 if Needs_Conditional_Null_Excluding_Check (Full_Init_Type)
1650 and then Nkind (Id_Ref) in N_Has_Entity
1651 and then (Comes_From_Source (Id_Ref)
1652 or else (Present (Associated_Node (Id_Ref))
1653 and then Comes_From_Source
1654 (Associated_Node (Id_Ref))))
1656 Append_To (Args, New_Occurrence_Of (Standard_True, Loc));
1659 -- Add discriminant values if discriminants are present
1661 if Has_Discriminants (Full_Init_Type) then
1662 Discr := First_Discriminant (Full_Init_Type);
1663 while Present (Discr) loop
1665 -- If this is a discriminated concurrent type, the init_proc
1666 -- for the corresponding record is being called. Use that type
1667 -- directly to find the discriminant value, to handle properly
1668 -- intervening renamed discriminants.
1671 T : Entity_Id := Full_Type;
1674 if Is_Protected_Type (T) then
1675 T := Corresponding_Record_Type (T);
1679 Get_Discriminant_Value (
1682 Discriminant_Constraint (Full_Type));
1685 -- If the target has access discriminants, and is constrained by
1686 -- an access to the enclosing construct, i.e. a current instance,
1687 -- replace the reference to the type by a reference to the object.
1689 if Nkind (Arg) = N_Attribute_Reference
1690 and then Is_Access_Type (Etype (Arg))
1691 and then Is_Entity_Name (Prefix (Arg))
1692 and then Is_Type (Entity (Prefix (Arg)))
1695 Make_Attribute_Reference (Loc,
1696 Prefix => New_Copy (Prefix (Id_Ref)),
1697 Attribute_Name => Name_Unrestricted_Access);
1699 elsif In_Init_Proc then
1701 -- Replace any possible references to the discriminant in the
1702 -- call to the record initialization procedure with references
1703 -- to the appropriate formal parameter.
1705 if Nkind (Arg) = N_Identifier
1706 and then Ekind (Entity (Arg)) = E_Discriminant
1708 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1710 -- Otherwise make a copy of the default expression. Note that
1711 -- we use the current Sloc for this, because we do not want the
1712 -- call to appear to be at the declaration point. Within the
1713 -- expression, replace discriminants with their discriminals.
1717 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1721 if Is_Constrained (Full_Type) then
1722 Arg := Duplicate_Subexpr_No_Checks (Arg);
1724 -- The constraints come from the discriminant default exps,
1725 -- they must be reevaluated, so we use New_Copy_Tree but we
1726 -- ensure the proper Sloc (for any embedded calls).
1727 -- In addition, if a predicate check is needed on the value
1728 -- of the discriminant, insert it ahead of the call.
1730 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1733 if Has_Predicates (Etype (Discr)) then
1734 Check_Predicated_Discriminant (Arg, Discr);
1738 -- Ada 2005 (AI-287): In case of default initialized components,
1739 -- if the component is constrained with a discriminant of the
1740 -- enclosing type, we need to generate the corresponding selected
1741 -- component node to access the discriminant value. In other cases
1742 -- this is not required, either because we are inside the init
1743 -- proc and we use the corresponding formal, or else because the
1744 -- component is constrained by an expression.
1746 if With_Default_Init
1747 and then Nkind (Id_Ref) = N_Selected_Component
1748 and then Nkind (Arg) = N_Identifier
1749 and then Ekind (Entity (Arg)) = E_Discriminant
1752 Make_Selected_Component (Loc,
1753 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1754 Selector_Name => Arg));
1756 Append_To (Args, Arg);
1759 Next_Discriminant (Discr);
1763 -- If this is a call to initialize the parent component of a derived
1764 -- tagged type, indicate that the tag should not be set in the parent.
1766 if Is_Tagged_Type (Full_Init_Type)
1767 and then not Is_CPP_Class (Full_Init_Type)
1768 and then Nkind (Id_Ref) = N_Selected_Component
1769 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1771 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1773 elsif Present (Constructor_Ref) then
1774 Append_List_To (Args,
1775 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1779 Make_Procedure_Call_Statement (Loc,
1780 Name => New_Occurrence_Of (Proc, Loc),
1781 Parameter_Associations => Args));
1783 if Needs_Finalization (Typ)
1784 and then Nkind (Id_Ref) = N_Selected_Component
1786 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1789 (Obj_Ref => New_Copy_Tree (First_Arg),
1792 -- Guard against a missing [Deep_]Initialize when the type was not
1795 if Present (Init_Call) then
1796 Append_To (Res, Init_Call);
1804 when RE_Not_Available =>
1806 end Build_Initialization_Call;
1808 ----------------------------
1809 -- Build_Record_Init_Proc --
1810 ----------------------------
1812 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1813 Decls : constant List_Id := New_List;
1814 Discr_Map : constant Elist_Id := New_Elmt_List;
1815 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1817 Proc_Id : Entity_Id;
1818 Rec_Type : Entity_Id;
1819 Set_Tag : Entity_Id := Empty;
1821 function Build_Assignment
1823 Default : Node_Id) return List_Id;
1824 -- Build an assignment statement that assigns the default expression to
1825 -- its corresponding record component if defined. The left-hand side of
1826 -- the assignment is marked Assignment_OK so that initialization of
1827 -- limited private records works correctly. This routine may also build
1828 -- an adjustment call if the component is controlled.
1830 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1831 -- If the record has discriminants, add assignment statements to
1832 -- Statement_List to initialize the discriminant values from the
1833 -- arguments of the initialization procedure.
1835 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1836 -- Build a list representing a sequence of statements which initialize
1837 -- components of the given component list. This may involve building
1838 -- case statements for the variant parts. Append any locally declared
1839 -- objects on list Decls.
1841 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1842 -- Given an untagged type-derivation that declares discriminants, e.g.
1844 -- type R (R1, R2 : Integer) is record ... end record;
1845 -- type D (D1 : Integer) is new R (1, D1);
1847 -- we make the _init_proc of D be
1849 -- procedure _init_proc (X : D; D1 : Integer) is
1851 -- _init_proc (R (X), 1, D1);
1854 -- This function builds the call statement in this _init_proc.
1856 procedure Build_CPP_Init_Procedure;
1857 -- Build the tree corresponding to the procedure specification and body
1858 -- of the IC procedure that initializes the C++ part of the dispatch
1859 -- table of an Ada tagged type that is a derivation of a CPP type.
1860 -- Install it as the CPP_Init TSS.
1862 procedure Build_Init_Procedure;
1863 -- Build the tree corresponding to the procedure specification and body
1864 -- of the initialization procedure and install it as the _init TSS.
1866 procedure Build_Offset_To_Top_Functions;
1867 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1868 -- and body of Offset_To_Top, a function used in conjuction with types
1869 -- having secondary dispatch tables.
1871 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1872 -- Add range checks to components of discriminated records. S is a
1873 -- subtype indication of a record component. Check_List is a list
1874 -- to which the check actions are appended.
1876 function Component_Needs_Simple_Initialization
1877 (T : Entity_Id) return Boolean;
1878 -- Determine if a component needs simple initialization, given its type
1879 -- T. This routine is the same as Needs_Simple_Initialization except for
1880 -- components of type Tag and Interface_Tag. These two access types do
1881 -- not require initialization since they are explicitly initialized by
1884 function Parent_Subtype_Renaming_Discrims return Boolean;
1885 -- Returns True for base types N that rename discriminants, else False
1887 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1888 -- Determine whether a record initialization procedure needs to be
1889 -- generated for the given record type.
1891 ----------------------
1892 -- Build_Assignment --
1893 ----------------------
1895 function Build_Assignment
1897 Default : Node_Id) return List_Id
1899 Default_Loc : constant Source_Ptr := Sloc (Default);
1900 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1903 Exp : Node_Id := Default;
1904 Kind : Node_Kind := Nkind (Default);
1908 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
1909 -- Analysis of the aggregate has replaced discriminants by their
1910 -- corresponding discriminals, but these are irrelevant when the
1911 -- component has a mutable type and is initialized with an aggregate.
1912 -- Instead, they must be replaced by the values supplied in the
1913 -- aggregate, that will be assigned during the expansion of the
1916 -----------------------
1917 -- Replace_Discr_Ref --
1918 -----------------------
1920 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
1924 if Is_Entity_Name (N)
1925 and then Present (Entity (N))
1926 and then Is_Formal (Entity (N))
1927 and then Present (Discriminal_Link (Entity (N)))
1930 Make_Selected_Component (Default_Loc,
1931 Prefix => New_Copy_Tree (Lhs),
1934 (Discriminal_Link (Entity (N)), Default_Loc));
1936 if Present (Val) then
1937 Rewrite (N, New_Copy_Tree (Val));
1942 end Replace_Discr_Ref;
1944 procedure Replace_Discriminant_References is
1945 new Traverse_Proc (Replace_Discr_Ref);
1947 -- Start of processing for Build_Assignment
1951 Make_Selected_Component (Default_Loc,
1952 Prefix => Make_Identifier (Loc, Name_uInit),
1953 Selector_Name => New_Occurrence_Of (Id, Default_Loc));
1954 Set_Assignment_OK (Lhs);
1956 if Nkind (Exp) = N_Aggregate
1957 and then Has_Discriminants (Typ)
1958 and then not Is_Constrained (Base_Type (Typ))
1960 -- The aggregate may provide new values for the discriminants
1961 -- of the component, and other components may depend on those
1962 -- discriminants. Previous analysis of those expressions have
1963 -- replaced the discriminants by the formals of the initialization
1964 -- procedure for the type, but these are irrelevant in the
1965 -- enclosing initialization procedure: those discriminant
1966 -- references must be replaced by the values provided in the
1969 Replace_Discriminant_References (Exp);
1972 -- Case of an access attribute applied to the current instance.
1973 -- Replace the reference to the type by a reference to the actual
1974 -- object. (Note that this handles the case of the top level of
1975 -- the expression being given by such an attribute, but does not
1976 -- cover uses nested within an initial value expression. Nested
1977 -- uses are unlikely to occur in practice, but are theoretically
1978 -- possible.) It is not clear how to handle them without fully
1979 -- traversing the expression. ???
1981 if Kind = N_Attribute_Reference
1982 and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
1983 Name_Unrestricted_Access)
1984 and then Is_Entity_Name (Prefix (Default))
1985 and then Is_Type (Entity (Prefix (Default)))
1986 and then Entity (Prefix (Default)) = Rec_Type
1989 Make_Attribute_Reference (Default_Loc,
1991 Make_Identifier (Default_Loc, Name_uInit),
1992 Attribute_Name => Name_Unrestricted_Access);
1995 -- Take a copy of Exp to ensure that later copies of this component
1996 -- declaration in derived types see the original tree, not a node
1997 -- rewritten during expansion of the init_proc. If the copy contains
1998 -- itypes, the scope of the new itypes is the init_proc being built.
2000 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
2003 Make_Assignment_Statement (Loc,
2005 Expression => Exp));
2007 Set_No_Ctrl_Actions (First (Res));
2009 -- Adjust the tag if tagged (because of possible view conversions).
2010 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2011 -- tags are represented implicitly in objects, and when the record is
2012 -- initialized with a raise expression.
2014 if Is_Tagged_Type (Typ)
2015 and then Tagged_Type_Expansion
2016 and then Nkind (Exp) /= N_Raise_Expression
2017 and then (Nkind (Exp) /= N_Qualified_Expression
2018 or else Nkind (Expression (Exp)) /= N_Raise_Expression)
2021 Make_Assignment_Statement (Default_Loc,
2023 Make_Selected_Component (Default_Loc,
2025 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
2028 (First_Tag_Component (Typ), Default_Loc)),
2031 Unchecked_Convert_To (RTE (RE_Tag),
2033 (Node (First_Elmt (Access_Disp_Table (Underlying_Type
2038 -- Adjust the component if controlled except if it is an aggregate
2039 -- that will be expanded inline.
2041 if Kind = N_Qualified_Expression then
2042 Kind := Nkind (Expression (Default));
2045 if Needs_Finalization (Typ)
2046 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
2047 and then not Is_Build_In_Place_Function_Call (Exp)
2051 (Obj_Ref => New_Copy_Tree (Lhs),
2054 -- Guard against a missing [Deep_]Adjust when the component type
2055 -- was not properly frozen.
2057 if Present (Adj_Call) then
2058 Append_To (Res, Adj_Call);
2062 -- If a component type has a predicate, add check to the component
2063 -- assignment. Discriminants are handled at the point of the call,
2064 -- which provides for a better error message.
2066 if Comes_From_Source (Exp)
2067 and then Has_Predicates (Typ)
2068 and then not Predicate_Checks_Suppressed (Empty)
2069 and then not Predicates_Ignored (Typ)
2071 Append (Make_Predicate_Check (Typ, Exp), Res);
2074 if Nkind (Exp) = N_Allocator
2075 and then Nkind (Expression (Exp)) = N_Qualified_Expression
2078 Subtype_Entity : constant Entity_Id
2079 := Entity (Subtype_Mark (Expression (Exp)));
2081 if Has_Predicates (Subtype_Entity) then
2082 Append (Make_Predicate_Check
2083 (Subtype_Entity, Expression (Expression (Exp))), Res);
2091 when RE_Not_Available =>
2093 end Build_Assignment;
2095 ------------------------------------
2096 -- Build_Discriminant_Assignments --
2097 ------------------------------------
2099 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
2100 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
2105 if Has_Discriminants (Rec_Type)
2106 and then not Is_Unchecked_Union (Rec_Type)
2108 D := First_Discriminant (Rec_Type);
2109 while Present (D) loop
2111 -- Don't generate the assignment for discriminants in derived
2112 -- tagged types if the discriminant is a renaming of some
2113 -- ancestor discriminant. This initialization will be done
2114 -- when initializing the _parent field of the derived record.
2117 and then Present (Corresponding_Discriminant (D))
2123 Append_List_To (Statement_List,
2124 Build_Assignment (D,
2125 New_Occurrence_Of (Discriminal (D), D_Loc)));
2128 Next_Discriminant (D);
2131 end Build_Discriminant_Assignments;
2133 --------------------------
2134 -- Build_Init_Call_Thru --
2135 --------------------------
2137 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
2138 Parent_Proc : constant Entity_Id :=
2139 Base_Init_Proc (Etype (Rec_Type));
2141 Parent_Type : constant Entity_Id :=
2142 Etype (First_Formal (Parent_Proc));
2144 Uparent_Type : constant Entity_Id :=
2145 Underlying_Type (Parent_Type);
2147 First_Discr_Param : Node_Id;
2151 First_Arg : Node_Id;
2152 Parent_Discr : Entity_Id;
2156 -- First argument (_Init) is the object to be initialized.
2157 -- ??? not sure where to get a reasonable Loc for First_Arg
2160 OK_Convert_To (Parent_Type,
2162 (Defining_Identifier (First (Parameters)), Loc));
2164 Set_Etype (First_Arg, Parent_Type);
2166 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
2168 -- In the tasks case,
2169 -- add _Master as the value of the _Master parameter
2170 -- add _Chain as the value of the _Chain parameter.
2171 -- add _Task_Name as the value of the _Task_Name parameter.
2172 -- At the outer level, these will be variables holding the
2173 -- corresponding values obtained from GNARL or the expander.
2175 -- At inner levels, they will be the parameters passed down through
2176 -- the outer routines.
2178 First_Discr_Param := Next (First (Parameters));
2180 if Has_Task (Rec_Type) then
2181 if Restriction_Active (No_Task_Hierarchy) then
2183 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
2185 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2188 -- Add _Chain (not done for sequential elaboration policy, see
2189 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2191 if Partition_Elaboration_Policy /= 'S' then
2192 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2195 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2196 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2199 -- Append discriminant values
2201 if Has_Discriminants (Uparent_Type) then
2202 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2204 Parent_Discr := First_Discriminant (Uparent_Type);
2205 while Present (Parent_Discr) loop
2207 -- Get the initial value for this discriminant
2208 -- ??? needs to be cleaned up to use parent_Discr_Constr
2212 Discr : Entity_Id :=
2213 First_Stored_Discriminant (Uparent_Type);
2215 Discr_Value : Elmt_Id :=
2216 First_Elmt (Stored_Constraint (Rec_Type));
2219 while Original_Record_Component (Parent_Discr) /= Discr loop
2220 Next_Stored_Discriminant (Discr);
2221 Next_Elmt (Discr_Value);
2224 Arg := Node (Discr_Value);
2227 -- Append it to the list
2229 if Nkind (Arg) = N_Identifier
2230 and then Ekind (Entity (Arg)) = E_Discriminant
2233 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2235 -- Case of access discriminants. We replace the reference
2236 -- to the type by a reference to the actual object.
2238 -- Is above comment right??? Use of New_Copy below seems mighty
2242 Append_To (Args, New_Copy (Arg));
2245 Next_Discriminant (Parent_Discr);
2251 Make_Procedure_Call_Statement (Loc,
2253 New_Occurrence_Of (Parent_Proc, Loc),
2254 Parameter_Associations => Args));
2257 end Build_Init_Call_Thru;
2259 -----------------------------------
2260 -- Build_Offset_To_Top_Functions --
2261 -----------------------------------
2263 procedure Build_Offset_To_Top_Functions is
2265 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2267 -- function Fxx (O : Address) return Storage_Offset is
2268 -- type Acc is access all <Typ>;
2270 -- return Acc!(O).Iface_Comp'Position;
2273 ----------------------------------
2274 -- Build_Offset_To_Top_Function --
2275 ----------------------------------
2277 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2278 Body_Node : Node_Id;
2279 Func_Id : Entity_Id;
2280 Spec_Node : Node_Id;
2281 Acc_Type : Entity_Id;
2284 Func_Id := Make_Temporary (Loc, 'F');
2285 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2288 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2290 Spec_Node := New_Node (N_Function_Specification, Loc);
2291 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2292 Set_Parameter_Specifications (Spec_Node, New_List (
2293 Make_Parameter_Specification (Loc,
2294 Defining_Identifier =>
2295 Make_Defining_Identifier (Loc, Name_uO),
2298 New_Occurrence_Of (RTE (RE_Address), Loc))));
2299 Set_Result_Definition (Spec_Node,
2300 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2303 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2305 -- return -O.Iface_Comp'Position;
2308 Body_Node := New_Node (N_Subprogram_Body, Loc);
2309 Set_Specification (Body_Node, Spec_Node);
2311 Acc_Type := Make_Temporary (Loc, 'T');
2312 Set_Declarations (Body_Node, New_List (
2313 Make_Full_Type_Declaration (Loc,
2314 Defining_Identifier => Acc_Type,
2316 Make_Access_To_Object_Definition (Loc,
2317 All_Present => True,
2318 Null_Exclusion_Present => False,
2319 Constant_Present => False,
2320 Subtype_Indication =>
2321 New_Occurrence_Of (Rec_Type, Loc)))));
2323 Set_Handled_Statement_Sequence (Body_Node,
2324 Make_Handled_Sequence_Of_Statements (Loc,
2325 Statements => New_List (
2326 Make_Simple_Return_Statement (Loc,
2329 Make_Attribute_Reference (Loc,
2331 Make_Selected_Component (Loc,
2333 Make_Explicit_Dereference (Loc,
2334 Unchecked_Convert_To (Acc_Type,
2335 Make_Identifier (Loc, Name_uO))),
2337 New_Occurrence_Of (Iface_Comp, Loc)),
2338 Attribute_Name => Name_Position))))));
2340 Set_Ekind (Func_Id, E_Function);
2341 Set_Mechanism (Func_Id, Default_Mechanism);
2342 Set_Is_Internal (Func_Id, True);
2344 if not Debug_Generated_Code then
2345 Set_Debug_Info_Off (Func_Id);
2348 Analyze (Body_Node);
2350 Append_Freeze_Action (Rec_Type, Body_Node);
2351 end Build_Offset_To_Top_Function;
2355 Iface_Comp : Node_Id;
2356 Iface_Comp_Elmt : Elmt_Id;
2357 Ifaces_Comp_List : Elist_Id;
2359 -- Start of processing for Build_Offset_To_Top_Functions
2362 -- Offset_To_Top_Functions are built only for derivations of types
2363 -- with discriminants that cover interface types.
2364 -- Nothing is needed either in case of virtual targets, since
2365 -- interfaces are handled directly by the target.
2367 if not Is_Tagged_Type (Rec_Type)
2368 or else Etype (Rec_Type) = Rec_Type
2369 or else not Has_Discriminants (Etype (Rec_Type))
2370 or else not Tagged_Type_Expansion
2375 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2377 -- For each interface type with secondary dispatch table we generate
2378 -- the Offset_To_Top_Functions (required to displace the pointer in
2379 -- interface conversions)
2381 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2382 while Present (Iface_Comp_Elmt) loop
2383 Iface_Comp := Node (Iface_Comp_Elmt);
2384 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2386 -- If the interface is a parent of Rec_Type it shares the primary
2387 -- dispatch table and hence there is no need to build the function
2389 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2390 Use_Full_View => True)
2392 Build_Offset_To_Top_Function (Iface_Comp);
2395 Next_Elmt (Iface_Comp_Elmt);
2397 end Build_Offset_To_Top_Functions;
2399 ------------------------------
2400 -- Build_CPP_Init_Procedure --
2401 ------------------------------
2403 procedure Build_CPP_Init_Procedure is
2404 Body_Node : Node_Id;
2405 Body_Stmts : List_Id;
2406 Flag_Id : Entity_Id;
2407 Handled_Stmt_Node : Node_Id;
2408 Init_Tags_List : List_Id;
2409 Proc_Id : Entity_Id;
2410 Proc_Spec_Node : Node_Id;
2413 -- Check cases requiring no IC routine
2415 if not Is_CPP_Class (Root_Type (Rec_Type))
2416 or else Is_CPP_Class (Rec_Type)
2417 or else CPP_Num_Prims (Rec_Type) = 0
2418 or else not Tagged_Type_Expansion
2419 or else No_Run_Time_Mode
2426 -- Flag : Boolean := False;
2428 -- procedure Typ_IC is
2431 -- Copy C++ dispatch table slots from parent
2432 -- Update C++ slots of overridden primitives
2436 Flag_Id := Make_Temporary (Loc, 'F');
2438 Append_Freeze_Action (Rec_Type,
2439 Make_Object_Declaration (Loc,
2440 Defining_Identifier => Flag_Id,
2441 Object_Definition =>
2442 New_Occurrence_Of (Standard_Boolean, Loc),
2444 New_Occurrence_Of (Standard_True, Loc)));
2446 Body_Stmts := New_List;
2447 Body_Node := New_Node (N_Subprogram_Body, Loc);
2449 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2452 Make_Defining_Identifier (Loc,
2453 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2455 Set_Ekind (Proc_Id, E_Procedure);
2456 Set_Is_Internal (Proc_Id);
2458 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2460 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2461 Set_Specification (Body_Node, Proc_Spec_Node);
2462 Set_Declarations (Body_Node, New_List);
2464 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2466 Append_To (Init_Tags_List,
2467 Make_Assignment_Statement (Loc,
2469 New_Occurrence_Of (Flag_Id, Loc),
2471 New_Occurrence_Of (Standard_False, Loc)));
2473 Append_To (Body_Stmts,
2474 Make_If_Statement (Loc,
2475 Condition => New_Occurrence_Of (Flag_Id, Loc),
2476 Then_Statements => Init_Tags_List));
2478 Handled_Stmt_Node :=
2479 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2480 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2481 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2482 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2484 if not Debug_Generated_Code then
2485 Set_Debug_Info_Off (Proc_Id);
2488 -- Associate CPP_Init_Proc with type
2490 Set_Init_Proc (Rec_Type, Proc_Id);
2491 end Build_CPP_Init_Procedure;
2493 --------------------------
2494 -- Build_Init_Procedure --
2495 --------------------------
2497 procedure Build_Init_Procedure is
2498 Body_Stmts : List_Id;
2499 Body_Node : Node_Id;
2500 Handled_Stmt_Node : Node_Id;
2501 Init_Tags_List : List_Id;
2502 Parameters : List_Id;
2503 Proc_Spec_Node : Node_Id;
2504 Record_Extension_Node : Node_Id;
2507 Body_Stmts := New_List;
2508 Body_Node := New_Node (N_Subprogram_Body, Loc);
2509 Set_Ekind (Proc_Id, E_Procedure);
2511 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2512 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2514 Parameters := Init_Formals (Rec_Type, Proc_Id);
2515 Append_List_To (Parameters,
2516 Build_Discriminant_Formals (Rec_Type, True));
2518 -- For tagged types, we add a flag to indicate whether the routine
2519 -- is called to initialize a parent component in the init_proc of
2520 -- a type extension. If the flag is false, we do not set the tag
2521 -- because it has been set already in the extension.
2523 if Is_Tagged_Type (Rec_Type) then
2524 Set_Tag := Make_Temporary (Loc, 'P');
2526 Append_To (Parameters,
2527 Make_Parameter_Specification (Loc,
2528 Defining_Identifier => Set_Tag,
2530 New_Occurrence_Of (Standard_Boolean, Loc),
2532 New_Occurrence_Of (Standard_True, Loc)));
2535 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2536 Set_Specification (Body_Node, Proc_Spec_Node);
2537 Set_Declarations (Body_Node, Decls);
2539 -- N is a Derived_Type_Definition that renames the parameters of the
2540 -- ancestor type. We initialize it by expanding our discriminants and
2541 -- call the ancestor _init_proc with a type-converted object.
2543 if Parent_Subtype_Renaming_Discrims then
2544 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2546 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2547 Build_Discriminant_Assignments (Body_Stmts);
2549 if not Null_Present (Type_Definition (N)) then
2550 Append_List_To (Body_Stmts,
2551 Build_Init_Statements (Component_List (Type_Definition (N))));
2554 -- N is a Derived_Type_Definition with a possible non-empty
2555 -- extension. The initialization of a type extension consists in the
2556 -- initialization of the components in the extension.
2559 Build_Discriminant_Assignments (Body_Stmts);
2561 Record_Extension_Node :=
2562 Record_Extension_Part (Type_Definition (N));
2564 if not Null_Present (Record_Extension_Node) then
2566 Stmts : constant List_Id :=
2567 Build_Init_Statements (
2568 Component_List (Record_Extension_Node));
2571 -- The parent field must be initialized first because the
2572 -- offset of the new discriminants may depend on it. This is
2573 -- not needed if the parent is an interface type because in
2574 -- such case the initialization of the _parent field was not
2577 if not Is_Interface (Etype (Rec_Ent)) then
2579 Parent_IP : constant Name_Id :=
2580 Make_Init_Proc_Name (Etype (Rec_Ent));
2586 -- Look for a call to the parent IP at the beginning
2587 -- of Stmts associated with the record extension
2589 Stmt := First (Stmts);
2591 while Present (Stmt) loop
2592 if Nkind (Stmt) = N_Procedure_Call_Statement
2593 and then Chars (Name (Stmt)) = Parent_IP
2602 -- If found then move it to the beginning of the
2603 -- statements of this IP routine
2605 if Present (IP_Call) then
2606 IP_Stmts := New_List;
2608 Stmt := Remove_Head (Stmts);
2609 Append_To (IP_Stmts, Stmt);
2610 exit when Stmt = IP_Call;
2613 Prepend_List_To (Body_Stmts, IP_Stmts);
2618 Append_List_To (Body_Stmts, Stmts);
2623 -- Add here the assignment to instantiate the Tag
2625 -- The assignment corresponds to the code:
2627 -- _Init._Tag := Typ'Tag;
2629 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2630 -- tags are represented implicitly in objects. It is also suppressed
2631 -- in case of CPP_Class types because in this case the tag is
2632 -- initialized in the C++ side.
2634 if Is_Tagged_Type (Rec_Type)
2635 and then Tagged_Type_Expansion
2636 and then not No_Run_Time_Mode
2638 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2639 -- the actual object and invoke the IP of the parent (in this
2640 -- order). The tag must be initialized before the call to the IP
2641 -- of the parent and the assignments to other components because
2642 -- the initial value of the components may depend on the tag (eg.
2643 -- through a dispatching operation on an access to the current
2644 -- type). The tag assignment is not done when initializing the
2645 -- parent component of a type extension, because in that case the
2646 -- tag is set in the extension.
2648 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2650 -- Initialize the primary tag component
2652 Init_Tags_List := New_List (
2653 Make_Assignment_Statement (Loc,
2655 Make_Selected_Component (Loc,
2656 Prefix => Make_Identifier (Loc, Name_uInit),
2659 (First_Tag_Component (Rec_Type), Loc)),
2663 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2665 -- Ada 2005 (AI-251): Initialize the secondary tags components
2666 -- located at fixed positions (tags whose position depends on
2667 -- variable size components are initialized later ---see below)
2669 if Ada_Version >= Ada_2005
2670 and then not Is_Interface (Rec_Type)
2671 and then Has_Interfaces (Rec_Type)
2674 Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
2675 Elab_List : List_Id := New_List;
2680 Target => Make_Identifier (Loc, Name_uInit),
2681 Init_Tags_List => Init_Tags_List,
2682 Stmts_List => Elab_Sec_DT_Stmts_List,
2683 Fixed_Comps => True,
2684 Variable_Comps => False);
2686 Elab_List := New_List (
2687 Make_If_Statement (Loc,
2688 Condition => New_Occurrence_Of (Set_Tag, Loc),
2689 Then_Statements => Init_Tags_List));
2691 if Elab_Flag_Needed (Rec_Type) then
2692 Append_To (Elab_Sec_DT_Stmts_List,
2693 Make_Assignment_Statement (Loc,
2696 (Access_Disp_Table_Elab_Flag (Rec_Type),
2699 New_Occurrence_Of (Standard_False, Loc)));
2701 Append_To (Elab_List,
2702 Make_If_Statement (Loc,
2705 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2706 Then_Statements => Elab_Sec_DT_Stmts_List));
2709 Prepend_List_To (Body_Stmts, Elab_List);
2712 Prepend_To (Body_Stmts,
2713 Make_If_Statement (Loc,
2714 Condition => New_Occurrence_Of (Set_Tag, Loc),
2715 Then_Statements => Init_Tags_List));
2718 -- Case 2: CPP type. The imported C++ constructor takes care of
2719 -- tags initialization. No action needed here because the IP
2720 -- is built by Set_CPP_Constructors; in this case the IP is a
2721 -- wrapper that invokes the C++ constructor and copies the C++
2722 -- tags locally. Done to inherit the C++ slots in Ada derivations
2725 elsif Is_CPP_Class (Rec_Type) then
2726 pragma Assert (False);
2729 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2730 -- type derivations. Derivations of imported C++ classes add a
2731 -- complication, because we cannot inhibit tag setting in the
2732 -- constructor for the parent. Hence we initialize the tag after
2733 -- the call to the parent IP (that is, in reverse order compared
2734 -- with pure Ada hierarchies ---see comment on case 1).
2737 -- Initialize the primary tag
2739 Init_Tags_List := New_List (
2740 Make_Assignment_Statement (Loc,
2742 Make_Selected_Component (Loc,
2743 Prefix => Make_Identifier (Loc, Name_uInit),
2746 (First_Tag_Component (Rec_Type), Loc)),
2750 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2752 -- Ada 2005 (AI-251): Initialize the secondary tags components
2753 -- located at fixed positions (tags whose position depends on
2754 -- variable size components are initialized later ---see below)
2756 if Ada_Version >= Ada_2005
2757 and then not Is_Interface (Rec_Type)
2758 and then Has_Interfaces (Rec_Type)
2762 Target => Make_Identifier (Loc, Name_uInit),
2763 Init_Tags_List => Init_Tags_List,
2764 Stmts_List => Init_Tags_List,
2765 Fixed_Comps => True,
2766 Variable_Comps => False);
2769 -- Initialize the tag component after invocation of parent IP.
2772 -- parent_IP(_init.parent); // Invokes the C++ constructor
2773 -- [ typIC; ] // Inherit C++ slots from parent
2780 -- Search for the call to the IP of the parent. We assume
2781 -- that the first init_proc call is for the parent.
2783 Ins_Nod := First (Body_Stmts);
2784 while Present (Next (Ins_Nod))
2785 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2786 or else not Is_Init_Proc (Name (Ins_Nod)))
2791 -- The IC routine copies the inherited slots of the C+ part
2792 -- of the dispatch table from the parent and updates the
2793 -- overridden C++ slots.
2795 if CPP_Num_Prims (Rec_Type) > 0 then
2797 Init_DT : Entity_Id;
2801 Init_DT := CPP_Init_Proc (Rec_Type);
2802 pragma Assert (Present (Init_DT));
2805 Make_Procedure_Call_Statement (Loc,
2806 New_Occurrence_Of (Init_DT, Loc));
2807 Insert_After (Ins_Nod, New_Nod);
2809 -- Update location of init tag statements
2815 Insert_List_After (Ins_Nod, Init_Tags_List);
2819 -- Ada 2005 (AI-251): Initialize the secondary tag components
2820 -- located at variable positions. We delay the generation of this
2821 -- code until here because the value of the attribute 'Position
2822 -- applied to variable size components of the parent type that
2823 -- depend on discriminants is only safely read at runtime after
2824 -- the parent components have been initialized.
2826 if Ada_Version >= Ada_2005
2827 and then not Is_Interface (Rec_Type)
2828 and then Has_Interfaces (Rec_Type)
2829 and then Has_Discriminants (Etype (Rec_Type))
2830 and then Is_Variable_Size_Record (Etype (Rec_Type))
2832 Init_Tags_List := New_List;
2836 Target => Make_Identifier (Loc, Name_uInit),
2837 Init_Tags_List => Init_Tags_List,
2838 Stmts_List => Init_Tags_List,
2839 Fixed_Comps => False,
2840 Variable_Comps => True);
2842 if Is_Non_Empty_List (Init_Tags_List) then
2843 Append_List_To (Body_Stmts, Init_Tags_List);
2848 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2849 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2852 -- Deep_Finalize (_init, C1, ..., CN);
2856 and then Needs_Finalization (Rec_Type)
2857 and then not Is_Abstract_Type (Rec_Type)
2858 and then not Restriction_Active (No_Exception_Propagation)
2865 -- Create a local version of Deep_Finalize which has indication
2866 -- of partial initialization state.
2869 Make_Defining_Identifier (Loc,
2870 Chars => New_External_Name (Name_uFinalizer));
2872 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2875 Make_Procedure_Call_Statement (Loc,
2876 Name => New_Occurrence_Of (DF_Id, Loc),
2877 Parameter_Associations => New_List (
2878 Make_Identifier (Loc, Name_uInit),
2879 New_Occurrence_Of (Standard_False, Loc)));
2881 -- Do not emit warnings related to the elaboration order when a
2882 -- controlled object is declared before the body of Finalize is
2885 if Legacy_Elaboration_Checks then
2886 Set_No_Elaboration_Check (DF_Call);
2889 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2890 Make_Exception_Handler (Loc,
2891 Exception_Choices => New_List (
2892 Make_Others_Choice (Loc)),
2893 Statements => New_List (
2895 Make_Raise_Statement (Loc)))));
2898 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2901 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2903 if not Debug_Generated_Code then
2904 Set_Debug_Info_Off (Proc_Id);
2907 -- Associate Init_Proc with type, and determine if the procedure
2908 -- is null (happens because of the Initialize_Scalars pragma case,
2909 -- where we have to generate a null procedure in case it is called
2910 -- by a client with Initialize_Scalars set). Such procedures have
2911 -- to be generated, but do not have to be called, so we mark them
2912 -- as null to suppress the call. Kill also warnings for the _Init
2913 -- out parameter, which is left entirely uninitialized.
2915 Set_Init_Proc (Rec_Type, Proc_Id);
2917 if Is_Null_Statement_List (Body_Stmts) then
2918 Set_Is_Null_Init_Proc (Proc_Id);
2919 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
2921 end Build_Init_Procedure;
2923 ---------------------------
2924 -- Build_Init_Statements --
2925 ---------------------------
2927 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2928 Checks : constant List_Id := New_List;
2929 Actions : List_Id := No_List;
2930 Counter_Id : Entity_Id := Empty;
2931 Comp_Loc : Source_Ptr;
2933 Has_Late_Init_Comp : Boolean;
2935 Parent_Stmts : List_Id;
2939 procedure Increment_Counter (Loc : Source_Ptr);
2940 -- Generate an "increment by one" statement for the current counter
2941 -- and append it to the list Stmts.
2943 procedure Make_Counter (Loc : Source_Ptr);
2944 -- Create a new counter for the current component list. The routine
2945 -- creates a new defining Id, adds an object declaration and sets
2946 -- the Id generator for the next variant.
2948 function Requires_Late_Initialization
2950 Rec_Type : Entity_Id) return Boolean;
2951 -- Return whether the given Decl requires late initialization, as
2952 -- defined by 3.3.1 (8.1/5).
2954 -----------------------
2955 -- Increment_Counter --
2956 -----------------------
2958 procedure Increment_Counter (Loc : Source_Ptr) is
2961 -- Counter := Counter + 1;
2964 Make_Assignment_Statement (Loc,
2965 Name => New_Occurrence_Of (Counter_Id, Loc),
2968 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
2969 Right_Opnd => Make_Integer_Literal (Loc, 1))));
2970 end Increment_Counter;
2976 procedure Make_Counter (Loc : Source_Ptr) is
2978 -- Increment the Id generator
2980 Counter := Counter + 1;
2982 -- Create the entity and declaration
2985 Make_Defining_Identifier (Loc,
2986 Chars => New_External_Name ('C', Counter));
2989 -- Cnn : Integer := 0;
2992 Make_Object_Declaration (Loc,
2993 Defining_Identifier => Counter_Id,
2994 Object_Definition =>
2995 New_Occurrence_Of (Standard_Integer, Loc),
2997 Make_Integer_Literal (Loc, 0)));
3000 ----------------------------------
3001 -- Requires_Late_Initialization --
3002 ----------------------------------
3004 function Requires_Late_Initialization
3006 Rec_Type : Entity_Id) return Boolean
3008 References_Current_Instance : Boolean := False;
3009 Has_Access_Discriminant : Boolean := False;
3010 Has_Internal_Call : Boolean := False;
3012 function Find_Access_Discriminant
3013 (N : Node_Id) return Traverse_Result;
3014 -- Look for a name denoting an access discriminant
3016 function Find_Current_Instance
3017 (N : Node_Id) return Traverse_Result;
3018 -- Look for a reference to the current instance of the type
3020 function Find_Internal_Call
3021 (N : Node_Id) return Traverse_Result;
3022 -- Look for an internal protected function call
3024 ------------------------------
3025 -- Find_Access_Discriminant --
3026 ------------------------------
3028 function Find_Access_Discriminant
3029 (N : Node_Id) return Traverse_Result is
3031 if Is_Entity_Name (N)
3032 and then Denotes_Discriminant (N)
3033 and then Is_Access_Type (Etype (N))
3035 Has_Access_Discriminant := True;
3040 end Find_Access_Discriminant;
3042 ---------------------------
3043 -- Find_Current_Instance --
3044 ---------------------------
3046 function Find_Current_Instance
3047 (N : Node_Id) return Traverse_Result is
3049 if Nkind (N) = N_Attribute_Reference
3050 and then Is_Access_Type (Etype (N))
3051 and then Is_Entity_Name (Prefix (N))
3052 and then Is_Type (Entity (Prefix (N)))
3054 References_Current_Instance := True;
3059 end Find_Current_Instance;
3061 ------------------------
3062 -- Find_Internal_Call --
3063 ------------------------
3065 function Find_Internal_Call (N : Node_Id) return Traverse_Result is
3067 function Call_Scope (N : Node_Id) return Entity_Id;
3068 -- Return the scope enclosing a given call node N
3074 function Call_Scope (N : Node_Id) return Entity_Id is
3075 Nam : constant Node_Id := Name (N);
3077 if Nkind (Nam) = N_Selected_Component then
3078 return Scope (Entity (Prefix (Nam)));
3080 return Scope (Entity (Nam));
3085 if Nkind (N) = N_Function_Call
3086 and then Call_Scope (N)
3087 = Corresponding_Concurrent_Type (Rec_Type)
3089 Has_Internal_Call := True;
3094 end Find_Internal_Call;
3096 procedure Search_Access_Discriminant is new
3097 Traverse_Proc (Find_Access_Discriminant);
3099 procedure Search_Current_Instance is new
3100 Traverse_Proc (Find_Current_Instance);
3102 procedure Search_Internal_Call is new
3103 Traverse_Proc (Find_Internal_Call);
3106 -- A component of an object is said to require late initialization
3109 -- it has an access discriminant value constrained by a per-object
3112 if Has_Access_Constraint (Defining_Identifier (Decl))
3113 and then No (Expression (Decl))
3117 elsif Present (Expression (Decl)) then
3119 -- it has an initialization expression that includes a name
3120 -- denoting an access discriminant;
3122 Search_Access_Discriminant (Expression (Decl));
3124 if Has_Access_Discriminant then
3128 -- or it has an initialization expression that includes a
3129 -- reference to the current instance of the type either by
3132 Search_Current_Instance (Expression (Decl));
3134 if References_Current_Instance then
3138 -- ...or implicitly as the target object of a call.
3140 if Is_Protected_Record_Type (Rec_Type) then
3141 Search_Internal_Call (Expression (Decl));
3143 if Has_Internal_Call then
3150 end Requires_Late_Initialization;
3152 -- Start of processing for Build_Init_Statements
3155 if Null_Present (Comp_List) then
3156 return New_List (Make_Null_Statement (Loc));
3159 Parent_Stmts := New_List;
3162 -- Loop through visible declarations of task types and protected
3163 -- types moving any expanded code from the spec to the body of the
3166 if Is_Task_Record_Type (Rec_Type)
3167 or else Is_Protected_Record_Type (Rec_Type)
3170 Decl : constant Node_Id :=
3171 Parent (Corresponding_Concurrent_Type (Rec_Type));
3177 if Is_Task_Record_Type (Rec_Type) then
3178 Def := Task_Definition (Decl);
3180 Def := Protected_Definition (Decl);
3183 if Present (Def) then
3184 N1 := First (Visible_Declarations (Def));
3185 while Present (N1) loop
3189 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
3190 or else Nkind (N2) in N_Raise_xxx_Error
3191 or else Nkind (N2) = N_Procedure_Call_Statement
3194 New_Copy_Tree (N2, New_Scope => Proc_Id));
3195 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
3203 -- Loop through components, skipping pragmas, in 2 steps. The first
3204 -- step deals with regular components. The second step deals with
3205 -- components that require late initialization.
3207 Has_Late_Init_Comp := False;
3209 -- First pass : regular components
3211 Decl := First_Non_Pragma (Component_Items (Comp_List));
3212 while Present (Decl) loop
3213 Comp_Loc := Sloc (Decl);
3215 (Subtype_Indication (Component_Definition (Decl)), Checks);
3217 Id := Defining_Identifier (Decl);
3220 -- Leave any processing of component requiring late initialization
3221 -- for the second pass.
3223 if Requires_Late_Initialization (Decl, Rec_Type) then
3224 Has_Late_Init_Comp := True;
3226 -- Regular component cases
3229 -- In the context of the init proc, references to discriminants
3230 -- resolve to denote the discriminals: this is where we can
3231 -- freeze discriminant dependent component subtypes.
3233 if not Is_Frozen (Typ) then
3234 Append_List_To (Stmts, Freeze_Entity (Typ, N));
3237 -- Explicit initialization
3239 if Present (Expression (Decl)) then
3240 if Is_CPP_Constructor_Call (Expression (Decl)) then
3242 Build_Initialization_Call
3245 Make_Selected_Component (Comp_Loc,
3247 Make_Identifier (Comp_Loc, Name_uInit),
3249 New_Occurrence_Of (Id, Comp_Loc)),
3251 In_Init_Proc => True,
3252 Enclos_Type => Rec_Type,
3253 Discr_Map => Discr_Map,
3254 Constructor_Ref => Expression (Decl));
3256 Actions := Build_Assignment (Id, Expression (Decl));
3259 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3260 -- components are filled in with the corresponding rep-item
3261 -- expression of the concurrent type (if any).
3263 elsif Ekind (Scope (Id)) = E_Record_Type
3264 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
3265 and then Nam_In (Chars (Id), Name_uCPU,
3266 Name_uDispatching_Domain,
3268 Name_uSecondary_Stack_Size)
3273 pragma Warnings (Off, Nam);
3277 if Chars (Id) = Name_uCPU then
3280 elsif Chars (Id) = Name_uDispatching_Domain then
3281 Nam := Name_Dispatching_Domain;
3283 elsif Chars (Id) = Name_uPriority then
3284 Nam := Name_Priority;
3286 elsif Chars (Id) = Name_uSecondary_Stack_Size then
3287 Nam := Name_Secondary_Stack_Size;
3290 -- Get the Rep Item (aspect specification, attribute
3291 -- definition clause or pragma) of the corresponding
3296 (Corresponding_Concurrent_Type (Scope (Id)),
3298 Check_Parents => False);
3300 if Present (Ritem) then
3304 if Nkind (Ritem) = N_Pragma then
3305 Exp := First (Pragma_Argument_Associations (Ritem));
3307 if Nkind (Exp) = N_Pragma_Argument_Association then
3308 Exp := Expression (Exp);
3311 -- Conversion for Priority expression
3313 if Nam = Name_Priority then
3314 if Pragma_Name (Ritem) = Name_Priority
3315 and then not GNAT_Mode
3317 Exp := Convert_To (RTE (RE_Priority), Exp);
3320 Convert_To (RTE (RE_Any_Priority), Exp);
3324 -- Aspect/Attribute definition clause case
3327 Exp := Expression (Ritem);
3329 -- Conversion for Priority expression
3331 if Nam = Name_Priority then
3332 if Chars (Ritem) = Name_Priority
3333 and then not GNAT_Mode
3335 Exp := Convert_To (RTE (RE_Priority), Exp);
3338 Convert_To (RTE (RE_Any_Priority), Exp);
3343 -- Conversion for Dispatching_Domain value
3345 if Nam = Name_Dispatching_Domain then
3347 Unchecked_Convert_To
3348 (RTE (RE_Dispatching_Domain_Access), Exp);
3350 -- Conversion for Secondary_Stack_Size value
3352 elsif Nam = Name_Secondary_Stack_Size then
3353 Exp := Convert_To (RTE (RE_Size_Type), Exp);
3356 Actions := Build_Assignment (Id, Exp);
3358 -- Nothing needed if no Rep Item
3365 -- Composite component with its own Init_Proc
3367 elsif not Is_Interface (Typ)
3368 and then Has_Non_Null_Base_Init_Proc (Typ)
3371 Build_Initialization_Call
3373 Make_Selected_Component (Comp_Loc,
3375 Make_Identifier (Comp_Loc, Name_uInit),
3376 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3378 In_Init_Proc => True,
3379 Enclos_Type => Rec_Type,
3380 Discr_Map => Discr_Map);
3382 Clean_Task_Names (Typ, Proc_Id);
3384 -- Simple initialization
3386 elsif Component_Needs_Simple_Initialization (Typ) then
3394 Size => Esize (Id)));
3396 -- Nothing needed for this case
3402 if Present (Checks) then
3403 if Chars (Id) = Name_uParent then
3404 Append_List_To (Parent_Stmts, Checks);
3406 Append_List_To (Stmts, Checks);
3410 if Present (Actions) then
3411 if Chars (Id) = Name_uParent then
3412 Append_List_To (Parent_Stmts, Actions);
3415 Append_List_To (Stmts, Actions);
3417 -- Preserve initialization state in the current counter
3419 if Needs_Finalization (Typ) then
3420 if No (Counter_Id) then
3421 Make_Counter (Comp_Loc);
3424 Increment_Counter (Comp_Loc);
3430 Next_Non_Pragma (Decl);
3433 -- The parent field must be initialized first because variable
3434 -- size components of the parent affect the location of all the
3437 Prepend_List_To (Stmts, Parent_Stmts);
3439 -- Set up tasks and protected object support. This needs to be done
3440 -- before any component with a per-object access discriminant
3441 -- constraint, or any variant part (which may contain such
3442 -- components) is initialized, because the initialization of these
3443 -- components may reference the enclosing concurrent object.
3445 -- For a task record type, add the task create call and calls to bind
3446 -- any interrupt (signal) entries.
3448 if Is_Task_Record_Type (Rec_Type) then
3450 -- In the case of the restricted run time the ATCB has already
3451 -- been preallocated.
3453 if Restricted_Profile then
3455 Make_Assignment_Statement (Loc,
3457 Make_Selected_Component (Loc,
3458 Prefix => Make_Identifier (Loc, Name_uInit),
3459 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3461 Make_Attribute_Reference (Loc,
3463 Make_Selected_Component (Loc,
3464 Prefix => Make_Identifier (Loc, Name_uInit),
3465 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3466 Attribute_Name => Name_Unchecked_Access)));
3469 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3472 Task_Type : constant Entity_Id :=
3473 Corresponding_Concurrent_Type (Rec_Type);
3474 Task_Decl : constant Node_Id := Parent (Task_Type);
3475 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3476 Decl_Loc : Source_Ptr;
3481 if Present (Task_Def) then
3482 Vis_Decl := First (Visible_Declarations (Task_Def));
3483 while Present (Vis_Decl) loop
3484 Decl_Loc := Sloc (Vis_Decl);
3486 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3487 if Get_Attribute_Id (Chars (Vis_Decl)) =
3490 Ent := Entity (Name (Vis_Decl));
3492 if Ekind (Ent) = E_Entry then
3494 Make_Procedure_Call_Statement (Decl_Loc,
3496 New_Occurrence_Of (RTE (
3497 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3498 Parameter_Associations => New_List (
3499 Make_Selected_Component (Decl_Loc,
3501 Make_Identifier (Decl_Loc, Name_uInit),
3504 (Decl_Loc, Name_uTask_Id)),
3505 Entry_Index_Expression
3506 (Decl_Loc, Ent, Empty, Task_Type),
3507 Expression (Vis_Decl))));
3518 -- For a protected type, add statements generated by
3519 -- Make_Initialize_Protection.
3521 if Is_Protected_Record_Type (Rec_Type) then
3522 Append_List_To (Stmts,
3523 Make_Initialize_Protection (Rec_Type));
3526 -- Second pass: components that require late initialization
3528 if Has_Late_Init_Comp then
3529 Decl := First_Non_Pragma (Component_Items (Comp_List));
3530 while Present (Decl) loop
3531 Comp_Loc := Sloc (Decl);
3532 Id := Defining_Identifier (Decl);
3535 if Requires_Late_Initialization (Decl, Rec_Type) then
3536 if Present (Expression (Decl)) then
3537 Append_List_To (Stmts,
3538 Build_Assignment (Id, Expression (Decl)));
3540 elsif Has_Non_Null_Base_Init_Proc (Typ) then
3541 Append_List_To (Stmts,
3542 Build_Initialization_Call (Comp_Loc,
3543 Make_Selected_Component (Comp_Loc,
3545 Make_Identifier (Comp_Loc, Name_uInit),
3546 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3548 In_Init_Proc => True,
3549 Enclos_Type => Rec_Type,
3550 Discr_Map => Discr_Map));
3552 Clean_Task_Names (Typ, Proc_Id);
3554 -- Preserve initialization state in the current counter
3556 if Needs_Finalization (Typ) then
3557 if No (Counter_Id) then
3558 Make_Counter (Comp_Loc);
3561 Increment_Counter (Comp_Loc);
3563 elsif Component_Needs_Simple_Initialization (Typ) then
3564 Append_List_To (Stmts,
3571 Size => Esize (Id))));
3575 Next_Non_Pragma (Decl);
3579 -- Process the variant part
3581 if Present (Variant_Part (Comp_List)) then
3583 Variant_Alts : constant List_Id := New_List;
3584 Var_Loc : Source_Ptr := No_Location;
3589 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3590 while Present (Variant) loop
3591 Var_Loc := Sloc (Variant);
3592 Append_To (Variant_Alts,
3593 Make_Case_Statement_Alternative (Var_Loc,
3595 New_Copy_List (Discrete_Choices (Variant)),
3597 Build_Init_Statements (Component_List (Variant))));
3598 Next_Non_Pragma (Variant);
3601 -- The expression of the case statement which is a reference
3602 -- to one of the discriminants is replaced by the appropriate
3603 -- formal parameter of the initialization procedure.
3606 Make_Case_Statement (Var_Loc,
3608 New_Occurrence_Of (Discriminal (
3609 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3610 Alternatives => Variant_Alts));
3614 -- If no initializations when generated for component declarations
3615 -- corresponding to this Stmts, append a null statement to Stmts to
3616 -- to make it a valid Ada tree.
3618 if Is_Empty_List (Stmts) then
3619 Append (Make_Null_Statement (Loc), Stmts);
3625 when RE_Not_Available =>
3627 end Build_Init_Statements;
3629 -------------------------
3630 -- Build_Record_Checks --
3631 -------------------------
3633 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3634 Subtype_Mark_Id : Entity_Id;
3636 procedure Constrain_Array
3638 Check_List : List_Id);
3639 -- Apply a list of index constraints to an unconstrained array type.
3640 -- The first parameter is the entity for the resulting subtype.
3641 -- Check_List is a list to which the check actions are appended.
3643 ---------------------
3644 -- Constrain_Array --
3645 ---------------------
3647 procedure Constrain_Array
3649 Check_List : List_Id)
3651 C : constant Node_Id := Constraint (SI);
3652 Number_Of_Constraints : Nat := 0;
3656 procedure Constrain_Index
3659 Check_List : List_Id);
3660 -- Process an index constraint in a constrained array declaration.
3661 -- The constraint can be either a subtype name or a range with or
3662 -- without an explicit subtype mark. Index is the corresponding
3663 -- index of the unconstrained array. S is the range expression.
3664 -- Check_List is a list to which the check actions are appended.
3666 ---------------------
3667 -- Constrain_Index --
3668 ---------------------
3670 procedure Constrain_Index
3673 Check_List : List_Id)
3675 T : constant Entity_Id := Etype (Index);
3678 if Nkind (S) = N_Range then
3679 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3681 end Constrain_Index;
3683 -- Start of processing for Constrain_Array
3686 T := Entity (Subtype_Mark (SI));
3688 if Is_Access_Type (T) then
3689 T := Designated_Type (T);
3692 S := First (Constraints (C));
3693 while Present (S) loop
3694 Number_Of_Constraints := Number_Of_Constraints + 1;
3698 -- In either case, the index constraint must provide a discrete
3699 -- range for each index of the array type and the type of each
3700 -- discrete range must be the same as that of the corresponding
3701 -- index. (RM 3.6.1)
3703 S := First (Constraints (C));
3704 Index := First_Index (T);
3707 -- Apply constraints to each index type
3709 for J in 1 .. Number_Of_Constraints loop
3710 Constrain_Index (Index, S, Check_List);
3714 end Constrain_Array;
3716 -- Start of processing for Build_Record_Checks
3719 if Nkind (S) = N_Subtype_Indication then
3720 Find_Type (Subtype_Mark (S));
3721 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3723 -- Remaining processing depends on type
3725 case Ekind (Subtype_Mark_Id) is
3727 Constrain_Array (S, Check_List);
3733 end Build_Record_Checks;
3735 -------------------------------------------
3736 -- Component_Needs_Simple_Initialization --
3737 -------------------------------------------
3739 function Component_Needs_Simple_Initialization
3740 (T : Entity_Id) return Boolean
3744 Needs_Simple_Initialization (T)
3745 and then not Is_RTE (T, RE_Tag)
3747 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3749 and then not Is_RTE (T, RE_Interface_Tag);
3750 end Component_Needs_Simple_Initialization;
3752 --------------------------------------
3753 -- Parent_Subtype_Renaming_Discrims --
3754 --------------------------------------
3756 function Parent_Subtype_Renaming_Discrims return Boolean is
3761 if Base_Type (Rec_Ent) /= Rec_Ent then
3765 if Etype (Rec_Ent) = Rec_Ent
3766 or else not Has_Discriminants (Rec_Ent)
3767 or else Is_Constrained (Rec_Ent)
3768 or else Is_Tagged_Type (Rec_Ent)
3773 -- If there are no explicit stored discriminants we have inherited
3774 -- the root type discriminants so far, so no renamings occurred.
3776 if First_Discriminant (Rec_Ent) =
3777 First_Stored_Discriminant (Rec_Ent)
3782 -- Check if we have done some trivial renaming of the parent
3783 -- discriminants, i.e. something like
3785 -- type DT (X1, X2: int) is new PT (X1, X2);
3787 De := First_Discriminant (Rec_Ent);
3788 Dp := First_Discriminant (Etype (Rec_Ent));
3789 while Present (De) loop
3790 pragma Assert (Present (Dp));
3792 if Corresponding_Discriminant (De) /= Dp then
3796 Next_Discriminant (De);
3797 Next_Discriminant (Dp);
3800 return Present (Dp);
3801 end Parent_Subtype_Renaming_Discrims;
3803 ------------------------
3804 -- Requires_Init_Proc --
3805 ------------------------
3807 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3808 Comp_Decl : Node_Id;
3813 -- Definitely do not need one if specifically suppressed
3815 if Initialization_Suppressed (Rec_Id) then
3819 -- If it is a type derived from a type with unknown discriminants,
3820 -- we cannot build an initialization procedure for it.
3822 if Has_Unknown_Discriminants (Rec_Id)
3823 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3828 -- Otherwise we need to generate an initialization procedure if
3829 -- Is_CPP_Class is False and at least one of the following applies:
3831 -- 1. Discriminants are present, since they need to be initialized
3832 -- with the appropriate discriminant constraint expressions.
3833 -- However, the discriminant of an unchecked union does not
3834 -- count, since the discriminant is not present.
3836 -- 2. The type is a tagged type, since the implicit Tag component
3837 -- needs to be initialized with a pointer to the dispatch table.
3839 -- 3. The type contains tasks
3841 -- 4. One or more components has an initial value
3843 -- 5. One or more components is for a type which itself requires
3844 -- an initialization procedure.
3846 -- 6. One or more components is a type that requires simple
3847 -- initialization (see Needs_Simple_Initialization), except
3848 -- that types Tag and Interface_Tag are excluded, since fields
3849 -- of these types are initialized by other means.
3851 -- 7. The type is the record type built for a task type (since at
3852 -- the very least, Create_Task must be called)
3854 -- 8. The type is the record type built for a protected type (since
3855 -- at least Initialize_Protection must be called)
3857 -- 9. The type is marked as a public entity. The reason we add this
3858 -- case (even if none of the above apply) is to properly handle
3859 -- Initialize_Scalars. If a package is compiled without an IS
3860 -- pragma, and the client is compiled with an IS pragma, then
3861 -- the client will think an initialization procedure is present
3862 -- and call it, when in fact no such procedure is required, but
3863 -- since the call is generated, there had better be a routine
3864 -- at the other end of the call, even if it does nothing).
3866 -- Note: the reason we exclude the CPP_Class case is because in this
3867 -- case the initialization is performed by the C++ constructors, and
3868 -- the IP is built by Set_CPP_Constructors.
3870 if Is_CPP_Class (Rec_Id) then
3873 elsif Is_Interface (Rec_Id) then
3876 elsif (Has_Discriminants (Rec_Id)
3877 and then not Is_Unchecked_Union (Rec_Id))
3878 or else Is_Tagged_Type (Rec_Id)
3879 or else Is_Concurrent_Record_Type (Rec_Id)
3880 or else Has_Task (Rec_Id)
3885 Id := First_Component (Rec_Id);
3886 while Present (Id) loop
3887 Comp_Decl := Parent (Id);
3890 if Present (Expression (Comp_Decl))
3891 or else Has_Non_Null_Base_Init_Proc (Typ)
3892 or else Component_Needs_Simple_Initialization (Typ)
3897 Next_Component (Id);
3900 -- As explained above, a record initialization procedure is needed
3901 -- for public types in case Initialize_Scalars applies to a client.
3902 -- However, such a procedure is not needed in the case where either
3903 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3904 -- applies. No_Initialize_Scalars excludes the possibility of using
3905 -- Initialize_Scalars in any partition, and No_Default_Initialization
3906 -- implies that no initialization should ever be done for objects of
3907 -- the type, so is incompatible with Initialize_Scalars.
3909 if not Restriction_Active (No_Initialize_Scalars)
3910 and then not Restriction_Active (No_Default_Initialization)
3911 and then Is_Public (Rec_Id)
3917 end Requires_Init_Proc;
3919 -- Start of processing for Build_Record_Init_Proc
3922 Rec_Type := Defining_Identifier (N);
3924 -- This may be full declaration of a private type, in which case
3925 -- the visible entity is a record, and the private entity has been
3926 -- exchanged with it in the private part of the current package.
3927 -- The initialization procedure is built for the record type, which
3928 -- is retrievable from the private entity.
3930 if Is_Incomplete_Or_Private_Type (Rec_Type) then
3931 Rec_Type := Underlying_Type (Rec_Type);
3934 -- If we have a variant record with restriction No_Implicit_Conditionals
3935 -- in effect, then we skip building the procedure. This is safe because
3936 -- if we can see the restriction, so can any caller, calls to initialize
3937 -- such records are not allowed for variant records if this restriction
3940 if Has_Variant_Part (Rec_Type)
3941 and then Restriction_Active (No_Implicit_Conditionals)
3946 -- If there are discriminants, build the discriminant map to replace
3947 -- discriminants by their discriminals in complex bound expressions.
3948 -- These only arise for the corresponding records of synchronized types.
3950 if Is_Concurrent_Record_Type (Rec_Type)
3951 and then Has_Discriminants (Rec_Type)
3956 Disc := First_Discriminant (Rec_Type);
3957 while Present (Disc) loop
3958 Append_Elmt (Disc, Discr_Map);
3959 Append_Elmt (Discriminal (Disc), Discr_Map);
3960 Next_Discriminant (Disc);
3965 -- Derived types that have no type extension can use the initialization
3966 -- procedure of their parent and do not need a procedure of their own.
3967 -- This is only correct if there are no representation clauses for the
3968 -- type or its parent, and if the parent has in fact been frozen so
3969 -- that its initialization procedure exists.
3971 if Is_Derived_Type (Rec_Type)
3972 and then not Is_Tagged_Type (Rec_Type)
3973 and then not Is_Unchecked_Union (Rec_Type)
3974 and then not Has_New_Non_Standard_Rep (Rec_Type)
3975 and then not Parent_Subtype_Renaming_Discrims
3976 and then Present (Base_Init_Proc (Etype (Rec_Type)))
3978 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3980 -- Otherwise if we need an initialization procedure, then build one,
3981 -- mark it as public and inlinable and as having a completion.
3983 elsif Requires_Init_Proc (Rec_Type)
3984 or else Is_Unchecked_Union (Rec_Type)
3987 Make_Defining_Identifier (Loc,
3988 Chars => Make_Init_Proc_Name (Rec_Type));
3990 -- If No_Default_Initialization restriction is active, then we don't
3991 -- want to build an init_proc, but we need to mark that an init_proc
3992 -- would be needed if this restriction was not active (so that we can
3993 -- detect attempts to call it), so set a dummy init_proc in place.
3995 if Restriction_Active (No_Default_Initialization) then
3996 Set_Init_Proc (Rec_Type, Proc_Id);
4000 Build_Offset_To_Top_Functions;
4001 Build_CPP_Init_Procedure;
4002 Build_Init_Procedure;
4004 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
4005 Set_Is_Internal (Proc_Id);
4006 Set_Has_Completion (Proc_Id);
4008 if not Debug_Generated_Code then
4009 Set_Debug_Info_Off (Proc_Id);
4012 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
4014 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4015 -- needed and may generate early references to non frozen types
4016 -- since we expand aggregate much more systematically.
4018 if Modify_Tree_For_C then
4023 Agg : constant Node_Id :=
4024 Build_Equivalent_Record_Aggregate (Rec_Type);
4026 procedure Collect_Itypes (Comp : Node_Id);
4027 -- Generate references to itypes in the aggregate, because
4028 -- the first use of the aggregate may be in a nested scope.
4030 --------------------
4031 -- Collect_Itypes --
4032 --------------------
4034 procedure Collect_Itypes (Comp : Node_Id) is
4037 Typ : constant Entity_Id := Etype (Comp);
4040 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
4041 Ref := Make_Itype_Reference (Loc);
4042 Set_Itype (Ref, Typ);
4043 Append_Freeze_Action (Rec_Type, Ref);
4045 Ref := Make_Itype_Reference (Loc);
4046 Set_Itype (Ref, Etype (First_Index (Typ)));
4047 Append_Freeze_Action (Rec_Type, Ref);
4049 -- Recurse on nested arrays
4051 Sub_Aggr := First (Expressions (Comp));
4052 while Present (Sub_Aggr) loop
4053 Collect_Itypes (Sub_Aggr);
4060 -- If there is a static initialization aggregate for the type,
4061 -- generate itype references for the types of its (sub)components,
4062 -- to prevent out-of-scope errors in the resulting tree.
4063 -- The aggregate may have been rewritten as a Raise node, in which
4064 -- case there are no relevant itypes.
4066 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
4067 Set_Static_Initialization (Proc_Id, Agg);
4072 Comp := First (Component_Associations (Agg));
4073 while Present (Comp) loop
4074 Collect_Itypes (Expression (Comp));
4081 end Build_Record_Init_Proc;
4083 ----------------------------
4084 -- Build_Slice_Assignment --
4085 ----------------------------
4087 -- Generates the following subprogram:
4090 -- (Source, Target : Array_Type,
4091 -- Left_Lo, Left_Hi : Index;
4092 -- Right_Lo, Right_Hi : Index;
4100 -- if Left_Hi < Left_Lo then
4113 -- Target (Li1) := Source (Ri1);
4116 -- exit when Li1 = Left_Lo;
4117 -- Li1 := Index'pred (Li1);
4118 -- Ri1 := Index'pred (Ri1);
4120 -- exit when Li1 = Left_Hi;
4121 -- Li1 := Index'succ (Li1);
4122 -- Ri1 := Index'succ (Ri1);
4127 procedure Build_Slice_Assignment (Typ : Entity_Id) is
4128 Loc : constant Source_Ptr := Sloc (Typ);
4129 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
4131 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
4132 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
4133 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
4134 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
4135 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
4136 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
4137 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
4138 -- Formal parameters of procedure
4140 Proc_Name : constant Entity_Id :=
4141 Make_Defining_Identifier (Loc,
4142 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
4144 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
4145 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
4146 -- Subscripts for left and right sides
4153 -- Build declarations for indexes
4158 Make_Object_Declaration (Loc,
4159 Defining_Identifier => Lnn,
4160 Object_Definition =>
4161 New_Occurrence_Of (Index, Loc)));
4164 Make_Object_Declaration (Loc,
4165 Defining_Identifier => Rnn,
4166 Object_Definition =>
4167 New_Occurrence_Of (Index, Loc)));
4171 -- Build test for empty slice case
4174 Make_If_Statement (Loc,
4177 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
4178 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
4179 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
4181 -- Build initializations for indexes
4184 F_Init : constant List_Id := New_List;
4185 B_Init : constant List_Id := New_List;
4189 Make_Assignment_Statement (Loc,
4190 Name => New_Occurrence_Of (Lnn, Loc),
4191 Expression => New_Occurrence_Of (Left_Lo, Loc)));
4194 Make_Assignment_Statement (Loc,
4195 Name => New_Occurrence_Of (Rnn, Loc),
4196 Expression => New_Occurrence_Of (Right_Lo, Loc)));
4199 Make_Assignment_Statement (Loc,
4200 Name => New_Occurrence_Of (Lnn, Loc),
4201 Expression => New_Occurrence_Of (Left_Hi, Loc)));
4204 Make_Assignment_Statement (Loc,
4205 Name => New_Occurrence_Of (Rnn, Loc),
4206 Expression => New_Occurrence_Of (Right_Hi, Loc)));
4209 Make_If_Statement (Loc,
4210 Condition => New_Occurrence_Of (Rev, Loc),
4211 Then_Statements => B_Init,
4212 Else_Statements => F_Init));
4215 -- Now construct the assignment statement
4218 Make_Loop_Statement (Loc,
4219 Statements => New_List (
4220 Make_Assignment_Statement (Loc,
4222 Make_Indexed_Component (Loc,
4223 Prefix => New_Occurrence_Of (Larray, Loc),
4224 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
4226 Make_Indexed_Component (Loc,
4227 Prefix => New_Occurrence_Of (Rarray, Loc),
4228 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
4229 End_Label => Empty);
4231 -- Build the exit condition and increment/decrement statements
4234 F_Ass : constant List_Id := New_List;
4235 B_Ass : constant List_Id := New_List;
4239 Make_Exit_Statement (Loc,
4242 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4243 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
4246 Make_Assignment_Statement (Loc,
4247 Name => New_Occurrence_Of (Lnn, Loc),
4249 Make_Attribute_Reference (Loc,
4251 New_Occurrence_Of (Index, Loc),
4252 Attribute_Name => Name_Succ,
4253 Expressions => New_List (
4254 New_Occurrence_Of (Lnn, Loc)))));
4257 Make_Assignment_Statement (Loc,
4258 Name => New_Occurrence_Of (Rnn, Loc),
4260 Make_Attribute_Reference (Loc,
4262 New_Occurrence_Of (Index, Loc),
4263 Attribute_Name => Name_Succ,
4264 Expressions => New_List (
4265 New_Occurrence_Of (Rnn, Loc)))));
4268 Make_Exit_Statement (Loc,
4271 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4272 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
4275 Make_Assignment_Statement (Loc,
4276 Name => New_Occurrence_Of (Lnn, Loc),
4278 Make_Attribute_Reference (Loc,
4280 New_Occurrence_Of (Index, Loc),
4281 Attribute_Name => Name_Pred,
4282 Expressions => New_List (
4283 New_Occurrence_Of (Lnn, Loc)))));
4286 Make_Assignment_Statement (Loc,
4287 Name => New_Occurrence_Of (Rnn, Loc),
4289 Make_Attribute_Reference (Loc,
4291 New_Occurrence_Of (Index, Loc),
4292 Attribute_Name => Name_Pred,
4293 Expressions => New_List (
4294 New_Occurrence_Of (Rnn, Loc)))));
4296 Append_To (Statements (Loops),
4297 Make_If_Statement (Loc,
4298 Condition => New_Occurrence_Of (Rev, Loc),
4299 Then_Statements => B_Ass,
4300 Else_Statements => F_Ass));
4303 Append_To (Stats, Loops);
4307 Formals : List_Id := New_List;
4310 Formals := New_List (
4311 Make_Parameter_Specification (Loc,
4312 Defining_Identifier => Larray,
4313 Out_Present => True,
4315 New_Occurrence_Of (Base_Type (Typ), Loc)),
4317 Make_Parameter_Specification (Loc,
4318 Defining_Identifier => Rarray,
4320 New_Occurrence_Of (Base_Type (Typ), Loc)),
4322 Make_Parameter_Specification (Loc,
4323 Defining_Identifier => Left_Lo,
4325 New_Occurrence_Of (Index, Loc)),
4327 Make_Parameter_Specification (Loc,
4328 Defining_Identifier => Left_Hi,
4330 New_Occurrence_Of (Index, Loc)),
4332 Make_Parameter_Specification (Loc,
4333 Defining_Identifier => Right_Lo,
4335 New_Occurrence_Of (Index, Loc)),
4337 Make_Parameter_Specification (Loc,
4338 Defining_Identifier => Right_Hi,
4340 New_Occurrence_Of (Index, Loc)));
4343 Make_Parameter_Specification (Loc,
4344 Defining_Identifier => Rev,
4346 New_Occurrence_Of (Standard_Boolean, Loc)));
4349 Make_Procedure_Specification (Loc,
4350 Defining_Unit_Name => Proc_Name,
4351 Parameter_Specifications => Formals);
4354 Make_Subprogram_Body (Loc,
4355 Specification => Spec,
4356 Declarations => Decls,
4357 Handled_Statement_Sequence =>
4358 Make_Handled_Sequence_Of_Statements (Loc,
4359 Statements => Stats)));
4362 Set_TSS (Typ, Proc_Name);
4363 Set_Is_Pure (Proc_Name);
4364 end Build_Slice_Assignment;
4366 -----------------------------
4367 -- Build_Untagged_Equality --
4368 -----------------------------
4370 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4378 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4379 -- Check whether the type T has a user-defined primitive equality. If so
4380 -- return it, else return Empty. If true for a component of Typ, we have
4381 -- to build the primitive equality for it.
4383 ---------------------
4384 -- User_Defined_Eq --
4385 ---------------------
4387 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4392 Op := TSS (T, TSS_Composite_Equality);
4394 if Present (Op) then
4398 Prim := First_Elmt (Collect_Primitive_Operations (T));
4399 while Present (Prim) loop
4402 if Chars (Op) = Name_Op_Eq
4403 and then Etype (Op) = Standard_Boolean
4404 and then Etype (First_Formal (Op)) = T
4405 and then Etype (Next_Formal (First_Formal (Op))) = T
4414 end User_Defined_Eq;
4416 -- Start of processing for Build_Untagged_Equality
4419 -- If a record component has a primitive equality operation, we must
4420 -- build the corresponding one for the current type.
4423 Comp := First_Component (Typ);
4424 while Present (Comp) loop
4425 if Is_Record_Type (Etype (Comp))
4426 and then Present (User_Defined_Eq (Etype (Comp)))
4431 Next_Component (Comp);
4434 -- If there is a user-defined equality for the type, we do not create
4435 -- the implicit one.
4437 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
4439 while Present (Prim) loop
4440 if Chars (Node (Prim)) = Name_Op_Eq
4441 and then Comes_From_Source (Node (Prim))
4443 -- Don't we also need to check formal types and return type as in
4444 -- User_Defined_Eq above???
4447 Eq_Op := Node (Prim);
4455 -- If the type is derived, inherit the operation, if present, from the
4456 -- parent type. It may have been declared after the type derivation. If
4457 -- the parent type itself is derived, it may have inherited an operation
4458 -- that has itself been overridden, so update its alias and related
4459 -- flags. Ditto for inequality.
4461 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4462 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
4463 while Present (Prim) loop
4464 if Chars (Node (Prim)) = Name_Op_Eq then
4465 Copy_TSS (Node (Prim), Typ);
4469 Op : constant Entity_Id := User_Defined_Eq (Typ);
4470 Eq_Op : constant Entity_Id := Node (Prim);
4471 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4474 if Present (Op) then
4475 Set_Alias (Op, Eq_Op);
4476 Set_Is_Abstract_Subprogram
4477 (Op, Is_Abstract_Subprogram (Eq_Op));
4479 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4480 Set_Is_Abstract_Subprogram
4481 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4493 -- If not inherited and not user-defined, build body as for a type with
4494 -- tagged components.
4498 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4499 Op := Defining_Entity (Decl);
4503 if Is_Library_Level_Entity (Typ) then
4507 end Build_Untagged_Equality;
4509 -----------------------------------
4510 -- Build_Variant_Record_Equality --
4511 -----------------------------------
4515 -- function <<Body_Id>> (Left, Right : T) return Boolean is
4516 -- [ X : T renames Left; ]
4517 -- [ Y : T renames Right; ]
4518 -- -- The above renamings are generated only if the parameters of
4519 -- -- this built function (which are passed by the caller) are not
4520 -- -- named 'X' and 'Y'; these names are required to reuse several
4521 -- -- expander routines when generating this body.
4524 -- -- Compare discriminants
4526 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4530 -- -- Compare components
4532 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4536 -- -- Compare variant part
4540 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4545 -- if X.Cn /= Y.Cn or else ... then
4553 function Build_Variant_Record_Equality
4555 Body_Id : Entity_Id;
4556 Param_Specs : List_Id) return Node_Id
4558 Loc : constant Source_Ptr := Sloc (Typ);
4559 Def : constant Node_Id := Parent (Typ);
4560 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4561 Left : constant Entity_Id := Defining_Identifier (First (Param_Specs));
4562 Right : constant Entity_Id :=
4563 Defining_Identifier (Next (First (Param_Specs)));
4564 Decls : constant List_Id := New_List;
4565 Stmts : constant List_Id := New_List;
4567 Subp_Body : Node_Id;
4570 pragma Assert (not Is_Tagged_Type (Typ));
4572 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
4573 -- the name of the formals must be X and Y; otherwise we generate two
4574 -- renaming declarations for such purpose.
4576 if Chars (Left) /= Name_X then
4578 Make_Object_Renaming_Declaration (Loc,
4579 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
4580 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4581 Name => Make_Identifier (Loc, Chars (Left))));
4584 if Chars (Right) /= Name_Y then
4586 Make_Object_Renaming_Declaration (Loc,
4587 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
4588 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4589 Name => Make_Identifier (Loc, Chars (Right))));
4592 -- Unchecked_Unions require additional machinery to support equality.
4593 -- Two extra parameters (A and B) are added to the equality function
4594 -- parameter list for each discriminant of the type, in order to
4595 -- capture the inferred values of the discriminants in equality calls.
4596 -- The names of the parameters match the names of the corresponding
4597 -- discriminant, with an added suffix.
4599 if Is_Unchecked_Union (Typ) then
4604 Discr_Type : Entity_Id;
4605 New_Discrs : Elist_Id;
4608 New_Discrs := New_Elmt_List;
4610 Discr := First_Discriminant (Typ);
4611 while Present (Discr) loop
4612 Discr_Type := Etype (Discr);
4615 Make_Defining_Identifier (Loc,
4616 Chars => New_External_Name (Chars (Discr), 'A'));
4619 Make_Defining_Identifier (Loc,
4620 Chars => New_External_Name (Chars (Discr), 'B'));
4622 -- Add new parameters to the parameter list
4624 Append_To (Param_Specs,
4625 Make_Parameter_Specification (Loc,
4626 Defining_Identifier => A,
4628 New_Occurrence_Of (Discr_Type, Loc)));
4630 Append_To (Param_Specs,
4631 Make_Parameter_Specification (Loc,
4632 Defining_Identifier => B,
4634 New_Occurrence_Of (Discr_Type, Loc)));
4636 Append_Elmt (A, New_Discrs);
4638 -- Generate the following code to compare each of the inferred
4646 Make_If_Statement (Loc,
4649 Left_Opnd => New_Occurrence_Of (A, Loc),
4650 Right_Opnd => New_Occurrence_Of (B, Loc)),
4651 Then_Statements => New_List (
4652 Make_Simple_Return_Statement (Loc,
4654 New_Occurrence_Of (Standard_False, Loc)))));
4655 Next_Discriminant (Discr);
4658 -- Generate component-by-component comparison. Note that we must
4659 -- propagate the inferred discriminants formals to act as the case
4660 -- statement switch. Their value is added when an equality call on
4661 -- unchecked unions is expanded.
4663 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4666 -- Normal case (not unchecked union)
4670 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4671 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4675 Make_Simple_Return_Statement (Loc,
4676 Expression => New_Occurrence_Of (Standard_True, Loc)));
4679 Make_Subprogram_Body (Loc,
4681 Make_Function_Specification (Loc,
4682 Defining_Unit_Name => Body_Id,
4683 Parameter_Specifications => Param_Specs,
4684 Result_Definition =>
4685 New_Occurrence_Of (Standard_Boolean, Loc)),
4686 Declarations => Decls,
4687 Handled_Statement_Sequence =>
4688 Make_Handled_Sequence_Of_Statements (Loc,
4689 Statements => Stmts));
4692 end Build_Variant_Record_Equality;
4694 -----------------------------
4695 -- Check_Stream_Attributes --
4696 -----------------------------
4698 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4700 Par_Read : constant Boolean :=
4701 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4702 and then not Has_Specified_Stream_Read (Typ);
4703 Par_Write : constant Boolean :=
4704 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4705 and then not Has_Specified_Stream_Write (Typ);
4707 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4708 -- Check that Comp has a user-specified Nam stream attribute
4714 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4716 -- Move this check to sem???
4718 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4719 Error_Msg_Name_1 := Nam;
4721 ("|component& in limited extension must have% attribute", Comp);
4725 -- Start of processing for Check_Stream_Attributes
4728 if Par_Read or else Par_Write then
4729 Comp := First_Component (Typ);
4730 while Present (Comp) loop
4731 if Comes_From_Source (Comp)
4732 and then Original_Record_Component (Comp) = Comp
4733 and then Is_Limited_Type (Etype (Comp))
4736 Check_Attr (Name_Read, TSS_Stream_Read);
4740 Check_Attr (Name_Write, TSS_Stream_Write);
4744 Next_Component (Comp);
4747 end Check_Stream_Attributes;
4749 ----------------------
4750 -- Clean_Task_Names --
4751 ----------------------
4753 procedure Clean_Task_Names
4755 Proc_Id : Entity_Id)
4759 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4760 and then not Global_Discard_Names
4761 and then Tagged_Type_Expansion
4763 Set_Uses_Sec_Stack (Proc_Id);
4765 end Clean_Task_Names;
4767 ------------------------------
4768 -- Expand_Freeze_Array_Type --
4769 ------------------------------
4771 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4772 Typ : constant Entity_Id := Entity (N);
4773 Base : constant Entity_Id := Base_Type (Typ);
4774 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4777 if not Is_Bit_Packed_Array (Typ) then
4779 -- If the component contains tasks, so does the array type. This may
4780 -- not be indicated in the array type because the component may have
4781 -- been a private type at the point of definition. Same if component
4782 -- type is controlled or contains protected objects.
4784 Propagate_Concurrent_Flags (Base, Comp_Typ);
4785 Set_Has_Controlled_Component
4786 (Base, Has_Controlled_Component (Comp_Typ)
4787 or else Is_Controlled (Comp_Typ));
4789 if No (Init_Proc (Base)) then
4791 -- If this is an anonymous array created for a declaration with
4792 -- an initial value, its init_proc will never be called. The
4793 -- initial value itself may have been expanded into assignments,
4794 -- in which case the object declaration is carries the
4795 -- No_Initialization flag.
4798 and then Nkind (Associated_Node_For_Itype (Base)) =
4799 N_Object_Declaration
4801 (Present (Expression (Associated_Node_For_Itype (Base)))
4802 or else No_Initialization (Associated_Node_For_Itype (Base)))
4806 -- We do not need an init proc for string or wide [wide] string,
4807 -- since the only time these need initialization in normalize or
4808 -- initialize scalars mode, and these types are treated specially
4809 -- and do not need initialization procedures.
4811 elsif Is_Standard_String_Type (Base) then
4814 -- Otherwise we have to build an init proc for the subtype
4817 Build_Array_Init_Proc (Base, N);
4821 if Typ = Base and then Has_Controlled_Component (Base) then
4822 Build_Controlling_Procs (Base);
4824 if not Is_Limited_Type (Comp_Typ)
4825 and then Number_Dimensions (Typ) = 1
4827 Build_Slice_Assignment (Typ);
4831 -- For packed case, default initialization, except if the component type
4832 -- is itself a packed structure with an initialization procedure, or
4833 -- initialize/normalize scalars active, and we have a base type, or the
4834 -- type is public, because in that case a client might specify
4835 -- Normalize_Scalars and there better be a public Init_Proc for it.
4837 elsif (Present (Init_Proc (Component_Type (Base)))
4838 and then No (Base_Init_Proc (Base)))
4839 or else (Init_Or_Norm_Scalars and then Base = Typ)
4840 or else Is_Public (Typ)
4842 Build_Array_Init_Proc (Base, N);
4844 end Expand_Freeze_Array_Type;
4846 -----------------------------------
4847 -- Expand_Freeze_Class_Wide_Type --
4848 -----------------------------------
4850 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4851 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4852 -- Given a type, determine whether it is derived from a C or C++ root
4854 ---------------------
4855 -- Is_C_Derivation --
4856 ---------------------
4858 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4865 or else Convention (T) = Convention_C
4866 or else Convention (T) = Convention_CPP
4871 exit when T = Etype (T);
4877 end Is_C_Derivation;
4881 Typ : constant Entity_Id := Entity (N);
4882 Root : constant Entity_Id := Root_Type (Typ);
4884 -- Start of processing for Expand_Freeze_Class_Wide_Type
4887 -- Certain run-time configurations and targets do not provide support
4888 -- for controlled types.
4890 if Restriction_Active (No_Finalization) then
4893 -- Do not create TSS routine Finalize_Address when dispatching calls are
4894 -- disabled since the core of the routine is a dispatching call.
4896 elsif Restriction_Active (No_Dispatching_Calls) then
4899 -- Do not create TSS routine Finalize_Address for concurrent class-wide
4900 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
4901 -- non-Ada side will handle their destruction.
4903 elsif Is_Concurrent_Type (Root)
4904 or else Is_C_Derivation (Root)
4905 or else Convention (Typ) = Convention_CPP
4909 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
4910 -- mode since the routine contains an Unchecked_Conversion.
4912 elsif CodePeer_Mode then
4916 -- Create the body of TSS primitive Finalize_Address. This automatically
4917 -- sets the TSS entry for the class-wide type.
4919 Make_Finalize_Address_Body (Typ);
4920 end Expand_Freeze_Class_Wide_Type;
4922 ------------------------------------
4923 -- Expand_Freeze_Enumeration_Type --
4924 ------------------------------------
4926 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
4927 Typ : constant Entity_Id := Entity (N);
4928 Loc : constant Source_Ptr := Sloc (Typ);
4933 Is_Contiguous : Boolean;
4934 Index_Typ : Entity_Id;
4942 pragma Warnings (Off, Func);
4945 -- Various optimizations possible if given representation is contiguous
4947 Is_Contiguous := True;
4949 Ent := First_Literal (Typ);
4950 Last_Repval := Enumeration_Rep (Ent);
4954 while Present (Ent) loop
4955 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4956 Is_Contiguous := False;
4958 Last_Repval := Enumeration_Rep (Ent);
4965 if Is_Contiguous then
4966 Set_Has_Contiguous_Rep (Typ);
4968 -- Now build a subtype declaration
4970 -- subtype typI is new Natural range 0 .. num - 1
4973 Make_Defining_Identifier (Loc,
4974 Chars => New_External_Name (Chars (Typ), 'I'));
4976 Append_Freeze_Action (Typ,
4977 Make_Subtype_Declaration (Loc,
4978 Defining_Identifier => Index_Typ,
4979 Subtype_Indication =>
4980 Make_Subtype_Indication (Loc,
4982 New_Occurrence_Of (Standard_Natural, Loc),
4984 Make_Range_Constraint (Loc,
4988 Make_Integer_Literal (Loc, 0),
4990 Make_Integer_Literal (Loc, Num - 1))))));
4992 Set_Enum_Pos_To_Rep (Typ, Index_Typ);
4995 -- Build list of literal references
4998 Ent := First_Literal (Typ);
4999 while Present (Ent) loop
5000 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
5004 -- Now build an array declaration
5006 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5007 -- (v, v, v, v, v, ....)
5010 Make_Defining_Identifier (Loc,
5011 Chars => New_External_Name (Chars (Typ), 'A'));
5013 Append_Freeze_Action (Typ,
5014 Make_Object_Declaration (Loc,
5015 Defining_Identifier => Arr,
5016 Constant_Present => True,
5018 Object_Definition =>
5019 Make_Constrained_Array_Definition (Loc,
5020 Discrete_Subtype_Definitions => New_List (
5021 Make_Subtype_Indication (Loc,
5023 New_Occurrence_Of (Standard_Natural, Loc),
5025 Make_Range_Constraint (Loc,
5029 Make_Integer_Literal (Loc, 0),
5031 Make_Integer_Literal (Loc, Num - 1))))),
5033 Component_Definition =>
5034 Make_Component_Definition (Loc,
5035 Aliased_Present => False,
5036 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
5039 Make_Aggregate (Loc,
5040 Expressions => Lst)));
5042 Set_Enum_Pos_To_Rep (Typ, Arr);
5045 -- Now we build the function that converts representation values to
5046 -- position values. This function has the form:
5048 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5051 -- when enum-lit'Enum_Rep => return posval;
5052 -- when enum-lit'Enum_Rep => return posval;
5055 -- [raise Constraint_Error when F "invalid data"]
5060 -- Note: the F parameter determines whether the others case (no valid
5061 -- representation) raises Constraint_Error or returns a unique value
5062 -- of minus one. The latter case is used, e.g. in 'Valid code.
5064 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5065 -- the code generator making inappropriate assumptions about the range
5066 -- of the values in the case where the value is invalid. ityp is a
5067 -- signed or unsigned integer type of appropriate width.
5069 -- Note: if exceptions are not supported, then we suppress the raise
5070 -- and return -1 unconditionally (this is an erroneous program in any
5071 -- case and there is no obligation to raise Constraint_Error here). We
5072 -- also do this if pragma Restrictions (No_Exceptions) is active.
5074 -- Is this right??? What about No_Exception_Propagation???
5076 -- Representations are signed
5078 if Enumeration_Rep (First_Literal (Typ)) < 0 then
5080 -- The underlying type is signed. Reset the Is_Unsigned_Type
5081 -- explicitly, because it might have been inherited from
5084 Set_Is_Unsigned_Type (Typ, False);
5086 if Esize (Typ) <= Standard_Integer_Size then
5087 Ityp := Standard_Integer;
5089 Ityp := Standard_Long_Long_Integer;
5092 -- Representations are unsigned
5095 if Esize (Typ) <= Standard_Integer_Size then
5096 Ityp := RTE (RE_Unsigned);
5098 Ityp := RTE (RE_Long_Long_Unsigned);
5102 -- The body of the function is a case statement. First collect case
5103 -- alternatives, or optimize the contiguous case.
5107 -- If representation is contiguous, Pos is computed by subtracting
5108 -- the representation of the first literal.
5110 if Is_Contiguous then
5111 Ent := First_Literal (Typ);
5113 if Enumeration_Rep (Ent) = Last_Repval then
5115 -- Another special case: for a single literal, Pos is zero
5117 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
5121 Convert_To (Standard_Integer,
5122 Make_Op_Subtract (Loc,
5124 Unchecked_Convert_To
5125 (Ityp, Make_Identifier (Loc, Name_uA)),
5127 Make_Integer_Literal (Loc,
5128 Intval => Enumeration_Rep (First_Literal (Typ)))));
5132 Make_Case_Statement_Alternative (Loc,
5133 Discrete_Choices => New_List (
5134 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
5136 Make_Integer_Literal (Loc,
5137 Intval => Enumeration_Rep (Ent)),
5139 Make_Integer_Literal (Loc, Intval => Last_Repval))),
5141 Statements => New_List (
5142 Make_Simple_Return_Statement (Loc,
5143 Expression => Pos_Expr))));
5146 Ent := First_Literal (Typ);
5147 while Present (Ent) loop
5149 Make_Case_Statement_Alternative (Loc,
5150 Discrete_Choices => New_List (
5151 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
5152 Intval => Enumeration_Rep (Ent))),
5154 Statements => New_List (
5155 Make_Simple_Return_Statement (Loc,
5157 Make_Integer_Literal (Loc,
5158 Intval => Enumeration_Pos (Ent))))));
5164 -- In normal mode, add the others clause with the test.
5165 -- If Predicates_Ignored is True, validity checks do not apply to
5168 if not No_Exception_Handlers_Set
5169 and then not Predicates_Ignored (Typ)
5172 Make_Case_Statement_Alternative (Loc,
5173 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5174 Statements => New_List (
5175 Make_Raise_Constraint_Error (Loc,
5176 Condition => Make_Identifier (Loc, Name_uF),
5177 Reason => CE_Invalid_Data),
5178 Make_Simple_Return_Statement (Loc,
5179 Expression => Make_Integer_Literal (Loc, -1)))));
5181 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5182 -- active then return -1 (we cannot usefully raise Constraint_Error in
5183 -- this case). See description above for further details.
5187 Make_Case_Statement_Alternative (Loc,
5188 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5189 Statements => New_List (
5190 Make_Simple_Return_Statement (Loc,
5191 Expression => Make_Integer_Literal (Loc, -1)))));
5194 -- Now we can build the function body
5197 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
5200 Make_Subprogram_Body (Loc,
5202 Make_Function_Specification (Loc,
5203 Defining_Unit_Name => Fent,
5204 Parameter_Specifications => New_List (
5205 Make_Parameter_Specification (Loc,
5206 Defining_Identifier =>
5207 Make_Defining_Identifier (Loc, Name_uA),
5208 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5209 Make_Parameter_Specification (Loc,
5210 Defining_Identifier =>
5211 Make_Defining_Identifier (Loc, Name_uF),
5213 New_Occurrence_Of (Standard_Boolean, Loc))),
5215 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
5217 Declarations => Empty_List,
5219 Handled_Statement_Sequence =>
5220 Make_Handled_Sequence_Of_Statements (Loc,
5221 Statements => New_List (
5222 Make_Case_Statement (Loc,
5224 Unchecked_Convert_To
5225 (Ityp, Make_Identifier (Loc, Name_uA)),
5226 Alternatives => Lst))));
5228 Set_TSS (Typ, Fent);
5230 -- Set Pure flag (it will be reset if the current context is not Pure).
5231 -- We also pretend there was a pragma Pure_Function so that for purposes
5232 -- of optimization and constant-folding, we will consider the function
5233 -- Pure even if we are not in a Pure context).
5236 Set_Has_Pragma_Pure_Function (Fent);
5238 -- Unless we are in -gnatD mode, where we are debugging generated code,
5239 -- this is an internal entity for which we don't need debug info.
5241 if not Debug_Generated_Code then
5242 Set_Debug_Info_Off (Fent);
5245 Set_Is_Inlined (Fent);
5248 when RE_Not_Available =>
5250 end Expand_Freeze_Enumeration_Type;
5252 -------------------------------
5253 -- Expand_Freeze_Record_Type --
5254 -------------------------------
5256 procedure Expand_Freeze_Record_Type (N : Node_Id) is
5257 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
5258 -- Create An Equality function for the untagged variant record Typ and
5259 -- attach it to the TSS list.
5261 -----------------------------------
5262 -- Build_Variant_Record_Equality --
5263 -----------------------------------
5265 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
5266 Loc : constant Source_Ptr := Sloc (Typ);
5267 F : constant Entity_Id :=
5268 Make_Defining_Identifier (Loc,
5269 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
5271 -- For a variant record with restriction No_Implicit_Conditionals
5272 -- in effect we skip building the procedure. This is safe because
5273 -- if we can see the restriction, so can any caller, and calls to
5274 -- equality test routines are not allowed for variant records if
5275 -- this restriction is active.
5277 if Restriction_Active (No_Implicit_Conditionals) then
5281 -- Derived Unchecked_Union types no longer inherit the equality
5282 -- function of their parent.
5284 if Is_Derived_Type (Typ)
5285 and then not Is_Unchecked_Union (Typ)
5286 and then not Has_New_Non_Standard_Rep (Typ)
5289 Parent_Eq : constant Entity_Id :=
5290 TSS (Root_Type (Typ), TSS_Composite_Equality);
5292 if Present (Parent_Eq) then
5293 Copy_TSS (Parent_Eq, Typ);
5300 Build_Variant_Record_Equality
5303 Param_Specs => New_List (
5304 Make_Parameter_Specification (Loc,
5305 Defining_Identifier =>
5306 Make_Defining_Identifier (Loc, Name_X),
5307 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5309 Make_Parameter_Specification (Loc,
5310 Defining_Identifier =>
5311 Make_Defining_Identifier (Loc, Name_Y),
5312 Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
5317 if not Debug_Generated_Code then
5318 Set_Debug_Info_Off (F);
5320 end Build_Variant_Record_Equality;
5324 Typ : constant Node_Id := Entity (N);
5325 Typ_Decl : constant Node_Id := Parent (Typ);
5328 Comp_Typ : Entity_Id;
5329 Predef_List : List_Id;
5331 Wrapper_Decl_List : List_Id := No_List;
5332 Wrapper_Body_List : List_Id := No_List;
5334 Renamed_Eq : Node_Id := Empty;
5335 -- Defining unit name for the predefined equality function in the case
5336 -- where the type has a primitive operation that is a renaming of
5337 -- predefined equality (but only if there is also an overriding
5338 -- user-defined equality function). Used to pass this entity from
5339 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
5341 -- Start of processing for Expand_Freeze_Record_Type
5344 -- Build discriminant checking functions if not a derived type (for
5345 -- derived types that are not tagged types, always use the discriminant
5346 -- checking functions of the parent type). However, for untagged types
5347 -- the derivation may have taken place before the parent was frozen, so
5348 -- we copy explicitly the discriminant checking functions from the
5349 -- parent into the components of the derived type.
5351 if not Is_Derived_Type (Typ)
5352 or else Has_New_Non_Standard_Rep (Typ)
5353 or else Is_Tagged_Type (Typ)
5355 Build_Discr_Checking_Funcs (Typ_Decl);
5357 elsif Is_Derived_Type (Typ)
5358 and then not Is_Tagged_Type (Typ)
5360 -- If we have a derived Unchecked_Union, we do not inherit the
5361 -- discriminant checking functions from the parent type since the
5362 -- discriminants are non existent.
5364 and then not Is_Unchecked_Union (Typ)
5365 and then Has_Discriminants (Typ)
5368 Old_Comp : Entity_Id;
5372 First_Component (Base_Type (Underlying_Type (Etype (Typ))));
5373 Comp := First_Component (Typ);
5374 while Present (Comp) loop
5375 if Ekind (Comp) = E_Component
5376 and then Chars (Comp) = Chars (Old_Comp)
5378 Set_Discriminant_Checking_Func
5379 (Comp, Discriminant_Checking_Func (Old_Comp));
5382 Next_Component (Old_Comp);
5383 Next_Component (Comp);
5388 if Is_Derived_Type (Typ)
5389 and then Is_Limited_Type (Typ)
5390 and then Is_Tagged_Type (Typ)
5392 Check_Stream_Attributes (Typ);
5395 -- Update task, protected, and controlled component flags, because some
5396 -- of the component types may have been private at the point of the
5397 -- record declaration. Detect anonymous access-to-controlled components.
5399 Comp := First_Component (Typ);
5400 while Present (Comp) loop
5401 Comp_Typ := Etype (Comp);
5403 Propagate_Concurrent_Flags (Typ, Comp_Typ);
5405 -- Do not set Has_Controlled_Component on a class-wide equivalent
5406 -- type. See Make_CW_Equivalent_Type.
5408 if not Is_Class_Wide_Equivalent_Type (Typ)
5410 (Has_Controlled_Component (Comp_Typ)
5411 or else (Chars (Comp) /= Name_uParent
5412 and then Is_Controlled (Comp_Typ)))
5414 Set_Has_Controlled_Component (Typ);
5417 Next_Component (Comp);
5420 -- Handle constructors of untagged CPP_Class types
5422 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
5423 Set_CPP_Constructors (Typ);
5426 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5427 -- for regular tagged types as well as for Ada types deriving from a C++
5428 -- Class, but not for tagged types directly corresponding to C++ classes
5429 -- In the later case we assume that it is created in the C++ side and we
5432 if Is_Tagged_Type (Typ) then
5434 -- Add the _Tag component
5436 if Underlying_Type (Etype (Typ)) = Typ then
5437 Expand_Tagged_Root (Typ);
5440 if Is_CPP_Class (Typ) then
5441 Set_All_DT_Position (Typ);
5443 -- Create the tag entities with a minimum decoration
5445 if Tagged_Type_Expansion then
5446 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5449 Set_CPP_Constructors (Typ);
5452 if not Building_Static_DT (Typ) then
5454 -- Usually inherited primitives are not delayed but the first
5455 -- Ada extension of a CPP_Class is an exception since the
5456 -- address of the inherited subprogram has to be inserted in
5457 -- the new Ada Dispatch Table and this is a freezing action.
5459 -- Similarly, if this is an inherited operation whose parent is
5460 -- not frozen yet, it is not in the DT of the parent, and we
5461 -- generate an explicit freeze node for the inherited operation
5462 -- so it is properly inserted in the DT of the current type.
5469 Elmt := First_Elmt (Primitive_Operations (Typ));
5470 while Present (Elmt) loop
5471 Subp := Node (Elmt);
5473 if Present (Alias (Subp)) then
5474 if Is_CPP_Class (Etype (Typ)) then
5475 Set_Has_Delayed_Freeze (Subp);
5477 elsif Has_Delayed_Freeze (Alias (Subp))
5478 and then not Is_Frozen (Alias (Subp))
5480 Set_Is_Frozen (Subp, False);
5481 Set_Has_Delayed_Freeze (Subp);
5490 -- Unfreeze momentarily the type to add the predefined primitives
5491 -- operations. The reason we unfreeze is so that these predefined
5492 -- operations will indeed end up as primitive operations (which
5493 -- must be before the freeze point).
5495 Set_Is_Frozen (Typ, False);
5497 -- Do not add the spec of predefined primitives in case of
5498 -- CPP tagged type derivations that have convention CPP.
5500 if Is_CPP_Class (Root_Type (Typ))
5501 and then Convention (Typ) = Convention_CPP
5505 -- Do not add the spec of the predefined primitives if we are
5506 -- compiling under restriction No_Dispatching_Calls.
5508 elsif not Restriction_Active (No_Dispatching_Calls) then
5509 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
5510 Insert_List_Before_And_Analyze (N, Predef_List);
5513 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5514 -- wrapper functions for each nonoverridden inherited function
5515 -- with a controlling result of the type. The wrapper for such
5516 -- a function returns an extension aggregate that invokes the
5519 if Ada_Version >= Ada_2005
5520 and then not Is_Abstract_Type (Typ)
5521 and then Is_Null_Extension (Typ)
5523 Make_Controlling_Function_Wrappers
5524 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
5525 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5528 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5529 -- null procedure declarations for each set of homographic null
5530 -- procedures that are inherited from interface types but not
5531 -- overridden. This is done to ensure that the dispatch table
5532 -- entry associated with such null primitives are properly filled.
5534 if Ada_Version >= Ada_2005
5535 and then Etype (Typ) /= Typ
5536 and then not Is_Abstract_Type (Typ)
5537 and then Has_Interfaces (Typ)
5539 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
5542 Set_Is_Frozen (Typ);
5544 if not Is_Derived_Type (Typ)
5545 or else Is_Tagged_Type (Etype (Typ))
5547 Set_All_DT_Position (Typ);
5549 -- If this is a type derived from an untagged private type whose
5550 -- full view is tagged, the type is marked tagged for layout
5551 -- reasons, but it has no dispatch table.
5553 elsif Is_Derived_Type (Typ)
5554 and then Is_Private_Type (Etype (Typ))
5555 and then not Is_Tagged_Type (Etype (Typ))
5560 -- Create and decorate the tags. Suppress their creation when
5561 -- not Tagged_Type_Expansion because the dispatching mechanism is
5562 -- handled internally by the virtual target.
5564 if Tagged_Type_Expansion then
5565 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5567 -- Generate dispatch table of locally defined tagged type.
5568 -- Dispatch tables of library level tagged types are built
5569 -- later (see Analyze_Declarations).
5571 if not Building_Static_DT (Typ) then
5572 Append_Freeze_Actions (Typ, Make_DT (Typ));
5576 -- If the type has unknown discriminants, propagate dispatching
5577 -- information to its underlying record view, which does not get
5578 -- its own dispatch table.
5580 if Is_Derived_Type (Typ)
5581 and then Has_Unknown_Discriminants (Typ)
5582 and then Present (Underlying_Record_View (Typ))
5585 Rep : constant Entity_Id := Underlying_Record_View (Typ);
5587 Set_Access_Disp_Table
5588 (Rep, Access_Disp_Table (Typ));
5589 Set_Dispatch_Table_Wrappers
5590 (Rep, Dispatch_Table_Wrappers (Typ));
5591 Set_Direct_Primitive_Operations
5592 (Rep, Direct_Primitive_Operations (Typ));
5596 -- Make sure that the primitives Initialize, Adjust and Finalize
5597 -- are Frozen before other TSS subprograms. We don't want them
5600 if Is_Controlled (Typ) then
5601 if not Is_Limited_Type (Typ) then
5602 Append_Freeze_Actions (Typ,
5603 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
5606 Append_Freeze_Actions (Typ,
5607 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
5609 Append_Freeze_Actions (Typ,
5610 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
5613 -- Freeze rest of primitive operations. There is no need to handle
5614 -- the predefined primitives if we are compiling under restriction
5615 -- No_Dispatching_Calls.
5617 if not Restriction_Active (No_Dispatching_Calls) then
5618 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5622 -- In the untagged case, ever since Ada 83 an equality function must
5623 -- be provided for variant records that are not unchecked unions.
5624 -- In Ada 2012 the equality function composes, and thus must be built
5625 -- explicitly just as for tagged records.
5627 elsif Has_Discriminants (Typ)
5628 and then not Is_Limited_Type (Typ)
5631 Comps : constant Node_Id :=
5632 Component_List (Type_Definition (Typ_Decl));
5635 and then Present (Variant_Part (Comps))
5637 Build_Variant_Record_Equality (Typ);
5641 -- Otherwise create primitive equality operation (AI05-0123)
5643 -- This is done unconditionally to ensure that tools can be linked
5644 -- properly with user programs compiled with older language versions.
5645 -- In addition, this is needed because "=" composes for bounded strings
5646 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5648 elsif Comes_From_Source (Typ)
5649 and then Convention (Typ) = Convention_Ada
5650 and then not Is_Limited_Type (Typ)
5652 Build_Untagged_Equality (Typ);
5655 -- Before building the record initialization procedure, if we are
5656 -- dealing with a concurrent record value type, then we must go through
5657 -- the discriminants, exchanging discriminals between the concurrent
5658 -- type and the concurrent record value type. See the section "Handling
5659 -- of Discriminants" in the Einfo spec for details.
5661 if Is_Concurrent_Record_Type (Typ)
5662 and then Has_Discriminants (Typ)
5665 Ctyp : constant Entity_Id :=
5666 Corresponding_Concurrent_Type (Typ);
5667 Conc_Discr : Entity_Id;
5668 Rec_Discr : Entity_Id;
5672 Conc_Discr := First_Discriminant (Ctyp);
5673 Rec_Discr := First_Discriminant (Typ);
5674 while Present (Conc_Discr) loop
5675 Temp := Discriminal (Conc_Discr);
5676 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5677 Set_Discriminal (Rec_Discr, Temp);
5679 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5680 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5682 Next_Discriminant (Conc_Discr);
5683 Next_Discriminant (Rec_Discr);
5688 if Has_Controlled_Component (Typ) then
5689 Build_Controlling_Procs (Typ);
5692 Adjust_Discriminants (Typ);
5694 -- Do not need init for interfaces on virtual targets since they're
5697 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5698 Build_Record_Init_Proc (Typ_Decl, Typ);
5701 -- For tagged type that are not interfaces, build bodies of primitive
5702 -- operations. Note: do this after building the record initialization
5703 -- procedure, since the primitive operations may need the initialization
5704 -- routine. There is no need to add predefined primitives of interfaces
5705 -- because all their predefined primitives are abstract.
5707 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5709 -- Do not add the body of predefined primitives in case of CPP tagged
5710 -- type derivations that have convention CPP.
5712 if Is_CPP_Class (Root_Type (Typ))
5713 and then Convention (Typ) = Convention_CPP
5717 -- Do not add the body of the predefined primitives if we are
5718 -- compiling under restriction No_Dispatching_Calls or if we are
5719 -- compiling a CPP tagged type.
5721 elsif not Restriction_Active (No_Dispatching_Calls) then
5723 -- Create the body of TSS primitive Finalize_Address. This must
5724 -- be done before the bodies of all predefined primitives are
5725 -- created. If Typ is limited, Stream_Input and Stream_Read may
5726 -- produce build-in-place allocations and for those the expander
5727 -- needs Finalize_Address.
5729 Make_Finalize_Address_Body (Typ);
5730 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5731 Append_Freeze_Actions (Typ, Predef_List);
5734 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5735 -- inherited functions, then add their bodies to the freeze actions.
5737 if Present (Wrapper_Body_List) then
5738 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5741 -- Create extra formals for the primitive operations of the type.
5742 -- This must be done before analyzing the body of the initialization
5743 -- procedure, because a self-referential type might call one of these
5744 -- primitives in the body of the init_proc itself.
5751 Elmt := First_Elmt (Primitive_Operations (Typ));
5752 while Present (Elmt) loop
5753 Subp := Node (Elmt);
5754 if not Has_Foreign_Convention (Subp)
5755 and then not Is_Predefined_Dispatching_Operation (Subp)
5757 Create_Extra_Formals (Subp);
5764 end Expand_Freeze_Record_Type;
5766 ------------------------------------
5767 -- Expand_N_Full_Type_Declaration --
5768 ------------------------------------
5770 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5771 procedure Build_Master (Ptr_Typ : Entity_Id);
5772 -- Create the master associated with Ptr_Typ
5778 procedure Build_Master (Ptr_Typ : Entity_Id) is
5779 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5782 -- If the designated type is an incomplete view coming from a
5783 -- limited-with'ed package, we need to use the nonlimited view in
5784 -- case it has tasks.
5786 if Is_Incomplete_Type (Desig_Typ)
5787 and then Present (Non_Limited_View (Desig_Typ))
5789 Desig_Typ := Non_Limited_View (Desig_Typ);
5792 -- Anonymous access types are created for the components of the
5793 -- record parameter for an entry declaration. No master is created
5796 if Has_Task (Desig_Typ) then
5797 Build_Master_Entity (Ptr_Typ);
5798 Build_Master_Renaming (Ptr_Typ);
5800 -- Create a class-wide master because a Master_Id must be generated
5801 -- for access-to-limited-class-wide types whose root may be extended
5802 -- with task components.
5804 -- Note: This code covers access-to-limited-interfaces because they
5805 -- can be used to reference tasks implementing them.
5807 -- Suppress the master creation for access types created for entry
5808 -- formal parameters (parameter block component types). Seems like
5809 -- suppression should be more general for compiler-generated types,
5810 -- but testing Comes_From_Source may be too general in this case
5811 -- (affects some test output)???
5813 elsif not Is_Param_Block_Component_Type (Ptr_Typ)
5814 and then Is_Limited_Class_Wide_Type (Desig_Typ)
5816 Build_Class_Wide_Master (Ptr_Typ);
5820 -- Local declarations
5822 Def_Id : constant Entity_Id := Defining_Identifier (N);
5823 B_Id : constant Entity_Id := Base_Type (Def_Id);
5827 -- Start of processing for Expand_N_Full_Type_Declaration
5830 if Is_Access_Type (Def_Id) then
5831 Build_Master (Def_Id);
5833 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5834 Expand_Access_Protected_Subprogram_Type (N);
5837 -- Array of anonymous access-to-task pointers
5839 elsif Ada_Version >= Ada_2005
5840 and then Is_Array_Type (Def_Id)
5841 and then Is_Access_Type (Component_Type (Def_Id))
5842 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5844 Build_Master (Component_Type (Def_Id));
5846 elsif Has_Task (Def_Id) then
5847 Expand_Previous_Access_Type (Def_Id);
5849 -- Check the components of a record type or array of records for
5850 -- anonymous access-to-task pointers.
5852 elsif Ada_Version >= Ada_2005
5853 and then (Is_Record_Type (Def_Id)
5855 (Is_Array_Type (Def_Id)
5856 and then Is_Record_Type (Component_Type (Def_Id))))
5861 M_Id : Entity_Id := Empty;
5865 if Is_Array_Type (Def_Id) then
5866 Comp := First_Entity (Component_Type (Def_Id));
5868 Comp := First_Entity (Def_Id);
5871 -- Examine all components looking for anonymous access-to-task
5875 while Present (Comp) loop
5876 Typ := Etype (Comp);
5878 if Ekind (Typ) = E_Anonymous_Access_Type
5879 and then Has_Task (Available_View (Designated_Type (Typ)))
5880 and then No (Master_Id (Typ))
5882 -- Ensure that the record or array type have a _master
5885 Build_Master_Entity (Def_Id);
5886 Build_Master_Renaming (Typ);
5887 M_Id := Master_Id (Typ);
5891 -- Reuse the same master to service any additional types
5894 pragma Assert (Present (M_Id));
5895 Set_Master_Id (Typ, M_Id);
5904 Par_Id := Etype (B_Id);
5906 -- The parent type is private then we need to inherit any TSS operations
5907 -- from the full view.
5909 if Ekind (Par_Id) in Private_Kind
5910 and then Present (Full_View (Par_Id))
5912 Par_Id := Base_Type (Full_View (Par_Id));
5915 if Nkind (Type_Definition (Original_Node (N))) =
5916 N_Derived_Type_Definition
5917 and then not Is_Tagged_Type (Def_Id)
5918 and then Present (Freeze_Node (Par_Id))
5919 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
5921 Ensure_Freeze_Node (B_Id);
5922 FN := Freeze_Node (B_Id);
5924 if No (TSS_Elist (FN)) then
5925 Set_TSS_Elist (FN, New_Elmt_List);
5929 T_E : constant Elist_Id := TSS_Elist (FN);
5933 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
5934 while Present (Elmt) loop
5935 if Chars (Node (Elmt)) /= Name_uInit then
5936 Append_Elmt (Node (Elmt), T_E);
5942 -- If the derived type itself is private with a full view, then
5943 -- associate the full view with the inherited TSS_Elist as well.
5945 if Ekind (B_Id) in Private_Kind
5946 and then Present (Full_View (B_Id))
5948 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
5950 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
5954 end Expand_N_Full_Type_Declaration;
5956 ---------------------------------
5957 -- Expand_N_Object_Declaration --
5958 ---------------------------------
5960 procedure Expand_N_Object_Declaration (N : Node_Id) is
5961 Loc : constant Source_Ptr := Sloc (N);
5962 Def_Id : constant Entity_Id := Defining_Identifier (N);
5963 Expr : constant Node_Id := Expression (N);
5964 Obj_Def : constant Node_Id := Object_Definition (N);
5965 Typ : constant Entity_Id := Etype (Def_Id);
5966 Base_Typ : constant Entity_Id := Base_Type (Typ);
5969 function Build_Equivalent_Aggregate return Boolean;
5970 -- If the object has a constrained discriminated type and no initial
5971 -- value, it may be possible to build an equivalent aggregate instead,
5972 -- and prevent an actual call to the initialization procedure.
5974 procedure Count_Default_Sized_Task_Stacks
5976 Pri_Stacks : out Int;
5977 Sec_Stacks : out Int);
5978 -- Count the number of default-sized primary and secondary task stacks
5979 -- required for task objects contained within type Typ. If the number of
5980 -- task objects contained within the type is not known at compile time
5981 -- the procedure will return the stack counts of zero.
5983 procedure Default_Initialize_Object (After : Node_Id);
5984 -- Generate all default initialization actions for object Def_Id. Any
5985 -- new code is inserted after node After.
5987 function Rewrite_As_Renaming return Boolean;
5988 -- Indicate whether to rewrite a declaration with initialization into an
5989 -- object renaming declaration (see below).
5991 --------------------------------
5992 -- Build_Equivalent_Aggregate --
5993 --------------------------------
5995 function Build_Equivalent_Aggregate return Boolean is
5999 Full_Type : Entity_Id;
6004 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6005 Full_Type := Full_View (Typ);
6008 -- Only perform this transformation if Elaboration_Code is forbidden
6009 -- or undesirable, and if this is a global entity of a constrained
6012 -- If Initialize_Scalars might be active this transformation cannot
6013 -- be performed either, because it will lead to different semantics
6014 -- or because elaboration code will in fact be created.
6016 if Ekind (Full_Type) /= E_Record_Subtype
6017 or else not Has_Discriminants (Full_Type)
6018 or else not Is_Constrained (Full_Type)
6019 or else Is_Controlled (Full_Type)
6020 or else Is_Limited_Type (Full_Type)
6021 or else not Restriction_Active (No_Initialize_Scalars)
6026 if Ekind (Current_Scope) = E_Package
6028 (Restriction_Active (No_Elaboration_Code)
6029 or else Is_Preelaborated (Current_Scope))
6031 -- Building a static aggregate is possible if the discriminants
6032 -- have static values and the other components have static
6033 -- defaults or none.
6035 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6036 while Present (Discr) loop
6037 if not Is_OK_Static_Expression (Node (Discr)) then
6044 -- Check that initialized components are OK, and that non-
6045 -- initialized components do not require a call to their own
6046 -- initialization procedure.
6048 Comp := First_Component (Full_Type);
6049 while Present (Comp) loop
6050 if Ekind (Comp) = E_Component
6051 and then Present (Expression (Parent (Comp)))
6053 not Is_OK_Static_Expression (Expression (Parent (Comp)))
6057 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
6062 Next_Component (Comp);
6065 -- Everything is static, assemble the aggregate, discriminant
6069 Make_Aggregate (Loc,
6070 Expressions => New_List,
6071 Component_Associations => New_List);
6073 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6074 while Present (Discr) loop
6075 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
6079 -- Now collect values of initialized components
6081 Comp := First_Component (Full_Type);
6082 while Present (Comp) loop
6083 if Ekind (Comp) = E_Component
6084 and then Present (Expression (Parent (Comp)))
6086 Append_To (Component_Associations (Aggr),
6087 Make_Component_Association (Loc,
6088 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
6089 Expression => New_Copy_Tree
6090 (Expression (Parent (Comp)))));
6093 Next_Component (Comp);
6096 -- Finally, box-initialize remaining components
6098 Append_To (Component_Associations (Aggr),
6099 Make_Component_Association (Loc,
6100 Choices => New_List (Make_Others_Choice (Loc)),
6101 Expression => Empty));
6102 Set_Box_Present (Last (Component_Associations (Aggr)));
6103 Set_Expression (N, Aggr);
6105 if Typ /= Full_Type then
6106 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
6107 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
6108 Analyze_And_Resolve (Aggr, Typ);
6110 Analyze_And_Resolve (Aggr, Full_Type);
6118 end Build_Equivalent_Aggregate;
6120 -------------------------------------
6121 -- Count_Default_Sized_Task_Stacks --
6122 -------------------------------------
6124 procedure Count_Default_Sized_Task_Stacks
6126 Pri_Stacks : out Int;
6127 Sec_Stacks : out Int)
6129 Component : Entity_Id;
6132 -- To calculate the number of default-sized task stacks required for
6133 -- an object of Typ, a depth-first recursive traversal of the AST
6134 -- from the Typ entity node is undertaken. Only type nodes containing
6135 -- task objects are visited.
6140 if not Has_Task (Typ) then
6148 -- A task type is found marking the bottom of the descent. If
6149 -- the type has no representation aspect for the corresponding
6150 -- stack then that stack is using the default size.
6152 if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then
6158 if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then
6164 when E_Array_Subtype
6167 -- First find the number of default stacks contained within an
6170 Count_Default_Sized_Task_Stacks
6171 (Component_Type (Typ),
6175 -- Then multiply the result by the size of the array
6178 Quantity : constant Int := Number_Of_Elements_In_Array (Typ);
6179 -- Number_Of_Elements_In_Array is non-trival, consequently
6180 -- its result is captured as an optimization.
6183 Pri_Stacks := Pri_Stacks * Quantity;
6184 Sec_Stacks := Sec_Stacks * Quantity;
6187 when E_Protected_Subtype
6192 Component := First_Component_Or_Discriminant (Typ);
6194 -- Recursively descend each component of the composite type
6195 -- looking for tasks, but only if the component is marked as
6198 while Present (Component) loop
6199 if Has_Task (Etype (Component)) then
6205 Count_Default_Sized_Task_Stacks
6206 (Etype (Component), P, S);
6207 Pri_Stacks := Pri_Stacks + P;
6208 Sec_Stacks := Sec_Stacks + S;
6212 Next_Component_Or_Discriminant (Component);
6215 when E_Limited_Private_Subtype
6216 | E_Limited_Private_Type
6217 | E_Record_Subtype_With_Private
6218 | E_Record_Type_With_Private
6220 -- Switch to the full view of the private type to continue
6223 Count_Default_Sized_Task_Stacks
6224 (Full_View (Typ), Pri_Stacks, Sec_Stacks);
6226 -- Other types should not contain tasks
6229 raise Program_Error;
6231 end Count_Default_Sized_Task_Stacks;
6233 -------------------------------
6234 -- Default_Initialize_Object --
6235 -------------------------------
6237 procedure Default_Initialize_Object (After : Node_Id) is
6238 function New_Object_Reference return Node_Id;
6239 -- Return a new reference to Def_Id with attributes Assignment_OK and
6240 -- Must_Not_Freeze already set.
6242 function Simple_Initialization_OK
6243 (Init_Typ : Entity_Id) return Boolean;
6244 -- Determine whether object declaration N with entity Def_Id needs
6245 -- simple initialization, assuming that it is of type Init_Typ.
6247 --------------------------
6248 -- New_Object_Reference --
6249 --------------------------
6251 function New_Object_Reference return Node_Id is
6252 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
6255 -- The call to the type init proc or [Deep_]Finalize must not
6256 -- freeze the related object as the call is internally generated.
6257 -- This way legal rep clauses that apply to the object will not be
6258 -- flagged. Note that the initialization call may be removed if
6259 -- pragma Import is encountered or moved to the freeze actions of
6260 -- the object because of an address clause.
6262 Set_Assignment_OK (Obj_Ref);
6263 Set_Must_Not_Freeze (Obj_Ref);
6266 end New_Object_Reference;
6268 ------------------------------
6269 -- Simple_Initialization_OK --
6270 ------------------------------
6272 function Simple_Initialization_OK
6273 (Init_Typ : Entity_Id) return Boolean
6276 -- Do not consider the object declaration if it comes with an
6277 -- initialization expression, or is internal in which case it
6278 -- will be assigned later.
6281 not Is_Internal (Def_Id)
6282 and then not Has_Init_Expression (N)
6283 and then Needs_Simple_Initialization
6287 and then No (Following_Address_Clause (N)));
6288 end Simple_Initialization_OK;
6292 Exceptions_OK : constant Boolean :=
6293 not Restriction_Active (No_Exception_Propagation);
6295 Aggr_Init : Node_Id;
6296 Comp_Init : List_Id := No_List;
6297 Fin_Block : Node_Id;
6299 Init_Stmts : List_Id := No_List;
6300 Obj_Init : Node_Id := Empty;
6303 -- Start of processing for Default_Initialize_Object
6306 -- Default initialization is suppressed for objects that are already
6307 -- known to be imported (i.e. whose declaration specifies the Import
6308 -- aspect). Note that for objects with a pragma Import, we generate
6309 -- initialization here, and then remove it downstream when processing
6310 -- the pragma. It is also suppressed for variables for which a pragma
6311 -- Suppress_Initialization has been explicitly given
6313 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
6316 -- Nothing to do if the object being initialized is of a task type
6317 -- and restriction No_Tasking is in effect, because this is a direct
6318 -- violation of the restriction.
6320 elsif Is_Task_Type (Base_Typ)
6321 and then Restriction_Active (No_Tasking)
6326 -- The expansion performed by this routine is as follows:
6330 -- Type_Init_Proc (Obj);
6333 -- [Deep_]Initialize (Obj);
6337 -- [Deep_]Finalize (Obj, Self => False);
6341 -- Abort_Undefer_Direct;
6344 -- Initialize the components of the object
6346 if Has_Non_Null_Base_Init_Proc (Typ)
6347 and then not No_Initialization (N)
6348 and then not Initialization_Suppressed (Typ)
6350 -- Do not initialize the components if No_Default_Initialization
6351 -- applies as the actual restriction check will occur later when
6352 -- the object is frozen as it is not known yet whether the object
6353 -- is imported or not.
6355 if not Restriction_Active (No_Default_Initialization) then
6357 -- If the values of the components are compile-time known, use
6358 -- their prebuilt aggregate form directly.
6360 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
6362 if Present (Aggr_Init) then
6364 New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
6366 -- If type has discriminants, try to build an equivalent
6367 -- aggregate using discriminant values from the declaration.
6368 -- This is a useful optimization, in particular if restriction
6369 -- No_Elaboration_Code is active.
6371 elsif Build_Equivalent_Aggregate then
6374 -- Optimize the default initialization of an array object when
6375 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
6376 -- Construct an in-place initialization aggregate which may be
6377 -- convert into a fast memset by the backend.
6379 elsif Init_Or_Norm_Scalars
6380 and then Is_Array_Type (Typ)
6382 -- The array must lack atomic components because they are
6383 -- treated as non-static, and as a result the backend will
6384 -- not initialize the memory in one go.
6386 and then not Has_Atomic_Components (Typ)
6388 -- The array must not be packed because the invalid values
6389 -- in System.Scalar_Values are multiples of Storage_Unit.
6391 and then not Is_Packed (Typ)
6393 -- The array must have static non-empty ranges, otherwise
6394 -- the backend cannot initialize the memory in one go.
6396 and then Has_Static_Non_Empty_Array_Bounds (Typ)
6398 -- The optimization is only relevant for arrays of scalar
6401 and then Is_Scalar_Type (Component_Type (Typ))
6403 -- Similar to regular array initialization using a type
6404 -- init proc, predicate checks are not performed because the
6405 -- initialization values are intentionally invalid, and may
6406 -- violate the predicate.
6408 and then not Has_Predicates (Component_Type (Typ))
6410 -- The component type must have a single initialization value
6412 and then Simple_Initialization_OK (Component_Type (Typ))
6414 Set_No_Initialization (N, False);
6419 Size => Esize (Def_Id)));
6422 (Expression (N), Typ, Suppress => All_Checks);
6424 -- Otherwise invoke the type init proc, generate:
6425 -- Type_Init_Proc (Obj);
6428 Obj_Ref := New_Object_Reference;
6430 if Comes_From_Source (Def_Id) then
6431 Initialization_Warning (Obj_Ref);
6434 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
6438 -- Provide a default value if the object needs simple initialization
6440 elsif Simple_Initialization_OK (Typ) then
6441 Set_No_Initialization (N, False);
6446 Size => Esize (Def_Id)));
6448 Analyze_And_Resolve (Expression (N), Typ);
6451 -- Initialize the object, generate:
6452 -- [Deep_]Initialize (Obj);
6454 if Needs_Finalization (Typ) and then not No_Initialization (N) then
6457 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
6461 -- Build a special finalization block when both the object and its
6462 -- controlled components are to be initialized. The block finalizes
6463 -- the components if the object initialization fails. Generate:
6474 if Has_Controlled_Component (Typ)
6475 and then Present (Comp_Init)
6476 and then Present (Obj_Init)
6477 and then Exceptions_OK
6479 Init_Stmts := Comp_Init;
6483 (Obj_Ref => New_Object_Reference,
6487 if Present (Fin_Call) then
6489 -- Do not emit warnings related to the elaboration order when a
6490 -- controlled object is declared before the body of Finalize is
6493 if Legacy_Elaboration_Checks then
6494 Set_No_Elaboration_Check (Fin_Call);
6498 Make_Block_Statement (Loc,
6499 Declarations => No_List,
6501 Handled_Statement_Sequence =>
6502 Make_Handled_Sequence_Of_Statements (Loc,
6503 Statements => New_List (Obj_Init),
6505 Exception_Handlers => New_List (
6506 Make_Exception_Handler (Loc,
6507 Exception_Choices => New_List (
6508 Make_Others_Choice (Loc)),
6510 Statements => New_List (
6512 Make_Raise_Statement (Loc))))));
6514 -- Signal the ABE mechanism that the block carries out
6515 -- initialization actions.
6517 Set_Is_Initialization_Block (Fin_Block);
6519 Append_To (Init_Stmts, Fin_Block);
6522 -- Otherwise finalization is not required, the initialization calls
6523 -- are passed to the abort block building circuitry, generate:
6525 -- Type_Init_Proc (Obj);
6526 -- [Deep_]Initialize (Obj);
6529 if Present (Comp_Init) then
6530 Init_Stmts := Comp_Init;
6533 if Present (Obj_Init) then
6534 if No (Init_Stmts) then
6535 Init_Stmts := New_List;
6538 Append_To (Init_Stmts, Obj_Init);
6542 -- Build an abort block to protect the initialization calls
6545 and then Present (Comp_Init)
6546 and then Present (Obj_Init)
6551 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
6553 -- When exceptions are propagated, abort deferral must take place
6554 -- in the presence of initialization or finalization exceptions.
6561 -- Abort_Undefer_Direct;
6564 if Exceptions_OK then
6565 Init_Stmts := New_List (
6566 Build_Abort_Undefer_Block (Loc,
6567 Stmts => Init_Stmts,
6570 -- Otherwise exceptions are not propagated. Generate:
6577 Append_To (Init_Stmts,
6578 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6582 -- Insert the whole initialization sequence into the tree. If the
6583 -- object has a delayed freeze, as will be the case when it has
6584 -- aspect specifications, the initialization sequence is part of
6585 -- the freeze actions.
6587 if Present (Init_Stmts) then
6588 if Has_Delayed_Freeze (Def_Id) then
6589 Append_Freeze_Actions (Def_Id, Init_Stmts);
6591 Insert_Actions_After (After, Init_Stmts);
6594 end Default_Initialize_Object;
6596 -------------------------
6597 -- Rewrite_As_Renaming --
6598 -------------------------
6600 function Rewrite_As_Renaming return Boolean is
6601 Result : constant Boolean :=
6603 -- If the object declaration appears in the form
6605 -- Obj : Ctrl_Typ := Func (...);
6607 -- where Ctrl_Typ is controlled but not immutably limited type, then
6608 -- the expansion of the function call should use a dereference of the
6609 -- result to reference the value on the secondary stack.
6611 -- Obj : Ctrl_Typ renames Func (...).all;
6613 -- As a result, the call avoids an extra copy. This an optimization,
6614 -- but it is required for passing ACATS tests in some cases where it
6615 -- would otherwise make two copies. The RM allows removing redunant
6616 -- Adjust/Finalize calls, but does not allow insertion of extra ones.
6618 -- This part is disabled for now, because it breaks GNAT Studio
6622 and then Nkind (Expr_Q) = N_Explicit_Dereference
6623 and then not Comes_From_Source (Expr_Q)
6624 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
6625 and then Nkind (Object_Definition (N)) in N_Has_Entity
6626 and then (Needs_Finalization (Entity (Object_Definition (N)))))
6628 -- If the initializing expression is for a variable with attribute
6629 -- OK_To_Rename set, then transform:
6631 -- Obj : Typ := Expr;
6635 -- Obj : Typ renames Expr;
6637 -- provided that Obj is not aliased. The aliased case has to be
6638 -- excluded in general because Expr will not be aliased in
6642 (not Aliased_Present (N)
6643 and then Is_Entity_Name (Expr_Q)
6644 and then Ekind (Entity (Expr_Q)) = E_Variable
6645 and then OK_To_Rename (Entity (Expr_Q))
6646 and then Is_Entity_Name (Obj_Def));
6648 -- Return False if there are any aspect specifications, because
6649 -- otherwise we duplicate that corresponding implicit attribute
6650 -- definition, and call Insert_Action, which has no place to insert
6651 -- the attribute definition. The attribute definition is stored in
6652 -- Aspect_Rep_Item, which is not a list.
6654 return Result and then No (Aspect_Specifications (N));
6655 end Rewrite_As_Renaming;
6659 Next_N : constant Node_Id := Next (N);
6663 Tag_Assign : Node_Id;
6665 Init_After : Node_Id := N;
6666 -- Node after which the initialization actions are to be inserted. This
6667 -- is normally N, except for the case of a shared passive variable, in
6668 -- which case the init proc call must be inserted only after the bodies
6669 -- of the shared variable procedures have been seen.
6671 -- Start of processing for Expand_N_Object_Declaration
6674 -- Don't do anything for deferred constants. All proper actions will be
6675 -- expanded during the full declaration.
6677 if No (Expr) and Constant_Present (N) then
6681 -- The type of the object cannot be abstract. This is diagnosed at the
6682 -- point the object is frozen, which happens after the declaration is
6683 -- fully expanded, so simply return now.
6685 if Is_Abstract_Type (Typ) then
6689 -- No action needed for the internal imported dummy object added by
6690 -- Make_DT to compute the offset of the components that reference
6691 -- secondary dispatch tables; required to avoid never-ending loop
6692 -- processing this internal object declaration.
6694 if Tagged_Type_Expansion
6695 and then Is_Internal (Def_Id)
6696 and then Is_Imported (Def_Id)
6697 and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
6702 -- First we do special processing for objects of a tagged type where
6703 -- this is the point at which the type is frozen. The creation of the
6704 -- dispatch table and the initialization procedure have to be deferred
6705 -- to this point, since we reference previously declared primitive
6708 -- Force construction of dispatch tables of library level tagged types
6710 if Tagged_Type_Expansion
6711 and then Building_Static_Dispatch_Tables
6712 and then Is_Library_Level_Entity (Def_Id)
6713 and then Is_Library_Level_Tagged_Type (Base_Typ)
6714 and then Ekind_In (Base_Typ, E_Record_Type,
6717 and then not Has_Dispatch_Table (Base_Typ)
6720 New_Nodes : List_Id := No_List;
6723 if Is_Concurrent_Type (Base_Typ) then
6724 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
6726 New_Nodes := Make_DT (Base_Typ, N);
6729 if not Is_Empty_List (New_Nodes) then
6730 Insert_List_Before (N, New_Nodes);
6735 -- Make shared memory routines for shared passive variable
6737 if Is_Shared_Passive (Def_Id) then
6738 Init_After := Make_Shared_Var_Procs (N);
6741 -- If tasks are being declared, make sure we have an activation chain
6742 -- defined for the tasks (has no effect if we already have one), and
6743 -- also that a Master variable is established (and that the appropriate
6744 -- enclosing construct is established as a task master).
6746 if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
6747 Build_Activation_Chain_Entity (N);
6749 if Has_Task (Typ) then
6750 Build_Master_Entity (Def_Id);
6752 -- Handle objects initialized with BIP function calls
6754 elsif Present (Expr) then
6756 Expr_Q : Node_Id := Expr;
6759 if Nkind (Expr) = N_Qualified_Expression then
6760 Expr_Q := Expression (Expr);
6763 if Is_Build_In_Place_Function_Call (Expr_Q)
6764 or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
6766 (Nkind (Expr_Q) = N_Reference
6768 Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
6770 Build_Master_Entity (Def_Id);
6776 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
6777 -- restrictions are active then default-sized secondary stacks are
6778 -- generated by the binder and allocated by SS_Init. To provide the
6779 -- binder the number of stacks to generate, the number of default-sized
6780 -- stacks required for task objects contained within the object
6781 -- declaration N is calculated here as it is at this point where
6782 -- unconstrained types become constrained. The result is stored in the
6783 -- enclosing unit's Unit_Record.
6785 -- Note if N is an array object declaration that has an initialization
6786 -- expression, a second object declaration for the initialization
6787 -- expression is created by the compiler. To prevent double counting
6788 -- of the stacks in this scenario, the stacks of the first array are
6791 if (Has_Task (Typ) or else Might_Have_Tasks (Typ))
6792 and then not Restriction_Active (No_Secondary_Stack)
6793 and then (Restriction_Active (No_Implicit_Heap_Allocations)
6794 or else Restriction_Active (No_Implicit_Task_Allocations))
6795 and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype)
6796 and then (Has_Init_Expression (N)))
6799 PS_Count, SS_Count : Int := 0;
6801 Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count);
6802 Increment_Primary_Stack_Count (PS_Count);
6803 Increment_Sec_Stack_Count (SS_Count);
6807 -- Default initialization required, and no expression present
6811 -- If we have a type with a variant part, the initialization proc
6812 -- will contain implicit tests of the discriminant values, which
6813 -- counts as a violation of the restriction No_Implicit_Conditionals.
6815 if Has_Variant_Part (Typ) then
6820 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
6824 ("\initialization of variant record tests discriminants",
6831 -- For the default initialization case, if we have a private type
6832 -- with invariants, and invariant checks are enabled, then insert an
6833 -- invariant check after the object declaration. Note that it is OK
6834 -- to clobber the object with an invalid value since if the exception
6835 -- is raised, then the object will go out of scope. In the case where
6836 -- an array object is initialized with an aggregate, the expression
6837 -- is removed. Check flag Has_Init_Expression to avoid generating a
6838 -- junk invariant check and flag No_Initialization to avoid checking
6839 -- an uninitialized object such as a compiler temporary used for an
6842 if Has_Invariants (Base_Typ)
6843 and then Present (Invariant_Procedure (Base_Typ))
6844 and then not Has_Init_Expression (N)
6845 and then not No_Initialization (N)
6847 -- If entity has an address clause or aspect, make invariant
6848 -- call into a freeze action for the explicit freeze node for
6849 -- object. Otherwise insert invariant check after declaration.
6851 if Present (Following_Address_Clause (N))
6852 or else Has_Aspect (Def_Id, Aspect_Address)
6854 Ensure_Freeze_Node (Def_Id);
6855 Set_Has_Delayed_Freeze (Def_Id);
6856 Set_Is_Frozen (Def_Id, False);
6858 if not Partial_View_Has_Unknown_Discr (Typ) then
6859 Append_Freeze_Action (Def_Id,
6860 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6863 elsif not Partial_View_Has_Unknown_Discr (Typ) then
6865 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6869 Default_Initialize_Object (Init_After);
6871 -- Generate attribute for Persistent_BSS if needed
6873 if Persistent_BSS_Mode
6874 and then Comes_From_Source (N)
6875 and then Is_Potentially_Persistent_Type (Typ)
6876 and then not Has_Init_Expression (N)
6877 and then Is_Library_Level_Entity (Def_Id)
6883 Make_Linker_Section_Pragma
6884 (Def_Id, Sloc (N), ".persistent.bss");
6885 Insert_After (N, Prag);
6890 -- If access type, then we know it is null if not initialized
6892 if Is_Access_Type (Typ) then
6893 Set_Is_Known_Null (Def_Id);
6896 -- Explicit initialization present
6899 -- Obtain actual expression from qualified expression
6901 if Nkind (Expr) = N_Qualified_Expression then
6902 Expr_Q := Expression (Expr);
6907 -- When we have the appropriate type of aggregate in the expression
6908 -- (it has been determined during analysis of the aggregate by
6909 -- setting the delay flag), let's perform in place assignment and
6910 -- thus avoid creating a temporary.
6912 if Is_Delayed_Aggregate (Expr_Q) then
6914 -- An aggregate that must be built in place is not resolved and
6915 -- expanded until the enclosing construct is expanded. This will
6916 -- happen when the aggregate is limited and the declared object
6917 -- has a following address clause; it happens also when generating
6918 -- C code for an aggregate that has an alignment or address clause
6919 -- (see Analyze_Object_Declaration).
6921 if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
6922 and then not Analyzed (Expr)
6924 Resolve (Expr, Typ);
6927 Convert_Aggr_In_Object_Decl (N);
6929 -- Ada 2005 (AI-318-02): If the initialization expression is a call
6930 -- to a build-in-place function, then access to the declared object
6931 -- must be passed to the function. Currently we limit such functions
6932 -- to those with constrained limited result subtypes, but eventually
6933 -- plan to expand the allowed forms of functions that are treated as
6936 elsif Is_Build_In_Place_Function_Call (Expr_Q) then
6937 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
6939 -- The previous call expands the expression initializing the
6940 -- built-in-place object into further code that will be analyzed
6941 -- later. No further expansion needed here.
6945 -- This is the same as the previous 'elsif', except that the call has
6946 -- been transformed by other expansion activities into something like
6947 -- F(...)'Reference.
6949 elsif Nkind (Expr_Q) = N_Reference
6950 and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
6951 and then not Is_Expanded_Build_In_Place_Call
6952 (Unqual_Conv (Prefix (Expr_Q)))
6954 Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
6956 -- The previous call expands the expression initializing the
6957 -- built-in-place object into further code that will be analyzed
6958 -- later. No further expansion needed here.
6962 -- Ada 2005 (AI-318-02): Specialization of the previous case for
6963 -- expressions containing a build-in-place function call whose
6964 -- returned object covers interface types, and Expr_Q has calls to
6965 -- Ada.Tags.Displace to displace the pointer to the returned build-
6966 -- in-place object to reference the secondary dispatch table of a
6967 -- covered interface type.
6969 elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
6970 Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
6972 -- The previous call expands the expression initializing the
6973 -- built-in-place object into further code that will be analyzed
6974 -- later. No further expansion needed here.
6978 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
6979 -- class-wide interface object to ensure that we copy the full
6980 -- object, unless we are targetting a VM where interfaces are handled
6981 -- by VM itself. Note that if the root type of Typ is an ancestor of
6982 -- Expr's type, both types share the same dispatch table and there is
6983 -- no need to displace the pointer.
6985 elsif Is_Interface (Typ)
6987 -- Avoid never-ending recursion because if Equivalent_Type is set
6988 -- then we've done it already and must not do it again.
6991 (Nkind (Obj_Def) = N_Identifier
6992 and then Present (Equivalent_Type (Entity (Obj_Def))))
6994 pragma Assert (Is_Class_Wide_Type (Typ));
6996 -- If the object is a return object of an inherently limited type,
6997 -- which implies build-in-place treatment, bypass the special
6998 -- treatment of class-wide interface initialization below. In this
6999 -- case, the expansion of the return statement will take care of
7000 -- creating the object (via allocator) and initializing it.
7002 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
7005 elsif Tagged_Type_Expansion then
7007 Iface : constant Entity_Id := Root_Type (Typ);
7008 Expr_N : Node_Id := Expr;
7009 Expr_Typ : Entity_Id;
7015 -- If the original node of the expression was a conversion
7016 -- to this specific class-wide interface type then restore
7017 -- the original node because we must copy the object before
7018 -- displacing the pointer to reference the secondary tag
7019 -- component. This code must be kept synchronized with the
7020 -- expansion done by routine Expand_Interface_Conversion
7022 if not Comes_From_Source (Expr_N)
7023 and then Nkind (Expr_N) = N_Explicit_Dereference
7024 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
7025 and then Etype (Original_Node (Expr_N)) = Typ
7027 Rewrite (Expr_N, Original_Node (Expression (N)));
7030 -- Avoid expansion of redundant interface conversion
7032 if Is_Interface (Etype (Expr_N))
7033 and then Nkind (Expr_N) = N_Type_Conversion
7034 and then Etype (Expr_N) = Typ
7036 Expr_N := Expression (Expr_N);
7037 Set_Expression (N, Expr_N);
7040 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
7041 Expr_Typ := Base_Type (Etype (Expr_N));
7043 if Is_Class_Wide_Type (Expr_Typ) then
7044 Expr_Typ := Root_Type (Expr_Typ);
7048 -- CW : I'Class := Obj;
7051 -- type Ityp is not null access I'Class;
7052 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
7054 if Comes_From_Source (Expr_N)
7055 and then Nkind (Expr_N) = N_Identifier
7056 and then not Is_Interface (Expr_Typ)
7057 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
7058 and then (Expr_Typ = Etype (Expr_Typ)
7060 Is_Variable_Size_Record (Etype (Expr_Typ)))
7065 Make_Object_Declaration (Loc,
7066 Defining_Identifier => Obj_Id,
7067 Object_Definition =>
7068 New_Occurrence_Of (Expr_Typ, Loc),
7069 Expression => Relocate_Node (Expr_N)));
7071 -- Statically reference the tag associated with the
7075 Make_Selected_Component (Loc,
7076 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7079 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
7082 -- IW : I'Class := Obj;
7084 -- type Equiv_Record is record ... end record;
7085 -- implicit subtype CW is <Class_Wide_Subtype>;
7086 -- Tmp : CW := CW!(Obj);
7087 -- type Ityp is not null access I'Class;
7088 -- IW : I'Class renames
7089 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
7092 -- Generate the equivalent record type and update the
7093 -- subtype indication to reference it.
7095 Expand_Subtype_From_Expr
7098 Subtype_Indic => Obj_Def,
7101 if not Is_Interface (Etype (Expr_N)) then
7102 New_Expr := Relocate_Node (Expr_N);
7104 -- For interface types we use 'Address which displaces
7105 -- the pointer to the base of the object (if required)
7109 Unchecked_Convert_To (Etype (Obj_Def),
7110 Make_Explicit_Dereference (Loc,
7111 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7112 Make_Attribute_Reference (Loc,
7113 Prefix => Relocate_Node (Expr_N),
7114 Attribute_Name => Name_Address))));
7119 if not Is_Limited_Record (Expr_Typ) then
7121 Make_Object_Declaration (Loc,
7122 Defining_Identifier => Obj_Id,
7123 Object_Definition =>
7124 New_Occurrence_Of (Etype (Obj_Def), Loc),
7125 Expression => New_Expr));
7127 -- Rename limited type object since they cannot be copied
7128 -- This case occurs when the initialization expression
7129 -- has been previously expanded into a temporary object.
7131 else pragma Assert (not Comes_From_Source (Expr_Q));
7133 Make_Object_Renaming_Declaration (Loc,
7134 Defining_Identifier => Obj_Id,
7136 New_Occurrence_Of (Etype (Obj_Def), Loc),
7138 Unchecked_Convert_To
7139 (Etype (Obj_Def), New_Expr)));
7142 -- Dynamically reference the tag associated with the
7146 Make_Function_Call (Loc,
7147 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
7148 Parameter_Associations => New_List (
7149 Make_Attribute_Reference (Loc,
7150 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7151 Attribute_Name => Name_Address),
7153 (Node (First_Elmt (Access_Disp_Table (Iface))),
7158 Make_Object_Renaming_Declaration (Loc,
7159 Defining_Identifier => Make_Temporary (Loc, 'D'),
7160 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7162 Convert_Tag_To_Interface (Typ, Tag_Comp)));
7164 -- If the original entity comes from source, then mark the
7165 -- new entity as needing debug information, even though it's
7166 -- defined by a generated renaming that does not come from
7167 -- source, so that Materialize_Entity will be set on the
7168 -- entity when Debug_Renaming_Declaration is called during
7171 if Comes_From_Source (Def_Id) then
7172 Set_Debug_Info_Needed (Defining_Identifier (N));
7175 Analyze (N, Suppress => All_Checks);
7177 -- Replace internal identifier of rewritten node by the
7178 -- identifier found in the sources. We also have to exchange
7179 -- entities containing their defining identifiers to ensure
7180 -- the correct replacement of the object declaration by this
7181 -- object renaming declaration because these identifiers
7182 -- were previously added by Enter_Name to the current scope.
7183 -- We must preserve the homonym chain of the source entity
7184 -- as well. We must also preserve the kind of the entity,
7185 -- which may be a constant. Preserve entity chain because
7186 -- itypes may have been generated already, and the full
7187 -- chain must be preserved for final freezing. Finally,
7188 -- preserve Comes_From_Source setting, so that debugging
7189 -- and cross-referencing information is properly kept, and
7190 -- preserve source location, to prevent spurious errors when
7191 -- entities are declared (they must have their own Sloc).
7194 New_Id : constant Entity_Id := Defining_Identifier (N);
7195 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
7196 Save_CFS : constant Boolean :=
7197 Comes_From_Source (Def_Id);
7198 Save_SP : constant Node_Id := SPARK_Pragma (Def_Id);
7199 Save_SPI : constant Boolean :=
7200 SPARK_Pragma_Inherited (Def_Id);
7203 Link_Entities (New_Id, Next_Entity (Def_Id));
7204 Link_Entities (Def_Id, Next_Temp);
7206 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
7207 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
7208 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
7209 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
7211 Set_Comes_From_Source (Def_Id, False);
7213 -- ??? This is extremely dangerous!!! Exchanging entities
7214 -- is very low level, and as a result it resets flags and
7215 -- fields which belong to the original Def_Id. Several of
7216 -- these attributes are saved and restored, but there may
7217 -- be many more that need to be preserverd.
7219 Exchange_Entities (Defining_Identifier (N), Def_Id);
7221 -- Restore clobbered attributes
7223 Set_Comes_From_Source (Def_Id, Save_CFS);
7224 Set_SPARK_Pragma (Def_Id, Save_SP);
7225 Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI);
7232 -- Common case of explicit object initialization
7235 -- In most cases, we must check that the initial value meets any
7236 -- constraint imposed by the declared type. However, there is one
7237 -- very important exception to this rule. If the entity has an
7238 -- unconstrained nominal subtype, then it acquired its constraints
7239 -- from the expression in the first place, and not only does this
7240 -- mean that the constraint check is not needed, but an attempt to
7241 -- perform the constraint check can cause order of elaboration
7244 if not Is_Constr_Subt_For_U_Nominal (Typ) then
7246 -- If this is an allocator for an aggregate that has been
7247 -- allocated in place, delay checks until assignments are
7248 -- made, because the discriminants are not initialized.
7250 if Nkind (Expr) = N_Allocator
7251 and then No_Initialization (Expr)
7255 -- Otherwise apply a constraint check now if no prev error
7257 elsif Nkind (Expr) /= N_Error then
7258 Apply_Constraint_Check (Expr, Typ);
7260 -- Deal with possible range check
7262 if Do_Range_Check (Expr) then
7264 -- If assignment checks are suppressed, turn off flag
7266 if Suppress_Assignment_Checks (N) then
7267 Set_Do_Range_Check (Expr, False);
7269 -- Otherwise generate the range check
7272 Generate_Range_Check
7273 (Expr, Typ, CE_Range_Check_Failed);
7279 -- If the type is controlled and not inherently limited, then
7280 -- the target is adjusted after the copy and attached to the
7281 -- finalization list. However, no adjustment is done in the case
7282 -- where the object was initialized by a call to a function whose
7283 -- result is built in place, since no copy occurred. Similarly, no
7284 -- adjustment is required if we are going to rewrite the object
7285 -- declaration into a renaming declaration.
7287 if Needs_Finalization (Typ)
7288 and then not Is_Limited_View (Typ)
7289 and then not Rewrite_As_Renaming
7293 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
7296 -- Guard against a missing [Deep_]Adjust when the base type
7297 -- was not properly frozen.
7299 if Present (Adj_Call) then
7300 Insert_Action_After (Init_After, Adj_Call);
7304 -- For tagged types, when an init value is given, the tag has to
7305 -- be re-initialized separately in order to avoid the propagation
7306 -- of a wrong tag coming from a view conversion unless the type
7307 -- is class wide (in this case the tag comes from the init value).
7308 -- Suppress the tag assignment when not Tagged_Type_Expansion
7309 -- because tags are represented implicitly in objects. Ditto for
7310 -- types that are CPP_CLASS, and for initializations that are
7311 -- aggregates, because they have to have the right tag.
7313 -- The re-assignment of the tag has to be done even if the object
7314 -- is a constant. The assignment must be analyzed after the
7315 -- declaration. If an address clause follows, this is handled as
7316 -- part of the freeze actions for the object, otherwise insert
7317 -- tag assignment here.
7319 Tag_Assign := Make_Tag_Assignment (N);
7321 if Present (Tag_Assign) then
7322 if Present (Following_Address_Clause (N)) then
7323 Ensure_Freeze_Node (Def_Id);
7326 Insert_Action_After (Init_After, Tag_Assign);
7329 -- Handle C++ constructor calls. Note that we do not check that
7330 -- Typ is a tagged type since the equivalent Ada type of a C++
7331 -- class that has no virtual methods is an untagged limited
7334 elsif Is_CPP_Constructor_Call (Expr) then
7336 -- The call to the initialization procedure does NOT freeze the
7337 -- object being initialized.
7339 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
7340 Set_Must_Not_Freeze (Id_Ref);
7341 Set_Assignment_OK (Id_Ref);
7343 Insert_Actions_After (Init_After,
7344 Build_Initialization_Call (Loc, Id_Ref, Typ,
7345 Constructor_Ref => Expr));
7347 -- We remove here the original call to the constructor
7348 -- to avoid its management in the backend
7350 Set_Expression (N, Empty);
7353 -- Handle initialization of limited tagged types
7355 elsif Is_Tagged_Type (Typ)
7356 and then Is_Class_Wide_Type (Typ)
7357 and then Is_Limited_Record (Typ)
7358 and then not Is_Limited_Interface (Typ)
7360 -- Given that the type is limited we cannot perform a copy. If
7361 -- Expr_Q is the reference to a variable we mark the variable
7362 -- as OK_To_Rename to expand this declaration into a renaming
7363 -- declaration (see below).
7365 if Is_Entity_Name (Expr_Q) then
7366 Set_OK_To_Rename (Entity (Expr_Q));
7368 -- If we cannot convert the expression into a renaming we must
7369 -- consider it an internal error because the backend does not
7370 -- have support to handle it. Also, when a raise expression is
7371 -- encountered we ignore it since it doesn't return a value and
7372 -- thus cannot trigger a copy.
7374 elsif Nkind (Original_Node (Expr_Q)) /= N_Raise_Expression then
7375 pragma Assert (False);
7376 raise Program_Error;
7379 -- For discrete types, set the Is_Known_Valid flag if the
7380 -- initializing value is known to be valid. Only do this for
7381 -- source assignments, since otherwise we can end up turning
7382 -- on the known valid flag prematurely from inserted code.
7384 elsif Comes_From_Source (N)
7385 and then Is_Discrete_Type (Typ)
7386 and then Expr_Known_Valid (Expr)
7388 Set_Is_Known_Valid (Def_Id);
7390 elsif Is_Access_Type (Typ) then
7392 -- For access types set the Is_Known_Non_Null flag if the
7393 -- initializing value is known to be non-null. We can also set
7394 -- Can_Never_Be_Null if this is a constant.
7396 if Known_Non_Null (Expr) then
7397 Set_Is_Known_Non_Null (Def_Id, True);
7399 if Constant_Present (N) then
7400 Set_Can_Never_Be_Null (Def_Id);
7405 -- If validity checking on copies, validate initial expression.
7406 -- But skip this if declaration is for a generic type, since it
7407 -- makes no sense to validate generic types. Not clear if this
7408 -- can happen for legal programs, but it definitely can arise
7409 -- from previous instantiation errors.
7411 if Validity_Checks_On
7412 and then Comes_From_Source (N)
7413 and then Validity_Check_Copies
7414 and then not Is_Generic_Type (Etype (Def_Id))
7416 Ensure_Valid (Expr);
7417 Set_Is_Known_Valid (Def_Id);
7421 -- Cases where the back end cannot handle the initialization
7422 -- directly. In such cases, we expand an assignment that will
7423 -- be appropriately handled by Expand_N_Assignment_Statement.
7425 -- The exclusion of the unconstrained case is wrong, but for now it
7426 -- is too much trouble ???
7428 if (Is_Possibly_Unaligned_Slice (Expr)
7429 or else (Is_Possibly_Unaligned_Object (Expr)
7430 and then not Represented_As_Scalar (Etype (Expr))))
7431 and then not (Is_Array_Type (Etype (Expr))
7432 and then not Is_Constrained (Etype (Expr)))
7435 Stat : constant Node_Id :=
7436 Make_Assignment_Statement (Loc,
7437 Name => New_Occurrence_Of (Def_Id, Loc),
7438 Expression => Relocate_Node (Expr));
7440 Set_Expression (N, Empty);
7441 Set_No_Initialization (N);
7442 Set_Assignment_OK (Name (Stat));
7443 Set_No_Ctrl_Actions (Stat);
7444 Insert_After_And_Analyze (Init_After, Stat);
7449 if Nkind (Obj_Def) = N_Access_Definition
7450 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
7452 -- An Ada 2012 stand-alone object of an anonymous access type
7455 Loc : constant Source_Ptr := Sloc (N);
7457 Level : constant Entity_Id :=
7458 Make_Defining_Identifier (Sloc (N),
7460 New_External_Name (Chars (Def_Id), Suffix => "L"));
7462 Level_Decl : Node_Id;
7463 Level_Expr : Node_Id;
7466 Set_Ekind (Level, Ekind (Def_Id));
7467 Set_Etype (Level, Standard_Natural);
7468 Set_Scope (Level, Scope (Def_Id));
7470 -- Set accessibility level of null
7474 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
7476 -- When the expression of the object is a function which returns
7477 -- an anonymous access type the master of the call is the object
7478 -- being initialized instead of the type.
7480 elsif Nkind (Expr) = N_Function_Call
7481 and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
7483 Level_Expr := Make_Integer_Literal (Loc,
7484 Object_Access_Level (Def_Id));
7489 Level_Expr := Dynamic_Accessibility_Level (Expr);
7493 Make_Object_Declaration (Loc,
7494 Defining_Identifier => Level,
7495 Object_Definition =>
7496 New_Occurrence_Of (Standard_Natural, Loc),
7497 Expression => Level_Expr,
7498 Constant_Present => Constant_Present (N),
7499 Has_Init_Expression => True);
7501 Insert_Action_After (Init_After, Level_Decl);
7503 Set_Extra_Accessibility (Def_Id, Level);
7507 -- If the object is default initialized and its type is subject to
7508 -- pragma Default_Initial_Condition, add a runtime check to verify
7509 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
7511 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
7513 -- Note that the check is generated for source objects only
7515 if Comes_From_Source (Def_Id)
7516 and then Has_DIC (Typ)
7517 and then Present (DIC_Procedure (Typ))
7518 and then not Has_Init_Expression (N)
7519 and then not Is_Imported (Def_Id)
7522 DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
7525 if Present (Next_N) then
7526 Insert_Before_And_Analyze (Next_N, DIC_Call);
7528 -- The object declaration is the last node in a declarative or a
7532 Append_To (List_Containing (N), DIC_Call);
7538 -- Final transformation - turn the object declaration into a renaming
7539 -- if appropriate. If this is the completion of a deferred constant
7540 -- declaration, then this transformation generates what would be
7541 -- illegal code if written by hand, but that's OK.
7543 if Present (Expr) then
7544 if Rewrite_As_Renaming then
7546 Make_Object_Renaming_Declaration (Loc,
7547 Defining_Identifier => Defining_Identifier (N),
7548 Subtype_Mark => Obj_Def,
7551 -- We do not analyze this renaming declaration, because all its
7552 -- components have already been analyzed, and if we were to go
7553 -- ahead and analyze it, we would in effect be trying to generate
7554 -- another declaration of X, which won't do.
7556 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
7559 -- We do need to deal with debug issues for this renaming
7561 -- First, if entity comes from source, then mark it as needing
7562 -- debug information, even though it is defined by a generated
7563 -- renaming that does not come from source.
7565 Set_Debug_Info_Defining_Id (N);
7567 -- Now call the routine to generate debug info for the renaming
7570 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
7572 if Present (Decl) then
7573 Insert_Action (N, Decl);
7579 -- Exception on library entity not available
7582 when RE_Not_Available =>
7584 end Expand_N_Object_Declaration;
7586 ---------------------------------
7587 -- Expand_N_Subtype_Indication --
7588 ---------------------------------
7590 -- Add a check on the range of the subtype and deal with validity checking
7592 procedure Expand_N_Subtype_Indication (N : Node_Id) is
7593 Ran : constant Node_Id := Range_Expression (Constraint (N));
7594 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
7597 if Nkind (Constraint (N)) = N_Range_Constraint then
7598 Validity_Check_Range (Range_Expression (Constraint (N)));
7601 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
7603 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice)
7604 and then Nkind (Parent (Parent (N))) /= N_Full_Type_Declaration
7605 and then Nkind (Parent (Parent (N))) /= N_Object_Declaration
7607 Apply_Range_Check (Ran, Typ);
7609 end Expand_N_Subtype_Indication;
7611 ---------------------------
7612 -- Expand_N_Variant_Part --
7613 ---------------------------
7615 -- Note: this procedure no longer has any effect. It used to be that we
7616 -- would replace the choices in the last variant by a when others, and
7617 -- also expanded static predicates in variant choices here, but both of
7618 -- those activities were being done too early, since we can't check the
7619 -- choices until the statically predicated subtypes are frozen, which can
7620 -- happen as late as the free point of the record, and we can't change the
7621 -- last choice to an others before checking the choices, which is now done
7622 -- at the freeze point of the record.
7624 procedure Expand_N_Variant_Part (N : Node_Id) is
7627 end Expand_N_Variant_Part;
7629 ---------------------------------
7630 -- Expand_Previous_Access_Type --
7631 ---------------------------------
7633 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
7634 Ptr_Typ : Entity_Id;
7637 -- Find all access types in the current scope whose designated type is
7638 -- Def_Id and build master renamings for them.
7640 Ptr_Typ := First_Entity (Current_Scope);
7641 while Present (Ptr_Typ) loop
7642 if Is_Access_Type (Ptr_Typ)
7643 and then Designated_Type (Ptr_Typ) = Def_Id
7644 and then No (Master_Id (Ptr_Typ))
7646 -- Ensure that the designated type has a master
7648 Build_Master_Entity (Def_Id);
7650 -- Private and incomplete types complicate the insertion of master
7651 -- renamings because the access type may precede the full view of
7652 -- the designated type. For this reason, the master renamings are
7653 -- inserted relative to the designated type.
7655 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
7658 Next_Entity (Ptr_Typ);
7660 end Expand_Previous_Access_Type;
7662 -----------------------------
7663 -- Expand_Record_Extension --
7664 -----------------------------
7666 -- Add a field _parent at the beginning of the record extension. This is
7667 -- used to implement inheritance. Here are some examples of expansion:
7669 -- 1. no discriminants
7670 -- type T2 is new T1 with null record;
7672 -- type T2 is new T1 with record
7676 -- 2. renamed discriminants
7677 -- type T2 (B, C : Int) is new T1 (A => B) with record
7678 -- _Parent : T1 (A => B);
7682 -- 3. inherited discriminants
7683 -- type T2 is new T1 with record -- discriminant A inherited
7684 -- _Parent : T1 (A);
7688 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
7689 Indic : constant Node_Id := Subtype_Indication (Def);
7690 Loc : constant Source_Ptr := Sloc (Def);
7691 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
7692 Par_Subtype : Entity_Id;
7693 Comp_List : Node_Id;
7694 Comp_Decl : Node_Id;
7697 List_Constr : constant List_Id := New_List;
7700 -- Expand_Record_Extension is called directly from the semantics, so
7701 -- we must check to see whether expansion is active before proceeding,
7702 -- because this affects the visibility of selected components in bodies
7705 if not Expander_Active then
7709 -- This may be a derivation of an untagged private type whose full
7710 -- view is tagged, in which case the Derived_Type_Definition has no
7711 -- extension part. Build an empty one now.
7713 if No (Rec_Ext_Part) then
7715 Make_Record_Definition (Loc,
7717 Component_List => Empty,
7718 Null_Present => True);
7720 Set_Record_Extension_Part (Def, Rec_Ext_Part);
7721 Mark_Rewrite_Insertion (Rec_Ext_Part);
7724 Comp_List := Component_List (Rec_Ext_Part);
7726 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
7728 -- If the derived type inherits its discriminants the type of the
7729 -- _parent field must be constrained by the inherited discriminants
7731 if Has_Discriminants (T)
7732 and then Nkind (Indic) /= N_Subtype_Indication
7733 and then not Is_Constrained (Entity (Indic))
7735 D := First_Discriminant (T);
7736 while Present (D) loop
7737 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
7738 Next_Discriminant (D);
7743 Make_Subtype_Indication (Loc,
7744 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
7746 Make_Index_Or_Discriminant_Constraint (Loc,
7747 Constraints => List_Constr)),
7750 -- Otherwise the original subtype_indication is just what is needed
7753 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
7756 Set_Parent_Subtype (T, Par_Subtype);
7759 Make_Component_Declaration (Loc,
7760 Defining_Identifier => Parent_N,
7761 Component_Definition =>
7762 Make_Component_Definition (Loc,
7763 Aliased_Present => False,
7764 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
7766 if Null_Present (Rec_Ext_Part) then
7767 Set_Component_List (Rec_Ext_Part,
7768 Make_Component_List (Loc,
7769 Component_Items => New_List (Comp_Decl),
7770 Variant_Part => Empty,
7771 Null_Present => False));
7772 Set_Null_Present (Rec_Ext_Part, False);
7774 elsif Null_Present (Comp_List)
7775 or else Is_Empty_List (Component_Items (Comp_List))
7777 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7778 Set_Null_Present (Comp_List, False);
7781 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7784 Analyze (Comp_Decl);
7785 end Expand_Record_Extension;
7787 ------------------------
7788 -- Expand_Tagged_Root --
7789 ------------------------
7791 procedure Expand_Tagged_Root (T : Entity_Id) is
7792 Def : constant Node_Id := Type_Definition (Parent (T));
7793 Comp_List : Node_Id;
7794 Comp_Decl : Node_Id;
7795 Sloc_N : Source_Ptr;
7798 if Null_Present (Def) then
7799 Set_Component_List (Def,
7800 Make_Component_List (Sloc (Def),
7801 Component_Items => Empty_List,
7802 Variant_Part => Empty,
7803 Null_Present => True));
7806 Comp_List := Component_List (Def);
7808 if Null_Present (Comp_List)
7809 or else Is_Empty_List (Component_Items (Comp_List))
7811 Sloc_N := Sloc (Comp_List);
7813 Sloc_N := Sloc (First (Component_Items (Comp_List)));
7817 Make_Component_Declaration (Sloc_N,
7818 Defining_Identifier => First_Tag_Component (T),
7819 Component_Definition =>
7820 Make_Component_Definition (Sloc_N,
7821 Aliased_Present => False,
7822 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
7824 if Null_Present (Comp_List)
7825 or else Is_Empty_List (Component_Items (Comp_List))
7827 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7828 Set_Null_Present (Comp_List, False);
7831 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7834 -- We don't Analyze the whole expansion because the tag component has
7835 -- already been analyzed previously. Here we just insure that the tree
7836 -- is coherent with the semantic decoration
7838 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
7841 when RE_Not_Available =>
7843 end Expand_Tagged_Root;
7845 ------------------------------
7846 -- Freeze_Stream_Operations --
7847 ------------------------------
7849 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
7850 Names : constant array (1 .. 4) of TSS_Name_Type :=
7855 Stream_Op : Entity_Id;
7858 -- Primitive operations of tagged types are frozen when the dispatch
7859 -- table is constructed.
7861 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
7865 for J in Names'Range loop
7866 Stream_Op := TSS (Typ, Names (J));
7868 if Present (Stream_Op)
7869 and then Is_Subprogram (Stream_Op)
7870 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
7871 N_Subprogram_Declaration
7872 and then not Is_Frozen (Stream_Op)
7874 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
7877 end Freeze_Stream_Operations;
7883 -- Full type declarations are expanded at the point at which the type is
7884 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
7885 -- declarations generated by the freezing (e.g. the procedure generated
7886 -- for initialization) are chained in the Actions field list of the freeze
7887 -- node using Append_Freeze_Actions.
7889 -- WARNING: This routine manages Ghost regions. Return statements must be
7890 -- replaced by gotos which jump to the end of the routine and restore the
7893 function Freeze_Type (N : Node_Id) return Boolean is
7894 procedure Process_RACW_Types (Typ : Entity_Id);
7895 -- Validate and generate stubs for all RACW types associated with type
7898 procedure Process_Pending_Access_Types (Typ : Entity_Id);
7899 -- Associate type Typ's Finalize_Address primitive with the finalization
7900 -- masters of pending access-to-Typ types.
7902 ------------------------
7903 -- Process_RACW_Types --
7904 ------------------------
7906 procedure Process_RACW_Types (Typ : Entity_Id) is
7907 List : constant Elist_Id := Access_Types_To_Process (N);
7909 Seen : Boolean := False;
7912 if Present (List) then
7913 E := First_Elmt (List);
7914 while Present (E) loop
7915 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
7916 Validate_RACW_Primitives (Node (E));
7924 -- If there are RACWs designating this type, make stubs now
7927 Remote_Types_Tagged_Full_View_Encountered (Typ);
7929 end Process_RACW_Types;
7931 ----------------------------------
7932 -- Process_Pending_Access_Types --
7933 ----------------------------------
7935 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
7939 -- Finalize_Address is not generated in CodePeer mode because the
7940 -- body contains address arithmetic. This processing is disabled.
7942 if CodePeer_Mode then
7945 -- Certain itypes are generated for contexts that cannot allocate
7946 -- objects and should not set primitive Finalize_Address.
7948 elsif Is_Itype (Typ)
7949 and then Nkind (Associated_Node_For_Itype (Typ)) =
7950 N_Explicit_Dereference
7954 -- When an access type is declared after the incomplete view of a
7955 -- Taft-amendment type, the access type is considered pending in
7956 -- case the full view of the Taft-amendment type is controlled. If
7957 -- this is indeed the case, associate the Finalize_Address routine
7958 -- of the full view with the finalization masters of all pending
7959 -- access types. This scenario applies to anonymous access types as
7962 elsif Needs_Finalization (Typ)
7963 and then Present (Pending_Access_Types (Typ))
7965 E := First_Elmt (Pending_Access_Types (Typ));
7966 while Present (E) loop
7969 -- Set_Finalize_Address
7970 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
7972 Append_Freeze_Action (Typ,
7973 Make_Set_Finalize_Address_Call
7975 Ptr_Typ => Node (E)));
7980 end Process_Pending_Access_Types;
7984 Def_Id : constant Entity_Id := Entity (N);
7986 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
7987 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
7988 -- Save the Ghost-related attributes to restore on exit
7990 Result : Boolean := False;
7992 -- Start of processing for Freeze_Type
7995 -- The type being frozen may be subject to pragma Ghost. Set the mode
7996 -- now to ensure that any nodes generated during freezing are properly
7999 Set_Ghost_Mode (Def_Id);
8001 -- Process any remote access-to-class-wide types designating the type
8004 Process_RACW_Types (Def_Id);
8006 -- Freeze processing for record types
8008 if Is_Record_Type (Def_Id) then
8009 if Ekind (Def_Id) = E_Record_Type then
8010 Expand_Freeze_Record_Type (N);
8011 elsif Is_Class_Wide_Type (Def_Id) then
8012 Expand_Freeze_Class_Wide_Type (N);
8015 -- Freeze processing for array types
8017 elsif Is_Array_Type (Def_Id) then
8018 Expand_Freeze_Array_Type (N);
8020 -- Freeze processing for access types
8022 -- For pool-specific access types, find out the pool object used for
8023 -- this type, needs actual expansion of it in some cases. Here are the
8024 -- different cases :
8026 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
8027 -- ---> don't use any storage pool
8029 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
8031 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
8033 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
8034 -- ---> Storage Pool is the specified one
8036 -- See GNAT Pool packages in the Run-Time for more details
8038 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
8040 Loc : constant Source_Ptr := Sloc (N);
8041 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
8043 Freeze_Action_Typ : Entity_Id;
8044 Pool_Object : Entity_Id;
8049 -- Rep Clause "for Def_Id'Storage_Size use 0;"
8050 -- ---> don't use any storage pool
8052 if No_Pool_Assigned (Def_Id) then
8057 -- Rep Clause : for Def_Id'Storage_Size use Expr.
8059 -- Def_Id__Pool : Stack_Bounded_Pool
8060 -- (Expr, DT'Size, DT'Alignment);
8062 elsif Has_Storage_Size_Clause (Def_Id) then
8068 -- For unconstrained composite types we give a size of zero
8069 -- so that the pool knows that it needs a special algorithm
8070 -- for variable size object allocation.
8072 if Is_Composite_Type (Desig_Type)
8073 and then not Is_Constrained (Desig_Type)
8075 DT_Size := Make_Integer_Literal (Loc, 0);
8076 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
8080 Make_Attribute_Reference (Loc,
8081 Prefix => New_Occurrence_Of (Desig_Type, Loc),
8082 Attribute_Name => Name_Max_Size_In_Storage_Elements);
8085 Make_Attribute_Reference (Loc,
8086 Prefix => New_Occurrence_Of (Desig_Type, Loc),
8087 Attribute_Name => Name_Alignment);
8091 Make_Defining_Identifier (Loc,
8092 Chars => New_External_Name (Chars (Def_Id), 'P'));
8094 -- We put the code associated with the pools in the entity
8095 -- that has the later freeze node, usually the access type
8096 -- but it can also be the designated_type; because the pool
8097 -- code requires both those types to be frozen
8099 if Is_Frozen (Desig_Type)
8100 and then (No (Freeze_Node (Desig_Type))
8101 or else Analyzed (Freeze_Node (Desig_Type)))
8103 Freeze_Action_Typ := Def_Id;
8105 -- A Taft amendment type cannot get the freeze actions
8106 -- since the full view is not there.
8108 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
8109 and then No (Full_View (Desig_Type))
8111 Freeze_Action_Typ := Def_Id;
8114 Freeze_Action_Typ := Desig_Type;
8117 Append_Freeze_Action (Freeze_Action_Typ,
8118 Make_Object_Declaration (Loc,
8119 Defining_Identifier => Pool_Object,
8120 Object_Definition =>
8121 Make_Subtype_Indication (Loc,
8124 (RTE (RE_Stack_Bounded_Pool), Loc),
8127 Make_Index_Or_Discriminant_Constraint (Loc,
8128 Constraints => New_List (
8130 -- First discriminant is the Pool Size
8133 Storage_Size_Variable (Def_Id), Loc),
8135 -- Second discriminant is the element size
8139 -- Third discriminant is the alignment
8144 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
8148 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
8149 -- ---> Storage Pool is the specified one
8151 -- When compiling in Ada 2012 mode, ensure that the accessibility
8152 -- level of the subpool access type is not deeper than that of the
8153 -- pool_with_subpools.
8155 elsif Ada_Version >= Ada_2012
8156 and then Present (Associated_Storage_Pool (Def_Id))
8158 -- Omit this check for the case of a configurable run-time that
8159 -- does not provide package System.Storage_Pools.Subpools.
8161 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
8164 Loc : constant Source_Ptr := Sloc (Def_Id);
8165 Pool : constant Entity_Id :=
8166 Associated_Storage_Pool (Def_Id);
8167 RSPWS : constant Entity_Id :=
8168 RTE (RE_Root_Storage_Pool_With_Subpools);
8171 -- It is known that the accessibility level of the access
8172 -- type is deeper than that of the pool.
8174 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
8175 and then not Accessibility_Checks_Suppressed (Def_Id)
8176 and then not Accessibility_Checks_Suppressed (Pool)
8178 -- Static case: the pool is known to be a descendant of
8179 -- Root_Storage_Pool_With_Subpools.
8181 if Is_Ancestor (RSPWS, Etype (Pool)) then
8183 ("??subpool access type has deeper accessibility "
8184 & "level than pool", Def_Id);
8186 Append_Freeze_Action (Def_Id,
8187 Make_Raise_Program_Error (Loc,
8188 Reason => PE_Accessibility_Check_Failed));
8190 -- Dynamic case: when the pool is of a class-wide type,
8191 -- it may or may not support subpools depending on the
8192 -- path of derivation. Generate:
8194 -- if Def_Id in RSPWS'Class then
8195 -- raise Program_Error;
8198 elsif Is_Class_Wide_Type (Etype (Pool)) then
8199 Append_Freeze_Action (Def_Id,
8200 Make_If_Statement (Loc,
8203 Left_Opnd => New_Occurrence_Of (Pool, Loc),
8206 (Class_Wide_Type (RSPWS), Loc)),
8208 Then_Statements => New_List (
8209 Make_Raise_Program_Error (Loc,
8210 Reason => PE_Accessibility_Check_Failed))));
8216 -- For access-to-controlled types (including class-wide types and
8217 -- Taft-amendment types, which potentially have controlled
8218 -- components), expand the list controller object that will store
8219 -- the dynamically allocated objects. Don't do this transformation
8220 -- for expander-generated access types, but do it for types that
8221 -- are the full view of types derived from other private types.
8222 -- Also suppress the list controller in the case of a designated
8223 -- type with convention Java, since this is used when binding to
8224 -- Java API specs, where there's no equivalent of a finalization
8225 -- list and we don't want to pull in the finalization support if
8228 if not Comes_From_Source (Def_Id)
8229 and then not Has_Private_Declaration (Def_Id)
8233 -- An exception is made for types defined in the run-time because
8234 -- Ada.Tags.Tag itself is such a type and cannot afford this
8235 -- unnecessary overhead that would generates a loop in the
8236 -- expansion scheme. Another exception is if Restrictions
8237 -- (No_Finalization) is active, since then we know nothing is
8240 elsif Restriction_Active (No_Finalization)
8241 or else In_Runtime (Def_Id)
8245 -- Create a finalization master for an access-to-controlled type
8246 -- or an access-to-incomplete type. It is assumed that the full
8247 -- view will be controlled.
8249 elsif Needs_Finalization (Desig_Type)
8250 or else (Is_Incomplete_Type (Desig_Type)
8251 and then No (Full_View (Desig_Type)))
8253 Build_Finalization_Master (Def_Id);
8255 -- Create a finalization master when the designated type contains
8256 -- a private component. It is assumed that the full view will be
8259 elsif Has_Private_Component (Desig_Type) then
8260 Build_Finalization_Master
8262 For_Private => True,
8263 Context_Scope => Scope (Def_Id),
8264 Insertion_Node => Declaration_Node (Desig_Type));
8268 -- Freeze processing for enumeration types
8270 elsif Ekind (Def_Id) = E_Enumeration_Type then
8272 -- We only have something to do if we have a non-standard
8273 -- representation (i.e. at least one literal whose pos value
8274 -- is not the same as its representation)
8276 if Has_Non_Standard_Rep (Def_Id) then
8277 Expand_Freeze_Enumeration_Type (N);
8280 -- Private types that are completed by a derivation from a private
8281 -- type have an internally generated full view, that needs to be
8282 -- frozen. This must be done explicitly because the two views share
8283 -- the freeze node, and the underlying full view is not visible when
8284 -- the freeze node is analyzed.
8286 elsif Is_Private_Type (Def_Id)
8287 and then Is_Derived_Type (Def_Id)
8288 and then Present (Full_View (Def_Id))
8289 and then Is_Itype (Full_View (Def_Id))
8290 and then Has_Private_Declaration (Full_View (Def_Id))
8291 and then Freeze_Node (Full_View (Def_Id)) = N
8293 Set_Entity (N, Full_View (Def_Id));
8294 Result := Freeze_Type (N);
8295 Set_Entity (N, Def_Id);
8297 -- All other types require no expander action. There are such cases
8298 -- (e.g. task types and protected types). In such cases, the freeze
8299 -- nodes are there for use by Gigi.
8303 -- Complete the initialization of all pending access types' finalization
8304 -- masters now that the designated type has been is frozen and primitive
8305 -- Finalize_Address generated.
8307 Process_Pending_Access_Types (Def_Id);
8308 Freeze_Stream_Operations (N, Def_Id);
8310 -- Generate the [spec and] body of the procedure tasked with the runtime
8311 -- verification of pragma Default_Initial_Condition's expression.
8313 if Has_DIC (Def_Id) then
8314 Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
8317 -- Generate the [spec and] body of the invariant procedure tasked with
8318 -- the runtime verification of all invariants that pertain to the type.
8319 -- This includes invariants on the partial and full view, inherited
8320 -- class-wide invariants from parent types or interfaces, and invariants
8321 -- on array elements or record components.
8323 if Is_Interface (Def_Id) then
8325 -- Interfaces are treated as the partial view of a private type in
8326 -- order to achieve uniformity with the general case. As a result, an
8327 -- interface receives only a "partial" invariant procedure which is
8330 if Has_Own_Invariants (Def_Id) then
8331 Build_Invariant_Procedure_Body
8333 Partial_Invariant => Is_Interface (Def_Id));
8336 -- Non-interface types
8338 -- Do not generate invariant procedure within other assertion
8339 -- subprograms, which may involve local declarations of local
8340 -- subtypes to which these checks do not apply.
8342 elsif Has_Invariants (Def_Id) then
8343 if Within_Internal_Subprogram
8344 or else (Ekind (Current_Scope) = E_Function
8345 and then Is_Predicate_Function (Current_Scope))
8349 Build_Invariant_Procedure_Body (Def_Id);
8353 Restore_Ghost_Region (Saved_GM, Saved_IGR);
8358 when RE_Not_Available =>
8359 Restore_Ghost_Region (Saved_GM, Saved_IGR);
8364 -------------------------
8365 -- Get_Simple_Init_Val --
8366 -------------------------
8368 function Get_Simple_Init_Val
8371 Size : Uint := No_Uint) return Node_Id
8373 IV_Attribute : constant Boolean :=
8374 Nkind (N) = N_Attribute_Reference
8375 and then Attribute_Name (N) = Name_Invalid_Value;
8377 Loc : constant Source_Ptr := Sloc (N);
8379 procedure Extract_Subtype_Bounds
8380 (Lo_Bound : out Uint;
8381 Hi_Bound : out Uint);
8382 -- Inspect subtype Typ as well its ancestor subtypes and derived types
8383 -- to determine the best known information about the bounds of the type.
8384 -- The output parameters are set as follows:
8386 -- * Lo_Bound - Set to No_Unit when there is no information available,
8387 -- or to the known low bound.
8389 -- * Hi_Bound - Set to No_Unit when there is no information available,
8390 -- or to the known high bound.
8392 function Simple_Init_Array_Type return Node_Id;
8393 -- Build an expression to initialize array type Typ
8395 function Simple_Init_Defaulted_Type return Node_Id;
8396 -- Build an expression to initialize type Typ which is subject to
8397 -- aspect Default_Value.
8399 function Simple_Init_Initialize_Scalars_Type
8400 (Size_To_Use : Uint) return Node_Id;
8401 -- Build an expression to initialize scalar type Typ which is subject to
8402 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
8404 function Simple_Init_Normalize_Scalars_Type
8405 (Size_To_Use : Uint) return Node_Id;
8406 -- Build an expression to initialize scalar type Typ which is subject to
8407 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
8409 function Simple_Init_Private_Type return Node_Id;
8410 -- Build an expression to initialize private type Typ
8412 function Simple_Init_Scalar_Type return Node_Id;
8413 -- Build an expression to initialize scalar type Typ
8415 ----------------------------
8416 -- Extract_Subtype_Bounds --
8417 ----------------------------
8419 procedure Extract_Subtype_Bounds
8420 (Lo_Bound : out Uint;
8421 Hi_Bound : out Uint)
8431 Lo_Bound := No_Uint;
8432 Hi_Bound := No_Uint;
8434 -- Loop to climb ancestor subtypes and derived types
8438 if not Is_Discrete_Type (ST1) then
8442 Lo := Type_Low_Bound (ST1);
8443 Hi := Type_High_Bound (ST1);
8445 if Compile_Time_Known_Value (Lo) then
8446 Lo_Val := Expr_Value (Lo);
8448 if Lo_Bound = No_Uint or else Lo_Bound < Lo_Val then
8453 if Compile_Time_Known_Value (Hi) then
8454 Hi_Val := Expr_Value (Hi);
8456 if Hi_Bound = No_Uint or else Hi_Bound > Hi_Val then
8461 ST2 := Ancestor_Subtype (ST1);
8467 exit when ST1 = ST2;
8470 end Extract_Subtype_Bounds;
8472 ----------------------------
8473 -- Simple_Init_Array_Type --
8474 ----------------------------
8476 function Simple_Init_Array_Type return Node_Id is
8477 Comp_Typ : constant Entity_Id := Component_Type (Typ);
8479 function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
8480 -- Initialize a single array dimension with index constraint Index
8482 --------------------
8483 -- Simple_Init_Dimension --
8484 --------------------
8486 function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
8488 -- Process the current dimension
8490 if Present (Index) then
8492 -- Build a suitable "others" aggregate for the next dimension,
8493 -- or initialize the component itself. Generate:
8498 Make_Aggregate (Loc,
8499 Component_Associations => New_List (
8500 Make_Component_Association (Loc,
8501 Choices => New_List (Make_Others_Choice (Loc)),
8503 Simple_Init_Dimension (Next_Index (Index)))));
8505 -- Otherwise all dimensions have been processed. Initialize the
8506 -- component itself.
8513 Size => Esize (Comp_Typ));
8515 end Simple_Init_Dimension;
8517 -- Start of processing for Simple_Init_Array_Type
8520 return Simple_Init_Dimension (First_Index (Typ));
8521 end Simple_Init_Array_Type;
8523 --------------------------------
8524 -- Simple_Init_Defaulted_Type --
8525 --------------------------------
8527 function Simple_Init_Defaulted_Type return Node_Id is
8528 Subtyp : constant Entity_Id := First_Subtype (Typ);
8531 -- Use the Sloc of the context node when constructing the initial
8532 -- value because the expression of Default_Value may come from a
8533 -- different unit. Updating the Sloc will result in accurate error
8536 -- When the first subtype is private, retrieve the expression of the
8537 -- Default_Value from the underlying type.
8539 if Is_Private_Type (Subtyp) then
8541 Unchecked_Convert_To
8545 (Source => Default_Aspect_Value (Full_View (Subtyp)),
8554 (Source => Default_Aspect_Value (Subtyp),
8557 end Simple_Init_Defaulted_Type;
8559 -----------------------------------------
8560 -- Simple_Init_Initialize_Scalars_Type --
8561 -----------------------------------------
8563 function Simple_Init_Initialize_Scalars_Type
8564 (Size_To_Use : Uint) return Node_Id
8566 Float_Typ : Entity_Id;
8569 Scal_Typ : Scalar_Id;
8572 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
8576 if Is_Floating_Point_Type (Typ) then
8577 Float_Typ := Root_Type (Typ);
8579 if Float_Typ = Standard_Short_Float then
8580 Scal_Typ := Name_Short_Float;
8581 elsif Float_Typ = Standard_Float then
8582 Scal_Typ := Name_Float;
8583 elsif Float_Typ = Standard_Long_Float then
8584 Scal_Typ := Name_Long_Float;
8585 else pragma Assert (Float_Typ = Standard_Long_Long_Float);
8586 Scal_Typ := Name_Long_Long_Float;
8589 -- If zero is invalid, it is a convenient value to use that is for
8590 -- sure an appropriate invalid value in all situations.
8592 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
8593 return Make_Integer_Literal (Loc, 0);
8597 elsif Is_Unsigned_Type (Typ) then
8598 if Size_To_Use <= 8 then
8599 Scal_Typ := Name_Unsigned_8;
8600 elsif Size_To_Use <= 16 then
8601 Scal_Typ := Name_Unsigned_16;
8602 elsif Size_To_Use <= 32 then
8603 Scal_Typ := Name_Unsigned_32;
8605 Scal_Typ := Name_Unsigned_64;
8611 if Size_To_Use <= 8 then
8612 Scal_Typ := Name_Signed_8;
8613 elsif Size_To_Use <= 16 then
8614 Scal_Typ := Name_Signed_16;
8615 elsif Size_To_Use <= 32 then
8616 Scal_Typ := Name_Signed_32;
8618 Scal_Typ := Name_Signed_64;
8622 -- Use the values specified by pragma Initialize_Scalars or the ones
8623 -- provided by the binder. Higher precedence is given to the pragma.
8625 return Invalid_Scalar_Value (Loc, Scal_Typ);
8626 end Simple_Init_Initialize_Scalars_Type;
8628 ----------------------------------------
8629 -- Simple_Init_Normalize_Scalars_Type --
8630 ----------------------------------------
8632 function Simple_Init_Normalize_Scalars_Type
8633 (Size_To_Use : Uint) return Node_Id
8635 Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1);
8642 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
8644 -- If zero is invalid, it is a convenient value to use that is for
8645 -- sure an appropriate invalid value in all situations.
8647 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
8648 Expr := Make_Integer_Literal (Loc, 0);
8650 -- Cases where all one bits is the appropriate invalid value
8652 -- For modular types, all 1 bits is either invalid or valid. If it
8653 -- is valid, then there is nothing that can be done since there are
8654 -- no invalid values (we ruled out zero already).
8656 -- For signed integer types that have no negative values, either
8657 -- there is room for negative values, or there is not. If there
8658 -- is, then all 1-bits may be interpreted as minus one, which is
8659 -- certainly invalid. Alternatively it is treated as the largest
8660 -- positive value, in which case the observation for modular types
8663 -- For float types, all 1-bits is a NaN (not a number), which is
8664 -- certainly an appropriately invalid value.
8666 elsif Is_Enumeration_Type (Typ)
8667 or else Is_Floating_Point_Type (Typ)
8668 or else Is_Unsigned_Type (Typ)
8670 Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
8672 -- Resolve as Unsigned_64, because the largest number we can
8673 -- generate is out of range of universal integer.
8675 Analyze_And_Resolve (Expr, RTE (RE_Unsigned_64));
8677 -- Case of signed types
8680 -- Normally we like to use the most negative number. The one
8681 -- exception is when this number is in the known subtype range and
8682 -- the largest positive number is not in the known subtype range.
8684 -- For this exceptional case, use largest positive value
8686 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
8687 and then Lo_Bound <= (-(2 ** Signed_Size))
8688 and then Hi_Bound < 2 ** Signed_Size
8690 Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
8692 -- Normal case of largest negative value
8695 Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
8700 end Simple_Init_Normalize_Scalars_Type;
8702 ------------------------------
8703 -- Simple_Init_Private_Type --
8704 ------------------------------
8706 function Simple_Init_Private_Type return Node_Id is
8707 Under_Typ : constant Entity_Id := Underlying_Type (Typ);
8711 -- The availability of the underlying view must be checked by routine
8712 -- Needs_Simple_Initialization.
8714 pragma Assert (Present (Under_Typ));
8716 Expr := Get_Simple_Init_Val (Under_Typ, N, Size);
8718 -- If the initial value is null or an aggregate, qualify it with the
8719 -- underlying type in order to provide a proper context.
8721 if Nkind_In (Expr, N_Aggregate, N_Null) then
8723 Make_Qualified_Expression (Loc,
8724 Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc),
8725 Expression => Expr);
8728 Expr := Unchecked_Convert_To (Typ, Expr);
8730 -- Do not truncate the result when scalar types are involved and
8731 -- Initialize/Normalize_Scalars is in effect.
8733 if Nkind (Expr) = N_Unchecked_Type_Conversion
8734 and then Is_Scalar_Type (Under_Typ)
8736 Set_No_Truncation (Expr);
8740 end Simple_Init_Private_Type;
8742 -----------------------------
8743 -- Simple_Init_Scalar_Type --
8744 -----------------------------
8746 function Simple_Init_Scalar_Type return Node_Id is
8751 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
8753 -- Determine the size of the object. This is either the size provided
8754 -- by the caller, or the Esize of the scalar type.
8756 if Size = No_Uint or else Size <= Uint_0 then
8757 Size_To_Use := UI_Max (Uint_1, Esize (Typ));
8759 Size_To_Use := Size;
8762 -- The maximum size to use is 64 bits. This will create values of
8763 -- type Unsigned_64 and the range must fit this type.
8765 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
8766 Size_To_Use := Uint_64;
8769 if Normalize_Scalars and then not IV_Attribute then
8770 Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use);
8772 Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use);
8775 -- The final expression is obtained by doing an unchecked conversion
8776 -- of this result to the base type of the required subtype. Use the
8777 -- base type to prevent the unchecked conversion from chopping bits,
8778 -- and then we set Kill_Range_Check to preserve the "bad" value.
8780 Expr := Unchecked_Convert_To (Base_Type (Typ), Expr);
8782 -- Ensure that the expression is not truncated since the "bad" bits
8783 -- are desired, and also kill the range checks.
8785 if Nkind (Expr) = N_Unchecked_Type_Conversion then
8786 Set_Kill_Range_Check (Expr);
8787 Set_No_Truncation (Expr);
8791 end Simple_Init_Scalar_Type;
8793 -- Start of processing for Get_Simple_Init_Val
8796 if Is_Private_Type (Typ) then
8797 return Simple_Init_Private_Type;
8799 elsif Is_Scalar_Type (Typ) then
8800 if Has_Default_Aspect (Typ) then
8801 return Simple_Init_Defaulted_Type;
8803 return Simple_Init_Scalar_Type;
8806 -- Array type with Initialize or Normalize_Scalars
8808 elsif Is_Array_Type (Typ) then
8809 pragma Assert (Init_Or_Norm_Scalars);
8810 return Simple_Init_Array_Type;
8812 -- Access type is initialized to null
8814 elsif Is_Access_Type (Typ) then
8815 return Make_Null (Loc);
8817 -- No other possibilities should arise, since we should only be calling
8818 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
8819 -- indicating one of the above cases held.
8822 raise Program_Error;
8826 when RE_Not_Available =>
8828 end Get_Simple_Init_Val;
8830 ------------------------------
8831 -- Has_New_Non_Standard_Rep --
8832 ------------------------------
8834 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
8836 if not Is_Derived_Type (T) then
8837 return Has_Non_Standard_Rep (T)
8838 or else Has_Non_Standard_Rep (Root_Type (T));
8840 -- If Has_Non_Standard_Rep is not set on the derived type, the
8841 -- representation is fully inherited.
8843 elsif not Has_Non_Standard_Rep (T) then
8847 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
8849 -- May need a more precise check here: the First_Rep_Item may be a
8850 -- stream attribute, which does not affect the representation of the
8854 end Has_New_Non_Standard_Rep;
8856 ----------------------
8857 -- Inline_Init_Proc --
8858 ----------------------
8860 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
8862 -- The initialization proc of protected records is not worth inlining.
8863 -- In addition, when compiled for another unit for inlining purposes,
8864 -- it may make reference to entities that have not been elaborated yet.
8865 -- The initialization proc of records that need finalization contains
8866 -- a nested clean-up procedure that makes it impractical to inline as
8867 -- well, except for simple controlled types themselves. And similar
8868 -- considerations apply to task types.
8870 if Is_Concurrent_Type (Typ) then
8873 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
8876 elsif Has_Task (Typ) then
8882 end Inline_Init_Proc;
8888 function In_Runtime (E : Entity_Id) return Boolean is
8893 while Scope (S1) /= Standard_Standard loop
8897 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
8900 ----------------------------
8901 -- Initialization_Warning --
8902 ----------------------------
8904 procedure Initialization_Warning (E : Entity_Id) is
8905 Warning_Needed : Boolean;
8908 Warning_Needed := False;
8910 if Ekind (Current_Scope) = E_Package
8911 and then Static_Elaboration_Desired (Current_Scope)
8914 if Is_Record_Type (E) then
8915 if Has_Discriminants (E)
8916 or else Is_Limited_Type (E)
8917 or else Has_Non_Standard_Rep (E)
8919 Warning_Needed := True;
8922 -- Verify that at least one component has an initialization
8923 -- expression. No need for a warning on a type if all its
8924 -- components have no initialization.
8930 Comp := First_Component (E);
8931 while Present (Comp) loop
8932 if Ekind (Comp) = E_Discriminant
8934 (Nkind (Parent (Comp)) = N_Component_Declaration
8935 and then Present (Expression (Parent (Comp))))
8937 Warning_Needed := True;
8941 Next_Component (Comp);
8946 if Warning_Needed then
8948 ("Objects of the type cannot be initialized statically "
8949 & "by default??", Parent (E));
8954 Error_Msg_N ("Object cannot be initialized statically??", E);
8957 end Initialization_Warning;
8963 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id
8965 Loc : constant Source_Ptr := Sloc (Typ);
8966 Unc_Arr : constant Boolean :=
8967 Is_Array_Type (Typ) and then not Is_Constrained (Typ);
8968 With_Prot : constant Boolean :=
8970 or else (Is_Record_Type (Typ)
8971 and then Is_Protected_Record_Type (Typ));
8972 With_Task : constant Boolean :=
8973 not Global_No_Tasking
8976 or else (Is_Record_Type (Typ)
8977 and then Is_Task_Record_Type (Typ)));
8981 -- The first parameter is always _Init : [in] out Typ. Note that we need
8982 -- it to be in/out in the case of an unconstrained array, because of the
8983 -- need to have the bounds, and in the case of protected or task record
8984 -- value, because there are default record fields that may be referenced
8985 -- in the generated initialization routine.
8987 Formals := New_List (
8988 Make_Parameter_Specification (Loc,
8989 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
8990 In_Present => Unc_Arr or else With_Prot or else With_Task,
8991 Out_Present => True,
8992 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
8994 -- For task record value, or type that contains tasks, add two more
8995 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
8996 -- We also add these parameters for the task record type case.
9000 Make_Parameter_Specification (Loc,
9001 Defining_Identifier =>
9002 Make_Defining_Identifier (Loc, Name_uMaster),
9004 New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
9006 Set_Has_Master_Entity (Proc_Id);
9008 -- Add _Chain (not done for sequential elaboration policy, see
9009 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
9011 if Partition_Elaboration_Policy /= 'S' then
9013 Make_Parameter_Specification (Loc,
9014 Defining_Identifier =>
9015 Make_Defining_Identifier (Loc, Name_uChain),
9017 Out_Present => True,
9019 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
9023 Make_Parameter_Specification (Loc,
9024 Defining_Identifier =>
9025 Make_Defining_Identifier (Loc, Name_uTask_Name),
9027 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
9030 -- Due to certain edge cases such as arrays with null-excluding
9031 -- components being built with the secondary stack it becomes necessary
9032 -- to add a formal to the Init_Proc which controls whether we raise
9033 -- Constraint_Errors on generated calls for internal object
9036 if Needs_Conditional_Null_Excluding_Check (Typ) then
9038 Make_Parameter_Specification (Loc,
9039 Defining_Identifier =>
9040 Make_Defining_Identifier (Loc,
9041 New_External_Name (Chars
9042 (Component_Type (Typ)), "_skip_null_excluding_check")),
9043 Expression => New_Occurrence_Of (Standard_False, Loc),
9046 New_Occurrence_Of (Standard_Boolean, Loc)));
9052 when RE_Not_Available =>
9056 -------------------------
9057 -- Init_Secondary_Tags --
9058 -------------------------
9060 procedure Init_Secondary_Tags
9063 Init_Tags_List : List_Id;
9064 Stmts_List : List_Id;
9065 Fixed_Comps : Boolean := True;
9066 Variable_Comps : Boolean := True)
9068 Loc : constant Source_Ptr := Sloc (Target);
9070 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
9071 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
9073 procedure Initialize_Tag
9076 Tag_Comp : Entity_Id;
9077 Iface_Tag : Node_Id);
9078 -- Initialize the tag of the secondary dispatch table of Typ associated
9079 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
9080 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
9081 -- of Typ CPP tagged type we generate code to inherit the contents of
9082 -- the dispatch table directly from the ancestor.
9084 --------------------
9085 -- Initialize_Tag --
9086 --------------------
9088 procedure Initialize_Tag
9091 Tag_Comp : Entity_Id;
9092 Iface_Tag : Node_Id)
9094 Comp_Typ : Entity_Id;
9095 Offset_To_Top_Comp : Entity_Id := Empty;
9098 -- Initialize pointer to secondary DT associated with the interface
9100 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
9101 Append_To (Init_Tags_List,
9102 Make_Assignment_Statement (Loc,
9104 Make_Selected_Component (Loc,
9105 Prefix => New_Copy_Tree (Target),
9106 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
9108 New_Occurrence_Of (Iface_Tag, Loc)));
9111 Comp_Typ := Scope (Tag_Comp);
9113 -- Initialize the entries of the table of interfaces. We generate a
9114 -- different call when the parent of the type has variable size
9117 if Comp_Typ /= Etype (Comp_Typ)
9118 and then Is_Variable_Size_Record (Etype (Comp_Typ))
9119 and then Chars (Tag_Comp) /= Name_uTag
9121 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
9123 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
9124 -- configurable run-time environment.
9126 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
9128 ("variable size record with interface types", Typ);
9133 -- Set_Dynamic_Offset_To_Top
9135 -- Prim_T => Typ'Tag,
9136 -- Interface_T => Iface'Tag,
9137 -- Offset_Value => n,
9138 -- Offset_Func => Fn'Address)
9140 Append_To (Stmts_List,
9141 Make_Procedure_Call_Statement (Loc,
9143 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
9144 Parameter_Associations => New_List (
9145 Make_Attribute_Reference (Loc,
9146 Prefix => New_Copy_Tree (Target),
9147 Attribute_Name => Name_Address),
9149 Unchecked_Convert_To (RTE (RE_Tag),
9151 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
9153 Unchecked_Convert_To (RTE (RE_Tag),
9155 (Node (First_Elmt (Access_Disp_Table (Iface))),
9158 Unchecked_Convert_To
9159 (RTE (RE_Storage_Offset),
9161 Make_Attribute_Reference (Loc,
9163 Make_Selected_Component (Loc,
9164 Prefix => New_Copy_Tree (Target),
9166 New_Occurrence_Of (Tag_Comp, Loc)),
9167 Attribute_Name => Name_Position))),
9169 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
9170 Make_Attribute_Reference (Loc,
9171 Prefix => New_Occurrence_Of
9172 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
9173 Attribute_Name => Name_Address)))));
9175 -- In this case the next component stores the value of the offset
9178 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
9179 pragma Assert (Present (Offset_To_Top_Comp));
9181 Append_To (Init_Tags_List,
9182 Make_Assignment_Statement (Loc,
9184 Make_Selected_Component (Loc,
9185 Prefix => New_Copy_Tree (Target),
9187 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
9191 Make_Attribute_Reference (Loc,
9193 Make_Selected_Component (Loc,
9194 Prefix => New_Copy_Tree (Target),
9195 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
9196 Attribute_Name => Name_Position))));
9198 -- Normal case: No discriminants in the parent type
9201 -- Don't need to set any value if the offset-to-top field is
9202 -- statically set or if this interface shares the primary
9205 if not Building_Static_Secondary_DT (Typ)
9206 and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
9208 Append_To (Stmts_List,
9209 Build_Set_Static_Offset_To_Top (Loc,
9210 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
9212 Unchecked_Convert_To (RTE (RE_Storage_Offset),
9214 Make_Attribute_Reference (Loc,
9216 Make_Selected_Component (Loc,
9217 Prefix => New_Copy_Tree (Target),
9219 New_Occurrence_Of (Tag_Comp, Loc)),
9220 Attribute_Name => Name_Position)))));
9224 -- Register_Interface_Offset
9225 -- (Prim_T => Typ'Tag,
9226 -- Interface_T => Iface'Tag,
9227 -- Is_Constant => True,
9228 -- Offset_Value => n,
9229 -- Offset_Func => null);
9231 if not Building_Static_Secondary_DT (Typ)
9232 and then RTE_Available (RE_Register_Interface_Offset)
9234 Append_To (Stmts_List,
9235 Make_Procedure_Call_Statement (Loc,
9238 (RTE (RE_Register_Interface_Offset), Loc),
9239 Parameter_Associations => New_List (
9240 Unchecked_Convert_To (RTE (RE_Tag),
9242 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
9244 Unchecked_Convert_To (RTE (RE_Tag),
9246 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
9248 New_Occurrence_Of (Standard_True, Loc),
9250 Unchecked_Convert_To (RTE (RE_Storage_Offset),
9252 Make_Attribute_Reference (Loc,
9254 Make_Selected_Component (Loc,
9255 Prefix => New_Copy_Tree (Target),
9257 New_Occurrence_Of (Tag_Comp, Loc)),
9258 Attribute_Name => Name_Position))),
9267 Full_Typ : Entity_Id;
9268 Ifaces_List : Elist_Id;
9269 Ifaces_Comp_List : Elist_Id;
9270 Ifaces_Tag_List : Elist_Id;
9271 Iface_Elmt : Elmt_Id;
9272 Iface_Comp_Elmt : Elmt_Id;
9273 Iface_Tag_Elmt : Elmt_Id;
9275 In_Variable_Pos : Boolean;
9277 -- Start of processing for Init_Secondary_Tags
9280 -- Handle private types
9282 if Present (Full_View (Typ)) then
9283 Full_Typ := Full_View (Typ);
9288 Collect_Interfaces_Info
9289 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
9291 Iface_Elmt := First_Elmt (Ifaces_List);
9292 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
9293 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
9294 while Present (Iface_Elmt) loop
9295 Tag_Comp := Node (Iface_Comp_Elmt);
9297 -- Check if parent of record type has variable size components
9299 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
9300 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
9302 -- If we are compiling under the CPP full ABI compatibility mode and
9303 -- the ancestor is a CPP_Pragma tagged type then we generate code to
9304 -- initialize the secondary tag components from tags that reference
9305 -- secondary tables filled with copy of parent slots.
9307 if Is_CPP_Class (Root_Type (Full_Typ)) then
9309 -- Reject interface components located at variable offset in
9310 -- C++ derivations. This is currently unsupported.
9312 if not Fixed_Comps and then In_Variable_Pos then
9314 -- Locate the first dynamic component of the record. Done to
9315 -- improve the text of the warning.
9319 Comp_Typ : Entity_Id;
9322 Comp := First_Entity (Typ);
9323 while Present (Comp) loop
9324 Comp_Typ := Etype (Comp);
9326 if Ekind (Comp) /= E_Discriminant
9327 and then not Is_Tag (Comp)
9330 (Is_Record_Type (Comp_Typ)
9332 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
9334 (Is_Array_Type (Comp_Typ)
9335 and then Is_Variable_Size_Array (Comp_Typ));
9341 pragma Assert (Present (Comp));
9343 -- Move this check to sem???
9344 Error_Msg_Node_2 := Comp;
9346 ("parent type & with dynamic component & cannot be parent"
9347 & " of 'C'P'P derivation if new interfaces are present",
9348 Typ, Scope (Original_Record_Component (Comp)));
9351 Sloc (Scope (Original_Record_Component (Comp)));
9353 ("type derived from 'C'P'P type & defined #",
9354 Typ, Scope (Original_Record_Component (Comp)));
9356 -- Avoid duplicated warnings
9361 -- Initialize secondary tags
9366 Iface => Node (Iface_Elmt),
9367 Tag_Comp => Tag_Comp,
9368 Iface_Tag => Node (Iface_Tag_Elmt));
9371 -- Otherwise generate code to initialize the tag
9374 if (In_Variable_Pos and then Variable_Comps)
9375 or else (not In_Variable_Pos and then Fixed_Comps)
9379 Iface => Node (Iface_Elmt),
9380 Tag_Comp => Tag_Comp,
9381 Iface_Tag => Node (Iface_Tag_Elmt));
9385 Next_Elmt (Iface_Elmt);
9386 Next_Elmt (Iface_Comp_Elmt);
9387 Next_Elmt (Iface_Tag_Elmt);
9389 end Init_Secondary_Tags;
9391 ----------------------------
9392 -- Is_Null_Statement_List --
9393 ----------------------------
9395 function Is_Null_Statement_List (Stmts : List_Id) return Boolean is
9399 -- We must skip SCIL nodes because they may have been added to the list
9400 -- by Insert_Actions.
9402 Stmt := First_Non_SCIL_Node (Stmts);
9403 while Present (Stmt) loop
9404 if Nkind (Stmt) = N_Case_Statement then
9408 Alt := First (Alternatives (Stmt));
9409 while Present (Alt) loop
9410 if not Is_Null_Statement_List (Statements (Alt)) then
9418 elsif Nkind (Stmt) /= N_Null_Statement then
9422 Stmt := Next_Non_SCIL_Node (Stmt);
9426 end Is_Null_Statement_List;
9428 ------------------------------
9429 -- Is_User_Defined_Equality --
9430 ------------------------------
9432 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
9434 return Chars (Prim) = Name_Op_Eq
9435 and then Etype (First_Formal (Prim)) =
9436 Etype (Next_Formal (First_Formal (Prim)))
9437 and then Base_Type (Etype (Prim)) = Standard_Boolean;
9438 end Is_User_Defined_Equality;
9440 ----------------------------------------
9441 -- Make_Controlling_Function_Wrappers --
9442 ----------------------------------------
9444 procedure Make_Controlling_Function_Wrappers
9445 (Tag_Typ : Entity_Id;
9446 Decl_List : out List_Id;
9447 Body_List : out List_Id)
9449 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9450 Prim_Elmt : Elmt_Id;
9452 Actual_List : List_Id;
9453 Formal_List : List_Id;
9455 Par_Formal : Entity_Id;
9456 Formal_Node : Node_Id;
9457 Func_Body : Node_Id;
9458 Func_Decl : Node_Id;
9459 Func_Spec : Node_Id;
9460 Return_Stmt : Node_Id;
9463 Decl_List := New_List;
9464 Body_List := New_List;
9466 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9467 while Present (Prim_Elmt) loop
9468 Subp := Node (Prim_Elmt);
9470 -- If a primitive function with a controlling result of the type has
9471 -- not been overridden by the user, then we must create a wrapper
9472 -- function here that effectively overrides it and invokes the
9473 -- (non-abstract) parent function. This can only occur for a null
9474 -- extension. Note that functions with anonymous controlling access
9475 -- results don't qualify and must be overridden. We also exclude
9476 -- Input attributes, since each type will have its own version of
9477 -- Input constructed by the expander. The test for Comes_From_Source
9478 -- is needed to distinguish inherited operations from renamings
9479 -- (which also have Alias set). We exclude internal entities with
9480 -- Interface_Alias to avoid generating duplicated wrappers since
9481 -- the primitive which covers the interface is also available in
9482 -- the list of primitive operations.
9484 -- The function may be abstract, or require_Overriding may be set
9485 -- for it, because tests for null extensions may already have reset
9486 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
9487 -- set, functions that need wrappers are recognized by having an
9488 -- alias that returns the parent type.
9490 if Comes_From_Source (Subp)
9491 or else No (Alias (Subp))
9492 or else Present (Interface_Alias (Subp))
9493 or else Ekind (Subp) /= E_Function
9494 or else not Has_Controlling_Result (Subp)
9495 or else Is_Access_Type (Etype (Subp))
9496 or else Is_Abstract_Subprogram (Alias (Subp))
9497 or else Is_TSS (Subp, TSS_Stream_Input)
9501 elsif Is_Abstract_Subprogram (Subp)
9502 or else Requires_Overriding (Subp)
9504 (Is_Null_Extension (Etype (Subp))
9505 and then Etype (Alias (Subp)) /= Etype (Subp))
9507 Formal_List := No_List;
9508 Formal := First_Formal (Subp);
9510 if Present (Formal) then
9511 Formal_List := New_List;
9513 while Present (Formal) loop
9515 (Make_Parameter_Specification
9517 Defining_Identifier =>
9518 Make_Defining_Identifier (Sloc (Formal),
9519 Chars => Chars (Formal)),
9520 In_Present => In_Present (Parent (Formal)),
9521 Out_Present => Out_Present (Parent (Formal)),
9522 Null_Exclusion_Present =>
9523 Null_Exclusion_Present (Parent (Formal)),
9525 New_Occurrence_Of (Etype (Formal), Loc),
9527 New_Copy_Tree (Expression (Parent (Formal)))),
9530 Next_Formal (Formal);
9535 Make_Function_Specification (Loc,
9536 Defining_Unit_Name =>
9537 Make_Defining_Identifier (Loc,
9538 Chars => Chars (Subp)),
9539 Parameter_Specifications => Formal_List,
9540 Result_Definition =>
9541 New_Occurrence_Of (Etype (Subp), Loc));
9543 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
9544 Append_To (Decl_List, Func_Decl);
9546 -- Build a wrapper body that calls the parent function. The body
9547 -- contains a single return statement that returns an extension
9548 -- aggregate whose ancestor part is a call to the parent function,
9549 -- passing the formals as actuals (with any controlling arguments
9550 -- converted to the types of the corresponding formals of the
9551 -- parent function, which might be anonymous access types), and
9552 -- having a null extension.
9554 Formal := First_Formal (Subp);
9555 Par_Formal := First_Formal (Alias (Subp));
9556 Formal_Node := First (Formal_List);
9558 if Present (Formal) then
9559 Actual_List := New_List;
9561 Actual_List := No_List;
9564 while Present (Formal) loop
9565 if Is_Controlling_Formal (Formal) then
9566 Append_To (Actual_List,
9567 Make_Type_Conversion (Loc,
9569 New_Occurrence_Of (Etype (Par_Formal), Loc),
9572 (Defining_Identifier (Formal_Node), Loc)));
9577 (Defining_Identifier (Formal_Node), Loc));
9580 Next_Formal (Formal);
9581 Next_Formal (Par_Formal);
9586 Make_Simple_Return_Statement (Loc,
9588 Make_Extension_Aggregate (Loc,
9590 Make_Function_Call (Loc,
9592 New_Occurrence_Of (Alias (Subp), Loc),
9593 Parameter_Associations => Actual_List),
9594 Null_Record_Present => True));
9597 Make_Subprogram_Body (Loc,
9598 Specification => New_Copy_Tree (Func_Spec),
9599 Declarations => Empty_List,
9600 Handled_Statement_Sequence =>
9601 Make_Handled_Sequence_Of_Statements (Loc,
9602 Statements => New_List (Return_Stmt)));
9604 Set_Defining_Unit_Name
9605 (Specification (Func_Body),
9606 Make_Defining_Identifier (Loc, Chars (Subp)));
9608 Append_To (Body_List, Func_Body);
9610 -- Replace the inherited function with the wrapper function in the
9611 -- primitive operations list. We add the minimum decoration needed
9612 -- to override interface primitives.
9614 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
9616 Override_Dispatching_Operation
9617 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
9618 Is_Wrapper => True);
9622 Next_Elmt (Prim_Elmt);
9624 end Make_Controlling_Function_Wrappers;
9630 function Make_Eq_Body
9632 Eq_Name : Name_Id) return Node_Id
9634 Loc : constant Source_Ptr := Sloc (Parent (Typ));
9636 Def : constant Node_Id := Parent (Typ);
9637 Stmts : constant List_Id := New_List;
9638 Variant_Case : Boolean := Has_Discriminants (Typ);
9639 Comps : Node_Id := Empty;
9640 Typ_Def : Node_Id := Type_Definition (Def);
9644 Predef_Spec_Or_Body (Loc,
9647 Profile => New_List (
9648 Make_Parameter_Specification (Loc,
9649 Defining_Identifier =>
9650 Make_Defining_Identifier (Loc, Name_X),
9651 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
9653 Make_Parameter_Specification (Loc,
9654 Defining_Identifier =>
9655 Make_Defining_Identifier (Loc, Name_Y),
9656 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9658 Ret_Type => Standard_Boolean,
9661 if Variant_Case then
9662 if Nkind (Typ_Def) = N_Derived_Type_Definition then
9663 Typ_Def := Record_Extension_Part (Typ_Def);
9666 if Present (Typ_Def) then
9667 Comps := Component_List (Typ_Def);
9671 Present (Comps) and then Present (Variant_Part (Comps));
9674 if Variant_Case then
9676 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
9677 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
9679 Make_Simple_Return_Statement (Loc,
9680 Expression => New_Occurrence_Of (Standard_True, Loc)));
9684 Make_Simple_Return_Statement (Loc,
9686 Expand_Record_Equality
9689 Lhs => Make_Identifier (Loc, Name_X),
9690 Rhs => Make_Identifier (Loc, Name_Y),
9691 Bodies => Declarations (Decl))));
9694 Set_Handled_Statement_Sequence
9695 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
9703 -- <Make_Eq_If shared components>
9706 -- when V1 => <Make_Eq_Case> on subcomponents
9708 -- when Vn => <Make_Eq_Case> on subcomponents
9711 function Make_Eq_Case
9714 Discrs : Elist_Id := New_Elmt_List) return List_Id
9716 Loc : constant Source_Ptr := Sloc (E);
9717 Result : constant List_Id := New_List;
9721 function Corresponding_Formal (C : Node_Id) return Entity_Id;
9722 -- Given the discriminant that controls a given variant of an unchecked
9723 -- union, find the formal of the equality function that carries the
9724 -- inferred value of the discriminant.
9726 function External_Name (E : Entity_Id) return Name_Id;
9727 -- The value of a given discriminant is conveyed in the corresponding
9728 -- formal parameter of the equality routine. The name of this formal
9729 -- parameter carries a one-character suffix which is removed here.
9731 --------------------------
9732 -- Corresponding_Formal --
9733 --------------------------
9735 function Corresponding_Formal (C : Node_Id) return Entity_Id is
9736 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
9740 Elm := First_Elmt (Discrs);
9741 while Present (Elm) loop
9742 if Chars (Discr) = External_Name (Node (Elm)) then
9749 -- A formal of the proper name must be found
9751 raise Program_Error;
9752 end Corresponding_Formal;
9758 function External_Name (E : Entity_Id) return Name_Id is
9760 Get_Name_String (Chars (E));
9761 Name_Len := Name_Len - 1;
9765 -- Start of processing for Make_Eq_Case
9768 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
9770 if No (Variant_Part (CL)) then
9774 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
9776 if No (Variant) then
9780 Alt_List := New_List;
9781 while Present (Variant) loop
9782 Append_To (Alt_List,
9783 Make_Case_Statement_Alternative (Loc,
9784 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
9786 Make_Eq_Case (E, Component_List (Variant), Discrs)));
9787 Next_Non_Pragma (Variant);
9790 -- If we have an Unchecked_Union, use one of the parameters of the
9791 -- enclosing equality routine that captures the discriminant, to use
9792 -- as the expression in the generated case statement.
9794 if Is_Unchecked_Union (E) then
9796 Make_Case_Statement (Loc,
9798 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
9799 Alternatives => Alt_List));
9803 Make_Case_Statement (Loc,
9805 Make_Selected_Component (Loc,
9806 Prefix => Make_Identifier (Loc, Name_X),
9807 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
9808 Alternatives => Alt_List));
9829 -- or a null statement if the list L is empty
9831 -- Equality may be user-defined for a given component type, in which case
9832 -- a function call is constructed instead of an operator node. This is an
9833 -- Ada 2012 change in the composability of equality for untagged composite
9838 L : List_Id) return Node_Id
9840 Loc : constant Source_Ptr := Sloc (E);
9844 Field_Name : Name_Id;
9845 Next_Test : Node_Id;
9850 return Make_Null_Statement (Loc);
9855 C := First_Non_Pragma (L);
9856 while Present (C) loop
9857 Typ := Etype (Defining_Identifier (C));
9858 Field_Name := Chars (Defining_Identifier (C));
9860 -- The tags must not be compared: they are not part of the value.
9861 -- Ditto for parent interfaces because their equality operator is
9864 -- Note also that in the following, we use Make_Identifier for
9865 -- the component names. Use of New_Occurrence_Of to identify the
9866 -- components would be incorrect because the wrong entities for
9867 -- discriminants could be picked up in the private type case.
9869 if Field_Name = Name_uParent
9870 and then Is_Interface (Typ)
9874 elsif Field_Name /= Name_uTag then
9876 Lhs : constant Node_Id :=
9877 Make_Selected_Component (Loc,
9878 Prefix => Make_Identifier (Loc, Name_X),
9879 Selector_Name => Make_Identifier (Loc, Field_Name));
9881 Rhs : constant Node_Id :=
9882 Make_Selected_Component (Loc,
9883 Prefix => Make_Identifier (Loc, Name_Y),
9884 Selector_Name => Make_Identifier (Loc, Field_Name));
9888 -- Build equality code with a user-defined operator, if
9889 -- available, and with the predefined "=" otherwise. For
9890 -- compatibility with older Ada versions, we also use the
9891 -- predefined operation if the component-type equality is
9892 -- abstract, rather than raising Program_Error.
9894 if Ada_Version < Ada_2012 then
9895 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
9898 Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
9900 if No (Eq_Call) then
9901 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
9903 -- If a component has a defined abstract equality, its
9904 -- application raises Program_Error on that component
9905 -- and therefore on the current variant.
9907 elsif Nkind (Eq_Call) = N_Raise_Program_Error then
9908 Set_Etype (Eq_Call, Standard_Boolean);
9909 Next_Test := Make_Op_Not (Loc, Eq_Call);
9912 Next_Test := Make_Op_Not (Loc, Eq_Call);
9917 Evolve_Or_Else (Cond, Next_Test);
9920 Next_Non_Pragma (C);
9924 return Make_Null_Statement (Loc);
9928 Make_Implicit_If_Statement (E,
9930 Then_Statements => New_List (
9931 Make_Simple_Return_Statement (Loc,
9932 Expression => New_Occurrence_Of (Standard_False, Loc))));
9941 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
9943 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
9944 -- Returns true if Prim is a renaming of an unresolved predefined
9945 -- inequality operation.
9947 --------------------------------
9948 -- Is_Predefined_Neq_Renaming --
9949 --------------------------------
9951 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
9953 return Chars (Prim) /= Name_Op_Ne
9954 and then Present (Alias (Prim))
9955 and then Comes_From_Source (Prim)
9956 and then Is_Intrinsic_Subprogram (Alias (Prim))
9957 and then Chars (Alias (Prim)) = Name_Op_Ne;
9958 end Is_Predefined_Neq_Renaming;
9962 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
9963 Stmts : constant List_Id := New_List;
9965 Eq_Prim : Entity_Id;
9966 Left_Op : Entity_Id;
9967 Renaming_Prim : Entity_Id;
9968 Right_Op : Entity_Id;
9971 -- Start of processing for Make_Neq_Body
9974 -- For a call on a renaming of a dispatching subprogram that is
9975 -- overridden, if the overriding occurred before the renaming, then
9976 -- the body executed is that of the overriding declaration, even if the
9977 -- overriding declaration is not visible at the place of the renaming;
9978 -- otherwise, the inherited or predefined subprogram is called, see
9981 -- Stage 1: Search for a renaming of the inequality primitive and also
9982 -- search for an overriding of the equality primitive located before the
9983 -- renaming declaration.
9991 Renaming_Prim := Empty;
9993 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9994 while Present (Elmt) loop
9995 Prim := Node (Elmt);
9997 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
9998 if No (Renaming_Prim) then
9999 pragma Assert (No (Eq_Prim));
10003 elsif Is_Predefined_Neq_Renaming (Prim) then
10004 Renaming_Prim := Prim;
10011 -- No further action needed if no renaming was found
10013 if No (Renaming_Prim) then
10017 -- Stage 2: Replace the renaming declaration by a subprogram declaration
10018 -- (required to add its body)
10020 Decl := Parent (Parent (Renaming_Prim));
10022 Make_Subprogram_Declaration (Loc,
10023 Specification => Specification (Decl)));
10024 Set_Analyzed (Decl);
10026 -- Remove the decoration of intrinsic renaming subprogram
10028 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
10029 Set_Convention (Renaming_Prim, Convention_Ada);
10030 Set_Alias (Renaming_Prim, Empty);
10031 Set_Has_Completion (Renaming_Prim, False);
10033 -- Stage 3: Build the corresponding body
10035 Left_Op := First_Formal (Renaming_Prim);
10036 Right_Op := Next_Formal (Left_Op);
10039 Predef_Spec_Or_Body (Loc,
10040 Tag_Typ => Tag_Typ,
10041 Name => Chars (Renaming_Prim),
10042 Profile => New_List (
10043 Make_Parameter_Specification (Loc,
10044 Defining_Identifier =>
10045 Make_Defining_Identifier (Loc, Chars (Left_Op)),
10046 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10048 Make_Parameter_Specification (Loc,
10049 Defining_Identifier =>
10050 Make_Defining_Identifier (Loc, Chars (Right_Op)),
10051 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10053 Ret_Type => Standard_Boolean,
10056 -- If the overriding of the equality primitive occurred before the
10057 -- renaming, then generate:
10059 -- function <Neq_Name> (X : Y : Typ) return Boolean is
10061 -- return not Oeq (X, Y);
10064 if Present (Eq_Prim) then
10067 -- Otherwise build a nested subprogram which performs the predefined
10068 -- evaluation of the equality operator. That is, generate:
10070 -- function <Neq_Name> (X : Y : Typ) return Boolean is
10071 -- function Oeq (X : Y) return Boolean is
10073 -- <<body of default implementation>>
10076 -- return not Oeq (X, Y);
10081 Local_Subp : Node_Id;
10083 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
10084 Set_Declarations (Decl, New_List (Local_Subp));
10085 Target := Defining_Entity (Local_Subp);
10090 Make_Simple_Return_Statement (Loc,
10093 Make_Function_Call (Loc,
10094 Name => New_Occurrence_Of (Target, Loc),
10095 Parameter_Associations => New_List (
10096 Make_Identifier (Loc, Chars (Left_Op)),
10097 Make_Identifier (Loc, Chars (Right_Op)))))));
10099 Set_Handled_Statement_Sequence
10100 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
10104 -------------------------------
10105 -- Make_Null_Procedure_Specs --
10106 -------------------------------
10108 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
10109 Decl_List : constant List_Id := New_List;
10110 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10111 Formal : Entity_Id;
10112 Formal_List : List_Id;
10113 New_Param_Spec : Node_Id;
10114 Parent_Subp : Entity_Id;
10115 Prim_Elmt : Elmt_Id;
10119 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
10120 while Present (Prim_Elmt) loop
10121 Subp := Node (Prim_Elmt);
10123 -- If a null procedure inherited from an interface has not been
10124 -- overridden, then we build a null procedure declaration to
10125 -- override the inherited procedure.
10127 Parent_Subp := Alias (Subp);
10129 if Present (Parent_Subp)
10130 and then Is_Null_Interface_Primitive (Parent_Subp)
10132 Formal_List := No_List;
10133 Formal := First_Formal (Subp);
10135 if Present (Formal) then
10136 Formal_List := New_List;
10138 while Present (Formal) loop
10140 -- Copy the parameter spec including default expressions
10143 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
10145 -- Generate a new defining identifier for the new formal.
10146 -- required because New_Copy_Tree does not duplicate
10147 -- semantic fields (except itypes).
10149 Set_Defining_Identifier (New_Param_Spec,
10150 Make_Defining_Identifier (Sloc (Formal),
10151 Chars => Chars (Formal)));
10153 -- For controlling arguments we must change their
10154 -- parameter type to reference the tagged type (instead
10155 -- of the interface type)
10157 if Is_Controlling_Formal (Formal) then
10158 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
10160 Set_Parameter_Type (New_Param_Spec,
10161 New_Occurrence_Of (Tag_Typ, Loc));
10164 (Nkind (Parameter_Type (Parent (Formal))) =
10165 N_Access_Definition);
10166 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
10167 New_Occurrence_Of (Tag_Typ, Loc));
10171 Append (New_Param_Spec, Formal_List);
10173 Next_Formal (Formal);
10177 Append_To (Decl_List,
10178 Make_Subprogram_Declaration (Loc,
10179 Make_Procedure_Specification (Loc,
10180 Defining_Unit_Name =>
10181 Make_Defining_Identifier (Loc, Chars (Subp)),
10182 Parameter_Specifications => Formal_List,
10183 Null_Present => True)));
10186 Next_Elmt (Prim_Elmt);
10190 end Make_Null_Procedure_Specs;
10192 -------------------------------------
10193 -- Make_Predefined_Primitive_Specs --
10194 -------------------------------------
10196 procedure Make_Predefined_Primitive_Specs
10197 (Tag_Typ : Entity_Id;
10198 Predef_List : out List_Id;
10199 Renamed_Eq : out Entity_Id)
10201 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
10202 -- Returns true if Prim is a renaming of an unresolved predefined
10203 -- equality operation.
10205 -------------------------------
10206 -- Is_Predefined_Eq_Renaming --
10207 -------------------------------
10209 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
10211 return Chars (Prim) /= Name_Op_Eq
10212 and then Present (Alias (Prim))
10213 and then Comes_From_Source (Prim)
10214 and then Is_Intrinsic_Subprogram (Alias (Prim))
10215 and then Chars (Alias (Prim)) = Name_Op_Eq;
10216 end Is_Predefined_Eq_Renaming;
10220 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10221 Res : constant List_Id := New_List;
10222 Eq_Name : Name_Id := Name_Op_Eq;
10223 Eq_Needed : Boolean;
10227 Has_Predef_Eq_Renaming : Boolean := False;
10228 -- Set to True if Tag_Typ has a primitive that renames the predefined
10229 -- equality operator. Used to implement (RM 8-5-4(8)).
10233 -- Start of processing for Make_Predefined_Primitive_Specs
10236 Renamed_Eq := Empty;
10240 Append_To (Res, Predef_Spec_Or_Body (Loc,
10241 Tag_Typ => Tag_Typ,
10242 Name => Name_uSize,
10243 Profile => New_List (
10244 Make_Parameter_Specification (Loc,
10245 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10246 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10248 Ret_Type => Standard_Long_Long_Integer));
10250 -- Spec of Put_Image
10252 if Enable_Put_Image (Tag_Typ)
10253 and then No (TSS (Tag_Typ, TSS_Put_Image))
10255 Append_To (Res, Predef_Spec_Or_Body (Loc,
10256 Tag_Typ => Tag_Typ,
10257 Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
10258 Profile => Build_Put_Image_Profile (Loc, Tag_Typ)));
10261 -- Specs for dispatching stream attributes
10264 Stream_Op_TSS_Names :
10265 constant array (Positive range <>) of TSS_Name_Type :=
10269 TSS_Stream_Output);
10272 for Op in Stream_Op_TSS_Names'Range loop
10273 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
10275 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
10276 Stream_Op_TSS_Names (Op)));
10281 -- Spec of "=" is expanded if the type is not limited and if a user
10282 -- defined "=" was not already declared for the non-full view of a
10283 -- private extension
10285 if not Is_Limited_Type (Tag_Typ) then
10287 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10288 while Present (Prim) loop
10290 -- If a primitive is encountered that renames the predefined
10291 -- equality operator before reaching any explicit equality
10292 -- primitive, then we still need to create a predefined equality
10293 -- function, because calls to it can occur via the renaming. A
10294 -- new name is created for the equality to avoid conflicting with
10295 -- any user-defined equality. (Note that this doesn't account for
10296 -- renamings of equality nested within subpackages???)
10298 if Is_Predefined_Eq_Renaming (Node (Prim)) then
10299 Has_Predef_Eq_Renaming := True;
10300 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
10302 -- User-defined equality
10304 elsif Is_User_Defined_Equality (Node (Prim)) then
10305 if No (Alias (Node (Prim)))
10306 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
10307 N_Subprogram_Renaming_Declaration
10309 Eq_Needed := False;
10312 -- If the parent is not an interface type and has an abstract
10313 -- equality function explicitly defined in the sources, then
10314 -- the inherited equality is abstract as well, and no body can
10315 -- be created for it.
10317 elsif not Is_Interface (Etype (Tag_Typ))
10318 and then Present (Alias (Node (Prim)))
10319 and then Comes_From_Source (Alias (Node (Prim)))
10320 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
10322 Eq_Needed := False;
10325 -- If the type has an equality function corresponding with
10326 -- a primitive defined in an interface type, the inherited
10327 -- equality is abstract as well, and no body can be created
10330 elsif Present (Alias (Node (Prim)))
10331 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
10334 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
10336 Eq_Needed := False;
10344 -- If a renaming of predefined equality was found but there was no
10345 -- user-defined equality (so Eq_Needed is still true), then set the
10346 -- name back to Name_Op_Eq. But in the case where a user-defined
10347 -- equality was located after such a renaming, then the predefined
10348 -- equality function is still needed, so Eq_Needed must be set back
10351 if Eq_Name /= Name_Op_Eq then
10353 Eq_Name := Name_Op_Eq;
10360 Eq_Spec := Predef_Spec_Or_Body (Loc,
10361 Tag_Typ => Tag_Typ,
10363 Profile => New_List (
10364 Make_Parameter_Specification (Loc,
10365 Defining_Identifier =>
10366 Make_Defining_Identifier (Loc, Name_X),
10367 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10369 Make_Parameter_Specification (Loc,
10370 Defining_Identifier =>
10371 Make_Defining_Identifier (Loc, Name_Y),
10372 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10373 Ret_Type => Standard_Boolean);
10374 Append_To (Res, Eq_Spec);
10376 if Has_Predef_Eq_Renaming then
10377 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
10379 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10380 while Present (Prim) loop
10382 -- Any renamings of equality that appeared before an
10383 -- overriding equality must be updated to refer to the
10384 -- entity for the predefined equality, otherwise calls via
10385 -- the renaming would get incorrectly resolved to call the
10386 -- user-defined equality function.
10388 if Is_Predefined_Eq_Renaming (Node (Prim)) then
10389 Set_Alias (Node (Prim), Renamed_Eq);
10391 -- Exit upon encountering a user-defined equality
10393 elsif Chars (Node (Prim)) = Name_Op_Eq
10394 and then No (Alias (Node (Prim)))
10404 -- Spec for dispatching assignment
10406 Append_To (Res, Predef_Spec_Or_Body (Loc,
10407 Tag_Typ => Tag_Typ,
10408 Name => Name_uAssign,
10409 Profile => New_List (
10410 Make_Parameter_Specification (Loc,
10411 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10412 Out_Present => True,
10413 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10415 Make_Parameter_Specification (Loc,
10416 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
10417 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
10420 -- Ada 2005: Generate declarations for the following primitive
10421 -- operations for limited interfaces and synchronized types that
10422 -- implement a limited interface.
10424 -- Disp_Asynchronous_Select
10425 -- Disp_Conditional_Select
10426 -- Disp_Get_Prim_Op_Kind
10427 -- Disp_Get_Task_Id
10429 -- Disp_Timed_Select
10431 -- Disable the generation of these bodies if No_Dispatching_Calls,
10432 -- Ravenscar or ZFP is active.
10434 if Ada_Version >= Ada_2005
10435 and then not Restriction_Active (No_Dispatching_Calls)
10436 and then not Restriction_Active (No_Select_Statements)
10437 and then RTE_Available (RE_Select_Specific_Data)
10439 -- These primitives are defined abstract in interface types
10441 if Is_Interface (Tag_Typ)
10442 and then Is_Limited_Record (Tag_Typ)
10445 Make_Abstract_Subprogram_Declaration (Loc,
10447 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
10450 Make_Abstract_Subprogram_Declaration (Loc,
10452 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
10455 Make_Abstract_Subprogram_Declaration (Loc,
10457 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
10460 Make_Abstract_Subprogram_Declaration (Loc,
10462 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
10465 Make_Abstract_Subprogram_Declaration (Loc,
10467 Make_Disp_Requeue_Spec (Tag_Typ)));
10470 Make_Abstract_Subprogram_Declaration (Loc,
10472 Make_Disp_Timed_Select_Spec (Tag_Typ)));
10474 -- If ancestor is an interface type, declare non-abstract primitives
10475 -- to override the abstract primitives of the interface type.
10477 -- In VM targets we define these primitives in all root tagged types
10478 -- that are not interface types. Done because in VM targets we don't
10479 -- have secondary dispatch tables and any derivation of Tag_Typ may
10480 -- cover limited interfaces (which always have these primitives since
10481 -- they may be ancestors of synchronized interface types).
10483 elsif (not Is_Interface (Tag_Typ)
10484 and then Is_Interface (Etype (Tag_Typ))
10485 and then Is_Limited_Record (Etype (Tag_Typ)))
10487 (Is_Concurrent_Record_Type (Tag_Typ)
10488 and then Has_Interfaces (Tag_Typ))
10490 (not Tagged_Type_Expansion
10491 and then not Is_Interface (Tag_Typ)
10492 and then Tag_Typ = Root_Type (Tag_Typ))
10495 Make_Subprogram_Declaration (Loc,
10497 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
10500 Make_Subprogram_Declaration (Loc,
10502 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
10505 Make_Subprogram_Declaration (Loc,
10507 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
10510 Make_Subprogram_Declaration (Loc,
10512 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
10515 Make_Subprogram_Declaration (Loc,
10517 Make_Disp_Requeue_Spec (Tag_Typ)));
10520 Make_Subprogram_Declaration (Loc,
10522 Make_Disp_Timed_Select_Spec (Tag_Typ)));
10526 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
10527 -- regardless of whether they are controlled or may contain controlled
10530 -- Do not generate the routines if finalization is disabled
10532 if Restriction_Active (No_Finalization) then
10536 if not Is_Limited_Type (Tag_Typ) then
10537 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
10540 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
10543 Predef_List := Res;
10544 end Make_Predefined_Primitive_Specs;
10546 -------------------------
10547 -- Make_Tag_Assignment --
10548 -------------------------
10550 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
10551 Loc : constant Source_Ptr := Sloc (N);
10552 Def_If : constant Entity_Id := Defining_Identifier (N);
10553 Expr : constant Node_Id := Expression (N);
10554 Typ : constant Entity_Id := Etype (Def_If);
10555 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
10559 -- This expansion activity is called during analysis.
10561 if Is_Tagged_Type (Typ)
10562 and then not Is_Class_Wide_Type (Typ)
10563 and then not Is_CPP_Class (Typ)
10564 and then Tagged_Type_Expansion
10565 and then Nkind (Expr) /= N_Aggregate
10566 and then (Nkind (Expr) /= N_Qualified_Expression
10567 or else Nkind (Expression (Expr)) /= N_Aggregate)
10570 Make_Selected_Component (Loc,
10571 Prefix => New_Occurrence_Of (Def_If, Loc),
10573 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
10574 Set_Assignment_OK (New_Ref);
10577 Make_Assignment_Statement (Loc,
10580 Unchecked_Convert_To (RTE (RE_Tag),
10581 New_Occurrence_Of (Node
10582 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
10586 end Make_Tag_Assignment;
10588 ----------------------
10589 -- Predef_Deep_Spec --
10590 ----------------------
10592 function Predef_Deep_Spec
10594 Tag_Typ : Entity_Id;
10595 Name : TSS_Name_Type;
10596 For_Body : Boolean := False) return Node_Id
10601 -- V : in out Tag_Typ
10603 Formals := New_List (
10604 Make_Parameter_Specification (Loc,
10605 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
10606 In_Present => True,
10607 Out_Present => True,
10608 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
10610 -- F : Boolean := True
10612 if Name = TSS_Deep_Adjust
10613 or else Name = TSS_Deep_Finalize
10615 Append_To (Formals,
10616 Make_Parameter_Specification (Loc,
10617 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
10618 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
10619 Expression => New_Occurrence_Of (Standard_True, Loc)));
10623 Predef_Spec_Or_Body (Loc,
10624 Name => Make_TSS_Name (Tag_Typ, Name),
10625 Tag_Typ => Tag_Typ,
10626 Profile => Formals,
10627 For_Body => For_Body);
10630 when RE_Not_Available =>
10632 end Predef_Deep_Spec;
10634 -------------------------
10635 -- Predef_Spec_Or_Body --
10636 -------------------------
10638 function Predef_Spec_Or_Body
10640 Tag_Typ : Entity_Id;
10643 Ret_Type : Entity_Id := Empty;
10644 For_Body : Boolean := False) return Node_Id
10646 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
10650 Set_Is_Public (Id, Is_Public (Tag_Typ));
10652 -- The internal flag is set to mark these declarations because they have
10653 -- specific properties. First, they are primitives even if they are not
10654 -- defined in the type scope (the freezing point is not necessarily in
10655 -- the same scope). Second, the predefined equality can be overridden by
10656 -- a user-defined equality, no body will be generated in this case.
10658 Set_Is_Internal (Id);
10660 if not Debug_Generated_Code then
10661 Set_Debug_Info_Off (Id);
10664 if No (Ret_Type) then
10666 Make_Procedure_Specification (Loc,
10667 Defining_Unit_Name => Id,
10668 Parameter_Specifications => Profile);
10671 Make_Function_Specification (Loc,
10672 Defining_Unit_Name => Id,
10673 Parameter_Specifications => Profile,
10674 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
10677 -- Declare an abstract subprogram for primitive subprograms of an
10678 -- interface type (except for "=").
10680 if Is_Interface (Tag_Typ) then
10681 if Name /= Name_Op_Eq then
10682 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
10684 -- The equality function (if any) for an interface type is defined
10685 -- to be nonabstract, so we create an expression function for it that
10686 -- always returns False. Note that the function can never actually be
10687 -- invoked because interface types are abstract, so there aren't any
10688 -- objects of such types (and their equality operation will always
10692 return Make_Expression_Function
10693 (Loc, Spec, New_Occurrence_Of (Standard_False, Loc));
10696 -- If body case, return empty subprogram body. Note that this is ill-
10697 -- formed, because there is not even a null statement, and certainly not
10698 -- a return in the function case. The caller is expected to do surgery
10699 -- on the body to add the appropriate stuff.
10701 elsif For_Body then
10702 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
10704 -- For the case of an Input attribute predefined for an abstract type,
10705 -- generate an abstract specification. This will never be called, but we
10706 -- need the slot allocated in the dispatching table so that attributes
10707 -- typ'Class'Input and typ'Class'Output will work properly.
10709 elsif Is_TSS (Name, TSS_Stream_Input)
10710 and then Is_Abstract_Type (Tag_Typ)
10712 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
10714 -- Normal spec case, where we return a subprogram declaration
10717 return Make_Subprogram_Declaration (Loc, Spec);
10719 end Predef_Spec_Or_Body;
10721 -----------------------------
10722 -- Predef_Stream_Attr_Spec --
10723 -----------------------------
10725 function Predef_Stream_Attr_Spec
10727 Tag_Typ : Entity_Id;
10728 Name : TSS_Name_Type;
10729 For_Body : Boolean := False) return Node_Id
10731 Ret_Type : Entity_Id;
10734 if Name = TSS_Stream_Input then
10735 Ret_Type := Tag_Typ;
10741 Predef_Spec_Or_Body
10743 Name => Make_TSS_Name (Tag_Typ, Name),
10744 Tag_Typ => Tag_Typ,
10745 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
10746 Ret_Type => Ret_Type,
10747 For_Body => For_Body);
10748 end Predef_Stream_Attr_Spec;
10750 ---------------------------------
10751 -- Predefined_Primitive_Bodies --
10752 ---------------------------------
10754 function Predefined_Primitive_Bodies
10755 (Tag_Typ : Entity_Id;
10756 Renamed_Eq : Entity_Id) return List_Id
10758 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10759 Res : constant List_Id := New_List;
10760 Adj_Call : Node_Id;
10762 Fin_Call : Node_Id;
10764 Eq_Needed : Boolean;
10768 pragma Warnings (Off, Ent);
10773 pragma Assert (not Is_Interface (Tag_Typ));
10775 -- See if we have a predefined "=" operator
10777 if Present (Renamed_Eq) then
10779 Eq_Name := Chars (Renamed_Eq);
10781 -- If the parent is an interface type then it has defined all the
10782 -- predefined primitives abstract and we need to check if the type
10783 -- has some user defined "=" function which matches the profile of
10784 -- the Ada predefined equality operator to avoid generating it.
10786 elsif Is_Interface (Etype (Tag_Typ)) then
10788 Eq_Name := Name_Op_Eq;
10790 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10791 while Present (Prim) loop
10792 if Chars (Node (Prim)) = Name_Op_Eq
10793 and then not Is_Internal (Node (Prim))
10794 and then Present (First_Entity (Node (Prim)))
10796 -- The predefined equality primitive must have exactly two
10797 -- formals whose type is this tagged type
10799 and then Present (Last_Entity (Node (Prim)))
10800 and then Next_Entity (First_Entity (Node (Prim)))
10801 = Last_Entity (Node (Prim))
10802 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
10803 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
10805 Eq_Needed := False;
10806 Eq_Name := No_Name;
10814 Eq_Needed := False;
10815 Eq_Name := No_Name;
10817 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10818 while Present (Prim) loop
10819 if Chars (Node (Prim)) = Name_Op_Eq
10820 and then Is_Internal (Node (Prim))
10823 Eq_Name := Name_Op_Eq;
10833 Decl := Predef_Spec_Or_Body (Loc,
10834 Tag_Typ => Tag_Typ,
10835 Name => Name_uSize,
10836 Profile => New_List (
10837 Make_Parameter_Specification (Loc,
10838 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10839 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10841 Ret_Type => Standard_Long_Long_Integer,
10844 Set_Handled_Statement_Sequence (Decl,
10845 Make_Handled_Sequence_Of_Statements (Loc, New_List (
10846 Make_Simple_Return_Statement (Loc,
10848 Make_Attribute_Reference (Loc,
10849 Prefix => Make_Identifier (Loc, Name_X),
10850 Attribute_Name => Name_Size)))));
10852 Append_To (Res, Decl);
10854 -- Body of Put_Image
10856 if Enable_Put_Image (Tag_Typ)
10857 and then No (TSS (Tag_Typ, TSS_Put_Image))
10859 Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
10860 Append_To (Res, Decl);
10863 -- Bodies for Dispatching stream IO routines. We need these only for
10864 -- non-limited types (in the limited case there is no dispatching).
10865 -- We also skip them if dispatching or finalization are not available
10866 -- or if stream operations are prohibited by restriction No_Streams or
10867 -- from use of pragma/aspect No_Tagged_Streams.
10869 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
10870 and then No (TSS (Tag_Typ, TSS_Stream_Read))
10872 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
10873 Append_To (Res, Decl);
10876 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
10877 and then No (TSS (Tag_Typ, TSS_Stream_Write))
10879 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
10880 Append_To (Res, Decl);
10883 -- Skip body of _Input for the abstract case, since the corresponding
10884 -- spec is abstract (see Predef_Spec_Or_Body).
10886 if not Is_Abstract_Type (Tag_Typ)
10887 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
10888 and then No (TSS (Tag_Typ, TSS_Stream_Input))
10890 Build_Record_Or_Elementary_Input_Function
10891 (Loc, Tag_Typ, Decl, Ent);
10892 Append_To (Res, Decl);
10895 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
10896 and then No (TSS (Tag_Typ, TSS_Stream_Output))
10898 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
10899 Append_To (Res, Decl);
10902 -- Ada 2005: Generate bodies for the following primitive operations for
10903 -- limited interfaces and synchronized types that implement a limited
10906 -- disp_asynchronous_select
10907 -- disp_conditional_select
10908 -- disp_get_prim_op_kind
10909 -- disp_get_task_id
10910 -- disp_timed_select
10912 -- The interface versions will have null bodies
10914 -- Disable the generation of these bodies if No_Dispatching_Calls,
10915 -- Ravenscar or ZFP is active.
10917 -- In VM targets we define these primitives in all root tagged types
10918 -- that are not interface types. Done because in VM targets we don't
10919 -- have secondary dispatch tables and any derivation of Tag_Typ may
10920 -- cover limited interfaces (which always have these primitives since
10921 -- they may be ancestors of synchronized interface types).
10923 if Ada_Version >= Ada_2005
10924 and then not Is_Interface (Tag_Typ)
10926 ((Is_Interface (Etype (Tag_Typ))
10927 and then Is_Limited_Record (Etype (Tag_Typ)))
10929 (Is_Concurrent_Record_Type (Tag_Typ)
10930 and then Has_Interfaces (Tag_Typ))
10932 (not Tagged_Type_Expansion
10933 and then Tag_Typ = Root_Type (Tag_Typ)))
10934 and then not Restriction_Active (No_Dispatching_Calls)
10935 and then not Restriction_Active (No_Select_Statements)
10936 and then RTE_Available (RE_Select_Specific_Data)
10938 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
10939 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
10940 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
10941 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
10942 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
10943 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
10946 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
10948 -- Body for equality
10951 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
10952 Append_To (Res, Decl);
10955 -- Body for inequality (if required)
10957 Decl := Make_Neq_Body (Tag_Typ);
10959 if Present (Decl) then
10960 Append_To (Res, Decl);
10963 -- Body for dispatching assignment
10966 Predef_Spec_Or_Body (Loc,
10967 Tag_Typ => Tag_Typ,
10968 Name => Name_uAssign,
10969 Profile => New_List (
10970 Make_Parameter_Specification (Loc,
10971 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10972 Out_Present => True,
10973 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10975 Make_Parameter_Specification (Loc,
10976 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
10977 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10980 Set_Handled_Statement_Sequence (Decl,
10981 Make_Handled_Sequence_Of_Statements (Loc, New_List (
10982 Make_Assignment_Statement (Loc,
10983 Name => Make_Identifier (Loc, Name_X),
10984 Expression => Make_Identifier (Loc, Name_Y)))));
10986 Append_To (Res, Decl);
10989 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
10990 -- tagged types which do not contain controlled components.
10992 -- Do not generate the routines if finalization is disabled
10994 if Restriction_Active (No_Finalization) then
10997 elsif not Has_Controlled_Component (Tag_Typ) then
10998 if not Is_Limited_Type (Tag_Typ) then
11000 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
11002 if Is_Controlled (Tag_Typ) then
11005 Obj_Ref => Make_Identifier (Loc, Name_V),
11009 if No (Adj_Call) then
11010 Adj_Call := Make_Null_Statement (Loc);
11013 Set_Handled_Statement_Sequence (Decl,
11014 Make_Handled_Sequence_Of_Statements (Loc,
11015 Statements => New_List (Adj_Call)));
11017 Append_To (Res, Decl);
11021 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
11023 if Is_Controlled (Tag_Typ) then
11026 (Obj_Ref => Make_Identifier (Loc, Name_V),
11030 if No (Fin_Call) then
11031 Fin_Call := Make_Null_Statement (Loc);
11034 Set_Handled_Statement_Sequence (Decl,
11035 Make_Handled_Sequence_Of_Statements (Loc,
11036 Statements => New_List (Fin_Call)));
11038 Append_To (Res, Decl);
11042 end Predefined_Primitive_Bodies;
11044 ---------------------------------
11045 -- Predefined_Primitive_Freeze --
11046 ---------------------------------
11048 function Predefined_Primitive_Freeze
11049 (Tag_Typ : Entity_Id) return List_Id
11051 Res : constant List_Id := New_List;
11056 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
11057 while Present (Prim) loop
11058 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
11059 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
11061 if Present (Frnodes) then
11062 Append_List_To (Res, Frnodes);
11070 end Predefined_Primitive_Freeze;
11072 -------------------------
11073 -- Stream_Operation_OK --
11074 -------------------------
11076 function Stream_Operation_OK
11078 Operation : TSS_Name_Type) return Boolean
11080 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
11083 -- Special case of a limited type extension: a default implementation
11084 -- of the stream attributes Read or Write exists if that attribute
11085 -- has been specified or is available for an ancestor type; a default
11086 -- implementation of the attribute Output (resp. Input) exists if the
11087 -- attribute has been specified or Write (resp. Read) is available for
11088 -- an ancestor type. The last condition only applies under Ada 2005.
11090 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
11091 if Operation = TSS_Stream_Read then
11092 Has_Predefined_Or_Specified_Stream_Attribute :=
11093 Has_Specified_Stream_Read (Typ);
11095 elsif Operation = TSS_Stream_Write then
11096 Has_Predefined_Or_Specified_Stream_Attribute :=
11097 Has_Specified_Stream_Write (Typ);
11099 elsif Operation = TSS_Stream_Input then
11100 Has_Predefined_Or_Specified_Stream_Attribute :=
11101 Has_Specified_Stream_Input (Typ)
11103 (Ada_Version >= Ada_2005
11104 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
11106 elsif Operation = TSS_Stream_Output then
11107 Has_Predefined_Or_Specified_Stream_Attribute :=
11108 Has_Specified_Stream_Output (Typ)
11110 (Ada_Version >= Ada_2005
11111 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
11114 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
11116 if not Has_Predefined_Or_Specified_Stream_Attribute
11117 and then Is_Derived_Type (Typ)
11118 and then (Operation = TSS_Stream_Read
11119 or else Operation = TSS_Stream_Write)
11121 Has_Predefined_Or_Specified_Stream_Attribute :=
11123 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
11127 -- If the type is not limited, or else is limited but the attribute is
11128 -- explicitly specified or is predefined for the type, then return True,
11129 -- unless other conditions prevail, such as restrictions prohibiting
11130 -- streams or dispatching operations. We also return True for limited
11131 -- interfaces, because they may be extended by nonlimited types and
11132 -- permit inheritance in this case (addresses cases where an abstract
11133 -- extension doesn't get 'Input declared, as per comments below, but
11134 -- 'Class'Input must still be allowed). Note that attempts to apply
11135 -- stream attributes to a limited interface or its class-wide type
11136 -- (or limited extensions thereof) will still get properly rejected
11137 -- by Check_Stream_Attribute.
11139 -- We exclude the Input operation from being a predefined subprogram in
11140 -- the case where the associated type is an abstract extension, because
11141 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
11142 -- we don't want an abstract version created because types derived from
11143 -- the abstract type may not even have Input available (for example if
11144 -- derived from a private view of the abstract type that doesn't have
11145 -- a visible Input).
11147 -- Do not generate stream routines for type Finalization_Master because
11148 -- a master may never appear in types and therefore cannot be read or
11152 (not Is_Limited_Type (Typ)
11153 or else Is_Interface (Typ)
11154 or else Has_Predefined_Or_Specified_Stream_Attribute)
11156 (Operation /= TSS_Stream_Input
11157 or else not Is_Abstract_Type (Typ)
11158 or else not Is_Derived_Type (Typ))
11159 and then not Has_Unknown_Discriminants (Typ)
11161 (Is_Interface (Typ)
11163 (Is_Task_Interface (Typ)
11164 or else Is_Protected_Interface (Typ)
11165 or else Is_Synchronized_Interface (Typ)))
11166 and then not Restriction_Active (No_Streams)
11167 and then not Restriction_Active (No_Dispatch)
11168 and then No (No_Tagged_Streams_Pragma (Typ))
11169 and then not No_Run_Time_Mode
11170 and then RTE_Available (RE_Tag)
11171 and then No (Type_Without_Stream_Operation (Typ))
11172 and then RTE_Available (RE_Root_Stream_Type)
11173 and then not Is_RTE (Typ, RE_Finalization_Master);
11174 end Stream_Operation_OK;