1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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 Einfo.Entities; use Einfo.Entities;
31 with Einfo.Utils; use Einfo.Utils;
32 with Errout; use Errout;
33 with Expander; use Expander;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Atag; use Exp_Atag;
36 with Exp_Ch4; use Exp_Ch4;
37 with Exp_Ch6; use Exp_Ch6;
38 with Exp_Ch7; use Exp_Ch7;
39 with Exp_Ch9; use Exp_Ch9;
40 with Exp_Dbug; use Exp_Dbug;
41 with Exp_Disp; use Exp_Disp;
42 with Exp_Dist; use Exp_Dist;
44 with Exp_Smem; use Exp_Smem;
45 with Exp_Strm; use Exp_Strm;
46 with Exp_Tss; use Exp_Tss;
47 with Exp_Util; use Exp_Util;
48 with Freeze; use Freeze;
49 with Ghost; use Ghost;
51 with Namet; use Namet;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
55 with Restrict; use Restrict;
56 with Rident; use Rident;
57 with Rtsfind; use Rtsfind;
59 with Sem_Aux; use Sem_Aux;
60 with Sem_Attr; use Sem_Attr;
61 with Sem_Cat; use Sem_Cat;
62 with Sem_Ch3; use Sem_Ch3;
63 with Sem_Ch6; use Sem_Ch6;
64 with Sem_Ch8; use Sem_Ch8;
65 with Sem_Disp; use Sem_Disp;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Mech; use Sem_Mech;
68 with Sem_Res; use Sem_Res;
69 with Sem_SCIL; use Sem_SCIL;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sinfo; use Sinfo;
73 with Sinfo.Nodes; use Sinfo.Nodes;
74 with Sinfo.Utils; use Sinfo.Utils;
75 with Stand; use Stand;
76 with Snames; use Snames;
77 with Tbuild; use Tbuild;
78 with Ttypes; use Ttypes;
79 with Validsw; use Validsw;
81 package body Exp_Ch3 is
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 procedure Adjust_Discriminants (Rtype : Entity_Id);
88 -- This is used when freezing a record type. It attempts to construct
89 -- more restrictive subtypes for discriminants so that the max size of
90 -- the record can be calculated more accurately. See the body of this
91 -- procedure for details.
93 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
94 -- Build initialization procedure for given array type. Nod is a node
95 -- used for attachment of any actions required in its construction.
96 -- It also supplies the source location used for the procedure.
98 function Build_Discriminant_Formals
100 Use_Dl : Boolean) return List_Id;
101 -- This function uses the discriminants of a type to build a list of
102 -- formal parameters, used in Build_Init_Procedure among other places.
103 -- If the flag Use_Dl is set, the list is built using the already
104 -- defined discriminals of the type, as is the case for concurrent
105 -- types with discriminants. Otherwise new identifiers are created,
106 -- with the source names of the discriminants.
108 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
109 -- This function builds a static aggregate that can serve as the initial
110 -- value for an array type whose bounds are static, and whose component
111 -- type is a composite type that has a static equivalent aggregate.
112 -- The equivalent array aggregate is used both for object initialization
113 -- and for component initialization, when used in the following function.
115 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
116 -- This function builds a static aggregate that can serve as the initial
117 -- value for a record type whose components are scalar and initialized
118 -- with compile-time values, or arrays with similar initialization or
119 -- defaults. When possible, initialization of an object of the type can
120 -- be achieved by using a copy of the aggregate as an initial value, thus
121 -- removing the implicit call that would otherwise constitute elaboration
124 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
125 -- Build record initialization procedure. N is the type declaration
126 -- node, and Rec_Ent is the corresponding entity for the record type.
128 procedure Build_Slice_Assignment (Typ : Entity_Id);
129 -- Build assignment procedure for one-dimensional arrays of controlled
130 -- types. Other array and slice assignments are expanded in-line, but
131 -- the code expansion for controlled components (when control actions
132 -- are active) can lead to very large blocks that GCC handles poorly.
134 procedure Build_Untagged_Equality (Typ : Entity_Id);
135 -- AI05-0123: Equality on untagged records composes. This procedure
136 -- builds the equality routine for an untagged record that has components
137 -- of a record type that has user-defined primitive equality operations.
138 -- The resulting operation is a TSS subprogram.
140 procedure Check_Stream_Attributes (Typ : Entity_Id);
141 -- Check that if a limited extension has a parent with user-defined stream
142 -- attributes, and does not itself have user-defined stream-attributes,
143 -- then any limited component of the extension also has the corresponding
144 -- user-defined stream attributes.
146 procedure Clean_Task_Names
148 Proc_Id : Entity_Id);
149 -- If an initialization procedure includes calls to generate names
150 -- for task subcomponents, indicate that secondary stack cleanup is
151 -- needed after an initialization. Typ is the component type, and Proc_Id
152 -- the initialization procedure for the enclosing composite type.
154 procedure Expand_Freeze_Array_Type (N : Node_Id);
155 -- Freeze an array type. Deals with building the initialization procedure,
156 -- creating the packed array type for a packed array and also with the
157 -- creation of the controlling procedures for the controlled case. The
158 -- argument N is the N_Freeze_Entity node for the type.
160 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
161 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
162 -- of finalizing controlled derivations from the class-wide's root type.
164 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
165 -- Freeze enumeration type with non-standard representation. Builds the
166 -- array and function needed to convert between enumeration pos and
167 -- enumeration representation values. N is the N_Freeze_Entity node
170 procedure Expand_Freeze_Record_Type (N : Node_Id);
171 -- Freeze record type. Builds all necessary discriminant checking
172 -- and other ancillary functions, and builds dispatch tables where
173 -- needed. The argument N is the N_Freeze_Entity node. This processing
174 -- applies only to E_Record_Type entities, not to class wide types,
175 -- record subtypes, or private types.
177 procedure Expand_Tagged_Root (T : Entity_Id);
178 -- Add a field _Tag at the beginning of the record. This field carries
179 -- the value of the access to the Dispatch table. This procedure is only
180 -- called on root type, the _Tag field being inherited by the descendants.
182 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
183 -- Treat user-defined stream operations as renaming_as_body if the
184 -- subprogram they rename is not frozen when the type is frozen.
186 procedure Initialization_Warning (E : Entity_Id);
187 -- If static elaboration of the package is requested, indicate
188 -- when a type does meet the conditions for static initialization. If
189 -- E is a type, it has components that have no static initialization.
190 -- if E is an entity, its initial expression is not compile-time known.
192 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id;
193 -- This function builds the list of formals for an initialization routine.
194 -- The first formal is always _Init with the given type. For task value
195 -- record types and types containing tasks, three additional formals are
196 -- added and Proc_Id is decorated with attribute Has_Master_Entity:
198 -- _Master : Master_Id
199 -- _Chain : in out Activation_Chain
200 -- _Task_Name : String
202 -- The caller must append additional entries for discriminants if required.
204 function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
205 -- Returns true if the initialization procedure of Typ should be inlined
207 function In_Runtime (E : Entity_Id) return Boolean;
208 -- Check if E is defined in the RTL (in a child of Ada or System). Used
209 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
211 function Is_Null_Statement_List (Stmts : List_Id) return Boolean;
212 -- Returns true if Stmts is made of null statements only, possibly wrapped
213 -- in a case statement, recursively. This latter pattern may occur for the
214 -- initialization procedure of an unchecked union.
216 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
217 -- Returns true if Prim is a user defined equality function
219 function Make_Eq_Body
221 Eq_Name : Name_Id) return Node_Id;
222 -- Build the body of a primitive equality operation for a tagged record
223 -- type, or in Ada 2012 for any record type that has components with a
224 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
226 function Make_Eq_Case
229 Discrs : Elist_Id := New_Elmt_List) return List_Id;
230 -- Building block for variant record equality. Defined to share the code
231 -- between the tagged and untagged case. Given a Component_List node CL,
232 -- it generates an 'if' followed by a 'case' statement that compares all
233 -- components of local temporaries named X and Y (that are declared as
234 -- formals at some upper level). E provides the Sloc to be used for the
237 -- IF E is an unchecked_union, Discrs is the list of formals created for
238 -- the inferred discriminants of one operand. These formals are used in
239 -- the generated case statements for each variant of the unchecked union.
243 L : List_Id) return Node_Id;
244 -- Building block for variant record equality. Defined to share the code
245 -- between the tagged and untagged case. Given the list of components
246 -- (or discriminants) L, it generates a return statement that compares all
247 -- components of local temporaries named X and Y (that are declared as
248 -- formals at some upper level). E provides the Sloc to be used for the
251 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
252 -- Search for a renaming of the inequality dispatching primitive of
253 -- this tagged type. If found then build and return the corresponding
254 -- rename-as-body inequality subprogram; otherwise return Empty.
256 procedure Make_Predefined_Primitive_Specs
257 (Tag_Typ : Entity_Id;
258 Predef_List : out List_Id;
259 Renamed_Eq : out Entity_Id);
260 -- Create a list with the specs of the predefined primitive operations.
261 -- For tagged types that are interfaces all these primitives are defined
264 -- The following entries are present for all tagged types, and provide
265 -- the results of the corresponding attribute applied to the object.
266 -- Dispatching is required in general, since the result of the attribute
267 -- will vary with the actual object subtype.
269 -- _size provides result of 'Size attribute
270 -- typSR provides result of 'Read attribute
271 -- typSW provides result of 'Write attribute
272 -- typSI provides result of 'Input attribute
273 -- typSO provides result of 'Output attribute
274 -- typPI provides result of 'Put_Image attribute
276 -- The following entries are additionally present for non-limited tagged
277 -- types, and implement additional dispatching operations for predefined
280 -- _equality implements "=" operator
281 -- _assign implements assignment operation
282 -- typDF implements deep finalization
283 -- typDA implements deep adjust
285 -- The latter two are empty procedures unless the type contains some
286 -- controlled components that require finalization actions (the deep
287 -- in the name refers to the fact that the action applies to components).
289 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
290 -- returns the value Empty, or else the defining unit name for the
291 -- predefined equality function in the case where the type has a primitive
292 -- operation that is a renaming of predefined equality (but only if there
293 -- is also an overriding user-defined equality function). The returned
294 -- Renamed_Eq will be passed to the corresponding parameter of
295 -- Predefined_Primitive_Bodies.
297 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
298 -- Returns True if there are representation clauses for type T that are not
299 -- inherited. If the result is false, the init_proc and the discriminant
300 -- checking functions of the parent can be reused by a derived type.
302 procedure Make_Controlling_Function_Wrappers
303 (Tag_Typ : Entity_Id;
304 Decl_List : out List_Id;
305 Body_List : out List_Id);
306 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
307 -- associated with inherited functions with controlling results which
308 -- are not overridden. The body of each wrapper function consists solely
309 -- of a return statement whose expression is an extension aggregate
310 -- invoking the inherited subprogram's parent subprogram and extended
311 -- with a null association list.
313 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
314 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
315 -- null procedures inherited from an interface type that have not been
316 -- overridden. Only one null procedure will be created for a given set of
317 -- inherited null procedures with homographic profiles.
319 function Predef_Spec_Or_Body
324 Ret_Type : Entity_Id := Empty;
325 For_Body : Boolean := False) return Node_Id;
326 -- This function generates the appropriate expansion for a predefined
327 -- primitive operation specified by its name, parameter profile and
328 -- return type (Empty means this is a procedure). If For_Body is false,
329 -- then the returned node is a subprogram declaration. If For_Body is
330 -- true, then the returned node is a empty subprogram body containing
331 -- no declarations and no statements.
333 function Predef_Stream_Attr_Spec
336 Name : TSS_Name_Type;
337 For_Body : Boolean := False) return Node_Id;
338 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
339 -- input and output attribute whose specs are constructed in Exp_Strm.
341 function Predef_Deep_Spec
344 Name : TSS_Name_Type;
345 For_Body : Boolean := False) return Node_Id;
346 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
347 -- and _deep_finalize
349 function Predefined_Primitive_Bodies
350 (Tag_Typ : Entity_Id;
351 Renamed_Eq : Entity_Id) return List_Id;
352 -- Create the bodies of the predefined primitives that are described in
353 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
354 -- the defining unit name of the type's predefined equality as returned
355 -- by Make_Predefined_Primitive_Specs.
357 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
358 -- Freeze entities of all predefined primitive operations. This is needed
359 -- because the bodies of these operations do not normally do any freezing.
361 function Stream_Operation_OK
363 Operation : TSS_Name_Type) return Boolean;
364 -- Check whether the named stream operation must be emitted for a given
365 -- type. The rules for inheritance of stream attributes by type extensions
366 -- are enforced by this function. Furthermore, various restrictions prevent
367 -- the generation of these operations, as a useful optimization or for
368 -- certification purposes and to save unnecessary generated code.
370 --------------------------
371 -- Adjust_Discriminants --
372 --------------------------
374 -- This procedure attempts to define subtypes for discriminants that are
375 -- more restrictive than those declared. Such a replacement is possible if
376 -- we can demonstrate that values outside the restricted range would cause
377 -- constraint errors in any case. The advantage of restricting the
378 -- discriminant types in this way is that the maximum size of the variant
379 -- record can be calculated more conservatively.
381 -- An example of a situation in which we can perform this type of
382 -- restriction is the following:
384 -- subtype B is range 1 .. 10;
385 -- type Q is array (B range <>) of Integer;
387 -- type V (N : Natural) is record
391 -- In this situation, we can restrict the upper bound of N to 10, since
392 -- any larger value would cause a constraint error in any case.
394 -- There are many situations in which such restriction is possible, but
395 -- for now, we just look for cases like the above, where the component
396 -- in question is a one dimensional array whose upper bound is one of
397 -- the record discriminants. Also the component must not be part of
398 -- any variant part, since then the component does not always exist.
400 procedure Adjust_Discriminants (Rtype : Entity_Id) is
401 Loc : constant Source_Ptr := Sloc (Rtype);
418 Comp := First_Component (Rtype);
419 while Present (Comp) loop
421 -- If our parent is a variant, quit, we do not look at components
422 -- that are in variant parts, because they may not always exist.
424 P := Parent (Comp); -- component declaration
425 P := Parent (P); -- component list
427 exit when Nkind (Parent (P)) = N_Variant;
429 -- We are looking for a one dimensional array type
431 Ctyp := Etype (Comp);
433 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
437 -- The lower bound must be constant, and the upper bound is a
438 -- discriminant (which is a discriminant of the current record).
440 Ityp := Etype (First_Index (Ctyp));
441 Lo := Type_Low_Bound (Ityp);
442 Hi := Type_High_Bound (Ityp);
444 if not Compile_Time_Known_Value (Lo)
445 or else Nkind (Hi) /= N_Identifier
446 or else No (Entity (Hi))
447 or else Ekind (Entity (Hi)) /= E_Discriminant
452 -- We have an array with appropriate bounds
454 Loval := Expr_Value (Lo);
455 Discr := Entity (Hi);
456 Dtyp := Etype (Discr);
458 -- See if the discriminant has a known upper bound
460 Dhi := Type_High_Bound (Dtyp);
462 if not Compile_Time_Known_Value (Dhi) then
466 Dhiv := Expr_Value (Dhi);
468 -- See if base type of component array has known upper bound
470 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
472 if not Compile_Time_Known_Value (Ahi) then
476 Ahiv := Expr_Value (Ahi);
478 -- The condition for doing the restriction is that the high bound
479 -- of the discriminant is greater than the low bound of the array,
480 -- and is also greater than the high bound of the base type index.
482 if Dhiv > Loval and then Dhiv > Ahiv then
484 -- We can reset the upper bound of the discriminant type to
485 -- whichever is larger, the low bound of the component, or
486 -- the high bound of the base type array index.
488 -- We build a subtype that is declared as
490 -- subtype Tnn is discr_type range discr_type'First .. max;
492 -- And insert this declaration into the tree. The type of the
493 -- discriminant is then reset to this more restricted subtype.
495 Tnn := Make_Temporary (Loc, 'T');
497 Insert_Action (Declaration_Node (Rtype),
498 Make_Subtype_Declaration (Loc,
499 Defining_Identifier => Tnn,
500 Subtype_Indication =>
501 Make_Subtype_Indication (Loc,
502 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
504 Make_Range_Constraint (Loc,
508 Make_Attribute_Reference (Loc,
509 Attribute_Name => Name_First,
510 Prefix => New_Occurrence_Of (Dtyp, Loc)),
512 Make_Integer_Literal (Loc,
513 Intval => UI_Max (Loval, Ahiv)))))));
515 Set_Etype (Discr, Tnn);
519 Next_Component (Comp);
521 end Adjust_Discriminants;
523 ------------------------------------------
524 -- Build_Access_Subprogram_Wrapper_Body --
525 ------------------------------------------
527 procedure Build_Access_Subprogram_Wrapper_Body
531 Loc : constant Source_Ptr := Sloc (Decl);
532 Actuals : constant List_Id := New_List;
533 Type_Def : constant Node_Id := Type_Definition (Decl);
534 Type_Id : constant Entity_Id := Defining_Identifier (Decl);
535 Spec_Node : constant Node_Id :=
536 Copy_Subprogram_Spec (Specification (New_Decl));
537 -- This copy creates new identifiers for formals and subprogram.
545 if not Expander_Active then
549 -- Create List of actuals for indirect call. The last parameter of the
550 -- subprogram declaration is the access value for the indirect call.
552 Act := First (Parameter_Specifications (Spec_Node));
554 while Present (Act) loop
555 exit when Act = Last (Parameter_Specifications (Spec_Node));
557 Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
563 (Last (Parameter_Specifications (Specification (New_Decl))));
565 if Nkind (Type_Def) = N_Access_Procedure_Definition then
566 Call_Stmt := Make_Procedure_Call_Statement (Loc,
568 Make_Explicit_Dereference
569 (Loc, New_Occurrence_Of (Ptr, Loc)),
570 Parameter_Associations => Actuals);
572 Call_Stmt := Make_Simple_Return_Statement (Loc,
574 Make_Function_Call (Loc,
575 Name => Make_Explicit_Dereference
576 (Loc, New_Occurrence_Of (Ptr, Loc)),
577 Parameter_Associations => Actuals));
580 Body_Node := Make_Subprogram_Body (Loc,
581 Specification => Spec_Node,
582 Declarations => New_List,
583 Handled_Statement_Sequence =>
584 Make_Handled_Sequence_Of_Statements (Loc,
585 Statements => New_List (Call_Stmt)));
587 -- Place body in list of freeze actions for the type.
589 Ensure_Freeze_Node (Type_Id);
590 Append_Freeze_Actions (Type_Id, New_List (Body_Node));
591 end Build_Access_Subprogram_Wrapper_Body;
593 ---------------------------
594 -- Build_Array_Init_Proc --
595 ---------------------------
597 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
598 Comp_Type : constant Entity_Id := Component_Type (A_Type);
599 Comp_Simple_Init : constant Boolean :=
600 Needs_Simple_Initialization
603 not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
604 -- True if the component needs simple initialization, based on its type,
605 -- plus the fact that we do not do simple initialization for components
606 -- of bit-packed arrays when validity checks are enabled, because the
607 -- initialization with deliberately out-of-range values would raise
610 Body_Stmts : List_Id;
611 Has_Default_Init : Boolean;
612 Index_List : List_Id;
614 Parameters : List_Id;
617 function Init_Component return List_Id;
618 -- Create one statement to initialize one array component, designated
619 -- by a full set of indexes.
621 function Init_One_Dimension (N : Int) return List_Id;
622 -- Create loop to initialize one dimension of the array. The single
623 -- statement in the loop body initializes the inner dimensions if any,
624 -- or else the single component. Note that this procedure is called
625 -- recursively, with N being the dimension to be initialized. A call
626 -- with N greater than the number of dimensions simply generates the
627 -- component initialization, terminating the recursion.
633 function Init_Component return List_Id is
638 Make_Indexed_Component (Loc,
639 Prefix => Make_Identifier (Loc, Name_uInit),
640 Expressions => Index_List);
642 if Has_Default_Aspect (A_Type) then
643 Set_Assignment_OK (Comp);
645 Make_Assignment_Statement (Loc,
648 Convert_To (Comp_Type,
649 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
651 elsif Comp_Simple_Init then
652 Set_Assignment_OK (Comp);
654 Make_Assignment_Statement (Loc,
660 Size => Component_Size (A_Type))));
663 Clean_Task_Names (Comp_Type, Proc_Id);
665 Build_Initialization_Call
669 In_Init_Proc => True,
670 Enclos_Type => A_Type);
674 ------------------------
675 -- Init_One_Dimension --
676 ------------------------
678 function Init_One_Dimension (N : Int) return List_Id is
681 Result_List : List_Id;
683 function Possible_DIC_Call return Node_Id;
684 -- If the component type has Default_Initial_Conditions and a DIC
685 -- procedure that is not an empty body, then builds a call to the
686 -- DIC procedure and returns it.
688 -----------------------
689 -- Possible_DIC_Call --
690 -----------------------
692 function Possible_DIC_Call return Node_Id is
694 -- When the component's type has a Default_Initial_Condition, then
695 -- create a call for the DIC check.
697 if Has_DIC (Comp_Type)
698 -- In GNATprove mode, the component DICs are checked by other
699 -- means. They should not be added to the record type DIC
700 -- procedure, so that the procedure can be used to check the
701 -- record type invariants or DICs if any.
703 and then not GNATprove_Mode
705 -- DIC checks for components of controlled types are done later
706 -- (see Exp_Ch7.Make_Deep_Array_Body).
708 and then not Is_Controlled (Comp_Type)
710 and then Present (DIC_Procedure (Comp_Type))
712 and then not Has_Null_Body (DIC_Procedure (Comp_Type))
716 Make_Indexed_Component (Loc,
717 Prefix => Make_Identifier (Loc, Name_uInit),
718 Expressions => Index_List),
723 end Possible_DIC_Call;
725 -- Start of processing for Init_One_Dimension
728 -- If the component does not need initializing, then there is nothing
729 -- to do here, so we return a null body. This occurs when generating
730 -- the dummy Init_Proc needed for Initialize_Scalars processing.
731 -- An exception is if component type has a Default_Initial_Condition,
732 -- in which case we generate a call to the type's DIC procedure.
734 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
735 and then not Comp_Simple_Init
736 and then not Has_Task (Comp_Type)
737 and then not Has_Default_Aspect (A_Type)
738 and then (not Has_DIC (Comp_Type)
739 or else N > Number_Dimensions (A_Type))
741 DIC_Call := Possible_DIC_Call;
743 if Present (DIC_Call) then
744 return New_List (DIC_Call);
746 return New_List (Make_Null_Statement (Loc));
749 -- If all dimensions dealt with, we simply initialize the component
750 -- and append a call to component type's DIC procedure when needed.
752 elsif N > Number_Dimensions (A_Type) then
753 DIC_Call := Possible_DIC_Call;
755 if Present (DIC_Call) then
756 Result_List := Init_Component;
757 Append (DIC_Call, Result_List);
761 return Init_Component;
764 -- Here we generate the required loop
768 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
770 Append (New_Occurrence_Of (Index, Loc), Index_List);
773 Make_Implicit_Loop_Statement (Nod,
776 Make_Iteration_Scheme (Loc,
777 Loop_Parameter_Specification =>
778 Make_Loop_Parameter_Specification (Loc,
779 Defining_Identifier => Index,
780 Discrete_Subtype_Definition =>
781 Make_Attribute_Reference (Loc,
783 Make_Identifier (Loc, Name_uInit),
784 Attribute_Name => Name_Range,
785 Expressions => New_List (
786 Make_Integer_Literal (Loc, N))))),
787 Statements => Init_One_Dimension (N + 1)));
789 end Init_One_Dimension;
791 -- Start of processing for Build_Array_Init_Proc
794 -- The init proc is created when analyzing the freeze node for the type,
795 -- but it properly belongs with the array type declaration. However, if
796 -- the freeze node is for a subtype of a type declared in another unit
797 -- it seems preferable to use the freeze node as the source location of
798 -- the init proc. In any case this is preferable for gcov usage, and
799 -- the Sloc is not otherwise used by the compiler.
801 if In_Open_Scopes (Scope (A_Type)) then
802 Loc := Sloc (A_Type);
807 -- Nothing to generate in the following cases:
809 -- 1. Initialization is suppressed for the type
810 -- 2. An initialization already exists for the base type
812 if Initialization_Suppressed (A_Type)
813 or else Present (Base_Init_Proc (A_Type))
818 Index_List := New_List;
820 -- We need an initialization procedure if any of the following is true:
822 -- 1. The component type has an initialization procedure
823 -- 2. The component type needs simple initialization
824 -- 3. Tasks are present
825 -- 4. The type is marked as a public entity
826 -- 5. The array type has a Default_Component_Value aspect
827 -- 6. The array component type has a Default_Initialization_Condition
829 -- The reason for the public entity test is to deal properly with the
830 -- Initialize_Scalars pragma. This pragma can be set in the client and
831 -- not in the declaring package, this means the client will make a call
832 -- to the initialization procedure (because one of conditions 1-3 must
833 -- apply in this case), and we must generate a procedure (even if it is
834 -- null) to satisfy the call in this case.
836 -- Exception: do not build an array init_proc for a type whose root
837 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
838 -- is no place to put the code, and in any case we handle initialization
839 -- of such types (in the Initialize_Scalars case, that's the only time
840 -- the issue arises) in a special manner anyway which does not need an
843 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
844 or else Comp_Simple_Init
845 or else Has_Task (Comp_Type)
846 or else Has_Default_Aspect (A_Type)
847 or else Has_DIC (Comp_Type);
850 or else (not Restriction_Active (No_Initialize_Scalars)
851 and then Is_Public (A_Type)
852 and then not Is_Standard_String_Type (A_Type))
855 Make_Defining_Identifier (Loc,
856 Chars => Make_Init_Proc_Name (A_Type));
858 -- If No_Default_Initialization restriction is active, then we don't
859 -- want to build an init_proc, but we need to mark that an init_proc
860 -- would be needed if this restriction was not active (so that we can
861 -- detect attempts to call it), so set a dummy init_proc in place.
862 -- This is only done though when actual default initialization is
863 -- needed (and not done when only Is_Public is True), since otherwise
864 -- objects such as arrays of scalars could be wrongly flagged as
865 -- violating the restriction.
867 if Restriction_Active (No_Default_Initialization) then
868 if Has_Default_Init then
869 Set_Init_Proc (A_Type, Proc_Id);
875 Body_Stmts := Init_One_Dimension (1);
876 Parameters := Init_Formals (A_Type, Proc_Id);
879 Make_Subprogram_Body (Loc,
881 Make_Procedure_Specification (Loc,
882 Defining_Unit_Name => Proc_Id,
883 Parameter_Specifications => Parameters),
884 Declarations => New_List,
885 Handled_Statement_Sequence =>
886 Make_Handled_Sequence_Of_Statements (Loc,
887 Statements => Body_Stmts)));
889 Mutate_Ekind (Proc_Id, E_Procedure);
890 Set_Is_Public (Proc_Id, Is_Public (A_Type));
891 Set_Is_Internal (Proc_Id);
892 Set_Has_Completion (Proc_Id);
894 if not Debug_Generated_Code then
895 Set_Debug_Info_Off (Proc_Id);
898 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
899 -- component type itself (see also Build_Record_Init_Proc).
901 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
903 -- Associate Init_Proc with type, and determine if the procedure
904 -- is null (happens because of the Initialize_Scalars pragma case,
905 -- where we have to generate a null procedure in case it is called
906 -- by a client with Initialize_Scalars set). Such procedures have
907 -- to be generated, but do not have to be called, so we mark them
908 -- as null to suppress the call. Kill also warnings for the _Init
909 -- out parameter, which is left entirely uninitialized.
911 Set_Init_Proc (A_Type, Proc_Id);
913 if Is_Null_Statement_List (Body_Stmts) then
914 Set_Is_Null_Init_Proc (Proc_Id);
915 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
918 -- Try to build a static aggregate to statically initialize
919 -- objects of the type. This can only be done for constrained
920 -- one-dimensional arrays with static bounds.
922 Set_Static_Initialization
924 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
927 end Build_Array_Init_Proc;
929 --------------------------------
930 -- Build_Discr_Checking_Funcs --
931 --------------------------------
933 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
936 Enclosing_Func_Id : Entity_Id;
941 function Build_Case_Statement
942 (Case_Id : Entity_Id;
943 Variant : Node_Id) return Node_Id;
944 -- Build a case statement containing only two alternatives. The first
945 -- alternative corresponds exactly to the discrete choices given on the
946 -- variant with contains the components that we are generating the
947 -- checks for. If the discriminant is one of these return False. The
948 -- second alternative is an OTHERS choice that will return True
949 -- indicating the discriminant did not match.
951 function Build_Dcheck_Function
952 (Case_Id : Entity_Id;
953 Variant : Node_Id) return Entity_Id;
954 -- Build the discriminant checking function for a given variant
956 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
957 -- Builds the discriminant checking function for each variant of the
958 -- given variant part of the record type.
960 --------------------------
961 -- Build_Case_Statement --
962 --------------------------
964 function Build_Case_Statement
965 (Case_Id : Entity_Id;
966 Variant : Node_Id) return Node_Id
968 Alt_List : constant List_Id := New_List;
969 Actuals_List : List_Id;
971 Case_Alt_Node : Node_Id;
973 Choice_List : List_Id;
975 Return_Node : Node_Id;
978 Case_Node := New_Node (N_Case_Statement, Loc);
980 -- Replace the discriminant which controls the variant with the name
981 -- of the formal of the checking function.
983 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
985 Choice := First (Discrete_Choices (Variant));
987 if Nkind (Choice) = N_Others_Choice then
988 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
990 Choice_List := New_Copy_List (Discrete_Choices (Variant));
993 if not Is_Empty_List (Choice_List) then
994 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
995 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
997 -- In case this is a nested variant, we need to return the result
998 -- of the discriminant checking function for the immediately
999 -- enclosing variant.
1001 if Present (Enclosing_Func_Id) then
1002 Actuals_List := New_List;
1004 D := First_Discriminant (Rec_Id);
1005 while Present (D) loop
1006 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
1007 Next_Discriminant (D);
1011 Make_Simple_Return_Statement (Loc,
1013 Make_Function_Call (Loc,
1015 New_Occurrence_Of (Enclosing_Func_Id, Loc),
1016 Parameter_Associations =>
1021 Make_Simple_Return_Statement (Loc,
1023 New_Occurrence_Of (Standard_False, Loc));
1026 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1027 Append (Case_Alt_Node, Alt_List);
1030 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
1031 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
1032 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
1035 Make_Simple_Return_Statement (Loc,
1037 New_Occurrence_Of (Standard_True, Loc));
1039 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1040 Append (Case_Alt_Node, Alt_List);
1042 Set_Alternatives (Case_Node, Alt_List);
1044 end Build_Case_Statement;
1046 ---------------------------
1047 -- Build_Dcheck_Function --
1048 ---------------------------
1050 function Build_Dcheck_Function
1051 (Case_Id : Entity_Id;
1052 Variant : Node_Id) return Entity_Id
1054 Body_Node : Node_Id;
1055 Func_Id : Entity_Id;
1056 Parameter_List : List_Id;
1057 Spec_Node : Node_Id;
1060 Body_Node := New_Node (N_Subprogram_Body, Loc);
1061 Sequence := Sequence + 1;
1064 Make_Defining_Identifier (Loc,
1065 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
1066 Set_Is_Discriminant_Check_Function (Func_Id);
1068 Spec_Node := New_Node (N_Function_Specification, Loc);
1069 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1071 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
1073 Set_Parameter_Specifications (Spec_Node, Parameter_List);
1074 Set_Result_Definition (Spec_Node,
1075 New_Occurrence_Of (Standard_Boolean, Loc));
1076 Set_Specification (Body_Node, Spec_Node);
1077 Set_Declarations (Body_Node, New_List);
1079 Set_Handled_Statement_Sequence (Body_Node,
1080 Make_Handled_Sequence_Of_Statements (Loc,
1081 Statements => New_List (
1082 Build_Case_Statement (Case_Id, Variant))));
1084 Mutate_Ekind (Func_Id, E_Function);
1085 Set_Mechanism (Func_Id, Default_Mechanism);
1086 Set_Is_Inlined (Func_Id, True);
1087 Set_Is_Pure (Func_Id, True);
1088 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
1089 Set_Is_Internal (Func_Id, True);
1091 if not Debug_Generated_Code then
1092 Set_Debug_Info_Off (Func_Id);
1095 Analyze (Body_Node);
1097 Append_Freeze_Action (Rec_Id, Body_Node);
1098 Set_Dcheck_Function (Variant, Func_Id);
1100 end Build_Dcheck_Function;
1102 ----------------------------
1103 -- Build_Dcheck_Functions --
1104 ----------------------------
1106 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
1107 Component_List_Node : Node_Id;
1109 Discr_Name : Entity_Id;
1110 Func_Id : Entity_Id;
1112 Saved_Enclosing_Func_Id : Entity_Id;
1115 -- Build the discriminant-checking function for each variant, and
1116 -- label all components of that variant with the function's name.
1117 -- We only Generate a discriminant-checking function when the
1118 -- variant is not empty, to prevent the creation of dead code.
1120 Discr_Name := Entity (Name (Variant_Part_Node));
1121 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
1123 while Present (Variant) loop
1124 Component_List_Node := Component_List (Variant);
1126 if not Null_Present (Component_List_Node) then
1127 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
1130 First_Non_Pragma (Component_Items (Component_List_Node));
1131 while Present (Decl) loop
1132 Set_Discriminant_Checking_Func
1133 (Defining_Identifier (Decl), Func_Id);
1134 Next_Non_Pragma (Decl);
1137 if Present (Variant_Part (Component_List_Node)) then
1138 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
1139 Enclosing_Func_Id := Func_Id;
1140 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
1141 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
1145 Next_Non_Pragma (Variant);
1147 end Build_Dcheck_Functions;
1149 -- Start of processing for Build_Discr_Checking_Funcs
1152 -- Only build if not done already
1154 if not Discr_Check_Funcs_Built (N) then
1155 Type_Def := Type_Definition (N);
1157 if Nkind (Type_Def) = N_Record_Definition then
1158 if No (Component_List (Type_Def)) then -- null record.
1161 V := Variant_Part (Component_List (Type_Def));
1164 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1165 if No (Component_List (Record_Extension_Part (Type_Def))) then
1169 (Component_List (Record_Extension_Part (Type_Def)));
1173 Rec_Id := Defining_Identifier (N);
1175 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1177 Enclosing_Func_Id := Empty;
1178 Build_Dcheck_Functions (V);
1181 Set_Discr_Check_Funcs_Built (N);
1183 end Build_Discr_Checking_Funcs;
1185 --------------------------------
1186 -- Build_Discriminant_Formals --
1187 --------------------------------
1189 function Build_Discriminant_Formals
1190 (Rec_Id : Entity_Id;
1191 Use_Dl : Boolean) return List_Id
1193 Loc : Source_Ptr := Sloc (Rec_Id);
1194 Parameter_List : constant List_Id := New_List;
1197 Formal_Type : Entity_Id;
1198 Param_Spec_Node : Node_Id;
1201 if Has_Discriminants (Rec_Id) then
1202 D := First_Discriminant (Rec_Id);
1203 while Present (D) loop
1207 Formal := Discriminal (D);
1208 Formal_Type := Etype (Formal);
1210 Formal := Make_Defining_Identifier (Loc, Chars (D));
1211 Formal_Type := Etype (D);
1215 Make_Parameter_Specification (Loc,
1216 Defining_Identifier => Formal,
1218 New_Occurrence_Of (Formal_Type, Loc));
1219 Append (Param_Spec_Node, Parameter_List);
1220 Next_Discriminant (D);
1224 return Parameter_List;
1225 end Build_Discriminant_Formals;
1227 --------------------------------------
1228 -- Build_Equivalent_Array_Aggregate --
1229 --------------------------------------
1231 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1232 Loc : constant Source_Ptr := Sloc (T);
1233 Comp_Type : constant Entity_Id := Component_Type (T);
1234 Index_Type : constant Entity_Id := Etype (First_Index (T));
1235 Proc : constant Entity_Id := Base_Init_Proc (T);
1241 if not Is_Constrained (T)
1242 or else Number_Dimensions (T) > 1
1245 Initialization_Warning (T);
1249 Lo := Type_Low_Bound (Index_Type);
1250 Hi := Type_High_Bound (Index_Type);
1252 if not Compile_Time_Known_Value (Lo)
1253 or else not Compile_Time_Known_Value (Hi)
1255 Initialization_Warning (T);
1259 if Is_Record_Type (Comp_Type)
1260 and then Present (Base_Init_Proc (Comp_Type))
1262 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1265 Initialization_Warning (T);
1270 Initialization_Warning (T);
1274 Aggr := Make_Aggregate (Loc, No_List, New_List);
1275 Set_Etype (Aggr, T);
1276 Set_Aggregate_Bounds (Aggr,
1278 Low_Bound => New_Copy (Lo),
1279 High_Bound => New_Copy (Hi)));
1280 Set_Parent (Aggr, Parent (Proc));
1282 Append_To (Component_Associations (Aggr),
1283 Make_Component_Association (Loc,
1287 Low_Bound => New_Copy (Lo),
1288 High_Bound => New_Copy (Hi))),
1289 Expression => Expr));
1291 if Static_Array_Aggregate (Aggr) then
1294 Initialization_Warning (T);
1297 end Build_Equivalent_Array_Aggregate;
1299 ---------------------------------------
1300 -- Build_Equivalent_Record_Aggregate --
1301 ---------------------------------------
1303 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1306 Comp_Type : Entity_Id;
1308 -- Start of processing for Build_Equivalent_Record_Aggregate
1311 if not Is_Record_Type (T)
1312 or else Has_Discriminants (T)
1313 or else Is_Limited_Type (T)
1314 or else Has_Non_Standard_Rep (T)
1316 Initialization_Warning (T);
1320 Comp := First_Component (T);
1322 -- A null record needs no warning
1328 while Present (Comp) loop
1330 -- Array components are acceptable if initialized by a positional
1331 -- aggregate with static components.
1333 if Is_Array_Type (Etype (Comp)) then
1334 Comp_Type := Component_Type (Etype (Comp));
1336 if Nkind (Parent (Comp)) /= N_Component_Declaration
1337 or else No (Expression (Parent (Comp)))
1338 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1340 Initialization_Warning (T);
1343 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1345 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1347 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1349 Initialization_Warning (T);
1353 not Static_Array_Aggregate (Expression (Parent (Comp)))
1355 Initialization_Warning (T);
1358 -- We need to return empty if the type has predicates because
1359 -- this would otherwise duplicate calls to the predicate
1360 -- function. If the type hasn't been frozen before being
1361 -- referenced in the current record, the extraneous call to
1362 -- the predicate function would be inserted somewhere before
1363 -- the predicate function is elaborated, which would result in
1366 elsif Has_Predicates (Etype (Comp)) then
1370 elsif Is_Scalar_Type (Etype (Comp)) then
1371 Comp_Type := Etype (Comp);
1373 if Nkind (Parent (Comp)) /= N_Component_Declaration
1374 or else No (Expression (Parent (Comp)))
1375 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1376 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1378 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1380 Initialization_Warning (T);
1384 -- For now, other types are excluded
1387 Initialization_Warning (T);
1391 Next_Component (Comp);
1394 -- All components have static initialization. Build positional aggregate
1395 -- from the given expressions or defaults.
1397 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1398 Set_Parent (Agg, Parent (T));
1400 Comp := First_Component (T);
1401 while Present (Comp) loop
1403 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1404 Next_Component (Comp);
1407 Analyze_And_Resolve (Agg, T);
1409 end Build_Equivalent_Record_Aggregate;
1411 ----------------------------
1412 -- Init_Proc_Level_Formal --
1413 ----------------------------
1415 function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is
1418 -- Move through the formals of the initialization procedure Proc to find
1419 -- the extra accessibility level parameter associated with the object
1420 -- being initialized.
1422 Form := First_Formal (Proc);
1423 while Present (Form) loop
1424 if Chars (Form) = Name_uInit_Level then
1431 -- No formal was found, return Empty
1434 end Init_Proc_Level_Formal;
1436 -------------------------------
1437 -- Build_Initialization_Call --
1438 -------------------------------
1440 -- References to a discriminant inside the record type declaration can
1441 -- appear either in the subtype_indication to constrain a record or an
1442 -- array, or as part of a larger expression given for the initial value
1443 -- of a component. In both of these cases N appears in the record
1444 -- initialization procedure and needs to be replaced by the formal
1445 -- parameter of the initialization procedure which corresponds to that
1448 -- In the example below, references to discriminants D1 and D2 in proc_1
1449 -- are replaced by references to formals with the same name
1452 -- A similar replacement is done for calls to any record initialization
1453 -- procedure for any components that are themselves of a record type.
1455 -- type R (D1, D2 : Integer) is record
1456 -- X : Integer := F * D1;
1457 -- Y : Integer := F * D2;
1460 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1464 -- Out_2.X := F * D1;
1465 -- Out_2.Y := F * D2;
1468 function Build_Initialization_Call
1472 In_Init_Proc : Boolean := False;
1473 Enclos_Type : Entity_Id := Empty;
1474 Discr_Map : Elist_Id := New_Elmt_List;
1475 With_Default_Init : Boolean := False;
1476 Constructor_Ref : Node_Id := Empty) return List_Id
1478 Res : constant List_Id := New_List;
1480 Full_Type : Entity_Id;
1482 procedure Check_Predicated_Discriminant
1485 -- Discriminants whose subtypes have predicates are checked in two
1487 -- a) When an object is default-initialized and assertions are enabled
1488 -- we check that the value of the discriminant obeys the predicate.
1490 -- b) In all cases, if the discriminant controls a variant and the
1491 -- variant has no others_choice, Constraint_Error must be raised if
1492 -- the predicate is violated, because there is no variant covered
1493 -- by the illegal discriminant value.
1495 -----------------------------------
1496 -- Check_Predicated_Discriminant --
1497 -----------------------------------
1499 procedure Check_Predicated_Discriminant
1503 Typ : constant Entity_Id := Etype (Discr);
1505 procedure Check_Missing_Others (V : Node_Id);
1506 -- Check that a given variant and its nested variants have an others
1507 -- choice, and generate a constraint error raise when it does not.
1509 --------------------------
1510 -- Check_Missing_Others --
1511 --------------------------
1513 procedure Check_Missing_Others (V : Node_Id) is
1519 Last_Var := Last_Non_Pragma (Variants (V));
1520 Choice := First (Discrete_Choices (Last_Var));
1522 -- An others_choice is added during expansion for gcc use, but
1523 -- does not cover the illegality.
1525 if Entity (Name (V)) = Discr then
1527 and then (Nkind (Choice) /= N_Others_Choice
1528 or else not Comes_From_Source (Choice))
1530 Check_Expression_Against_Static_Predicate (Val, Typ);
1532 if not Is_Static_Expression (Val) then
1534 Make_Raise_Constraint_Error (Loc,
1537 Right_Opnd => Make_Predicate_Call (Typ, Val)),
1538 Reason => CE_Invalid_Data));
1543 -- Check whether some nested variant is ruled by the predicated
1546 Alt := First (Variants (V));
1547 while Present (Alt) loop
1548 if Nkind (Alt) = N_Variant
1549 and then Present (Variant_Part (Component_List (Alt)))
1551 Check_Missing_Others
1552 (Variant_Part (Component_List (Alt)));
1557 end Check_Missing_Others;
1563 -- Start of processing for Check_Predicated_Discriminant
1566 if Ekind (Base_Type (Full_Type)) = E_Record_Type then
1567 Def := Type_Definition (Parent (Base_Type (Full_Type)));
1572 if Policy_In_Effect (Name_Assert) = Name_Check
1573 and then not Predicates_Ignored (Etype (Discr))
1575 Prepend_To (Res, Make_Predicate_Check (Typ, Val));
1578 -- If discriminant controls a variant, verify that predicate is
1579 -- obeyed or else an Others_Choice is present.
1581 if Nkind (Def) = N_Record_Definition
1582 and then Present (Variant_Part (Component_List (Def)))
1583 and then Policy_In_Effect (Name_Assert) = Name_Ignore
1585 Check_Missing_Others (Variant_Part (Component_List (Def)));
1587 end Check_Predicated_Discriminant;
1596 First_Arg : Node_Id;
1597 Full_Init_Type : Entity_Id;
1598 Init_Call : Node_Id;
1599 Init_Type : Entity_Id;
1602 -- Start of processing for Build_Initialization_Call
1605 pragma Assert (Constructor_Ref = Empty
1606 or else Is_CPP_Constructor_Call (Constructor_Ref));
1608 if No (Constructor_Ref) then
1609 Proc := Base_Init_Proc (Typ);
1611 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1614 pragma Assert (Present (Proc));
1615 Init_Type := Etype (First_Formal (Proc));
1616 Full_Init_Type := Underlying_Type (Init_Type);
1618 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1619 -- is active (in which case we make the call anyway, since in the
1620 -- actual compiled client it may be non null).
1622 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1625 -- Nothing to do for an array of controlled components that have only
1626 -- the inherited Initialize primitive. This is a useful optimization
1629 elsif Is_Trivial_Subprogram (Proc)
1630 and then Is_Array_Type (Full_Init_Type)
1632 return New_List (Make_Null_Statement (Loc));
1635 -- Use the [underlying] full view when dealing with a private type. This
1636 -- may require several steps depending on derivations.
1640 if Is_Private_Type (Full_Type) then
1641 if Present (Full_View (Full_Type)) then
1642 Full_Type := Full_View (Full_Type);
1644 elsif Present (Underlying_Full_View (Full_Type)) then
1645 Full_Type := Underlying_Full_View (Full_Type);
1647 -- When a private type acts as a generic actual and lacks a full
1648 -- view, use the base type.
1650 elsif Is_Generic_Actual_Type (Full_Type) then
1651 Full_Type := Base_Type (Full_Type);
1653 elsif Ekind (Full_Type) = E_Private_Subtype
1654 and then (not Has_Discriminants (Full_Type)
1655 or else No (Discriminant_Constraint (Full_Type)))
1657 Full_Type := Etype (Full_Type);
1659 -- The loop has recovered the [underlying] full view, stop the
1666 -- The type is not private, nothing to do
1673 -- If Typ is derived, the procedure is the initialization procedure for
1674 -- the root type. Wrap the argument in an conversion to make it type
1675 -- honest. Actually it isn't quite type honest, because there can be
1676 -- conflicts of views in the private type case. That is why we set
1677 -- Conversion_OK in the conversion node.
1679 if (Is_Record_Type (Typ)
1680 or else Is_Array_Type (Typ)
1681 or else Is_Private_Type (Typ))
1682 and then Init_Type /= Base_Type (Typ)
1684 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1685 Set_Etype (First_Arg, Init_Type);
1688 First_Arg := Id_Ref;
1691 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1693 -- In the tasks case, add _Master as the value of the _Master parameter
1694 -- and _Chain as the value of the _Chain parameter. At the outer level,
1695 -- these will be variables holding the corresponding values obtained
1696 -- from GNARL. At inner levels, they will be the parameters passed down
1697 -- through the outer routines.
1699 if Has_Task (Full_Type) then
1700 if Restriction_Active (No_Task_Hierarchy) then
1701 Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level));
1703 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1706 -- Add _Chain (not done for sequential elaboration policy, see
1707 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1709 if Partition_Elaboration_Policy /= 'S' then
1710 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1713 -- Ada 2005 (AI-287): In case of default initialized components
1714 -- with tasks, we generate a null string actual parameter.
1715 -- This is just a workaround that must be improved later???
1717 if With_Default_Init then
1719 Make_String_Literal (Loc,
1724 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1725 Decl := Last (Decls);
1728 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1729 Append_List (Decls, Res);
1737 -- Handle the optionally generated formal *_skip_null_excluding_checks
1739 -- Look at the associated node for the object we are referencing and
1740 -- verify that we are expanding a call to an Init_Proc for an internally
1741 -- generated object declaration before passing True and skipping the
1744 if Needs_Conditional_Null_Excluding_Check (Full_Init_Type)
1745 and then Nkind (Id_Ref) in N_Has_Entity
1746 and then (Comes_From_Source (Id_Ref)
1747 or else (Present (Associated_Node (Id_Ref))
1748 and then Comes_From_Source
1749 (Associated_Node (Id_Ref))))
1751 Append_To (Args, New_Occurrence_Of (Standard_True, Loc));
1754 -- Add discriminant values if discriminants are present
1756 if Has_Discriminants (Full_Init_Type) then
1757 Discr := First_Discriminant (Full_Init_Type);
1758 while Present (Discr) loop
1760 -- If this is a discriminated concurrent type, the init_proc
1761 -- for the corresponding record is being called. Use that type
1762 -- directly to find the discriminant value, to handle properly
1763 -- intervening renamed discriminants.
1766 T : Entity_Id := Full_Type;
1769 if Is_Protected_Type (T) then
1770 T := Corresponding_Record_Type (T);
1774 Get_Discriminant_Value (
1777 Discriminant_Constraint (Full_Type));
1780 -- If the target has access discriminants, and is constrained by
1781 -- an access to the enclosing construct, i.e. a current instance,
1782 -- replace the reference to the type by a reference to the object.
1784 if Nkind (Arg) = N_Attribute_Reference
1785 and then Is_Access_Type (Etype (Arg))
1786 and then Is_Entity_Name (Prefix (Arg))
1787 and then Is_Type (Entity (Prefix (Arg)))
1790 Make_Attribute_Reference (Loc,
1791 Prefix => New_Copy (Prefix (Id_Ref)),
1792 Attribute_Name => Name_Unrestricted_Access);
1794 elsif In_Init_Proc then
1796 -- Replace any possible references to the discriminant in the
1797 -- call to the record initialization procedure with references
1798 -- to the appropriate formal parameter.
1800 if Nkind (Arg) = N_Identifier
1801 and then Ekind (Entity (Arg)) = E_Discriminant
1803 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1805 -- Otherwise make a copy of the default expression. Note that
1806 -- we use the current Sloc for this, because we do not want the
1807 -- call to appear to be at the declaration point. Within the
1808 -- expression, replace discriminants with their discriminals.
1812 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1816 if Is_Constrained (Full_Type) then
1817 Arg := Duplicate_Subexpr_No_Checks (Arg);
1819 -- The constraints come from the discriminant default exps,
1820 -- they must be reevaluated, so we use New_Copy_Tree but we
1821 -- ensure the proper Sloc (for any embedded calls).
1822 -- In addition, if a predicate check is needed on the value
1823 -- of the discriminant, insert it ahead of the call.
1825 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1828 if Has_Predicates (Etype (Discr)) then
1829 Check_Predicated_Discriminant (Arg, Discr);
1833 -- Ada 2005 (AI-287): In case of default initialized components,
1834 -- if the component is constrained with a discriminant of the
1835 -- enclosing type, we need to generate the corresponding selected
1836 -- component node to access the discriminant value. In other cases
1837 -- this is not required, either because we are inside the init
1838 -- proc and we use the corresponding formal, or else because the
1839 -- component is constrained by an expression.
1841 if With_Default_Init
1842 and then Nkind (Id_Ref) = N_Selected_Component
1843 and then Nkind (Arg) = N_Identifier
1844 and then Ekind (Entity (Arg)) = E_Discriminant
1847 Make_Selected_Component (Loc,
1848 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1849 Selector_Name => Arg));
1851 Append_To (Args, Arg);
1854 Next_Discriminant (Discr);
1858 -- If this is a call to initialize the parent component of a derived
1859 -- tagged type, indicate that the tag should not be set in the parent.
1861 if Is_Tagged_Type (Full_Init_Type)
1862 and then not Is_CPP_Class (Full_Init_Type)
1863 and then Nkind (Id_Ref) = N_Selected_Component
1864 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1866 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1868 elsif Present (Constructor_Ref) then
1869 Append_List_To (Args,
1870 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1873 -- Pass the extra accessibility level parameter associated with the
1874 -- level of the object being initialized when required.
1876 if Is_Entity_Name (Id_Ref)
1877 and then Present (Init_Proc_Level_Formal (Proc))
1880 Make_Parameter_Association (Loc,
1882 Make_Identifier (Loc, Name_uInit_Level),
1883 Explicit_Actual_Parameter =>
1884 Accessibility_Level (Id_Ref, Dynamic_Level)));
1888 Make_Procedure_Call_Statement (Loc,
1889 Name => New_Occurrence_Of (Proc, Loc),
1890 Parameter_Associations => Args));
1892 if Needs_Finalization (Typ)
1893 and then Nkind (Id_Ref) = N_Selected_Component
1895 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1898 (Obj_Ref => New_Copy_Tree (First_Arg),
1901 -- Guard against a missing [Deep_]Initialize when the type was not
1904 if Present (Init_Call) then
1905 Append_To (Res, Init_Call);
1913 when RE_Not_Available =>
1915 end Build_Initialization_Call;
1917 ----------------------------
1918 -- Build_Record_Init_Proc --
1919 ----------------------------
1921 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1922 Decls : constant List_Id := New_List;
1923 Discr_Map : constant Elist_Id := New_Elmt_List;
1924 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1926 Proc_Id : Entity_Id;
1927 Rec_Type : Entity_Id;
1928 Set_Tag : Entity_Id := Empty;
1929 Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
1931 function Build_Assignment
1933 Default : Node_Id) return List_Id;
1934 -- Build an assignment statement that assigns the default expression to
1935 -- its corresponding record component if defined. The left-hand side of
1936 -- the assignment is marked Assignment_OK so that initialization of
1937 -- limited private records works correctly. This routine may also build
1938 -- an adjustment call if the component is controlled.
1940 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1941 -- If the record has discriminants, add assignment statements to
1942 -- Statement_List to initialize the discriminant values from the
1943 -- arguments of the initialization procedure.
1945 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1946 -- Build a list representing a sequence of statements which initialize
1947 -- components of the given component list. This may involve building
1948 -- case statements for the variant parts. Append any locally declared
1949 -- objects on list Decls.
1951 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1952 -- Given an untagged type-derivation that declares discriminants, e.g.
1954 -- type R (R1, R2 : Integer) is record ... end record;
1955 -- type D (D1 : Integer) is new R (1, D1);
1957 -- we make the _init_proc of D be
1959 -- procedure _init_proc (X : D; D1 : Integer) is
1961 -- _init_proc (R (X), 1, D1);
1964 -- This function builds the call statement in this _init_proc.
1966 procedure Build_CPP_Init_Procedure;
1967 -- Build the tree corresponding to the procedure specification and body
1968 -- of the IC procedure that initializes the C++ part of the dispatch
1969 -- table of an Ada tagged type that is a derivation of a CPP type.
1970 -- Install it as the CPP_Init TSS.
1972 procedure Build_Init_Procedure;
1973 -- Build the tree corresponding to the procedure specification and body
1974 -- of the initialization procedure and install it as the _init TSS.
1976 procedure Build_Offset_To_Top_Functions;
1977 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1978 -- and body of Offset_To_Top, a function used in conjuction with types
1979 -- having secondary dispatch tables.
1981 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1982 -- Add range checks to components of discriminated records. S is a
1983 -- subtype indication of a record component. Check_List is a list
1984 -- to which the check actions are appended.
1986 function Component_Needs_Simple_Initialization
1987 (T : Entity_Id) return Boolean;
1988 -- Determine if a component needs simple initialization, given its type
1989 -- T. This routine is the same as Needs_Simple_Initialization except for
1990 -- components of type Tag and Interface_Tag. These two access types do
1991 -- not require initialization since they are explicitly initialized by
1994 function Parent_Subtype_Renaming_Discrims return Boolean;
1995 -- Returns True for base types N that rename discriminants, else False
1997 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1998 -- Determine whether a record initialization procedure needs to be
1999 -- generated for the given record type.
2001 ----------------------
2002 -- Build_Assignment --
2003 ----------------------
2005 function Build_Assignment
2007 Default : Node_Id) return List_Id
2009 Default_Loc : constant Source_Ptr := Sloc (Default);
2010 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
2013 Exp : Node_Id := Default;
2014 Kind : Node_Kind := Nkind (Default);
2020 Make_Selected_Component (Default_Loc,
2021 Prefix => Make_Identifier (Loc, Name_uInit),
2022 Selector_Name => New_Occurrence_Of (Id, Default_Loc));
2023 Set_Assignment_OK (Lhs);
2025 -- Take a copy of Exp to ensure that later copies of this component
2026 -- declaration in derived types see the original tree, not a node
2027 -- rewritten during expansion of the init_proc. If the copy contains
2028 -- itypes, the scope of the new itypes is the init_proc being built.
2031 Map : Elist_Id := No_Elist;
2033 if Has_Late_Init_Comp then
2034 -- Map the type to the _Init parameter in order to
2035 -- handle "current instance" references.
2037 Map := New_Elmt_List
2039 Elmt2 => Defining_Identifier (First
2040 (Parameter_Specifications
2041 (Parent (Proc_Id)))));
2044 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map);
2048 Make_Assignment_Statement (Loc,
2050 Expression => Exp));
2052 Set_No_Ctrl_Actions (First (Res));
2054 -- Adjust the tag if tagged (because of possible view conversions).
2055 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2056 -- tags are represented implicitly in objects, and when the record is
2057 -- initialized with a raise expression.
2059 if Is_Tagged_Type (Typ)
2060 and then Tagged_Type_Expansion
2061 and then Nkind (Exp) /= N_Raise_Expression
2062 and then (Nkind (Exp) /= N_Qualified_Expression
2063 or else Nkind (Expression (Exp)) /= N_Raise_Expression)
2066 Make_Assignment_Statement (Default_Loc,
2068 Make_Selected_Component (Default_Loc,
2070 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
2073 (First_Tag_Component (Typ), Default_Loc)),
2076 Unchecked_Convert_To (RTE (RE_Tag),
2078 (Node (First_Elmt (Access_Disp_Table (Underlying_Type
2083 -- Adjust the component if controlled except if it is an aggregate
2084 -- that will be expanded inline.
2086 if Kind = N_Qualified_Expression then
2087 Kind := Nkind (Expression (Default));
2090 if Needs_Finalization (Typ)
2091 and then Kind not in N_Aggregate | N_Extension_Aggregate
2092 and then not Is_Build_In_Place_Function_Call (Exp)
2096 (Obj_Ref => New_Copy_Tree (Lhs),
2099 -- Guard against a missing [Deep_]Adjust when the component type
2100 -- was not properly frozen.
2102 if Present (Adj_Call) then
2103 Append_To (Res, Adj_Call);
2107 -- If a component type has a predicate, add check to the component
2108 -- assignment. Discriminants are handled at the point of the call,
2109 -- which provides for a better error message.
2111 if Comes_From_Source (Exp)
2112 and then Predicate_Enabled (Typ)
2114 Append (Make_Predicate_Check (Typ, Exp), Res);
2120 when RE_Not_Available =>
2122 end Build_Assignment;
2124 ------------------------------------
2125 -- Build_Discriminant_Assignments --
2126 ------------------------------------
2128 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
2129 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
2134 if Has_Discriminants (Rec_Type)
2135 and then not Is_Unchecked_Union (Rec_Type)
2137 D := First_Discriminant (Rec_Type);
2138 while Present (D) loop
2140 -- Don't generate the assignment for discriminants in derived
2141 -- tagged types if the discriminant is a renaming of some
2142 -- ancestor discriminant. This initialization will be done
2143 -- when initializing the _parent field of the derived record.
2146 and then Present (Corresponding_Discriminant (D))
2152 Append_List_To (Statement_List,
2153 Build_Assignment (D,
2154 New_Occurrence_Of (Discriminal (D), D_Loc)));
2157 Next_Discriminant (D);
2160 end Build_Discriminant_Assignments;
2162 --------------------------
2163 -- Build_Init_Call_Thru --
2164 --------------------------
2166 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
2167 Parent_Proc : constant Entity_Id :=
2168 Base_Init_Proc (Etype (Rec_Type));
2170 Parent_Type : constant Entity_Id :=
2171 Etype (First_Formal (Parent_Proc));
2173 Uparent_Type : constant Entity_Id :=
2174 Underlying_Type (Parent_Type);
2176 First_Discr_Param : Node_Id;
2180 First_Arg : Node_Id;
2181 Parent_Discr : Entity_Id;
2185 -- First argument (_Init) is the object to be initialized.
2186 -- ??? not sure where to get a reasonable Loc for First_Arg
2189 OK_Convert_To (Parent_Type,
2191 (Defining_Identifier (First (Parameters)), Loc));
2193 Set_Etype (First_Arg, Parent_Type);
2195 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
2197 -- In the tasks case,
2198 -- add _Master as the value of the _Master parameter
2199 -- add _Chain as the value of the _Chain parameter.
2200 -- add _Task_Name as the value of the _Task_Name parameter.
2201 -- At the outer level, these will be variables holding the
2202 -- corresponding values obtained from GNARL or the expander.
2204 -- At inner levels, they will be the parameters passed down through
2205 -- the outer routines.
2207 First_Discr_Param := Next (First (Parameters));
2209 if Has_Task (Rec_Type) then
2210 if Restriction_Active (No_Task_Hierarchy) then
2212 (Args, Make_Integer_Literal (Loc, Library_Task_Level));
2214 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2217 -- Add _Chain (not done for sequential elaboration policy, see
2218 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2220 if Partition_Elaboration_Policy /= 'S' then
2221 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2224 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2225 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2228 -- Append discriminant values
2230 if Has_Discriminants (Uparent_Type) then
2231 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2233 Parent_Discr := First_Discriminant (Uparent_Type);
2234 while Present (Parent_Discr) loop
2236 -- Get the initial value for this discriminant
2237 -- ??? needs to be cleaned up to use parent_Discr_Constr
2241 Discr : Entity_Id :=
2242 First_Stored_Discriminant (Uparent_Type);
2244 Discr_Value : Elmt_Id :=
2245 First_Elmt (Stored_Constraint (Rec_Type));
2248 while Original_Record_Component (Parent_Discr) /= Discr loop
2249 Next_Stored_Discriminant (Discr);
2250 Next_Elmt (Discr_Value);
2253 Arg := Node (Discr_Value);
2256 -- Append it to the list
2258 if Nkind (Arg) = N_Identifier
2259 and then Ekind (Entity (Arg)) = E_Discriminant
2262 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2264 -- Case of access discriminants. We replace the reference
2265 -- to the type by a reference to the actual object.
2267 -- Is above comment right??? Use of New_Copy below seems mighty
2271 Append_To (Args, New_Copy (Arg));
2274 Next_Discriminant (Parent_Discr);
2280 Make_Procedure_Call_Statement (Loc,
2282 New_Occurrence_Of (Parent_Proc, Loc),
2283 Parameter_Associations => Args));
2286 end Build_Init_Call_Thru;
2288 -----------------------------------
2289 -- Build_Offset_To_Top_Functions --
2290 -----------------------------------
2292 procedure Build_Offset_To_Top_Functions is
2294 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2296 -- function Fxx (O : Address) return Storage_Offset is
2297 -- type Acc is access all <Typ>;
2299 -- return Acc!(O).Iface_Comp'Position;
2302 ----------------------------------
2303 -- Build_Offset_To_Top_Function --
2304 ----------------------------------
2306 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2307 Body_Node : Node_Id;
2308 Func_Id : Entity_Id;
2309 Spec_Node : Node_Id;
2310 Acc_Type : Entity_Id;
2313 Func_Id := Make_Temporary (Loc, 'F');
2314 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2317 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2319 Spec_Node := New_Node (N_Function_Specification, Loc);
2320 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2321 Set_Parameter_Specifications (Spec_Node, New_List (
2322 Make_Parameter_Specification (Loc,
2323 Defining_Identifier =>
2324 Make_Defining_Identifier (Loc, Name_uO),
2327 New_Occurrence_Of (RTE (RE_Address), Loc))));
2328 Set_Result_Definition (Spec_Node,
2329 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2332 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2334 -- return -O.Iface_Comp'Position;
2337 Body_Node := New_Node (N_Subprogram_Body, Loc);
2338 Set_Specification (Body_Node, Spec_Node);
2340 Acc_Type := Make_Temporary (Loc, 'T');
2341 Set_Declarations (Body_Node, New_List (
2342 Make_Full_Type_Declaration (Loc,
2343 Defining_Identifier => Acc_Type,
2345 Make_Access_To_Object_Definition (Loc,
2346 All_Present => True,
2347 Null_Exclusion_Present => False,
2348 Constant_Present => False,
2349 Subtype_Indication =>
2350 New_Occurrence_Of (Rec_Type, Loc)))));
2352 Set_Handled_Statement_Sequence (Body_Node,
2353 Make_Handled_Sequence_Of_Statements (Loc,
2354 Statements => New_List (
2355 Make_Simple_Return_Statement (Loc,
2358 Make_Attribute_Reference (Loc,
2360 Make_Selected_Component (Loc,
2362 Make_Explicit_Dereference (Loc,
2363 Unchecked_Convert_To (Acc_Type,
2364 Make_Identifier (Loc, Name_uO))),
2366 New_Occurrence_Of (Iface_Comp, Loc)),
2367 Attribute_Name => Name_Position))))));
2369 Mutate_Ekind (Func_Id, E_Function);
2370 Set_Mechanism (Func_Id, Default_Mechanism);
2371 Set_Is_Internal (Func_Id, True);
2373 if not Debug_Generated_Code then
2374 Set_Debug_Info_Off (Func_Id);
2377 Analyze (Body_Node);
2379 Append_Freeze_Action (Rec_Type, Body_Node);
2380 end Build_Offset_To_Top_Function;
2384 Iface_Comp : Node_Id;
2385 Iface_Comp_Elmt : Elmt_Id;
2386 Ifaces_Comp_List : Elist_Id;
2388 -- Start of processing for Build_Offset_To_Top_Functions
2391 -- Offset_To_Top_Functions are built only for derivations of types
2392 -- with discriminants that cover interface types.
2393 -- Nothing is needed either in case of virtual targets, since
2394 -- interfaces are handled directly by the target.
2396 if not Is_Tagged_Type (Rec_Type)
2397 or else Etype (Rec_Type) = Rec_Type
2398 or else not Has_Discriminants (Etype (Rec_Type))
2399 or else not Tagged_Type_Expansion
2404 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2406 -- For each interface type with secondary dispatch table we generate
2407 -- the Offset_To_Top_Functions (required to displace the pointer in
2408 -- interface conversions)
2410 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2411 while Present (Iface_Comp_Elmt) loop
2412 Iface_Comp := Node (Iface_Comp_Elmt);
2413 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2415 -- If the interface is a parent of Rec_Type it shares the primary
2416 -- dispatch table and hence there is no need to build the function
2418 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2419 Use_Full_View => True)
2421 Build_Offset_To_Top_Function (Iface_Comp);
2424 Next_Elmt (Iface_Comp_Elmt);
2426 end Build_Offset_To_Top_Functions;
2428 ------------------------------
2429 -- Build_CPP_Init_Procedure --
2430 ------------------------------
2432 procedure Build_CPP_Init_Procedure is
2433 Body_Node : Node_Id;
2434 Body_Stmts : List_Id;
2435 Flag_Id : Entity_Id;
2436 Handled_Stmt_Node : Node_Id;
2437 Init_Tags_List : List_Id;
2438 Proc_Id : Entity_Id;
2439 Proc_Spec_Node : Node_Id;
2442 -- Check cases requiring no IC routine
2444 if not Is_CPP_Class (Root_Type (Rec_Type))
2445 or else Is_CPP_Class (Rec_Type)
2446 or else CPP_Num_Prims (Rec_Type) = 0
2447 or else not Tagged_Type_Expansion
2448 or else No_Run_Time_Mode
2455 -- Flag : Boolean := False;
2457 -- procedure Typ_IC is
2460 -- Copy C++ dispatch table slots from parent
2461 -- Update C++ slots of overridden primitives
2465 Flag_Id := Make_Temporary (Loc, 'F');
2467 Append_Freeze_Action (Rec_Type,
2468 Make_Object_Declaration (Loc,
2469 Defining_Identifier => Flag_Id,
2470 Object_Definition =>
2471 New_Occurrence_Of (Standard_Boolean, Loc),
2473 New_Occurrence_Of (Standard_True, Loc)));
2475 Body_Stmts := New_List;
2476 Body_Node := New_Node (N_Subprogram_Body, Loc);
2478 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2481 Make_Defining_Identifier (Loc,
2482 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2484 Mutate_Ekind (Proc_Id, E_Procedure);
2485 Set_Is_Internal (Proc_Id);
2487 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2489 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2490 Set_Specification (Body_Node, Proc_Spec_Node);
2491 Set_Declarations (Body_Node, New_List);
2493 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2495 Append_To (Init_Tags_List,
2496 Make_Assignment_Statement (Loc,
2498 New_Occurrence_Of (Flag_Id, Loc),
2500 New_Occurrence_Of (Standard_False, Loc)));
2502 Append_To (Body_Stmts,
2503 Make_If_Statement (Loc,
2504 Condition => New_Occurrence_Of (Flag_Id, Loc),
2505 Then_Statements => Init_Tags_List));
2507 Handled_Stmt_Node :=
2508 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2509 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2510 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2511 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2513 if not Debug_Generated_Code then
2514 Set_Debug_Info_Off (Proc_Id);
2517 -- Associate CPP_Init_Proc with type
2519 Set_Init_Proc (Rec_Type, Proc_Id);
2520 end Build_CPP_Init_Procedure;
2522 --------------------------
2523 -- Build_Init_Procedure --
2524 --------------------------
2526 procedure Build_Init_Procedure is
2527 Body_Stmts : List_Id;
2528 Body_Node : Node_Id;
2529 Handled_Stmt_Node : Node_Id;
2530 Init_Tags_List : List_Id;
2531 Parameters : List_Id;
2532 Proc_Spec_Node : Node_Id;
2533 Record_Extension_Node : Node_Id;
2536 Body_Stmts := New_List;
2537 Body_Node := New_Node (N_Subprogram_Body, Loc);
2538 Mutate_Ekind (Proc_Id, E_Procedure);
2540 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2541 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2543 Parameters := Init_Formals (Rec_Type, Proc_Id);
2544 Append_List_To (Parameters,
2545 Build_Discriminant_Formals (Rec_Type, True));
2547 -- For tagged types, we add a flag to indicate whether the routine
2548 -- is called to initialize a parent component in the init_proc of
2549 -- a type extension. If the flag is false, we do not set the tag
2550 -- because it has been set already in the extension.
2552 if Is_Tagged_Type (Rec_Type) then
2553 Set_Tag := Make_Temporary (Loc, 'P');
2555 Append_To (Parameters,
2556 Make_Parameter_Specification (Loc,
2557 Defining_Identifier => Set_Tag,
2559 New_Occurrence_Of (Standard_Boolean, Loc),
2561 New_Occurrence_Of (Standard_True, Loc)));
2564 -- Create an extra accessibility parameter to capture the level of
2565 -- the object being initialized when its type is a limited record.
2567 if Is_Limited_Record (Rec_Type) then
2568 Append_To (Parameters,
2569 Make_Parameter_Specification (Loc,
2570 Defining_Identifier => Make_Defining_Identifier
2571 (Loc, Name_uInit_Level),
2573 New_Occurrence_Of (Standard_Natural, Loc),
2575 Make_Integer_Literal
2576 (Loc, Scope_Depth (Standard_Standard))));
2579 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2580 Set_Specification (Body_Node, Proc_Spec_Node);
2581 Set_Declarations (Body_Node, Decls);
2583 -- N is a Derived_Type_Definition that renames the parameters of the
2584 -- ancestor type. We initialize it by expanding our discriminants and
2585 -- call the ancestor _init_proc with a type-converted object.
2587 if Parent_Subtype_Renaming_Discrims then
2588 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2590 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2591 Build_Discriminant_Assignments (Body_Stmts);
2593 if not Null_Present (Type_Definition (N)) then
2594 Append_List_To (Body_Stmts,
2595 Build_Init_Statements (Component_List (Type_Definition (N))));
2598 -- N is a Derived_Type_Definition with a possible non-empty
2599 -- extension. The initialization of a type extension consists in the
2600 -- initialization of the components in the extension.
2603 Build_Discriminant_Assignments (Body_Stmts);
2605 Record_Extension_Node :=
2606 Record_Extension_Part (Type_Definition (N));
2608 if not Null_Present (Record_Extension_Node) then
2610 Stmts : constant List_Id :=
2611 Build_Init_Statements (
2612 Component_List (Record_Extension_Node));
2615 -- The parent field must be initialized first because the
2616 -- offset of the new discriminants may depend on it. This is
2617 -- not needed if the parent is an interface type because in
2618 -- such case the initialization of the _parent field was not
2621 if not Is_Interface (Etype (Rec_Ent)) then
2623 Parent_IP : constant Name_Id :=
2624 Make_Init_Proc_Name (Etype (Rec_Ent));
2630 -- Look for a call to the parent IP at the beginning
2631 -- of Stmts associated with the record extension
2633 Stmt := First (Stmts);
2635 while Present (Stmt) loop
2636 if Nkind (Stmt) = N_Procedure_Call_Statement
2637 and then Chars (Name (Stmt)) = Parent_IP
2646 -- If found then move it to the beginning of the
2647 -- statements of this IP routine
2649 if Present (IP_Call) then
2650 IP_Stmts := New_List;
2652 Stmt := Remove_Head (Stmts);
2653 Append_To (IP_Stmts, Stmt);
2654 exit when Stmt = IP_Call;
2657 Prepend_List_To (Body_Stmts, IP_Stmts);
2662 Append_List_To (Body_Stmts, Stmts);
2667 -- Add here the assignment to instantiate the Tag
2669 -- The assignment corresponds to the code:
2671 -- _Init._Tag := Typ'Tag;
2673 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2674 -- tags are represented implicitly in objects. It is also suppressed
2675 -- in case of CPP_Class types because in this case the tag is
2676 -- initialized in the C++ side.
2678 if Is_Tagged_Type (Rec_Type)
2679 and then Tagged_Type_Expansion
2680 and then not No_Run_Time_Mode
2682 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2683 -- the actual object and invoke the IP of the parent (in this
2684 -- order). The tag must be initialized before the call to the IP
2685 -- of the parent and the assignments to other components because
2686 -- the initial value of the components may depend on the tag (eg.
2687 -- through a dispatching operation on an access to the current
2688 -- type). The tag assignment is not done when initializing the
2689 -- parent component of a type extension, because in that case the
2690 -- tag is set in the extension.
2692 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2694 -- Initialize the primary tag component
2696 Init_Tags_List := New_List (
2697 Make_Assignment_Statement (Loc,
2699 Make_Selected_Component (Loc,
2700 Prefix => Make_Identifier (Loc, Name_uInit),
2703 (First_Tag_Component (Rec_Type), Loc)),
2707 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2709 -- Ada 2005 (AI-251): Initialize the secondary tags components
2710 -- located at fixed positions (tags whose position depends on
2711 -- variable size components are initialized later ---see below)
2713 if Ada_Version >= Ada_2005
2714 and then not Is_Interface (Rec_Type)
2715 and then Has_Interfaces (Rec_Type)
2718 Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
2719 Elab_List : List_Id := New_List;
2724 Target => Make_Identifier (Loc, Name_uInit),
2725 Init_Tags_List => Init_Tags_List,
2726 Stmts_List => Elab_Sec_DT_Stmts_List,
2727 Fixed_Comps => True,
2728 Variable_Comps => False);
2730 Elab_List := New_List (
2731 Make_If_Statement (Loc,
2732 Condition => New_Occurrence_Of (Set_Tag, Loc),
2733 Then_Statements => Init_Tags_List));
2735 if Elab_Flag_Needed (Rec_Type) then
2736 Append_To (Elab_Sec_DT_Stmts_List,
2737 Make_Assignment_Statement (Loc,
2740 (Access_Disp_Table_Elab_Flag (Rec_Type),
2743 New_Occurrence_Of (Standard_False, Loc)));
2745 Append_To (Elab_List,
2746 Make_If_Statement (Loc,
2749 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2750 Then_Statements => Elab_Sec_DT_Stmts_List));
2753 Prepend_List_To (Body_Stmts, Elab_List);
2756 Prepend_To (Body_Stmts,
2757 Make_If_Statement (Loc,
2758 Condition => New_Occurrence_Of (Set_Tag, Loc),
2759 Then_Statements => Init_Tags_List));
2762 -- Case 2: CPP type. The imported C++ constructor takes care of
2763 -- tags initialization. No action needed here because the IP
2764 -- is built by Set_CPP_Constructors; in this case the IP is a
2765 -- wrapper that invokes the C++ constructor and copies the C++
2766 -- tags locally. Done to inherit the C++ slots in Ada derivations
2769 elsif Is_CPP_Class (Rec_Type) then
2770 pragma Assert (False);
2773 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2774 -- type derivations. Derivations of imported C++ classes add a
2775 -- complication, because we cannot inhibit tag setting in the
2776 -- constructor for the parent. Hence we initialize the tag after
2777 -- the call to the parent IP (that is, in reverse order compared
2778 -- with pure Ada hierarchies ---see comment on case 1).
2781 -- Initialize the primary tag
2783 Init_Tags_List := New_List (
2784 Make_Assignment_Statement (Loc,
2786 Make_Selected_Component (Loc,
2787 Prefix => Make_Identifier (Loc, Name_uInit),
2790 (First_Tag_Component (Rec_Type), Loc)),
2794 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2796 -- Ada 2005 (AI-251): Initialize the secondary tags components
2797 -- located at fixed positions (tags whose position depends on
2798 -- variable size components are initialized later ---see below)
2800 if Ada_Version >= Ada_2005
2801 and then not Is_Interface (Rec_Type)
2802 and then Has_Interfaces (Rec_Type)
2806 Target => Make_Identifier (Loc, Name_uInit),
2807 Init_Tags_List => Init_Tags_List,
2808 Stmts_List => Init_Tags_List,
2809 Fixed_Comps => True,
2810 Variable_Comps => False);
2813 -- Initialize the tag component after invocation of parent IP.
2816 -- parent_IP(_init.parent); // Invokes the C++ constructor
2817 -- [ typIC; ] // Inherit C++ slots from parent
2824 -- Search for the call to the IP of the parent. We assume
2825 -- that the first init_proc call is for the parent.
2827 Ins_Nod := First (Body_Stmts);
2828 while Present (Next (Ins_Nod))
2829 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2830 or else not Is_Init_Proc (Name (Ins_Nod)))
2835 -- The IC routine copies the inherited slots of the C+ part
2836 -- of the dispatch table from the parent and updates the
2837 -- overridden C++ slots.
2839 if CPP_Num_Prims (Rec_Type) > 0 then
2841 Init_DT : Entity_Id;
2845 Init_DT := CPP_Init_Proc (Rec_Type);
2846 pragma Assert (Present (Init_DT));
2849 Make_Procedure_Call_Statement (Loc,
2850 New_Occurrence_Of (Init_DT, Loc));
2851 Insert_After (Ins_Nod, New_Nod);
2853 -- Update location of init tag statements
2859 Insert_List_After (Ins_Nod, Init_Tags_List);
2863 -- Ada 2005 (AI-251): Initialize the secondary tag components
2864 -- located at variable positions. We delay the generation of this
2865 -- code until here because the value of the attribute 'Position
2866 -- applied to variable size components of the parent type that
2867 -- depend on discriminants is only safely read at runtime after
2868 -- the parent components have been initialized.
2870 if Ada_Version >= Ada_2005
2871 and then not Is_Interface (Rec_Type)
2872 and then Has_Interfaces (Rec_Type)
2873 and then Has_Discriminants (Etype (Rec_Type))
2874 and then Is_Variable_Size_Record (Etype (Rec_Type))
2876 Init_Tags_List := New_List;
2880 Target => Make_Identifier (Loc, Name_uInit),
2881 Init_Tags_List => Init_Tags_List,
2882 Stmts_List => Init_Tags_List,
2883 Fixed_Comps => False,
2884 Variable_Comps => True);
2886 if Is_Non_Empty_List (Init_Tags_List) then
2887 Append_List_To (Body_Stmts, Init_Tags_List);
2892 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2893 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2896 -- Deep_Finalize (_init, C1, ..., CN);
2900 and then Needs_Finalization (Rec_Type)
2901 and then not Is_Abstract_Type (Rec_Type)
2902 and then not Restriction_Active (No_Exception_Propagation)
2909 -- Create a local version of Deep_Finalize which has indication
2910 -- of partial initialization state.
2913 Make_Defining_Identifier (Loc,
2914 Chars => New_External_Name (Name_uFinalizer));
2916 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2919 Make_Procedure_Call_Statement (Loc,
2920 Name => New_Occurrence_Of (DF_Id, Loc),
2921 Parameter_Associations => New_List (
2922 Make_Identifier (Loc, Name_uInit),
2923 New_Occurrence_Of (Standard_False, Loc)));
2925 -- Do not emit warnings related to the elaboration order when a
2926 -- controlled object is declared before the body of Finalize is
2929 if Legacy_Elaboration_Checks then
2930 Set_No_Elaboration_Check (DF_Call);
2933 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2934 Make_Exception_Handler (Loc,
2935 Exception_Choices => New_List (
2936 Make_Others_Choice (Loc)),
2937 Statements => New_List (
2939 Make_Raise_Statement (Loc)))));
2942 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2945 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2947 if not Debug_Generated_Code then
2948 Set_Debug_Info_Off (Proc_Id);
2951 -- Associate Init_Proc with type, and determine if the procedure
2952 -- is null (happens because of the Initialize_Scalars pragma case,
2953 -- where we have to generate a null procedure in case it is called
2954 -- by a client with Initialize_Scalars set). Such procedures have
2955 -- to be generated, but do not have to be called, so we mark them
2956 -- as null to suppress the call. Kill also warnings for the _Init
2957 -- out parameter, which is left entirely uninitialized.
2959 Set_Init_Proc (Rec_Type, Proc_Id);
2961 if Is_Null_Statement_List (Body_Stmts) then
2962 Set_Is_Null_Init_Proc (Proc_Id);
2963 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
2965 end Build_Init_Procedure;
2967 ---------------------------
2968 -- Build_Init_Statements --
2969 ---------------------------
2971 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2972 Checks : constant List_Id := New_List;
2973 Actions : List_Id := No_List;
2974 Counter_Id : Entity_Id := Empty;
2975 Comp_Loc : Source_Ptr;
2978 Parent_Stmts : List_Id;
2982 procedure Increment_Counter (Loc : Source_Ptr);
2983 -- Generate an "increment by one" statement for the current counter
2984 -- and append it to the list Stmts.
2986 procedure Make_Counter (Loc : Source_Ptr);
2987 -- Create a new counter for the current component list. The routine
2988 -- creates a new defining Id, adds an object declaration and sets
2989 -- the Id generator for the next variant.
2991 function Requires_Late_Initialization
2993 Rec_Type : Entity_Id) return Boolean;
2994 -- Return whether the given Decl requires late initialization, as
2995 -- defined by 3.3.1 (8.1/5).
2997 -----------------------
2998 -- Increment_Counter --
2999 -----------------------
3001 procedure Increment_Counter (Loc : Source_Ptr) is
3004 -- Counter := Counter + 1;
3007 Make_Assignment_Statement (Loc,
3008 Name => New_Occurrence_Of (Counter_Id, Loc),
3011 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
3012 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3013 end Increment_Counter;
3019 procedure Make_Counter (Loc : Source_Ptr) is
3021 -- Increment the Id generator
3023 Counter := Counter + 1;
3025 -- Create the entity and declaration
3028 Make_Defining_Identifier (Loc,
3029 Chars => New_External_Name ('C', Counter));
3032 -- Cnn : Integer := 0;
3035 Make_Object_Declaration (Loc,
3036 Defining_Identifier => Counter_Id,
3037 Object_Definition =>
3038 New_Occurrence_Of (Standard_Integer, Loc),
3040 Make_Integer_Literal (Loc, 0)));
3043 ----------------------------------
3044 -- Requires_Late_Initialization --
3045 ----------------------------------
3047 function Requires_Late_Initialization
3049 Rec_Type : Entity_Id) return Boolean
3051 References_Current_Instance : Boolean := False;
3052 Has_Access_Discriminant : Boolean := False;
3053 Has_Internal_Call : Boolean := False;
3055 function Find_Access_Discriminant
3056 (N : Node_Id) return Traverse_Result;
3057 -- Look for a name denoting an access discriminant
3059 function Find_Current_Instance
3060 (N : Node_Id) return Traverse_Result;
3061 -- Look for a reference to the current instance of the type
3063 function Find_Internal_Call
3064 (N : Node_Id) return Traverse_Result;
3065 -- Look for an internal protected function call
3067 ------------------------------
3068 -- Find_Access_Discriminant --
3069 ------------------------------
3071 function Find_Access_Discriminant
3072 (N : Node_Id) return Traverse_Result is
3074 if Is_Entity_Name (N)
3075 and then Denotes_Discriminant (N)
3076 and then Is_Access_Type (Etype (N))
3078 Has_Access_Discriminant := True;
3083 end Find_Access_Discriminant;
3085 ---------------------------
3086 -- Find_Current_Instance --
3087 ---------------------------
3089 function Find_Current_Instance
3090 (N : Node_Id) return Traverse_Result is
3092 if Is_Entity_Name (N)
3093 and then Present (Entity (N))
3094 and then Is_Current_Instance (N)
3096 References_Current_Instance := True;
3101 end Find_Current_Instance;
3103 ------------------------
3104 -- Find_Internal_Call --
3105 ------------------------
3107 function Find_Internal_Call (N : Node_Id) return Traverse_Result is
3109 function Call_Scope (N : Node_Id) return Entity_Id;
3110 -- Return the scope enclosing a given call node N
3116 function Call_Scope (N : Node_Id) return Entity_Id is
3117 Nam : constant Node_Id := Name (N);
3119 if Nkind (Nam) = N_Selected_Component then
3120 return Scope (Entity (Prefix (Nam)));
3122 return Scope (Entity (Nam));
3127 if Nkind (N) = N_Function_Call
3128 and then Call_Scope (N)
3129 = Corresponding_Concurrent_Type (Rec_Type)
3131 Has_Internal_Call := True;
3136 end Find_Internal_Call;
3138 procedure Search_Access_Discriminant is new
3139 Traverse_Proc (Find_Access_Discriminant);
3141 procedure Search_Current_Instance is new
3142 Traverse_Proc (Find_Current_Instance);
3144 procedure Search_Internal_Call is new
3145 Traverse_Proc (Find_Internal_Call);
3148 -- A component of an object is said to require late initialization
3151 -- it has an access discriminant value constrained by a per-object
3154 if Has_Access_Constraint (Defining_Identifier (Decl))
3155 and then No (Expression (Decl))
3159 elsif Present (Expression (Decl)) then
3161 -- it has an initialization expression that includes a name
3162 -- denoting an access discriminant;
3164 Search_Access_Discriminant (Expression (Decl));
3166 if Has_Access_Discriminant then
3170 -- or it has an initialization expression that includes a
3171 -- reference to the current instance of the type either by
3174 Search_Current_Instance (Expression (Decl));
3176 if References_Current_Instance then
3180 -- ...or implicitly as the target object of a call.
3182 if Is_Protected_Record_Type (Rec_Type) then
3183 Search_Internal_Call (Expression (Decl));
3185 if Has_Internal_Call then
3192 end Requires_Late_Initialization;
3194 -- Start of processing for Build_Init_Statements
3197 if Null_Present (Comp_List) then
3198 return New_List (Make_Null_Statement (Loc));
3201 Parent_Stmts := New_List;
3204 -- Loop through visible declarations of task types and protected
3205 -- types moving any expanded code from the spec to the body of the
3208 if Is_Task_Record_Type (Rec_Type)
3209 or else Is_Protected_Record_Type (Rec_Type)
3212 Decl : constant Node_Id :=
3213 Parent (Corresponding_Concurrent_Type (Rec_Type));
3219 if Is_Task_Record_Type (Rec_Type) then
3220 Def := Task_Definition (Decl);
3222 Def := Protected_Definition (Decl);
3225 if Present (Def) then
3226 N1 := First (Visible_Declarations (Def));
3227 while Present (N1) loop
3231 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
3232 or else Nkind (N2) in N_Raise_xxx_Error
3233 or else Nkind (N2) = N_Procedure_Call_Statement
3236 New_Copy_Tree (N2, New_Scope => Proc_Id));
3237 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
3245 -- Loop through components, skipping pragmas, in 2 steps. The first
3246 -- step deals with regular components. The second step deals with
3247 -- components that require late initialization.
3249 -- First pass : regular components
3251 Decl := First_Non_Pragma (Component_Items (Comp_List));
3252 while Present (Decl) loop
3253 Comp_Loc := Sloc (Decl);
3255 (Subtype_Indication (Component_Definition (Decl)), Checks);
3257 Id := Defining_Identifier (Decl);
3260 -- Leave any processing of component requiring late initialization
3261 -- for the second pass.
3263 if Requires_Late_Initialization (Decl, Rec_Type) then
3264 Has_Late_Init_Comp := True;
3266 -- Regular component cases
3269 -- In the context of the init proc, references to discriminants
3270 -- resolve to denote the discriminals: this is where we can
3271 -- freeze discriminant dependent component subtypes.
3273 if not Is_Frozen (Typ) then
3274 Append_List_To (Stmts, Freeze_Entity (Typ, N));
3277 -- Explicit initialization
3279 if Present (Expression (Decl)) then
3280 if Is_CPP_Constructor_Call (Expression (Decl)) then
3282 Build_Initialization_Call
3285 Make_Selected_Component (Comp_Loc,
3287 Make_Identifier (Comp_Loc, Name_uInit),
3289 New_Occurrence_Of (Id, Comp_Loc)),
3291 In_Init_Proc => True,
3292 Enclos_Type => Rec_Type,
3293 Discr_Map => Discr_Map,
3294 Constructor_Ref => Expression (Decl));
3296 Actions := Build_Assignment (Id, Expression (Decl));
3299 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3300 -- components are filled in with the corresponding rep-item
3301 -- expression of the concurrent type (if any).
3303 elsif Ekind (Scope (Id)) = E_Record_Type
3304 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
3305 and then Chars (Id) in Name_uCPU
3306 | Name_uDispatching_Domain
3308 | Name_uSecondary_Stack_Size
3313 pragma Warnings (Off, Nam);
3317 if Chars (Id) = Name_uCPU then
3320 elsif Chars (Id) = Name_uDispatching_Domain then
3321 Nam := Name_Dispatching_Domain;
3323 elsif Chars (Id) = Name_uPriority then
3324 Nam := Name_Priority;
3326 elsif Chars (Id) = Name_uSecondary_Stack_Size then
3327 Nam := Name_Secondary_Stack_Size;
3330 -- Get the Rep Item (aspect specification, attribute
3331 -- definition clause or pragma) of the corresponding
3336 (Corresponding_Concurrent_Type (Scope (Id)),
3338 Check_Parents => False);
3340 if Present (Ritem) then
3344 if Nkind (Ritem) = N_Pragma then
3345 Exp := First (Pragma_Argument_Associations (Ritem));
3347 if Nkind (Exp) = N_Pragma_Argument_Association then
3348 Exp := Expression (Exp);
3351 -- Conversion for Priority expression
3353 if Nam = Name_Priority then
3354 if Pragma_Name (Ritem) = Name_Priority
3355 and then not GNAT_Mode
3357 Exp := Convert_To (RTE (RE_Priority), Exp);
3360 Convert_To (RTE (RE_Any_Priority), Exp);
3364 -- Aspect/Attribute definition clause case
3367 Exp := Expression (Ritem);
3369 -- Conversion for Priority expression
3371 if Nam = Name_Priority then
3372 if Chars (Ritem) = Name_Priority
3373 and then not GNAT_Mode
3375 Exp := Convert_To (RTE (RE_Priority), Exp);
3378 Convert_To (RTE (RE_Any_Priority), Exp);
3383 -- Conversion for Dispatching_Domain value
3385 if Nam = Name_Dispatching_Domain then
3387 Unchecked_Convert_To
3388 (RTE (RE_Dispatching_Domain_Access), Exp);
3390 -- Conversion for Secondary_Stack_Size value
3392 elsif Nam = Name_Secondary_Stack_Size then
3393 Exp := Convert_To (RTE (RE_Size_Type), Exp);
3396 Actions := Build_Assignment (Id, Exp);
3398 -- Nothing needed if no Rep Item
3405 -- Composite component with its own Init_Proc
3407 elsif not Is_Interface (Typ)
3408 and then Has_Non_Null_Base_Init_Proc (Typ)
3411 Build_Initialization_Call
3413 Make_Selected_Component (Comp_Loc,
3415 Make_Identifier (Comp_Loc, Name_uInit),
3416 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3418 In_Init_Proc => True,
3419 Enclos_Type => Rec_Type,
3420 Discr_Map => Discr_Map);
3422 Clean_Task_Names (Typ, Proc_Id);
3424 -- Simple initialization. If the Esize is not yet set, we pass
3425 -- Uint_0 as expected by Get_Simple_Init_Val.
3427 elsif Component_Needs_Simple_Initialization (Typ) then
3436 (if Known_Esize (Id) then Esize (Id)
3439 -- Nothing needed for this case
3445 -- When the component's type has a Default_Initial_Condition,
3446 -- and the component is default initialized, then check the
3450 and then not Present (Expression (Decl))
3451 and then Present (DIC_Procedure (Typ))
3452 and then not Has_Null_Body (DIC_Procedure (Typ))
3454 -- The DICs of ancestors are checked as part of the type's
3457 and then Chars (Id) /= Name_uParent
3459 -- In GNATprove mode, the component DICs are checked by other
3460 -- means. They should not be added to the record type DIC
3461 -- procedure, so that the procedure can be used to check the
3462 -- record type invariants or DICs if any.
3464 and then not GNATprove_Mode
3466 Append_New_To (Actions,
3469 Make_Selected_Component (Comp_Loc,
3471 Make_Identifier (Comp_Loc, Name_uInit),
3473 New_Occurrence_Of (Id, Comp_Loc)),
3477 if Present (Checks) then
3478 if Chars (Id) = Name_uParent then
3479 Append_List_To (Parent_Stmts, Checks);
3481 Append_List_To (Stmts, Checks);
3485 if Present (Actions) then
3486 if Chars (Id) = Name_uParent then
3487 Append_List_To (Parent_Stmts, Actions);
3490 Append_List_To (Stmts, Actions);
3492 -- Preserve initialization state in the current counter
3494 if Needs_Finalization (Typ) then
3495 if No (Counter_Id) then
3496 Make_Counter (Comp_Loc);
3499 Increment_Counter (Comp_Loc);
3505 Next_Non_Pragma (Decl);
3508 -- The parent field must be initialized first because variable
3509 -- size components of the parent affect the location of all the
3512 Prepend_List_To (Stmts, Parent_Stmts);
3514 -- Set up tasks and protected object support. This needs to be done
3515 -- before any component with a per-object access discriminant
3516 -- constraint, or any variant part (which may contain such
3517 -- components) is initialized, because the initialization of these
3518 -- components may reference the enclosing concurrent object.
3520 -- For a task record type, add the task create call and calls to bind
3521 -- any interrupt (signal) entries.
3523 if Is_Task_Record_Type (Rec_Type) then
3525 -- In the case of the restricted run time the ATCB has already
3526 -- been preallocated.
3528 if Restricted_Profile then
3530 Make_Assignment_Statement (Loc,
3532 Make_Selected_Component (Loc,
3533 Prefix => Make_Identifier (Loc, Name_uInit),
3534 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3536 Make_Attribute_Reference (Loc,
3538 Make_Selected_Component (Loc,
3539 Prefix => Make_Identifier (Loc, Name_uInit),
3540 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3541 Attribute_Name => Name_Unchecked_Access)));
3544 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3547 Task_Type : constant Entity_Id :=
3548 Corresponding_Concurrent_Type (Rec_Type);
3549 Task_Decl : constant Node_Id := Parent (Task_Type);
3550 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3551 Decl_Loc : Source_Ptr;
3556 if Present (Task_Def) then
3557 Vis_Decl := First (Visible_Declarations (Task_Def));
3558 while Present (Vis_Decl) loop
3559 Decl_Loc := Sloc (Vis_Decl);
3561 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3562 if Get_Attribute_Id (Chars (Vis_Decl)) =
3565 Ent := Entity (Name (Vis_Decl));
3567 if Ekind (Ent) = E_Entry then
3569 Make_Procedure_Call_Statement (Decl_Loc,
3571 New_Occurrence_Of (RTE (
3572 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3573 Parameter_Associations => New_List (
3574 Make_Selected_Component (Decl_Loc,
3576 Make_Identifier (Decl_Loc, Name_uInit),
3579 (Decl_Loc, Name_uTask_Id)),
3580 Entry_Index_Expression
3581 (Decl_Loc, Ent, Empty, Task_Type),
3582 Expression (Vis_Decl))));
3593 -- For a protected type, add statements generated by
3594 -- Make_Initialize_Protection.
3596 if Is_Protected_Record_Type (Rec_Type) then
3597 Append_List_To (Stmts,
3598 Make_Initialize_Protection (Rec_Type));
3601 -- Second pass: components that require late initialization
3603 if Has_Late_Init_Comp then
3604 Decl := First_Non_Pragma (Component_Items (Comp_List));
3605 while Present (Decl) loop
3606 Comp_Loc := Sloc (Decl);
3607 Id := Defining_Identifier (Decl);
3610 if Requires_Late_Initialization (Decl, Rec_Type) then
3611 if Present (Expression (Decl)) then
3612 Append_List_To (Stmts,
3613 Build_Assignment (Id, Expression (Decl)));
3615 elsif Has_Non_Null_Base_Init_Proc (Typ) then
3616 Append_List_To (Stmts,
3617 Build_Initialization_Call (Comp_Loc,
3618 Make_Selected_Component (Comp_Loc,
3620 Make_Identifier (Comp_Loc, Name_uInit),
3621 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3623 In_Init_Proc => True,
3624 Enclos_Type => Rec_Type,
3625 Discr_Map => Discr_Map));
3627 Clean_Task_Names (Typ, Proc_Id);
3629 -- Preserve initialization state in the current counter
3631 if Needs_Finalization (Typ) then
3632 if No (Counter_Id) then
3633 Make_Counter (Comp_Loc);
3636 Increment_Counter (Comp_Loc);
3638 elsif Component_Needs_Simple_Initialization (Typ) then
3639 Append_List_To (Stmts,
3646 Size => Esize (Id))));
3650 Next_Non_Pragma (Decl);
3654 -- Process the variant part
3656 if Present (Variant_Part (Comp_List)) then
3658 Variant_Alts : constant List_Id := New_List;
3659 Var_Loc : Source_Ptr := No_Location;
3664 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3665 while Present (Variant) loop
3666 Var_Loc := Sloc (Variant);
3667 Append_To (Variant_Alts,
3668 Make_Case_Statement_Alternative (Var_Loc,
3670 New_Copy_List (Discrete_Choices (Variant)),
3672 Build_Init_Statements (Component_List (Variant))));
3673 Next_Non_Pragma (Variant);
3676 -- The expression of the case statement which is a reference
3677 -- to one of the discriminants is replaced by the appropriate
3678 -- formal parameter of the initialization procedure.
3681 Make_Case_Statement (Var_Loc,
3683 New_Occurrence_Of (Discriminal (
3684 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3685 Alternatives => Variant_Alts));
3689 -- If no initializations when generated for component declarations
3690 -- corresponding to this Stmts, append a null statement to Stmts to
3691 -- to make it a valid Ada tree.
3693 if Is_Empty_List (Stmts) then
3694 Append (Make_Null_Statement (Loc), Stmts);
3700 when RE_Not_Available =>
3702 end Build_Init_Statements;
3704 -------------------------
3705 -- Build_Record_Checks --
3706 -------------------------
3708 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3709 Subtype_Mark_Id : Entity_Id;
3711 procedure Constrain_Array
3713 Check_List : List_Id);
3714 -- Apply a list of index constraints to an unconstrained array type.
3715 -- The first parameter is the entity for the resulting subtype.
3716 -- Check_List is a list to which the check actions are appended.
3718 ---------------------
3719 -- Constrain_Array --
3720 ---------------------
3722 procedure Constrain_Array
3724 Check_List : List_Id)
3726 C : constant Node_Id := Constraint (SI);
3727 Number_Of_Constraints : Nat := 0;
3731 procedure Constrain_Index
3734 Check_List : List_Id);
3735 -- Process an index constraint in a constrained array declaration.
3736 -- The constraint can be either a subtype name or a range with or
3737 -- without an explicit subtype mark. Index is the corresponding
3738 -- index of the unconstrained array. S is the range expression.
3739 -- Check_List is a list to which the check actions are appended.
3741 ---------------------
3742 -- Constrain_Index --
3743 ---------------------
3745 procedure Constrain_Index
3748 Check_List : List_Id)
3750 T : constant Entity_Id := Etype (Index);
3753 if Nkind (S) = N_Range then
3754 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3756 end Constrain_Index;
3758 -- Start of processing for Constrain_Array
3761 T := Entity (Subtype_Mark (SI));
3763 if Is_Access_Type (T) then
3764 T := Designated_Type (T);
3767 S := First (Constraints (C));
3768 while Present (S) loop
3769 Number_Of_Constraints := Number_Of_Constraints + 1;
3773 -- In either case, the index constraint must provide a discrete
3774 -- range for each index of the array type and the type of each
3775 -- discrete range must be the same as that of the corresponding
3776 -- index. (RM 3.6.1)
3778 S := First (Constraints (C));
3779 Index := First_Index (T);
3782 -- Apply constraints to each index type
3784 for J in 1 .. Number_Of_Constraints loop
3785 Constrain_Index (Index, S, Check_List);
3789 end Constrain_Array;
3791 -- Start of processing for Build_Record_Checks
3794 if Nkind (S) = N_Subtype_Indication then
3795 Find_Type (Subtype_Mark (S));
3796 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3798 -- Remaining processing depends on type
3800 case Ekind (Subtype_Mark_Id) is
3802 Constrain_Array (S, Check_List);
3808 end Build_Record_Checks;
3810 -------------------------------------------
3811 -- Component_Needs_Simple_Initialization --
3812 -------------------------------------------
3814 function Component_Needs_Simple_Initialization
3815 (T : Entity_Id) return Boolean
3819 Needs_Simple_Initialization (T)
3820 and then not Is_RTE (T, RE_Tag)
3822 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3824 and then not Is_RTE (T, RE_Interface_Tag);
3825 end Component_Needs_Simple_Initialization;
3827 --------------------------------------
3828 -- Parent_Subtype_Renaming_Discrims --
3829 --------------------------------------
3831 function Parent_Subtype_Renaming_Discrims return Boolean is
3836 if Base_Type (Rec_Ent) /= Rec_Ent then
3840 if Etype (Rec_Ent) = Rec_Ent
3841 or else not Has_Discriminants (Rec_Ent)
3842 or else Is_Constrained (Rec_Ent)
3843 or else Is_Tagged_Type (Rec_Ent)
3848 -- If there are no explicit stored discriminants we have inherited
3849 -- the root type discriminants so far, so no renamings occurred.
3851 if First_Discriminant (Rec_Ent) =
3852 First_Stored_Discriminant (Rec_Ent)
3857 -- Check if we have done some trivial renaming of the parent
3858 -- discriminants, i.e. something like
3860 -- type DT (X1, X2: int) is new PT (X1, X2);
3862 De := First_Discriminant (Rec_Ent);
3863 Dp := First_Discriminant (Etype (Rec_Ent));
3864 while Present (De) loop
3865 pragma Assert (Present (Dp));
3867 if Corresponding_Discriminant (De) /= Dp then
3871 Next_Discriminant (De);
3872 Next_Discriminant (Dp);
3875 return Present (Dp);
3876 end Parent_Subtype_Renaming_Discrims;
3878 ------------------------
3879 -- Requires_Init_Proc --
3880 ------------------------
3882 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3883 Comp_Decl : Node_Id;
3888 -- Definitely do not need one if specifically suppressed
3890 if Initialization_Suppressed (Rec_Id) then
3894 -- If it is a type derived from a type with unknown discriminants,
3895 -- we cannot build an initialization procedure for it.
3897 if Has_Unknown_Discriminants (Rec_Id)
3898 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3903 -- Otherwise we need to generate an initialization procedure if
3904 -- Is_CPP_Class is False and at least one of the following applies:
3906 -- 1. Discriminants are present, since they need to be initialized
3907 -- with the appropriate discriminant constraint expressions.
3908 -- However, the discriminant of an unchecked union does not
3909 -- count, since the discriminant is not present.
3911 -- 2. The type is a tagged type, since the implicit Tag component
3912 -- needs to be initialized with a pointer to the dispatch table.
3914 -- 3. The type contains tasks
3916 -- 4. One or more components has an initial value
3918 -- 5. One or more components is for a type which itself requires
3919 -- an initialization procedure.
3921 -- 6. One or more components is a type that requires simple
3922 -- initialization (see Needs_Simple_Initialization), except
3923 -- that types Tag and Interface_Tag are excluded, since fields
3924 -- of these types are initialized by other means.
3926 -- 7. The type is the record type built for a task type (since at
3927 -- the very least, Create_Task must be called)
3929 -- 8. The type is the record type built for a protected type (since
3930 -- at least Initialize_Protection must be called)
3932 -- 9. The type is marked as a public entity. The reason we add this
3933 -- case (even if none of the above apply) is to properly handle
3934 -- Initialize_Scalars. If a package is compiled without an IS
3935 -- pragma, and the client is compiled with an IS pragma, then
3936 -- the client will think an initialization procedure is present
3937 -- and call it, when in fact no such procedure is required, but
3938 -- since the call is generated, there had better be a routine
3939 -- at the other end of the call, even if it does nothing).
3941 -- Note: the reason we exclude the CPP_Class case is because in this
3942 -- case the initialization is performed by the C++ constructors, and
3943 -- the IP is built by Set_CPP_Constructors.
3945 if Is_CPP_Class (Rec_Id) then
3948 elsif Is_Interface (Rec_Id) then
3951 elsif (Has_Discriminants (Rec_Id)
3952 and then not Is_Unchecked_Union (Rec_Id))
3953 or else Is_Tagged_Type (Rec_Id)
3954 or else Is_Concurrent_Record_Type (Rec_Id)
3955 or else Has_Task (Rec_Id)
3960 Id := First_Component (Rec_Id);
3961 while Present (Id) loop
3962 Comp_Decl := Parent (Id);
3965 if Present (Expression (Comp_Decl))
3966 or else Has_Non_Null_Base_Init_Proc (Typ)
3967 or else Component_Needs_Simple_Initialization (Typ)
3972 Next_Component (Id);
3975 -- As explained above, a record initialization procedure is needed
3976 -- for public types in case Initialize_Scalars applies to a client.
3977 -- However, such a procedure is not needed in the case where either
3978 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3979 -- applies. No_Initialize_Scalars excludes the possibility of using
3980 -- Initialize_Scalars in any partition, and No_Default_Initialization
3981 -- implies that no initialization should ever be done for objects of
3982 -- the type, so is incompatible with Initialize_Scalars.
3984 if not Restriction_Active (No_Initialize_Scalars)
3985 and then not Restriction_Active (No_Default_Initialization)
3986 and then Is_Public (Rec_Id)
3992 end Requires_Init_Proc;
3994 -- Start of processing for Build_Record_Init_Proc
3997 Rec_Type := Defining_Identifier (N);
3999 -- This may be full declaration of a private type, in which case
4000 -- the visible entity is a record, and the private entity has been
4001 -- exchanged with it in the private part of the current package.
4002 -- The initialization procedure is built for the record type, which
4003 -- is retrievable from the private entity.
4005 if Is_Incomplete_Or_Private_Type (Rec_Type) then
4006 Rec_Type := Underlying_Type (Rec_Type);
4009 -- If we have a variant record with restriction No_Implicit_Conditionals
4010 -- in effect, then we skip building the procedure. This is safe because
4011 -- if we can see the restriction, so can any caller, calls to initialize
4012 -- such records are not allowed for variant records if this restriction
4015 if Has_Variant_Part (Rec_Type)
4016 and then Restriction_Active (No_Implicit_Conditionals)
4021 -- If there are discriminants, build the discriminant map to replace
4022 -- discriminants by their discriminals in complex bound expressions.
4023 -- These only arise for the corresponding records of synchronized types.
4025 if Is_Concurrent_Record_Type (Rec_Type)
4026 and then Has_Discriminants (Rec_Type)
4031 Disc := First_Discriminant (Rec_Type);
4032 while Present (Disc) loop
4033 Append_Elmt (Disc, Discr_Map);
4034 Append_Elmt (Discriminal (Disc), Discr_Map);
4035 Next_Discriminant (Disc);
4040 -- Derived types that have no type extension can use the initialization
4041 -- procedure of their parent and do not need a procedure of their own.
4042 -- This is only correct if there are no representation clauses for the
4043 -- type or its parent, and if the parent has in fact been frozen so
4044 -- that its initialization procedure exists.
4046 if Is_Derived_Type (Rec_Type)
4047 and then not Is_Tagged_Type (Rec_Type)
4048 and then not Is_Unchecked_Union (Rec_Type)
4049 and then not Has_New_Non_Standard_Rep (Rec_Type)
4050 and then not Parent_Subtype_Renaming_Discrims
4051 and then Present (Base_Init_Proc (Etype (Rec_Type)))
4053 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
4055 -- Otherwise if we need an initialization procedure, then build one,
4056 -- mark it as public and inlinable and as having a completion.
4058 elsif Requires_Init_Proc (Rec_Type)
4059 or else Is_Unchecked_Union (Rec_Type)
4062 Make_Defining_Identifier (Loc,
4063 Chars => Make_Init_Proc_Name (Rec_Type));
4065 -- If No_Default_Initialization restriction is active, then we don't
4066 -- want to build an init_proc, but we need to mark that an init_proc
4067 -- would be needed if this restriction was not active (so that we can
4068 -- detect attempts to call it), so set a dummy init_proc in place.
4070 if Restriction_Active (No_Default_Initialization) then
4071 Set_Init_Proc (Rec_Type, Proc_Id);
4075 Build_Offset_To_Top_Functions;
4076 Build_CPP_Init_Procedure;
4077 Build_Init_Procedure;
4079 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
4080 Set_Is_Internal (Proc_Id);
4081 Set_Has_Completion (Proc_Id);
4083 if not Debug_Generated_Code then
4084 Set_Debug_Info_Off (Proc_Id);
4087 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
4089 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4090 -- needed and may generate early references to non frozen types
4091 -- since we expand aggregate much more systematically.
4093 if Modify_Tree_For_C then
4098 Agg : constant Node_Id :=
4099 Build_Equivalent_Record_Aggregate (Rec_Type);
4101 procedure Collect_Itypes (Comp : Node_Id);
4102 -- Generate references to itypes in the aggregate, because
4103 -- the first use of the aggregate may be in a nested scope.
4105 --------------------
4106 -- Collect_Itypes --
4107 --------------------
4109 procedure Collect_Itypes (Comp : Node_Id) is
4112 Typ : constant Entity_Id := Etype (Comp);
4115 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
4116 Ref := Make_Itype_Reference (Loc);
4117 Set_Itype (Ref, Typ);
4118 Append_Freeze_Action (Rec_Type, Ref);
4120 Ref := Make_Itype_Reference (Loc);
4121 Set_Itype (Ref, Etype (First_Index (Typ)));
4122 Append_Freeze_Action (Rec_Type, Ref);
4124 -- Recurse on nested arrays
4126 Sub_Aggr := First (Expressions (Comp));
4127 while Present (Sub_Aggr) loop
4128 Collect_Itypes (Sub_Aggr);
4135 -- If there is a static initialization aggregate for the type,
4136 -- generate itype references for the types of its (sub)components,
4137 -- to prevent out-of-scope errors in the resulting tree.
4138 -- The aggregate may have been rewritten as a Raise node, in which
4139 -- case there are no relevant itypes.
4141 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
4142 Set_Static_Initialization (Proc_Id, Agg);
4147 Comp := First (Component_Associations (Agg));
4148 while Present (Comp) loop
4149 Collect_Itypes (Expression (Comp));
4156 end Build_Record_Init_Proc;
4158 ----------------------------
4159 -- Build_Slice_Assignment --
4160 ----------------------------
4162 -- Generates the following subprogram:
4164 -- procedure array_typeSA
4165 -- (Source, Target : Array_Type,
4166 -- Left_Lo, Left_Hi : Index;
4167 -- Right_Lo, Right_Hi : Index;
4174 -- if Left_Hi < Left_Lo then
4187 -- Target (Li1) := Source (Ri1);
4190 -- exit when Li1 = Left_Lo;
4191 -- Li1 := Index'pred (Li1);
4192 -- Ri1 := Index'pred (Ri1);
4194 -- exit when Li1 = Left_Hi;
4195 -- Li1 := Index'succ (Li1);
4196 -- Ri1 := Index'succ (Ri1);
4199 -- end array_typeSA;
4201 procedure Build_Slice_Assignment (Typ : Entity_Id) is
4202 Loc : constant Source_Ptr := Sloc (Typ);
4203 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
4205 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
4206 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
4207 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
4208 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
4209 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
4210 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
4211 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
4212 -- Formal parameters of procedure
4214 Proc_Name : constant Entity_Id :=
4215 Make_Defining_Identifier (Loc,
4216 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
4218 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
4219 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
4220 -- Subscripts for left and right sides
4227 -- Build declarations for indexes
4232 Make_Object_Declaration (Loc,
4233 Defining_Identifier => Lnn,
4234 Object_Definition =>
4235 New_Occurrence_Of (Index, Loc)));
4238 Make_Object_Declaration (Loc,
4239 Defining_Identifier => Rnn,
4240 Object_Definition =>
4241 New_Occurrence_Of (Index, Loc)));
4245 -- Build test for empty slice case
4248 Make_If_Statement (Loc,
4251 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
4252 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
4253 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
4255 -- Build initializations for indexes
4258 F_Init : constant List_Id := New_List;
4259 B_Init : constant List_Id := New_List;
4263 Make_Assignment_Statement (Loc,
4264 Name => New_Occurrence_Of (Lnn, Loc),
4265 Expression => New_Occurrence_Of (Left_Lo, Loc)));
4268 Make_Assignment_Statement (Loc,
4269 Name => New_Occurrence_Of (Rnn, Loc),
4270 Expression => New_Occurrence_Of (Right_Lo, Loc)));
4273 Make_Assignment_Statement (Loc,
4274 Name => New_Occurrence_Of (Lnn, Loc),
4275 Expression => New_Occurrence_Of (Left_Hi, Loc)));
4278 Make_Assignment_Statement (Loc,
4279 Name => New_Occurrence_Of (Rnn, Loc),
4280 Expression => New_Occurrence_Of (Right_Hi, Loc)));
4283 Make_If_Statement (Loc,
4284 Condition => New_Occurrence_Of (Rev, Loc),
4285 Then_Statements => B_Init,
4286 Else_Statements => F_Init));
4289 -- Now construct the assignment statement
4292 Make_Loop_Statement (Loc,
4293 Statements => New_List (
4294 Make_Assignment_Statement (Loc,
4296 Make_Indexed_Component (Loc,
4297 Prefix => New_Occurrence_Of (Larray, Loc),
4298 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
4300 Make_Indexed_Component (Loc,
4301 Prefix => New_Occurrence_Of (Rarray, Loc),
4302 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
4303 End_Label => Empty);
4305 -- Build the exit condition and increment/decrement statements
4308 F_Ass : constant List_Id := New_List;
4309 B_Ass : constant List_Id := New_List;
4313 Make_Exit_Statement (Loc,
4316 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4317 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
4320 Make_Assignment_Statement (Loc,
4321 Name => New_Occurrence_Of (Lnn, Loc),
4323 Make_Attribute_Reference (Loc,
4325 New_Occurrence_Of (Index, Loc),
4326 Attribute_Name => Name_Succ,
4327 Expressions => New_List (
4328 New_Occurrence_Of (Lnn, Loc)))));
4331 Make_Assignment_Statement (Loc,
4332 Name => New_Occurrence_Of (Rnn, Loc),
4334 Make_Attribute_Reference (Loc,
4336 New_Occurrence_Of (Index, Loc),
4337 Attribute_Name => Name_Succ,
4338 Expressions => New_List (
4339 New_Occurrence_Of (Rnn, Loc)))));
4342 Make_Exit_Statement (Loc,
4345 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4346 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
4349 Make_Assignment_Statement (Loc,
4350 Name => New_Occurrence_Of (Lnn, Loc),
4352 Make_Attribute_Reference (Loc,
4354 New_Occurrence_Of (Index, Loc),
4355 Attribute_Name => Name_Pred,
4356 Expressions => New_List (
4357 New_Occurrence_Of (Lnn, Loc)))));
4360 Make_Assignment_Statement (Loc,
4361 Name => New_Occurrence_Of (Rnn, Loc),
4363 Make_Attribute_Reference (Loc,
4365 New_Occurrence_Of (Index, Loc),
4366 Attribute_Name => Name_Pred,
4367 Expressions => New_List (
4368 New_Occurrence_Of (Rnn, Loc)))));
4370 Append_To (Statements (Loops),
4371 Make_If_Statement (Loc,
4372 Condition => New_Occurrence_Of (Rev, Loc),
4373 Then_Statements => B_Ass,
4374 Else_Statements => F_Ass));
4377 Append_To (Stats, Loops);
4384 Formals := New_List (
4385 Make_Parameter_Specification (Loc,
4386 Defining_Identifier => Larray,
4387 Out_Present => True,
4389 New_Occurrence_Of (Base_Type (Typ), Loc)),
4391 Make_Parameter_Specification (Loc,
4392 Defining_Identifier => Rarray,
4394 New_Occurrence_Of (Base_Type (Typ), Loc)),
4396 Make_Parameter_Specification (Loc,
4397 Defining_Identifier => Left_Lo,
4399 New_Occurrence_Of (Index, Loc)),
4401 Make_Parameter_Specification (Loc,
4402 Defining_Identifier => Left_Hi,
4404 New_Occurrence_Of (Index, Loc)),
4406 Make_Parameter_Specification (Loc,
4407 Defining_Identifier => Right_Lo,
4409 New_Occurrence_Of (Index, Loc)),
4411 Make_Parameter_Specification (Loc,
4412 Defining_Identifier => Right_Hi,
4414 New_Occurrence_Of (Index, Loc)));
4417 Make_Parameter_Specification (Loc,
4418 Defining_Identifier => Rev,
4420 New_Occurrence_Of (Standard_Boolean, Loc)));
4423 Make_Procedure_Specification (Loc,
4424 Defining_Unit_Name => Proc_Name,
4425 Parameter_Specifications => Formals);
4428 Make_Subprogram_Body (Loc,
4429 Specification => Spec,
4430 Declarations => Decls,
4431 Handled_Statement_Sequence =>
4432 Make_Handled_Sequence_Of_Statements (Loc,
4433 Statements => Stats)));
4436 Set_TSS (Typ, Proc_Name);
4437 Set_Is_Pure (Proc_Name);
4438 end Build_Slice_Assignment;
4440 -----------------------------
4441 -- Build_Untagged_Equality --
4442 -----------------------------
4444 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4452 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4453 -- Check whether the type T has a user-defined primitive equality. If so
4454 -- return it, else return Empty. If true for a component of Typ, we have
4455 -- to build the primitive equality for it.
4457 ---------------------
4458 -- User_Defined_Eq --
4459 ---------------------
4461 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4466 Op := TSS (T, TSS_Composite_Equality);
4468 if Present (Op) then
4472 Prim := First_Elmt (Collect_Primitive_Operations (T));
4473 while Present (Prim) loop
4476 if Chars (Op) = Name_Op_Eq
4477 and then Etype (Op) = Standard_Boolean
4478 and then Etype (First_Formal (Op)) = T
4479 and then Etype (Next_Formal (First_Formal (Op))) = T
4488 end User_Defined_Eq;
4490 -- Start of processing for Build_Untagged_Equality
4493 -- If a record component has a primitive equality operation, we must
4494 -- build the corresponding one for the current type.
4497 Comp := First_Component (Typ);
4498 while Present (Comp) loop
4499 if Is_Record_Type (Etype (Comp))
4500 and then Present (User_Defined_Eq (Etype (Comp)))
4505 Next_Component (Comp);
4508 -- If there is a user-defined equality for the type, we do not create
4509 -- the implicit one.
4511 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
4513 while Present (Prim) loop
4514 if Chars (Node (Prim)) = Name_Op_Eq
4515 and then Comes_From_Source (Node (Prim))
4517 -- Don't we also need to check formal types and return type as in
4518 -- User_Defined_Eq above???
4521 Eq_Op := Node (Prim);
4529 -- If the type is derived, inherit the operation, if present, from the
4530 -- parent type. It may have been declared after the type derivation. If
4531 -- the parent type itself is derived, it may have inherited an operation
4532 -- that has itself been overridden, so update its alias and related
4533 -- flags. Ditto for inequality.
4535 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4536 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
4537 while Present (Prim) loop
4538 if Chars (Node (Prim)) = Name_Op_Eq then
4539 Copy_TSS (Node (Prim), Typ);
4543 Op : constant Entity_Id := User_Defined_Eq (Typ);
4544 Eq_Op : constant Entity_Id := Node (Prim);
4545 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4548 if Present (Op) then
4549 Set_Alias (Op, Eq_Op);
4550 Set_Is_Abstract_Subprogram
4551 (Op, Is_Abstract_Subprogram (Eq_Op));
4553 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4554 Set_Is_Abstract_Subprogram
4555 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4567 -- If not inherited and not user-defined, build body as for a type with
4568 -- tagged components.
4572 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4573 Op := Defining_Entity (Decl);
4577 if Is_Library_Level_Entity (Typ) then
4581 end Build_Untagged_Equality;
4583 -----------------------------------
4584 -- Build_Variant_Record_Equality --
4585 -----------------------------------
4589 -- function <<Body_Id>> (Left, Right : T) return Boolean is
4590 -- [ X : T renames Left; ]
4591 -- [ Y : T renames Right; ]
4592 -- -- The above renamings are generated only if the parameters of
4593 -- -- this built function (which are passed by the caller) are not
4594 -- -- named 'X' and 'Y'; these names are required to reuse several
4595 -- -- expander routines when generating this body.
4598 -- -- Compare discriminants
4600 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4604 -- -- Compare components
4606 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4610 -- -- Compare variant part
4614 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4619 -- if X.Cn /= Y.Cn or else ... then
4627 function Build_Variant_Record_Equality
4629 Body_Id : Entity_Id;
4630 Param_Specs : List_Id) return Node_Id
4632 Loc : constant Source_Ptr := Sloc (Typ);
4633 Def : constant Node_Id := Parent (Typ);
4634 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4635 Left : constant Entity_Id := Defining_Identifier (First (Param_Specs));
4636 Right : constant Entity_Id :=
4637 Defining_Identifier (Next (First (Param_Specs)));
4638 Decls : constant List_Id := New_List;
4639 Stmts : constant List_Id := New_List;
4641 Subp_Body : Node_Id;
4644 pragma Assert (not Is_Tagged_Type (Typ));
4646 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
4647 -- the name of the formals must be X and Y; otherwise we generate two
4648 -- renaming declarations for such purpose.
4650 if Chars (Left) /= Name_X then
4652 Make_Object_Renaming_Declaration (Loc,
4653 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
4654 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4655 Name => Make_Identifier (Loc, Chars (Left))));
4658 if Chars (Right) /= Name_Y then
4660 Make_Object_Renaming_Declaration (Loc,
4661 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
4662 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4663 Name => Make_Identifier (Loc, Chars (Right))));
4666 -- Unchecked_Unions require additional machinery to support equality.
4667 -- Two extra parameters (A and B) are added to the equality function
4668 -- parameter list for each discriminant of the type, in order to
4669 -- capture the inferred values of the discriminants in equality calls.
4670 -- The names of the parameters match the names of the corresponding
4671 -- discriminant, with an added suffix.
4673 if Is_Unchecked_Union (Typ) then
4678 Discr_Type : Entity_Id;
4679 New_Discrs : Elist_Id;
4682 New_Discrs := New_Elmt_List;
4684 Discr := First_Discriminant (Typ);
4685 while Present (Discr) loop
4686 Discr_Type := Etype (Discr);
4689 Make_Defining_Identifier (Loc,
4690 Chars => New_External_Name (Chars (Discr), 'A'));
4693 Make_Defining_Identifier (Loc,
4694 Chars => New_External_Name (Chars (Discr), 'B'));
4696 -- Add new parameters to the parameter list
4698 Append_To (Param_Specs,
4699 Make_Parameter_Specification (Loc,
4700 Defining_Identifier => A,
4702 New_Occurrence_Of (Discr_Type, Loc)));
4704 Append_To (Param_Specs,
4705 Make_Parameter_Specification (Loc,
4706 Defining_Identifier => B,
4708 New_Occurrence_Of (Discr_Type, Loc)));
4710 Append_Elmt (A, New_Discrs);
4712 -- Generate the following code to compare each of the inferred
4720 Make_If_Statement (Loc,
4723 Left_Opnd => New_Occurrence_Of (A, Loc),
4724 Right_Opnd => New_Occurrence_Of (B, Loc)),
4725 Then_Statements => New_List (
4726 Make_Simple_Return_Statement (Loc,
4728 New_Occurrence_Of (Standard_False, Loc)))));
4729 Next_Discriminant (Discr);
4732 -- Generate component-by-component comparison. Note that we must
4733 -- propagate the inferred discriminants formals to act as the case
4734 -- statement switch. Their value is added when an equality call on
4735 -- unchecked unions is expanded.
4737 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4740 -- Normal case (not unchecked union)
4744 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4745 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4749 Make_Simple_Return_Statement (Loc,
4750 Expression => New_Occurrence_Of (Standard_True, Loc)));
4753 Make_Subprogram_Body (Loc,
4755 Make_Function_Specification (Loc,
4756 Defining_Unit_Name => Body_Id,
4757 Parameter_Specifications => Param_Specs,
4758 Result_Definition =>
4759 New_Occurrence_Of (Standard_Boolean, Loc)),
4760 Declarations => Decls,
4761 Handled_Statement_Sequence =>
4762 Make_Handled_Sequence_Of_Statements (Loc,
4763 Statements => Stmts));
4766 end Build_Variant_Record_Equality;
4768 -----------------------------
4769 -- Check_Stream_Attributes --
4770 -----------------------------
4772 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4774 Par_Read : constant Boolean :=
4775 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4776 and then not Has_Specified_Stream_Read (Typ);
4777 Par_Write : constant Boolean :=
4778 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4779 and then not Has_Specified_Stream_Write (Typ);
4781 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4782 -- Check that Comp has a user-specified Nam stream attribute
4788 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4790 -- Move this check to sem???
4792 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4793 Error_Msg_Name_1 := Nam;
4795 ("|component& in limited extension must have% attribute", Comp);
4799 -- Start of processing for Check_Stream_Attributes
4802 if Par_Read or else Par_Write then
4803 Comp := First_Component (Typ);
4804 while Present (Comp) loop
4805 if Comes_From_Source (Comp)
4806 and then Original_Record_Component (Comp) = Comp
4807 and then Is_Limited_Type (Etype (Comp))
4810 Check_Attr (Name_Read, TSS_Stream_Read);
4814 Check_Attr (Name_Write, TSS_Stream_Write);
4818 Next_Component (Comp);
4821 end Check_Stream_Attributes;
4823 ----------------------
4824 -- Clean_Task_Names --
4825 ----------------------
4827 procedure Clean_Task_Names
4829 Proc_Id : Entity_Id)
4833 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4834 and then not Global_Discard_Names
4835 and then Tagged_Type_Expansion
4837 Set_Uses_Sec_Stack (Proc_Id);
4839 end Clean_Task_Names;
4841 ----------------------------------------
4842 -- Ensure_Activation_Chain_And_Master --
4843 ----------------------------------------
4845 procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is
4846 Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
4847 Expr : constant Node_Id := Expression (Obj_Decl);
4849 Typ : constant Entity_Id := Etype (Def_Id);
4852 pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration);
4854 if Might_Have_Tasks (Typ) then
4855 Build_Activation_Chain_Entity (Obj_Decl);
4857 if Has_Task (Typ) then
4858 Build_Master_Entity (Def_Id);
4860 -- Handle objects initialized with BIP function calls
4862 elsif Present (Expr) then
4863 if Nkind (Expr) = N_Qualified_Expression then
4864 Expr_Q := Expression (Expr);
4869 if Is_Build_In_Place_Function_Call (Expr_Q)
4870 or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
4872 (Nkind (Expr_Q) = N_Reference
4874 Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
4876 Build_Master_Entity (Def_Id);
4880 end Ensure_Activation_Chain_And_Master;
4882 ------------------------------
4883 -- Expand_Freeze_Array_Type --
4884 ------------------------------
4886 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4887 Typ : constant Entity_Id := Entity (N);
4888 Base : constant Entity_Id := Base_Type (Typ);
4889 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4892 if not Is_Bit_Packed_Array (Typ) then
4894 -- If the component contains tasks, so does the array type. This may
4895 -- not be indicated in the array type because the component may have
4896 -- been a private type at the point of definition. Same if component
4897 -- type is controlled or contains protected objects.
4899 Propagate_Concurrent_Flags (Base, Comp_Typ);
4900 Set_Has_Controlled_Component
4901 (Base, Has_Controlled_Component (Comp_Typ)
4902 or else Is_Controlled (Comp_Typ));
4904 if No (Init_Proc (Base)) then
4906 -- If this is an anonymous array created for a declaration with
4907 -- an initial value, its init_proc will never be called. The
4908 -- initial value itself may have been expanded into assignments,
4909 -- in which case the object declaration is carries the
4910 -- No_Initialization flag.
4913 and then Nkind (Associated_Node_For_Itype (Base)) =
4914 N_Object_Declaration
4916 (Present (Expression (Associated_Node_For_Itype (Base)))
4917 or else No_Initialization (Associated_Node_For_Itype (Base)))
4921 -- We do not need an init proc for string or wide [wide] string,
4922 -- since the only time these need initialization in normalize or
4923 -- initialize scalars mode, and these types are treated specially
4924 -- and do not need initialization procedures.
4926 elsif Is_Standard_String_Type (Base) then
4929 -- Otherwise we have to build an init proc for the subtype
4932 Build_Array_Init_Proc (Base, N);
4936 if Typ = Base and then Has_Controlled_Component (Base) then
4937 Build_Controlling_Procs (Base);
4939 if not Is_Limited_Type (Comp_Typ)
4940 and then Number_Dimensions (Typ) = 1
4942 Build_Slice_Assignment (Typ);
4946 -- For packed case, default initialization, except if the component type
4947 -- is itself a packed structure with an initialization procedure, or
4948 -- initialize/normalize scalars active, and we have a base type, or the
4949 -- type is public, because in that case a client might specify
4950 -- Normalize_Scalars and there better be a public Init_Proc for it.
4952 elsif (Present (Init_Proc (Component_Type (Base)))
4953 and then No (Base_Init_Proc (Base)))
4954 or else (Init_Or_Norm_Scalars and then Base = Typ)
4955 or else Is_Public (Typ)
4957 Build_Array_Init_Proc (Base, N);
4959 end Expand_Freeze_Array_Type;
4961 -----------------------------------
4962 -- Expand_Freeze_Class_Wide_Type --
4963 -----------------------------------
4965 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4966 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4967 -- Given a type, determine whether it is derived from a C or C++ root
4969 ---------------------
4970 -- Is_C_Derivation --
4971 ---------------------
4973 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4980 or else Convention (T) = Convention_C
4981 or else Convention (T) = Convention_CPP
4986 exit when T = Etype (T);
4992 end Is_C_Derivation;
4996 Typ : constant Entity_Id := Entity (N);
4997 Root : constant Entity_Id := Root_Type (Typ);
4999 -- Start of processing for Expand_Freeze_Class_Wide_Type
5002 -- Certain run-time configurations and targets do not provide support
5003 -- for controlled types.
5005 if Restriction_Active (No_Finalization) then
5008 -- Do not create TSS routine Finalize_Address when dispatching calls are
5009 -- disabled since the core of the routine is a dispatching call.
5011 elsif Restriction_Active (No_Dispatching_Calls) then
5014 -- Do not create TSS routine Finalize_Address for concurrent class-wide
5015 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
5016 -- non-Ada side will handle their destruction.
5018 elsif Is_Concurrent_Type (Root)
5019 or else Is_C_Derivation (Root)
5020 or else Convention (Typ) = Convention_CPP
5024 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
5025 -- mode since the routine contains an Unchecked_Conversion.
5027 elsif CodePeer_Mode then
5031 -- Create the body of TSS primitive Finalize_Address. This automatically
5032 -- sets the TSS entry for the class-wide type.
5034 Make_Finalize_Address_Body (Typ);
5035 end Expand_Freeze_Class_Wide_Type;
5037 ------------------------------------
5038 -- Expand_Freeze_Enumeration_Type --
5039 ------------------------------------
5041 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
5042 Typ : constant Entity_Id := Entity (N);
5043 Loc : constant Source_Ptr := Sloc (Typ);
5048 Is_Contiguous : Boolean;
5049 Index_Typ : Entity_Id;
5057 pragma Warnings (Off, Func);
5060 -- Various optimizations possible if given representation is contiguous
5062 Is_Contiguous := True;
5064 Ent := First_Literal (Typ);
5065 Last_Repval := Enumeration_Rep (Ent);
5069 while Present (Ent) loop
5070 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
5071 Is_Contiguous := False;
5073 Last_Repval := Enumeration_Rep (Ent);
5080 if Is_Contiguous then
5081 Set_Has_Contiguous_Rep (Typ);
5083 -- Now build a subtype declaration
5085 -- subtype typI is new Natural range 0 .. num - 1
5088 Make_Defining_Identifier (Loc,
5089 Chars => New_External_Name (Chars (Typ), 'I'));
5091 Append_Freeze_Action (Typ,
5092 Make_Subtype_Declaration (Loc,
5093 Defining_Identifier => Index_Typ,
5094 Subtype_Indication =>
5095 Make_Subtype_Indication (Loc,
5097 New_Occurrence_Of (Standard_Natural, Loc),
5099 Make_Range_Constraint (Loc,
5103 Make_Integer_Literal (Loc, 0),
5105 Make_Integer_Literal (Loc, Num - 1))))));
5107 Set_Enum_Pos_To_Rep (Typ, Index_Typ);
5110 -- Build list of literal references
5113 Ent := First_Literal (Typ);
5114 while Present (Ent) loop
5115 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
5119 -- Now build an array declaration
5121 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5122 -- (v, v, v, v, v, ....)
5125 Make_Defining_Identifier (Loc,
5126 Chars => New_External_Name (Chars (Typ), 'A'));
5128 Append_Freeze_Action (Typ,
5129 Make_Object_Declaration (Loc,
5130 Defining_Identifier => Arr,
5131 Constant_Present => True,
5133 Object_Definition =>
5134 Make_Constrained_Array_Definition (Loc,
5135 Discrete_Subtype_Definitions => New_List (
5136 Make_Subtype_Indication (Loc,
5138 New_Occurrence_Of (Standard_Natural, Loc),
5140 Make_Range_Constraint (Loc,
5144 Make_Integer_Literal (Loc, 0),
5146 Make_Integer_Literal (Loc, Num - 1))))),
5148 Component_Definition =>
5149 Make_Component_Definition (Loc,
5150 Aliased_Present => False,
5151 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
5154 Make_Aggregate (Loc,
5155 Expressions => Lst)));
5157 Set_Enum_Pos_To_Rep (Typ, Arr);
5160 -- Now we build the function that converts representation values to
5161 -- position values. This function has the form:
5163 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5166 -- when enum-lit'Enum_Rep => return posval;
5167 -- when enum-lit'Enum_Rep => return posval;
5170 -- [raise Constraint_Error when F "invalid data"]
5175 -- Note: the F parameter determines whether the others case (no valid
5176 -- representation) raises Constraint_Error or returns a unique value
5177 -- of minus one. The latter case is used, e.g. in 'Valid code.
5179 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5180 -- the code generator making inappropriate assumptions about the range
5181 -- of the values in the case where the value is invalid. ityp is a
5182 -- signed or unsigned integer type of appropriate width.
5184 -- Note: if exceptions are not supported, then we suppress the raise
5185 -- and return -1 unconditionally (this is an erroneous program in any
5186 -- case and there is no obligation to raise Constraint_Error here). We
5187 -- also do this if pragma Restrictions (No_Exceptions) is active.
5189 -- Is this right??? What about No_Exception_Propagation???
5191 -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly
5192 -- because it might have been inherited from the parent type.
5194 if Enumeration_Rep (First_Literal (Typ)) < 0 then
5195 Set_Is_Unsigned_Type (Typ, False);
5198 Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ));
5200 -- The body of the function is a case statement. First collect case
5201 -- alternatives, or optimize the contiguous case.
5205 -- If representation is contiguous, Pos is computed by subtracting
5206 -- the representation of the first literal.
5208 if Is_Contiguous then
5209 Ent := First_Literal (Typ);
5211 if Enumeration_Rep (Ent) = Last_Repval then
5213 -- Another special case: for a single literal, Pos is zero
5215 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
5219 Convert_To (Standard_Integer,
5220 Make_Op_Subtract (Loc,
5222 Unchecked_Convert_To
5223 (Ityp, Make_Identifier (Loc, Name_uA)),
5225 Make_Integer_Literal (Loc,
5226 Intval => Enumeration_Rep (First_Literal (Typ)))));
5230 Make_Case_Statement_Alternative (Loc,
5231 Discrete_Choices => New_List (
5232 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
5234 Make_Integer_Literal (Loc,
5235 Intval => Enumeration_Rep (Ent)),
5237 Make_Integer_Literal (Loc, Intval => Last_Repval))),
5239 Statements => New_List (
5240 Make_Simple_Return_Statement (Loc,
5241 Expression => Pos_Expr))));
5244 Ent := First_Literal (Typ);
5245 while Present (Ent) loop
5247 Make_Case_Statement_Alternative (Loc,
5248 Discrete_Choices => New_List (
5249 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
5250 Intval => Enumeration_Rep (Ent))),
5252 Statements => New_List (
5253 Make_Simple_Return_Statement (Loc,
5255 Make_Integer_Literal (Loc,
5256 Intval => Enumeration_Pos (Ent))))));
5262 -- In normal mode, add the others clause with the test.
5263 -- If Predicates_Ignored is True, validity checks do not apply to
5266 if not No_Exception_Handlers_Set
5267 and then not Predicates_Ignored (Typ)
5270 Make_Case_Statement_Alternative (Loc,
5271 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5272 Statements => New_List (
5273 Make_Raise_Constraint_Error (Loc,
5274 Condition => Make_Identifier (Loc, Name_uF),
5275 Reason => CE_Invalid_Data),
5276 Make_Simple_Return_Statement (Loc,
5277 Expression => Make_Integer_Literal (Loc, -1)))));
5279 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5280 -- active then return -1 (we cannot usefully raise Constraint_Error in
5281 -- this case). See description above for further details.
5285 Make_Case_Statement_Alternative (Loc,
5286 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5287 Statements => New_List (
5288 Make_Simple_Return_Statement (Loc,
5289 Expression => Make_Integer_Literal (Loc, -1)))));
5292 -- Now we can build the function body
5295 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
5298 Make_Subprogram_Body (Loc,
5300 Make_Function_Specification (Loc,
5301 Defining_Unit_Name => Fent,
5302 Parameter_Specifications => New_List (
5303 Make_Parameter_Specification (Loc,
5304 Defining_Identifier =>
5305 Make_Defining_Identifier (Loc, Name_uA),
5306 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5307 Make_Parameter_Specification (Loc,
5308 Defining_Identifier =>
5309 Make_Defining_Identifier (Loc, Name_uF),
5311 New_Occurrence_Of (Standard_Boolean, Loc))),
5313 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
5315 Declarations => Empty_List,
5317 Handled_Statement_Sequence =>
5318 Make_Handled_Sequence_Of_Statements (Loc,
5319 Statements => New_List (
5320 Make_Case_Statement (Loc,
5322 Unchecked_Convert_To
5323 (Ityp, Make_Identifier (Loc, Name_uA)),
5324 Alternatives => Lst))));
5326 Set_TSS (Typ, Fent);
5328 -- Set Pure flag (it will be reset if the current context is not Pure).
5329 -- We also pretend there was a pragma Pure_Function so that for purposes
5330 -- of optimization and constant-folding, we will consider the function
5331 -- Pure even if we are not in a Pure context).
5334 Set_Has_Pragma_Pure_Function (Fent);
5336 -- Unless we are in -gnatD mode, where we are debugging generated code,
5337 -- this is an internal entity for which we don't need debug info.
5339 if not Debug_Generated_Code then
5340 Set_Debug_Info_Off (Fent);
5343 Set_Is_Inlined (Fent);
5346 when RE_Not_Available =>
5348 end Expand_Freeze_Enumeration_Type;
5350 -------------------------------
5351 -- Expand_Freeze_Record_Type --
5352 -------------------------------
5354 procedure Expand_Freeze_Record_Type (N : Node_Id) is
5355 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
5356 -- Create An Equality function for the untagged variant record Typ and
5357 -- attach it to the TSS list.
5359 -----------------------------------
5360 -- Build_Variant_Record_Equality --
5361 -----------------------------------
5363 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
5364 Loc : constant Source_Ptr := Sloc (Typ);
5365 F : constant Entity_Id :=
5366 Make_Defining_Identifier (Loc,
5367 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
5369 -- For a variant record with restriction No_Implicit_Conditionals
5370 -- in effect we skip building the procedure. This is safe because
5371 -- if we can see the restriction, so can any caller, and calls to
5372 -- equality test routines are not allowed for variant records if
5373 -- this restriction is active.
5375 if Restriction_Active (No_Implicit_Conditionals) then
5379 -- Derived Unchecked_Union types no longer inherit the equality
5380 -- function of their parent.
5382 if Is_Derived_Type (Typ)
5383 and then not Is_Unchecked_Union (Typ)
5384 and then not Has_New_Non_Standard_Rep (Typ)
5387 Parent_Eq : constant Entity_Id :=
5388 TSS (Root_Type (Typ), TSS_Composite_Equality);
5390 if Present (Parent_Eq) then
5391 Copy_TSS (Parent_Eq, Typ);
5398 Build_Variant_Record_Equality
5401 Param_Specs => New_List (
5402 Make_Parameter_Specification (Loc,
5403 Defining_Identifier =>
5404 Make_Defining_Identifier (Loc, Name_X),
5405 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5407 Make_Parameter_Specification (Loc,
5408 Defining_Identifier =>
5409 Make_Defining_Identifier (Loc, Name_Y),
5410 Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
5415 if not Debug_Generated_Code then
5416 Set_Debug_Info_Off (F);
5418 end Build_Variant_Record_Equality;
5422 Typ : constant Node_Id := Entity (N);
5423 Typ_Decl : constant Node_Id := Parent (Typ);
5426 Comp_Typ : Entity_Id;
5427 Predef_List : List_Id;
5429 Wrapper_Decl_List : List_Id := No_List;
5430 Wrapper_Body_List : List_Id := No_List;
5432 Renamed_Eq : Node_Id := Empty;
5433 -- Defining unit name for the predefined equality function in the case
5434 -- where the type has a primitive operation that is a renaming of
5435 -- predefined equality (but only if there is also an overriding
5436 -- user-defined equality function). Used to pass this entity from
5437 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
5439 -- Start of processing for Expand_Freeze_Record_Type
5442 -- Build discriminant checking functions if not a derived type (for
5443 -- derived types that are not tagged types, always use the discriminant
5444 -- checking functions of the parent type). However, for untagged types
5445 -- the derivation may have taken place before the parent was frozen, so
5446 -- we copy explicitly the discriminant checking functions from the
5447 -- parent into the components of the derived type.
5449 if not Is_Derived_Type (Typ)
5450 or else Has_New_Non_Standard_Rep (Typ)
5451 or else Is_Tagged_Type (Typ)
5453 Build_Discr_Checking_Funcs (Typ_Decl);
5455 elsif Is_Derived_Type (Typ)
5456 and then not Is_Tagged_Type (Typ)
5458 -- If we have a derived Unchecked_Union, we do not inherit the
5459 -- discriminant checking functions from the parent type since the
5460 -- discriminants are non existent.
5462 and then not Is_Unchecked_Union (Typ)
5463 and then Has_Discriminants (Typ)
5466 Old_Comp : Entity_Id;
5470 First_Component (Base_Type (Underlying_Type (Etype (Typ))));
5471 Comp := First_Component (Typ);
5472 while Present (Comp) loop
5473 if Chars (Comp) = Chars (Old_Comp) then
5474 Set_Discriminant_Checking_Func
5475 (Comp, Discriminant_Checking_Func (Old_Comp));
5478 Next_Component (Old_Comp);
5479 Next_Component (Comp);
5484 if Is_Derived_Type (Typ)
5485 and then Is_Limited_Type (Typ)
5486 and then Is_Tagged_Type (Typ)
5488 Check_Stream_Attributes (Typ);
5491 -- Update task, protected, and controlled component flags, because some
5492 -- of the component types may have been private at the point of the
5493 -- record declaration. Detect anonymous access-to-controlled components.
5495 Comp := First_Component (Typ);
5496 while Present (Comp) loop
5497 Comp_Typ := Etype (Comp);
5499 Propagate_Concurrent_Flags (Typ, Comp_Typ);
5501 -- Do not set Has_Controlled_Component on a class-wide equivalent
5502 -- type. See Make_CW_Equivalent_Type.
5504 if not Is_Class_Wide_Equivalent_Type (Typ)
5506 (Has_Controlled_Component (Comp_Typ)
5507 or else (Chars (Comp) /= Name_uParent
5508 and then Is_Controlled (Comp_Typ)))
5510 Set_Has_Controlled_Component (Typ);
5513 Next_Component (Comp);
5516 -- Handle constructors of untagged CPP_Class types
5518 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
5519 Set_CPP_Constructors (Typ);
5522 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5523 -- for regular tagged types as well as for Ada types deriving from a C++
5524 -- Class, but not for tagged types directly corresponding to C++ classes
5525 -- In the later case we assume that it is created in the C++ side and we
5528 if Is_Tagged_Type (Typ) then
5530 -- Add the _Tag component
5532 if Underlying_Type (Etype (Typ)) = Typ then
5533 Expand_Tagged_Root (Typ);
5536 if Is_CPP_Class (Typ) then
5537 Set_All_DT_Position (Typ);
5539 -- Create the tag entities with a minimum decoration
5541 if Tagged_Type_Expansion then
5542 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5545 Set_CPP_Constructors (Typ);
5548 if not Building_Static_DT (Typ) then
5550 -- Usually inherited primitives are not delayed but the first
5551 -- Ada extension of a CPP_Class is an exception since the
5552 -- address of the inherited subprogram has to be inserted in
5553 -- the new Ada Dispatch Table and this is a freezing action.
5555 -- Similarly, if this is an inherited operation whose parent is
5556 -- not frozen yet, it is not in the DT of the parent, and we
5557 -- generate an explicit freeze node for the inherited operation
5558 -- so it is properly inserted in the DT of the current type.
5565 Elmt := First_Elmt (Primitive_Operations (Typ));
5566 while Present (Elmt) loop
5567 Subp := Node (Elmt);
5569 if Present (Alias (Subp)) then
5570 if Is_CPP_Class (Etype (Typ)) then
5571 Set_Has_Delayed_Freeze (Subp);
5573 elsif Has_Delayed_Freeze (Alias (Subp))
5574 and then not Is_Frozen (Alias (Subp))
5576 Set_Is_Frozen (Subp, False);
5577 Set_Has_Delayed_Freeze (Subp);
5586 -- Unfreeze momentarily the type to add the predefined primitives
5587 -- operations. The reason we unfreeze is so that these predefined
5588 -- operations will indeed end up as primitive operations (which
5589 -- must be before the freeze point).
5591 Set_Is_Frozen (Typ, False);
5593 -- Do not add the spec of predefined primitives in case of
5594 -- CPP tagged type derivations that have convention CPP.
5596 if Is_CPP_Class (Root_Type (Typ))
5597 and then Convention (Typ) = Convention_CPP
5601 -- Do not add the spec of the predefined primitives if we are
5602 -- compiling under restriction No_Dispatching_Calls.
5604 elsif not Restriction_Active (No_Dispatching_Calls) then
5605 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
5606 Insert_List_Before_And_Analyze (N, Predef_List);
5609 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5610 -- wrapper functions for each nonoverridden inherited function
5611 -- with a controlling result of the type. The wrapper for such
5612 -- a function returns an extension aggregate that invokes the
5615 if Ada_Version >= Ada_2005
5616 and then not Is_Abstract_Type (Typ)
5617 and then Is_Null_Extension (Typ)
5619 Make_Controlling_Function_Wrappers
5620 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
5621 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5624 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5625 -- null procedure declarations for each set of homographic null
5626 -- procedures that are inherited from interface types but not
5627 -- overridden. This is done to ensure that the dispatch table
5628 -- entry associated with such null primitives are properly filled.
5630 if Ada_Version >= Ada_2005
5631 and then Etype (Typ) /= Typ
5632 and then not Is_Abstract_Type (Typ)
5633 and then Has_Interfaces (Typ)
5635 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
5638 Set_Is_Frozen (Typ);
5640 if not Is_Derived_Type (Typ)
5641 or else Is_Tagged_Type (Etype (Typ))
5643 Set_All_DT_Position (Typ);
5645 -- If this is a type derived from an untagged private type whose
5646 -- full view is tagged, the type is marked tagged for layout
5647 -- reasons, but it has no dispatch table.
5649 elsif Is_Derived_Type (Typ)
5650 and then Is_Private_Type (Etype (Typ))
5651 and then not Is_Tagged_Type (Etype (Typ))
5656 -- Create and decorate the tags. Suppress their creation when
5657 -- not Tagged_Type_Expansion because the dispatching mechanism is
5658 -- handled internally by the virtual target.
5660 if Tagged_Type_Expansion then
5661 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5663 -- Generate dispatch table of locally defined tagged type.
5664 -- Dispatch tables of library level tagged types are built
5665 -- later (see Analyze_Declarations).
5667 if not Building_Static_DT (Typ) then
5668 Append_Freeze_Actions (Typ, Make_DT (Typ));
5672 -- If the type has unknown discriminants, propagate dispatching
5673 -- information to its underlying record view, which does not get
5674 -- its own dispatch table.
5676 if Is_Derived_Type (Typ)
5677 and then Has_Unknown_Discriminants (Typ)
5678 and then Present (Underlying_Record_View (Typ))
5681 Rep : constant Entity_Id := Underlying_Record_View (Typ);
5683 Set_Access_Disp_Table
5684 (Rep, Access_Disp_Table (Typ));
5685 Set_Dispatch_Table_Wrappers
5686 (Rep, Dispatch_Table_Wrappers (Typ));
5687 Set_Direct_Primitive_Operations
5688 (Rep, Direct_Primitive_Operations (Typ));
5692 -- Make sure that the primitives Initialize, Adjust and Finalize
5693 -- are Frozen before other TSS subprograms. We don't want them
5696 if Is_Controlled (Typ) then
5697 if not Is_Limited_Type (Typ) then
5698 Append_Freeze_Actions (Typ,
5699 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
5702 Append_Freeze_Actions (Typ,
5703 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
5705 Append_Freeze_Actions (Typ,
5706 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
5709 -- Freeze rest of primitive operations. There is no need to handle
5710 -- the predefined primitives if we are compiling under restriction
5711 -- No_Dispatching_Calls.
5713 if not Restriction_Active (No_Dispatching_Calls) then
5714 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5718 -- In the untagged case, ever since Ada 83 an equality function must
5719 -- be provided for variant records that are not unchecked unions.
5720 -- In Ada 2012 the equality function composes, and thus must be built
5721 -- explicitly just as for tagged records.
5723 elsif Has_Discriminants (Typ)
5724 and then not Is_Limited_Type (Typ)
5727 Comps : constant Node_Id :=
5728 Component_List (Type_Definition (Typ_Decl));
5731 and then Present (Variant_Part (Comps))
5733 Build_Variant_Record_Equality (Typ);
5737 -- Otherwise create primitive equality operation (AI05-0123)
5739 -- This is done unconditionally to ensure that tools can be linked
5740 -- properly with user programs compiled with older language versions.
5741 -- In addition, this is needed because "=" composes for bounded strings
5742 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5744 elsif Comes_From_Source (Typ)
5745 and then Convention (Typ) = Convention_Ada
5746 and then not Is_Limited_Type (Typ)
5748 Build_Untagged_Equality (Typ);
5751 -- Before building the record initialization procedure, if we are
5752 -- dealing with a concurrent record value type, then we must go through
5753 -- the discriminants, exchanging discriminals between the concurrent
5754 -- type and the concurrent record value type. See the section "Handling
5755 -- of Discriminants" in the Einfo spec for details.
5757 if Is_Concurrent_Record_Type (Typ)
5758 and then Has_Discriminants (Typ)
5761 Ctyp : constant Entity_Id :=
5762 Corresponding_Concurrent_Type (Typ);
5763 Conc_Discr : Entity_Id;
5764 Rec_Discr : Entity_Id;
5768 Conc_Discr := First_Discriminant (Ctyp);
5769 Rec_Discr := First_Discriminant (Typ);
5770 while Present (Conc_Discr) loop
5771 Temp := Discriminal (Conc_Discr);
5772 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5773 Set_Discriminal (Rec_Discr, Temp);
5775 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5776 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5778 Next_Discriminant (Conc_Discr);
5779 Next_Discriminant (Rec_Discr);
5784 if Has_Controlled_Component (Typ) then
5785 Build_Controlling_Procs (Typ);
5788 Adjust_Discriminants (Typ);
5790 -- Do not need init for interfaces on virtual targets since they're
5793 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5794 Build_Record_Init_Proc (Typ_Decl, Typ);
5797 -- For tagged type that are not interfaces, build bodies of primitive
5798 -- operations. Note: do this after building the record initialization
5799 -- procedure, since the primitive operations may need the initialization
5800 -- routine. There is no need to add predefined primitives of interfaces
5801 -- because all their predefined primitives are abstract.
5803 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5805 -- Do not add the body of predefined primitives in case of CPP tagged
5806 -- type derivations that have convention CPP.
5808 if Is_CPP_Class (Root_Type (Typ))
5809 and then Convention (Typ) = Convention_CPP
5813 -- Do not add the body of the predefined primitives if we are
5814 -- compiling under restriction No_Dispatching_Calls or if we are
5815 -- compiling a CPP tagged type.
5817 elsif not Restriction_Active (No_Dispatching_Calls) then
5819 -- Create the body of TSS primitive Finalize_Address. This must
5820 -- be done before the bodies of all predefined primitives are
5821 -- created. If Typ is limited, Stream_Input and Stream_Read may
5822 -- produce build-in-place allocations and for those the expander
5823 -- needs Finalize_Address.
5825 Make_Finalize_Address_Body (Typ);
5826 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5827 Append_Freeze_Actions (Typ, Predef_List);
5830 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5831 -- inherited functions, then add their bodies to the freeze actions.
5833 if Present (Wrapper_Body_List) then
5834 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5837 -- Create extra formals for the primitive operations of the type.
5838 -- This must be done before analyzing the body of the initialization
5839 -- procedure, because a self-referential type might call one of these
5840 -- primitives in the body of the init_proc itself.
5847 Elmt := First_Elmt (Primitive_Operations (Typ));
5848 while Present (Elmt) loop
5849 Subp := Node (Elmt);
5850 if not Has_Foreign_Convention (Subp)
5851 and then not Is_Predefined_Dispatching_Operation (Subp)
5853 Create_Extra_Formals (Subp);
5860 end Expand_Freeze_Record_Type;
5862 ------------------------------------
5863 -- Expand_N_Full_Type_Declaration --
5864 ------------------------------------
5866 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5867 procedure Build_Master (Ptr_Typ : Entity_Id);
5868 -- Create the master associated with Ptr_Typ
5874 procedure Build_Master (Ptr_Typ : Entity_Id) is
5875 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5878 -- If the designated type is an incomplete view coming from a
5879 -- limited-with'ed package, we need to use the nonlimited view in
5880 -- case it has tasks.
5882 if Is_Incomplete_Type (Desig_Typ)
5883 and then Present (Non_Limited_View (Desig_Typ))
5885 Desig_Typ := Non_Limited_View (Desig_Typ);
5888 -- Anonymous access types are created for the components of the
5889 -- record parameter for an entry declaration. No master is created
5892 if Has_Task (Desig_Typ) then
5893 Build_Master_Entity (Ptr_Typ);
5894 Build_Master_Renaming (Ptr_Typ);
5896 -- Create a class-wide master because a Master_Id must be generated
5897 -- for access-to-limited-class-wide types whose root may be extended
5898 -- with task components.
5900 -- Note: This code covers access-to-limited-interfaces because they
5901 -- can be used to reference tasks implementing them.
5903 -- Suppress the master creation for access types created for entry
5904 -- formal parameters (parameter block component types). Seems like
5905 -- suppression should be more general for compiler-generated types,
5906 -- but testing Comes_From_Source may be too general in this case
5907 -- (affects some test output)???
5909 elsif not Is_Param_Block_Component_Type (Ptr_Typ)
5910 and then Is_Limited_Class_Wide_Type (Desig_Typ)
5912 Build_Class_Wide_Master (Ptr_Typ);
5916 -- Local declarations
5918 Def_Id : constant Entity_Id := Defining_Identifier (N);
5919 B_Id : constant Entity_Id := Base_Type (Def_Id);
5923 -- Start of processing for Expand_N_Full_Type_Declaration
5926 if Is_Access_Type (Def_Id) then
5927 Build_Master (Def_Id);
5929 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5930 Expand_Access_Protected_Subprogram_Type (N);
5933 -- Array of anonymous access-to-task pointers
5935 elsif Ada_Version >= Ada_2005
5936 and then Is_Array_Type (Def_Id)
5937 and then Is_Access_Type (Component_Type (Def_Id))
5938 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5940 Build_Master (Component_Type (Def_Id));
5942 elsif Has_Task (Def_Id) then
5943 Expand_Previous_Access_Type (Def_Id);
5945 -- Check the components of a record type or array of records for
5946 -- anonymous access-to-task pointers.
5948 elsif Ada_Version >= Ada_2005
5949 and then (Is_Record_Type (Def_Id)
5951 (Is_Array_Type (Def_Id)
5952 and then Is_Record_Type (Component_Type (Def_Id))))
5957 M_Id : Entity_Id := Empty;
5961 if Is_Array_Type (Def_Id) then
5962 Comp := First_Entity (Component_Type (Def_Id));
5964 Comp := First_Entity (Def_Id);
5967 -- Examine all components looking for anonymous access-to-task
5971 while Present (Comp) loop
5972 Typ := Etype (Comp);
5974 if Ekind (Typ) = E_Anonymous_Access_Type
5975 and then Might_Have_Tasks
5976 (Available_View (Designated_Type (Typ)))
5977 and then No (Master_Id (Typ))
5979 -- Ensure that the record or array type have a _master
5982 Build_Master_Entity (Def_Id);
5983 Build_Master_Renaming (Typ);
5984 M_Id := Master_Id (Typ);
5988 -- Reuse the same master to service any additional types
5991 pragma Assert (Present (M_Id));
5992 Set_Master_Id (Typ, M_Id);
6001 Par_Id := Etype (B_Id);
6003 -- The parent type is private then we need to inherit any TSS operations
6004 -- from the full view.
6006 if Is_Private_Type (Par_Id)
6007 and then Present (Full_View (Par_Id))
6009 Par_Id := Base_Type (Full_View (Par_Id));
6012 if Nkind (Type_Definition (Original_Node (N))) =
6013 N_Derived_Type_Definition
6014 and then not Is_Tagged_Type (Def_Id)
6015 and then Present (Freeze_Node (Par_Id))
6016 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
6018 Ensure_Freeze_Node (B_Id);
6019 FN := Freeze_Node (B_Id);
6021 if No (TSS_Elist (FN)) then
6022 Set_TSS_Elist (FN, New_Elmt_List);
6026 T_E : constant Elist_Id := TSS_Elist (FN);
6030 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
6031 while Present (Elmt) loop
6032 if Chars (Node (Elmt)) /= Name_uInit then
6033 Append_Elmt (Node (Elmt), T_E);
6039 -- If the derived type itself is private with a full view, then
6040 -- associate the full view with the inherited TSS_Elist as well.
6042 if Is_Private_Type (B_Id)
6043 and then Present (Full_View (B_Id))
6045 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
6047 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
6051 end Expand_N_Full_Type_Declaration;
6053 ---------------------------------
6054 -- Expand_N_Object_Declaration --
6055 ---------------------------------
6057 procedure Expand_N_Object_Declaration (N : Node_Id) is
6058 Loc : constant Source_Ptr := Sloc (N);
6059 Def_Id : constant Entity_Id := Defining_Identifier (N);
6060 Expr : constant Node_Id := Expression (N);
6061 Obj_Def : constant Node_Id := Object_Definition (N);
6062 Typ : constant Entity_Id := Etype (Def_Id);
6063 Base_Typ : constant Entity_Id := Base_Type (Typ);
6066 function Build_Equivalent_Aggregate return Boolean;
6067 -- If the object has a constrained discriminated type and no initial
6068 -- value, it may be possible to build an equivalent aggregate instead,
6069 -- and prevent an actual call to the initialization procedure.
6071 procedure Count_Default_Sized_Task_Stacks
6073 Pri_Stacks : out Int;
6074 Sec_Stacks : out Int);
6075 -- Count the number of default-sized primary and secondary task stacks
6076 -- required for task objects contained within type Typ. If the number of
6077 -- task objects contained within the type is not known at compile time
6078 -- the procedure will return the stack counts of zero.
6080 procedure Default_Initialize_Object (After : Node_Id);
6081 -- Generate all default initialization actions for object Def_Id. Any
6082 -- new code is inserted after node After.
6084 function Rewrite_As_Renaming return Boolean;
6085 -- Indicate whether to rewrite a declaration with initialization into an
6086 -- object renaming declaration (see below).
6088 --------------------------------
6089 -- Build_Equivalent_Aggregate --
6090 --------------------------------
6092 function Build_Equivalent_Aggregate return Boolean is
6096 Full_Type : Entity_Id;
6101 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6102 Full_Type := Full_View (Typ);
6105 -- Only perform this transformation if Elaboration_Code is forbidden
6106 -- or undesirable, and if this is a global entity of a constrained
6109 -- If Initialize_Scalars might be active this transformation cannot
6110 -- be performed either, because it will lead to different semantics
6111 -- or because elaboration code will in fact be created.
6113 if Ekind (Full_Type) /= E_Record_Subtype
6114 or else not Has_Discriminants (Full_Type)
6115 or else not Is_Constrained (Full_Type)
6116 or else Is_Controlled (Full_Type)
6117 or else Is_Limited_Type (Full_Type)
6118 or else not Restriction_Active (No_Initialize_Scalars)
6123 if Ekind (Current_Scope) = E_Package
6125 (Restriction_Active (No_Elaboration_Code)
6126 or else Is_Preelaborated (Current_Scope))
6128 -- Building a static aggregate is possible if the discriminants
6129 -- have static values and the other components have static
6130 -- defaults or none.
6132 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6133 while Present (Discr) loop
6134 if not Is_OK_Static_Expression (Node (Discr)) then
6141 -- Check that initialized components are OK, and that non-
6142 -- initialized components do not require a call to their own
6143 -- initialization procedure.
6145 Comp := First_Component (Full_Type);
6146 while Present (Comp) loop
6147 if Present (Expression (Parent (Comp)))
6149 not Is_OK_Static_Expression (Expression (Parent (Comp)))
6153 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
6158 Next_Component (Comp);
6161 -- Everything is static, assemble the aggregate, discriminant
6165 Make_Aggregate (Loc,
6166 Expressions => New_List,
6167 Component_Associations => New_List);
6169 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6170 while Present (Discr) loop
6171 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
6175 -- Now collect values of initialized components
6177 Comp := First_Component (Full_Type);
6178 while Present (Comp) loop
6179 if Present (Expression (Parent (Comp))) then
6180 Append_To (Component_Associations (Aggr),
6181 Make_Component_Association (Loc,
6182 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
6183 Expression => New_Copy_Tree
6184 (Expression (Parent (Comp)))));
6187 Next_Component (Comp);
6190 -- Finally, box-initialize remaining components
6192 Append_To (Component_Associations (Aggr),
6193 Make_Component_Association (Loc,
6194 Choices => New_List (Make_Others_Choice (Loc)),
6195 Expression => Empty));
6196 Set_Box_Present (Last (Component_Associations (Aggr)));
6197 Set_Expression (N, Aggr);
6199 if Typ /= Full_Type then
6200 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
6201 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
6202 Analyze_And_Resolve (Aggr, Typ);
6204 Analyze_And_Resolve (Aggr, Full_Type);
6212 end Build_Equivalent_Aggregate;
6214 -------------------------------------
6215 -- Count_Default_Sized_Task_Stacks --
6216 -------------------------------------
6218 procedure Count_Default_Sized_Task_Stacks
6220 Pri_Stacks : out Int;
6221 Sec_Stacks : out Int)
6223 Component : Entity_Id;
6226 -- To calculate the number of default-sized task stacks required for
6227 -- an object of Typ, a depth-first recursive traversal of the AST
6228 -- from the Typ entity node is undertaken. Only type nodes containing
6229 -- task objects are visited.
6234 if not Has_Task (Typ) then
6242 -- A task type is found marking the bottom of the descent. If
6243 -- the type has no representation aspect for the corresponding
6244 -- stack then that stack is using the default size.
6246 if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then
6252 if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then
6258 when E_Array_Subtype
6261 -- First find the number of default stacks contained within an
6264 Count_Default_Sized_Task_Stacks
6265 (Component_Type (Typ),
6269 -- Then multiply the result by the size of the array
6272 Quantity : constant Int := Number_Of_Elements_In_Array (Typ);
6273 -- Number_Of_Elements_In_Array is non-trival, consequently
6274 -- its result is captured as an optimization.
6277 Pri_Stacks := Pri_Stacks * Quantity;
6278 Sec_Stacks := Sec_Stacks * Quantity;
6281 when E_Protected_Subtype
6286 Component := First_Component_Or_Discriminant (Typ);
6288 -- Recursively descend each component of the composite type
6289 -- looking for tasks, but only if the component is marked as
6292 while Present (Component) loop
6293 if Has_Task (Etype (Component)) then
6299 Count_Default_Sized_Task_Stacks
6300 (Etype (Component), P, S);
6301 Pri_Stacks := Pri_Stacks + P;
6302 Sec_Stacks := Sec_Stacks + S;
6306 Next_Component_Or_Discriminant (Component);
6309 when E_Limited_Private_Subtype
6310 | E_Limited_Private_Type
6311 | E_Record_Subtype_With_Private
6312 | E_Record_Type_With_Private
6314 -- Switch to the full view of the private type to continue
6317 Count_Default_Sized_Task_Stacks
6318 (Full_View (Typ), Pri_Stacks, Sec_Stacks);
6320 -- Other types should not contain tasks
6323 raise Program_Error;
6325 end Count_Default_Sized_Task_Stacks;
6327 -------------------------------
6328 -- Default_Initialize_Object --
6329 -------------------------------
6331 procedure Default_Initialize_Object (After : Node_Id) is
6332 function New_Object_Reference return Node_Id;
6333 -- Return a new reference to Def_Id with attributes Assignment_OK and
6334 -- Must_Not_Freeze already set.
6336 function Simple_Initialization_OK
6337 (Init_Typ : Entity_Id) return Boolean;
6338 -- Determine whether object declaration N with entity Def_Id needs
6339 -- simple initialization, assuming that it is of type Init_Typ.
6341 --------------------------
6342 -- New_Object_Reference --
6343 --------------------------
6345 function New_Object_Reference return Node_Id is
6346 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
6349 -- The call to the type init proc or [Deep_]Finalize must not
6350 -- freeze the related object as the call is internally generated.
6351 -- This way legal rep clauses that apply to the object will not be
6352 -- flagged. Note that the initialization call may be removed if
6353 -- pragma Import is encountered or moved to the freeze actions of
6354 -- the object because of an address clause.
6356 Set_Assignment_OK (Obj_Ref);
6357 Set_Must_Not_Freeze (Obj_Ref);
6360 end New_Object_Reference;
6362 ------------------------------
6363 -- Simple_Initialization_OK --
6364 ------------------------------
6366 function Simple_Initialization_OK
6367 (Init_Typ : Entity_Id) return Boolean
6370 -- Do not consider the object declaration if it comes with an
6371 -- initialization expression, or is internal in which case it
6372 -- will be assigned later.
6375 not Is_Internal (Def_Id)
6376 and then not Has_Init_Expression (N)
6377 and then Needs_Simple_Initialization
6381 and then No (Following_Address_Clause (N)));
6382 end Simple_Initialization_OK;
6386 Exceptions_OK : constant Boolean :=
6387 not Restriction_Active (No_Exception_Propagation);
6389 Aggr_Init : Node_Id;
6390 Comp_Init : List_Id := No_List;
6391 Fin_Block : Node_Id;
6393 Init_Stmts : List_Id := No_List;
6394 Obj_Init : Node_Id := Empty;
6397 -- Start of processing for Default_Initialize_Object
6400 -- Default initialization is suppressed for objects that are already
6401 -- known to be imported (i.e. whose declaration specifies the Import
6402 -- aspect). Note that for objects with a pragma Import, we generate
6403 -- initialization here, and then remove it downstream when processing
6404 -- the pragma. It is also suppressed for variables for which a pragma
6405 -- Suppress_Initialization has been explicitly given
6407 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
6410 -- Nothing to do if the object being initialized is of a task type
6411 -- and restriction No_Tasking is in effect, because this is a direct
6412 -- violation of the restriction.
6414 elsif Is_Task_Type (Base_Typ)
6415 and then Restriction_Active (No_Tasking)
6420 -- The expansion performed by this routine is as follows:
6424 -- Type_Init_Proc (Obj);
6427 -- [Deep_]Initialize (Obj);
6431 -- [Deep_]Finalize (Obj, Self => False);
6435 -- Abort_Undefer_Direct;
6438 -- Initialize the components of the object
6440 if Has_Non_Null_Base_Init_Proc (Typ)
6441 and then not No_Initialization (N)
6442 and then not Initialization_Suppressed (Typ)
6444 -- Do not initialize the components if No_Default_Initialization
6445 -- applies as the actual restriction check will occur later when
6446 -- the object is frozen as it is not known yet whether the object
6447 -- is imported or not.
6449 if not Restriction_Active (No_Default_Initialization) then
6451 -- If the values of the components are compile-time known, use
6452 -- their prebuilt aggregate form directly.
6454 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
6456 if Present (Aggr_Init) then
6458 New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
6460 -- If type has discriminants, try to build an equivalent
6461 -- aggregate using discriminant values from the declaration.
6462 -- This is a useful optimization, in particular if restriction
6463 -- No_Elaboration_Code is active.
6465 elsif Build_Equivalent_Aggregate then
6468 -- Optimize the default initialization of an array object when
6469 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
6470 -- Construct an in-place initialization aggregate which may be
6471 -- convert into a fast memset by the backend.
6473 elsif Init_Or_Norm_Scalars
6474 and then Is_Array_Type (Typ)
6476 -- The array must lack atomic components because they are
6477 -- treated as non-static, and as a result the backend will
6478 -- not initialize the memory in one go.
6480 and then not Has_Atomic_Components (Typ)
6482 -- The array must not be packed because the invalid values
6483 -- in System.Scalar_Values are multiples of Storage_Unit.
6485 and then not Is_Packed (Typ)
6487 -- The array must have static non-empty ranges, otherwise
6488 -- the backend cannot initialize the memory in one go.
6490 and then Has_Static_Non_Empty_Array_Bounds (Typ)
6492 -- The optimization is only relevant for arrays of scalar
6495 and then Is_Scalar_Type (Component_Type (Typ))
6497 -- Similar to regular array initialization using a type
6498 -- init proc, predicate checks are not performed because the
6499 -- initialization values are intentionally invalid, and may
6500 -- violate the predicate.
6502 and then not Has_Predicates (Component_Type (Typ))
6504 -- The component type must have a single initialization value
6506 and then Simple_Initialization_OK (Component_Type (Typ))
6508 Set_No_Initialization (N, False);
6513 Size => (if Known_Esize (Def_Id) then Esize (Def_Id)
6517 (Expression (N), Typ, Suppress => All_Checks);
6519 -- Otherwise invoke the type init proc, generate:
6520 -- Type_Init_Proc (Obj);
6523 Obj_Ref := New_Object_Reference;
6525 if Comes_From_Source (Def_Id) then
6526 Initialization_Warning (Obj_Ref);
6529 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
6533 -- Provide a default value if the object needs simple initialization
6535 elsif Simple_Initialization_OK (Typ) then
6536 Set_No_Initialization (N, False);
6542 (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0)));
6544 Analyze_And_Resolve (Expression (N), Typ);
6547 -- Initialize the object, generate:
6548 -- [Deep_]Initialize (Obj);
6550 if Needs_Finalization (Typ) and then not No_Initialization (N) then
6553 (Obj_Ref => New_Object_Reference,
6557 -- Build a special finalization block when both the object and its
6558 -- controlled components are to be initialized. The block finalizes
6559 -- the components if the object initialization fails. Generate:
6570 if Has_Controlled_Component (Typ)
6571 and then Present (Comp_Init)
6572 and then Present (Obj_Init)
6573 and then Exceptions_OK
6575 Init_Stmts := Comp_Init;
6579 (Obj_Ref => New_Object_Reference,
6583 if Present (Fin_Call) then
6585 -- Do not emit warnings related to the elaboration order when a
6586 -- controlled object is declared before the body of Finalize is
6589 if Legacy_Elaboration_Checks then
6590 Set_No_Elaboration_Check (Fin_Call);
6594 Make_Block_Statement (Loc,
6595 Declarations => No_List,
6597 Handled_Statement_Sequence =>
6598 Make_Handled_Sequence_Of_Statements (Loc,
6599 Statements => New_List (Obj_Init),
6601 Exception_Handlers => New_List (
6602 Make_Exception_Handler (Loc,
6603 Exception_Choices => New_List (
6604 Make_Others_Choice (Loc)),
6606 Statements => New_List (
6608 Make_Raise_Statement (Loc))))));
6610 -- Signal the ABE mechanism that the block carries out
6611 -- initialization actions.
6613 Set_Is_Initialization_Block (Fin_Block);
6615 Append_To (Init_Stmts, Fin_Block);
6618 -- Otherwise finalization is not required, the initialization calls
6619 -- are passed to the abort block building circuitry, generate:
6621 -- Type_Init_Proc (Obj);
6622 -- [Deep_]Initialize (Obj);
6625 if Present (Comp_Init) then
6626 Init_Stmts := Comp_Init;
6629 if Present (Obj_Init) then
6630 if No (Init_Stmts) then
6631 Init_Stmts := New_List;
6634 Append_To (Init_Stmts, Obj_Init);
6638 -- Build an abort block to protect the initialization calls
6641 and then Present (Comp_Init)
6642 and then Present (Obj_Init)
6647 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
6649 -- When exceptions are propagated, abort deferral must take place
6650 -- in the presence of initialization or finalization exceptions.
6657 -- Abort_Undefer_Direct;
6660 if Exceptions_OK then
6661 Init_Stmts := New_List (
6662 Build_Abort_Undefer_Block (Loc,
6663 Stmts => Init_Stmts,
6666 -- Otherwise exceptions are not propagated. Generate:
6673 Append_To (Init_Stmts,
6674 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6678 -- Insert the whole initialization sequence into the tree. If the
6679 -- object has a delayed freeze, as will be the case when it has
6680 -- aspect specifications, the initialization sequence is part of
6681 -- the freeze actions.
6683 if Present (Init_Stmts) then
6684 if Has_Delayed_Freeze (Def_Id) then
6685 Append_Freeze_Actions (Def_Id, Init_Stmts);
6687 Insert_Actions_After (After, Init_Stmts);
6690 end Default_Initialize_Object;
6692 -------------------------
6693 -- Rewrite_As_Renaming --
6694 -------------------------
6696 function Rewrite_As_Renaming return Boolean is
6697 Result : constant Boolean :=
6699 -- If the object declaration appears in the form
6701 -- Obj : Ctrl_Typ := Func (...);
6703 -- where Ctrl_Typ is controlled but not immutably limited type, then
6704 -- the expansion of the function call should use a dereference of the
6705 -- result to reference the value on the secondary stack.
6707 -- Obj : Ctrl_Typ renames Func (...).all;
6709 -- As a result, the call avoids an extra copy. This an optimization,
6710 -- but it is required for passing ACATS tests in some cases where it
6711 -- would otherwise make two copies. The RM allows removing redunant
6712 -- Adjust/Finalize calls, but does not allow insertion of extra ones.
6714 -- This part is disabled for now, because it breaks GNAT Studio
6718 and then Nkind (Expr_Q) = N_Explicit_Dereference
6719 and then not Comes_From_Source (Expr_Q)
6720 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
6721 and then Nkind (Object_Definition (N)) in N_Has_Entity
6722 and then (Needs_Finalization (Entity (Object_Definition (N)))))
6724 -- If the initializing expression is for a variable with attribute
6725 -- OK_To_Rename set, then transform:
6727 -- Obj : Typ := Expr;
6731 -- Obj : Typ renames Expr;
6733 -- provided that Obj is not aliased. The aliased case has to be
6734 -- excluded in general because Expr will not be aliased in
6738 (not Aliased_Present (N)
6739 and then Is_Entity_Name (Expr_Q)
6740 and then Ekind (Entity (Expr_Q)) = E_Variable
6741 and then OK_To_Rename (Entity (Expr_Q))
6742 and then Is_Entity_Name (Obj_Def));
6744 -- Return False if there are any aspect specifications, because
6745 -- otherwise we duplicate that corresponding implicit attribute
6746 -- definition, and call Insert_Action, which has no place to insert
6747 -- the attribute definition. The attribute definition is stored in
6748 -- Aspect_Rep_Item, which is not a list.
6750 return Result and then No (Aspect_Specifications (N));
6751 end Rewrite_As_Renaming;
6755 Next_N : constant Node_Id := Next (N);
6759 Tag_Assign : Node_Id;
6761 Init_After : Node_Id := N;
6762 -- Node after which the initialization actions are to be inserted. This
6763 -- is normally N, except for the case of a shared passive variable, in
6764 -- which case the init proc call must be inserted only after the bodies
6765 -- of the shared variable procedures have been seen.
6767 -- Start of processing for Expand_N_Object_Declaration
6770 -- Don't do anything for deferred constants. All proper actions will be
6771 -- expanded during the full declaration.
6773 if No (Expr) and Constant_Present (N) then
6777 -- The type of the object cannot be abstract. This is diagnosed at the
6778 -- point the object is frozen, which happens after the declaration is
6779 -- fully expanded, so simply return now.
6781 if Is_Abstract_Type (Typ) then
6785 -- No action needed for the internal imported dummy object added by
6786 -- Make_DT to compute the offset of the components that reference
6787 -- secondary dispatch tables; required to avoid never-ending loop
6788 -- processing this internal object declaration.
6790 if Tagged_Type_Expansion
6791 and then Is_Internal (Def_Id)
6792 and then Is_Imported (Def_Id)
6793 and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
6798 -- First we do special processing for objects of a tagged type where
6799 -- this is the point at which the type is frozen. The creation of the
6800 -- dispatch table and the initialization procedure have to be deferred
6801 -- to this point, since we reference previously declared primitive
6804 -- Force construction of dispatch tables of library level tagged types
6806 if Tagged_Type_Expansion
6807 and then Building_Static_Dispatch_Tables
6808 and then Is_Library_Level_Entity (Def_Id)
6809 and then Is_Library_Level_Tagged_Type (Base_Typ)
6810 and then Ekind (Base_Typ) in E_Record_Type
6813 and then not Has_Dispatch_Table (Base_Typ)
6816 New_Nodes : List_Id := No_List;
6819 if Is_Concurrent_Type (Base_Typ) then
6820 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
6822 New_Nodes := Make_DT (Base_Typ, N);
6825 if not Is_Empty_List (New_Nodes) then
6826 Insert_List_Before (N, New_Nodes);
6831 -- Make shared memory routines for shared passive variable
6833 if Is_Shared_Passive (Def_Id) then
6834 Init_After := Make_Shared_Var_Procs (N);
6837 -- If tasks are being declared, make sure we have an activation chain
6838 -- defined for the tasks (has no effect if we already have one), and
6839 -- also that a Master variable is established (and that the appropriate
6840 -- enclosing construct is established as a task master).
6842 Ensure_Activation_Chain_And_Master (N);
6844 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
6845 -- restrictions are active then default-sized secondary stacks are
6846 -- generated by the binder and allocated by SS_Init. To provide the
6847 -- binder the number of stacks to generate, the number of default-sized
6848 -- stacks required for task objects contained within the object
6849 -- declaration N is calculated here as it is at this point where
6850 -- unconstrained types become constrained. The result is stored in the
6851 -- enclosing unit's Unit_Record.
6853 -- Note if N is an array object declaration that has an initialization
6854 -- expression, a second object declaration for the initialization
6855 -- expression is created by the compiler. To prevent double counting
6856 -- of the stacks in this scenario, the stacks of the first array are
6859 if Might_Have_Tasks (Typ)
6860 and then not Restriction_Active (No_Secondary_Stack)
6861 and then (Restriction_Active (No_Implicit_Heap_Allocations)
6862 or else Restriction_Active (No_Implicit_Task_Allocations))
6863 and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype
6864 and then (Has_Init_Expression (N)))
6867 PS_Count, SS_Count : Int := 0;
6869 Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count);
6870 Increment_Primary_Stack_Count (PS_Count);
6871 Increment_Sec_Stack_Count (SS_Count);
6875 -- Default initialization required, and no expression present
6879 -- If we have a type with a variant part, the initialization proc
6880 -- will contain implicit tests of the discriminant values, which
6881 -- counts as a violation of the restriction No_Implicit_Conditionals.
6883 if Has_Variant_Part (Typ) then
6888 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
6892 ("\initialization of variant record tests discriminants",
6899 -- For the default initialization case, if we have a private type
6900 -- with invariants, and invariant checks are enabled, then insert an
6901 -- invariant check after the object declaration. Note that it is OK
6902 -- to clobber the object with an invalid value since if the exception
6903 -- is raised, then the object will go out of scope. In the case where
6904 -- an array object is initialized with an aggregate, the expression
6905 -- is removed. Check flag Has_Init_Expression to avoid generating a
6906 -- junk invariant check and flag No_Initialization to avoid checking
6907 -- an uninitialized object such as a compiler temporary used for an
6910 if Has_Invariants (Base_Typ)
6911 and then Present (Invariant_Procedure (Base_Typ))
6912 and then not Has_Init_Expression (N)
6913 and then not No_Initialization (N)
6915 -- If entity has an address clause or aspect, make invariant
6916 -- call into a freeze action for the explicit freeze node for
6917 -- object. Otherwise insert invariant check after declaration.
6919 if Present (Following_Address_Clause (N))
6920 or else Has_Aspect (Def_Id, Aspect_Address)
6922 Ensure_Freeze_Node (Def_Id);
6923 Set_Has_Delayed_Freeze (Def_Id);
6924 Set_Is_Frozen (Def_Id, False);
6926 if not Partial_View_Has_Unknown_Discr (Typ) then
6927 Append_Freeze_Action (Def_Id,
6928 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6931 elsif not Partial_View_Has_Unknown_Discr (Typ) then
6933 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
6937 Default_Initialize_Object (Init_After);
6939 -- Generate attribute for Persistent_BSS if needed
6941 if Persistent_BSS_Mode
6942 and then Comes_From_Source (N)
6943 and then Is_Potentially_Persistent_Type (Typ)
6944 and then not Has_Init_Expression (N)
6945 and then Is_Library_Level_Entity (Def_Id)
6951 Make_Linker_Section_Pragma
6952 (Def_Id, Sloc (N), ".persistent.bss");
6953 Insert_After (N, Prag);
6958 -- If access type, then we know it is null if not initialized
6960 if Is_Access_Type (Typ) then
6961 Set_Is_Known_Null (Def_Id);
6964 -- Explicit initialization present
6967 -- Obtain actual expression from qualified expression
6969 Expr_Q := Unqualify (Expr);
6971 -- When we have the appropriate type of aggregate in the expression
6972 -- (it has been determined during analysis of the aggregate by
6973 -- setting the delay flag), let's perform in place assignment and
6974 -- thus avoid creating a temporary.
6976 if Is_Delayed_Aggregate (Expr_Q) then
6978 -- An aggregate that must be built in place is not resolved and
6979 -- expanded until the enclosing construct is expanded. This will
6980 -- happen when the aggregate is limited and the declared object
6981 -- has a following address clause; it happens also when generating
6982 -- C code for an aggregate that has an alignment or address clause
6983 -- (see Analyze_Object_Declaration). Resolution is done without
6984 -- expansion because it will take place when the declaration
6985 -- itself is expanded.
6987 if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
6988 and then not Analyzed (Expr)
6990 Expander_Mode_Save_And_Set (False);
6991 Resolve (Expr, Typ);
6992 Expander_Mode_Restore;
6995 Convert_Aggr_In_Object_Decl (N);
6997 -- Ada 2005 (AI-318-02): If the initialization expression is a call
6998 -- to a build-in-place function, then access to the declared object
6999 -- must be passed to the function. Currently we limit such functions
7000 -- to those with constrained limited result subtypes, but eventually
7001 -- plan to expand the allowed forms of functions that are treated as
7004 elsif Is_Build_In_Place_Function_Call (Expr_Q) then
7005 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
7007 -- The previous call expands the expression initializing the
7008 -- built-in-place object into further code that will be analyzed
7009 -- later. No further expansion needed here.
7013 -- This is the same as the previous 'elsif', except that the call has
7014 -- been transformed by other expansion activities into something like
7015 -- F(...)'Reference.
7017 elsif Nkind (Expr_Q) = N_Reference
7018 and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
7019 and then not Is_Expanded_Build_In_Place_Call
7020 (Unqual_Conv (Prefix (Expr_Q)))
7022 Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
7024 -- The previous call expands the expression initializing the
7025 -- built-in-place object into further code that will be analyzed
7026 -- later. No further expansion needed here.
7030 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7031 -- expressions containing a build-in-place function call whose
7032 -- returned object covers interface types, and Expr_Q has calls to
7033 -- Ada.Tags.Displace to displace the pointer to the returned build-
7034 -- in-place object to reference the secondary dispatch table of a
7035 -- covered interface type.
7037 elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
7038 Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
7040 -- The previous call expands the expression initializing the
7041 -- built-in-place object into further code that will be analyzed
7042 -- later. No further expansion needed here.
7046 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7047 -- class-wide interface object to ensure that we copy the full
7048 -- object, unless we are targetting a VM where interfaces are handled
7049 -- by VM itself. Note that if the root type of Typ is an ancestor of
7050 -- Expr's type, both types share the same dispatch table and there is
7051 -- no need to displace the pointer.
7053 elsif Is_Interface (Typ)
7055 -- Avoid never-ending recursion because if Equivalent_Type is set
7056 -- then we've done it already and must not do it again.
7059 (Nkind (Obj_Def) = N_Identifier
7060 and then Present (Equivalent_Type (Entity (Obj_Def))))
7062 pragma Assert (Is_Class_Wide_Type (Typ));
7064 -- If the object is a return object of an inherently limited type,
7065 -- which implies build-in-place treatment, bypass the special
7066 -- treatment of class-wide interface initialization below. In this
7067 -- case, the expansion of the return statement will take care of
7068 -- creating the object (via allocator) and initializing it.
7070 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
7073 elsif Tagged_Type_Expansion then
7075 Iface : constant Entity_Id := Root_Type (Typ);
7076 Expr_N : Node_Id := Expr;
7077 Expr_Typ : Entity_Id;
7083 -- If the original node of the expression was a conversion
7084 -- to this specific class-wide interface type then restore
7085 -- the original node because we must copy the object before
7086 -- displacing the pointer to reference the secondary tag
7087 -- component. This code must be kept synchronized with the
7088 -- expansion done by routine Expand_Interface_Conversion
7090 if not Comes_From_Source (Expr_N)
7091 and then Nkind (Expr_N) = N_Explicit_Dereference
7092 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
7093 and then Etype (Original_Node (Expr_N)) = Typ
7095 Rewrite (Expr_N, Original_Node (Expression (N)));
7098 -- Avoid expansion of redundant interface conversion
7100 if Is_Interface (Etype (Expr_N))
7101 and then Nkind (Expr_N) = N_Type_Conversion
7102 and then Etype (Expr_N) = Typ
7104 Expr_N := Expression (Expr_N);
7105 Set_Expression (N, Expr_N);
7108 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
7109 Expr_Typ := Base_Type (Etype (Expr_N));
7111 if Is_Class_Wide_Type (Expr_Typ) then
7112 Expr_Typ := Root_Type (Expr_Typ);
7116 -- CW : I'Class := Obj;
7119 -- type Ityp is not null access I'Class;
7120 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
7122 if Comes_From_Source (Expr_N)
7123 and then Nkind (Expr_N) = N_Identifier
7124 and then not Is_Interface (Expr_Typ)
7125 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
7126 and then (Expr_Typ = Etype (Expr_Typ)
7128 Is_Variable_Size_Record (Etype (Expr_Typ)))
7133 Make_Object_Declaration (Loc,
7134 Defining_Identifier => Obj_Id,
7135 Object_Definition =>
7136 New_Occurrence_Of (Expr_Typ, Loc),
7137 Expression => Relocate_Node (Expr_N)));
7139 -- Statically reference the tag associated with the
7143 Make_Selected_Component (Loc,
7144 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7147 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
7150 -- IW : I'Class := Obj;
7152 -- type Equiv_Record is record ... end record;
7153 -- implicit subtype CW is <Class_Wide_Subtype>;
7154 -- Tmp : CW := CW!(Obj);
7155 -- type Ityp is not null access I'Class;
7156 -- IW : I'Class renames
7157 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
7160 -- Generate the equivalent record type and update the
7161 -- subtype indication to reference it.
7163 Expand_Subtype_From_Expr
7166 Subtype_Indic => Obj_Def,
7169 if not Is_Interface (Etype (Expr_N)) then
7170 New_Expr := Relocate_Node (Expr_N);
7172 -- For interface types we use 'Address which displaces
7173 -- the pointer to the base of the object (if required)
7177 Unchecked_Convert_To (Etype (Obj_Def),
7178 Make_Explicit_Dereference (Loc,
7179 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7180 Make_Attribute_Reference (Loc,
7181 Prefix => Relocate_Node (Expr_N),
7182 Attribute_Name => Name_Address))));
7187 if not Is_Limited_Record (Expr_Typ) then
7189 Make_Object_Declaration (Loc,
7190 Defining_Identifier => Obj_Id,
7191 Object_Definition =>
7192 New_Occurrence_Of (Etype (Obj_Def), Loc),
7193 Expression => New_Expr));
7195 -- Rename limited type object since they cannot be copied
7196 -- This case occurs when the initialization expression
7197 -- has been previously expanded into a temporary object.
7199 else pragma Assert (not Comes_From_Source (Expr_Q));
7201 Make_Object_Renaming_Declaration (Loc,
7202 Defining_Identifier => Obj_Id,
7204 New_Occurrence_Of (Etype (Obj_Def), Loc),
7206 Unchecked_Convert_To
7207 (Etype (Obj_Def), New_Expr)));
7210 -- Dynamically reference the tag associated with the
7214 Make_Function_Call (Loc,
7215 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
7216 Parameter_Associations => New_List (
7217 Make_Attribute_Reference (Loc,
7218 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7219 Attribute_Name => Name_Address),
7221 (Node (First_Elmt (Access_Disp_Table (Iface))),
7226 Make_Object_Renaming_Declaration (Loc,
7227 Defining_Identifier => Make_Temporary (Loc, 'D'),
7228 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7230 Convert_Tag_To_Interface (Typ, Tag_Comp)));
7232 -- If the original entity comes from source, then mark the
7233 -- new entity as needing debug information, even though it's
7234 -- defined by a generated renaming that does not come from
7235 -- source, so that Materialize_Entity will be set on the
7236 -- entity when Debug_Renaming_Declaration is called during
7239 if Comes_From_Source (Def_Id) then
7240 Set_Debug_Info_Needed (Defining_Identifier (N));
7243 Analyze (N, Suppress => All_Checks);
7245 -- Replace internal identifier of rewritten node by the
7246 -- identifier found in the sources. We also have to exchange
7247 -- entities containing their defining identifiers to ensure
7248 -- the correct replacement of the object declaration by this
7249 -- object renaming declaration because these identifiers
7250 -- were previously added by Enter_Name to the current scope.
7251 -- We must preserve the homonym chain of the source entity
7252 -- as well. We must also preserve the kind of the entity,
7253 -- which may be a constant. Preserve entity chain because
7254 -- itypes may have been generated already, and the full
7255 -- chain must be preserved for final freezing. Finally,
7256 -- preserve Comes_From_Source setting, so that debugging
7257 -- and cross-referencing information is properly kept, and
7258 -- preserve source location, to prevent spurious errors when
7259 -- entities are declared (they must have their own Sloc).
7262 New_Id : constant Entity_Id := Defining_Identifier (N);
7263 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
7264 Save_CFS : constant Boolean :=
7265 Comes_From_Source (Def_Id);
7266 Save_SP : constant Node_Id := SPARK_Pragma (Def_Id);
7267 Save_SPI : constant Boolean :=
7268 SPARK_Pragma_Inherited (Def_Id);
7271 Link_Entities (New_Id, Next_Entity (Def_Id));
7272 Link_Entities (Def_Id, Next_Temp);
7274 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
7275 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
7276 Mutate_Ekind (Defining_Identifier (N), Ekind (Def_Id));
7277 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
7279 Set_Comes_From_Source (Def_Id, False);
7281 -- ??? This is extremely dangerous!!! Exchanging entities
7282 -- is very low level, and as a result it resets flags and
7283 -- fields which belong to the original Def_Id. Several of
7284 -- these attributes are saved and restored, but there may
7285 -- be many more that need to be preserverd.
7287 Exchange_Entities (Defining_Identifier (N), Def_Id);
7289 -- Restore clobbered attributes
7291 Set_Comes_From_Source (Def_Id, Save_CFS);
7292 Set_SPARK_Pragma (Def_Id, Save_SP);
7293 Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI);
7300 -- Common case of explicit object initialization
7303 -- In most cases, we must check that the initial value meets any
7304 -- constraint imposed by the declared type. However, there is one
7305 -- very important exception to this rule. If the entity has an
7306 -- unconstrained nominal subtype, then it acquired its constraints
7307 -- from the expression in the first place, and not only does this
7308 -- mean that the constraint check is not needed, but an attempt to
7309 -- perform the constraint check can cause order of elaboration
7312 if not Is_Constr_Subt_For_U_Nominal (Typ) then
7314 -- If this is an allocator for an aggregate that has been
7315 -- allocated in place, delay checks until assignments are
7316 -- made, because the discriminants are not initialized.
7318 if Nkind (Expr) = N_Allocator
7319 and then No_Initialization (Expr)
7323 -- Otherwise apply a constraint check now if no prev error
7325 elsif Nkind (Expr) /= N_Error then
7326 Apply_Constraint_Check (Expr, Typ);
7328 -- Deal with possible range check
7330 if Do_Range_Check (Expr) then
7332 -- If assignment checks are suppressed, turn off flag
7334 if Suppress_Assignment_Checks (N) then
7335 Set_Do_Range_Check (Expr, False);
7337 -- Otherwise generate the range check
7340 Generate_Range_Check
7341 (Expr, Typ, CE_Range_Check_Failed);
7347 -- If the type is controlled and not inherently limited, then
7348 -- the target is adjusted after the copy and attached to the
7349 -- finalization list. However, no adjustment is done in the case
7350 -- where the object was initialized by a call to a function whose
7351 -- result is built in place, since no copy occurred. Similarly, no
7352 -- adjustment is required if we are going to rewrite the object
7353 -- declaration into a renaming declaration.
7355 if Needs_Finalization (Typ)
7356 and then not Is_Limited_View (Typ)
7357 and then not Rewrite_As_Renaming
7361 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
7364 -- Guard against a missing [Deep_]Adjust when the base type
7365 -- was not properly frozen.
7367 if Present (Adj_Call) then
7368 Insert_Action_After (Init_After, Adj_Call);
7372 -- For tagged types, when an init value is given, the tag has to
7373 -- be re-initialized separately in order to avoid the propagation
7374 -- of a wrong tag coming from a view conversion unless the type
7375 -- is class wide (in this case the tag comes from the init value).
7376 -- Suppress the tag assignment when not Tagged_Type_Expansion
7377 -- because tags are represented implicitly in objects. Ditto for
7378 -- types that are CPP_CLASS, and for initializations that are
7379 -- aggregates, because they have to have the right tag.
7381 -- The re-assignment of the tag has to be done even if the object
7382 -- is a constant. The assignment must be analyzed after the
7383 -- declaration. If an address clause follows, this is handled as
7384 -- part of the freeze actions for the object, otherwise insert
7385 -- tag assignment here.
7387 Tag_Assign := Make_Tag_Assignment (N);
7389 if Present (Tag_Assign) then
7390 if Present (Following_Address_Clause (N)) then
7391 Ensure_Freeze_Node (Def_Id);
7394 Insert_Action_After (Init_After, Tag_Assign);
7397 -- Handle C++ constructor calls. Note that we do not check that
7398 -- Typ is a tagged type since the equivalent Ada type of a C++
7399 -- class that has no virtual methods is an untagged limited
7402 elsif Is_CPP_Constructor_Call (Expr) then
7404 -- The call to the initialization procedure does NOT freeze the
7405 -- object being initialized.
7407 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
7408 Set_Must_Not_Freeze (Id_Ref);
7409 Set_Assignment_OK (Id_Ref);
7411 Insert_Actions_After (Init_After,
7412 Build_Initialization_Call (Loc, Id_Ref, Typ,
7413 Constructor_Ref => Expr));
7415 -- We remove here the original call to the constructor
7416 -- to avoid its management in the backend
7418 Set_Expression (N, Empty);
7421 -- Handle initialization of limited tagged types
7423 elsif Is_Tagged_Type (Typ)
7424 and then Is_Class_Wide_Type (Typ)
7425 and then Is_Limited_Record (Typ)
7426 and then not Is_Limited_Interface (Typ)
7428 -- Given that the type is limited we cannot perform a copy. If
7429 -- Expr_Q is the reference to a variable we mark the variable
7430 -- as OK_To_Rename to expand this declaration into a renaming
7431 -- declaration (see below).
7433 if Is_Entity_Name (Expr_Q) then
7434 Set_OK_To_Rename (Entity (Expr_Q));
7436 -- If we cannot convert the expression into a renaming we must
7437 -- consider it an internal error because the backend does not
7438 -- have support to handle it. But avoid crashing on a raise
7439 -- expression or conditional expression.
7441 elsif Nkind (Original_Node (Expr_Q)) not in
7442 N_Raise_Expression | N_If_Expression | N_Case_Expression
7444 raise Program_Error;
7447 -- For discrete types, set the Is_Known_Valid flag if the
7448 -- initializing value is known to be valid. Only do this for
7449 -- source assignments, since otherwise we can end up turning
7450 -- on the known valid flag prematurely from inserted code.
7452 elsif Comes_From_Source (N)
7453 and then Is_Discrete_Type (Typ)
7454 and then Expr_Known_Valid (Expr)
7456 Set_Is_Known_Valid (Def_Id);
7458 elsif Is_Access_Type (Typ) then
7460 -- For access types set the Is_Known_Non_Null flag if the
7461 -- initializing value is known to be non-null. We can also set
7462 -- Can_Never_Be_Null if this is a constant.
7464 if Known_Non_Null (Expr) then
7465 Set_Is_Known_Non_Null (Def_Id, True);
7467 if Constant_Present (N) then
7468 Set_Can_Never_Be_Null (Def_Id);
7473 -- If validity checking on copies, validate initial expression.
7474 -- But skip this if declaration is for a generic type, since it
7475 -- makes no sense to validate generic types. Not clear if this
7476 -- can happen for legal programs, but it definitely can arise
7477 -- from previous instantiation errors.
7479 if Validity_Checks_On
7480 and then Comes_From_Source (N)
7481 and then Validity_Check_Copies
7482 and then not Is_Generic_Type (Etype (Def_Id))
7484 Ensure_Valid (Expr);
7485 Set_Is_Known_Valid (Def_Id);
7489 -- Cases where the back end cannot handle the initialization
7490 -- directly. In such cases, we expand an assignment that will
7491 -- be appropriately handled by Expand_N_Assignment_Statement.
7493 -- The exclusion of the unconstrained case is wrong, but for now it
7494 -- is too much trouble ???
7496 if (Is_Possibly_Unaligned_Slice (Expr)
7497 or else (Is_Possibly_Unaligned_Object (Expr)
7498 and then not Represented_As_Scalar (Etype (Expr))))
7499 and then not (Is_Array_Type (Etype (Expr))
7500 and then not Is_Constrained (Etype (Expr)))
7503 Stat : constant Node_Id :=
7504 Make_Assignment_Statement (Loc,
7505 Name => New_Occurrence_Of (Def_Id, Loc),
7506 Expression => Relocate_Node (Expr));
7508 Set_Expression (N, Empty);
7509 Set_No_Initialization (N);
7510 Set_Assignment_OK (Name (Stat));
7511 Set_No_Ctrl_Actions (Stat);
7512 Insert_After_And_Analyze (Init_After, Stat);
7517 if Nkind (Obj_Def) = N_Access_Definition
7518 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
7520 -- An Ada 2012 stand-alone object of an anonymous access type
7523 Loc : constant Source_Ptr := Sloc (N);
7525 Level : constant Entity_Id :=
7526 Make_Defining_Identifier (Sloc (N),
7528 New_External_Name (Chars (Def_Id), Suffix => "L"));
7530 Level_Decl : Node_Id;
7531 Level_Expr : Node_Id;
7534 Mutate_Ekind (Level, Ekind (Def_Id));
7535 Set_Etype (Level, Standard_Natural);
7536 Set_Scope (Level, Scope (Def_Id));
7538 -- Set accessibility level of null
7542 Make_Integer_Literal
7543 (Loc, Scope_Depth (Standard_Standard));
7545 -- When the expression of the object is a function which returns
7546 -- an anonymous access type the master of the call is the object
7547 -- being initialized instead of the type.
7549 elsif Nkind (Expr) = N_Function_Call
7550 and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
7552 Level_Expr := Accessibility_Level
7553 (Def_Id, Object_Decl_Level);
7558 Level_Expr := Accessibility_Level (Expr, Dynamic_Level);
7562 Make_Object_Declaration (Loc,
7563 Defining_Identifier => Level,
7564 Object_Definition =>
7565 New_Occurrence_Of (Standard_Natural, Loc),
7566 Expression => Level_Expr,
7567 Constant_Present => Constant_Present (N),
7568 Has_Init_Expression => True);
7570 Insert_Action_After (Init_After, Level_Decl);
7572 Set_Extra_Accessibility (Def_Id, Level);
7576 -- If the object is default initialized and its type is subject to
7577 -- pragma Default_Initial_Condition, add a runtime check to verify
7578 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
7580 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
7582 -- Note that the check is generated for source objects only
7584 if Comes_From_Source (Def_Id)
7585 and then Has_DIC (Typ)
7586 and then Present (DIC_Procedure (Typ))
7587 and then not Has_Null_Body (DIC_Procedure (Typ))
7588 and then not Has_Init_Expression (N)
7589 and then not Is_Imported (Def_Id)
7592 DIC_Call : constant Node_Id :=
7594 (Loc, New_Occurrence_Of (Def_Id, Loc), Typ);
7596 if Present (Next_N) then
7597 Insert_Before_And_Analyze (Next_N, DIC_Call);
7599 -- The object declaration is the last node in a declarative or a
7603 Append_To (List_Containing (N), DIC_Call);
7609 -- Final transformation - turn the object declaration into a renaming
7610 -- if appropriate. If this is the completion of a deferred constant
7611 -- declaration, then this transformation generates what would be
7612 -- illegal code if written by hand, but that's OK.
7614 if Present (Expr) then
7615 if Rewrite_As_Renaming then
7617 Make_Object_Renaming_Declaration (Loc,
7618 Defining_Identifier => Defining_Identifier (N),
7619 Subtype_Mark => Obj_Def,
7622 -- We do not analyze this renaming declaration, because all its
7623 -- components have already been analyzed, and if we were to go
7624 -- ahead and analyze it, we would in effect be trying to generate
7625 -- another declaration of X, which won't do.
7627 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
7630 -- We do need to deal with debug issues for this renaming
7632 -- First, if entity comes from source, then mark it as needing
7633 -- debug information, even though it is defined by a generated
7634 -- renaming that does not come from source.
7636 Set_Debug_Info_Defining_Id (N);
7638 -- Now call the routine to generate debug info for the renaming
7641 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
7643 if Present (Decl) then
7644 Insert_Action (N, Decl);
7650 -- Exception on library entity not available
7653 when RE_Not_Available =>
7655 end Expand_N_Object_Declaration;
7657 ---------------------------------
7658 -- Expand_N_Subtype_Indication --
7659 ---------------------------------
7661 -- Add a check on the range of the subtype and deal with validity checking
7663 procedure Expand_N_Subtype_Indication (N : Node_Id) is
7664 Ran : constant Node_Id := Range_Expression (Constraint (N));
7665 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
7668 if Nkind (Constraint (N)) = N_Range_Constraint then
7669 Validity_Check_Range (Range_Expression (Constraint (N)));
7672 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
7674 if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice
7675 and then Nkind (Parent (Parent (N))) not in
7676 N_Full_Type_Declaration | N_Object_Declaration
7678 Apply_Range_Check (Ran, Typ);
7680 end Expand_N_Subtype_Indication;
7682 ---------------------------
7683 -- Expand_N_Variant_Part --
7684 ---------------------------
7686 -- Note: this procedure no longer has any effect. It used to be that we
7687 -- would replace the choices in the last variant by a when others, and
7688 -- also expanded static predicates in variant choices here, but both of
7689 -- those activities were being done too early, since we can't check the
7690 -- choices until the statically predicated subtypes are frozen, which can
7691 -- happen as late as the free point of the record, and we can't change the
7692 -- last choice to an others before checking the choices, which is now done
7693 -- at the freeze point of the record.
7695 procedure Expand_N_Variant_Part (N : Node_Id) is
7698 end Expand_N_Variant_Part;
7700 ---------------------------------
7701 -- Expand_Previous_Access_Type --
7702 ---------------------------------
7704 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
7705 Ptr_Typ : Entity_Id;
7708 -- Find all access types in the current scope whose designated type is
7709 -- Def_Id and build master renamings for them.
7711 Ptr_Typ := First_Entity (Current_Scope);
7712 while Present (Ptr_Typ) loop
7713 if Is_Access_Type (Ptr_Typ)
7714 and then Designated_Type (Ptr_Typ) = Def_Id
7715 and then No (Master_Id (Ptr_Typ))
7717 -- Ensure that the designated type has a master
7719 Build_Master_Entity (Def_Id);
7721 -- Private and incomplete types complicate the insertion of master
7722 -- renamings because the access type may precede the full view of
7723 -- the designated type. For this reason, the master renamings are
7724 -- inserted relative to the designated type.
7726 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
7729 Next_Entity (Ptr_Typ);
7731 end Expand_Previous_Access_Type;
7733 -----------------------------
7734 -- Expand_Record_Extension --
7735 -----------------------------
7737 -- Add a field _parent at the beginning of the record extension. This is
7738 -- used to implement inheritance. Here are some examples of expansion:
7740 -- 1. no discriminants
7741 -- type T2 is new T1 with null record;
7743 -- type T2 is new T1 with record
7747 -- 2. renamed discriminants
7748 -- type T2 (B, C : Int) is new T1 (A => B) with record
7749 -- _Parent : T1 (A => B);
7753 -- 3. inherited discriminants
7754 -- type T2 is new T1 with record -- discriminant A inherited
7755 -- _Parent : T1 (A);
7759 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
7760 Indic : constant Node_Id := Subtype_Indication (Def);
7761 Loc : constant Source_Ptr := Sloc (Def);
7762 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
7763 Par_Subtype : Entity_Id;
7764 Comp_List : Node_Id;
7765 Comp_Decl : Node_Id;
7768 List_Constr : constant List_Id := New_List;
7771 -- Expand_Record_Extension is called directly from the semantics, so
7772 -- we must check to see whether expansion is active before proceeding,
7773 -- because this affects the visibility of selected components in bodies
7774 -- of instances. Within a generic we still need to set Parent_Subtype
7775 -- link because the visibility of inherited components will have to be
7776 -- verified in subsequent instances.
7778 if not Expander_Active then
7779 if Inside_A_Generic and then Ekind (T) = E_Record_Type then
7780 Set_Parent_Subtype (T, Etype (T));
7785 -- This may be a derivation of an untagged private type whose full
7786 -- view is tagged, in which case the Derived_Type_Definition has no
7787 -- extension part. Build an empty one now.
7789 if No (Rec_Ext_Part) then
7791 Make_Record_Definition (Loc,
7793 Component_List => Empty,
7794 Null_Present => True);
7796 Set_Record_Extension_Part (Def, Rec_Ext_Part);
7797 Mark_Rewrite_Insertion (Rec_Ext_Part);
7800 Comp_List := Component_List (Rec_Ext_Part);
7802 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
7804 -- If the derived type inherits its discriminants the type of the
7805 -- _parent field must be constrained by the inherited discriminants
7807 if Has_Discriminants (T)
7808 and then Nkind (Indic) /= N_Subtype_Indication
7809 and then not Is_Constrained (Entity (Indic))
7811 D := First_Discriminant (T);
7812 while Present (D) loop
7813 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
7814 Next_Discriminant (D);
7819 Make_Subtype_Indication (Loc,
7820 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
7822 Make_Index_Or_Discriminant_Constraint (Loc,
7823 Constraints => List_Constr)),
7826 -- Otherwise the original subtype_indication is just what is needed
7829 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
7832 Set_Parent_Subtype (T, Par_Subtype);
7835 Make_Component_Declaration (Loc,
7836 Defining_Identifier => Parent_N,
7837 Component_Definition =>
7838 Make_Component_Definition (Loc,
7839 Aliased_Present => False,
7840 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
7842 if Null_Present (Rec_Ext_Part) then
7843 Set_Component_List (Rec_Ext_Part,
7844 Make_Component_List (Loc,
7845 Component_Items => New_List (Comp_Decl),
7846 Variant_Part => Empty,
7847 Null_Present => False));
7848 Set_Null_Present (Rec_Ext_Part, False);
7850 elsif Null_Present (Comp_List)
7851 or else Is_Empty_List (Component_Items (Comp_List))
7853 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7854 Set_Null_Present (Comp_List, False);
7857 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7860 Analyze (Comp_Decl);
7861 end Expand_Record_Extension;
7863 ------------------------
7864 -- Expand_Tagged_Root --
7865 ------------------------
7867 procedure Expand_Tagged_Root (T : Entity_Id) is
7868 Def : constant Node_Id := Type_Definition (Parent (T));
7869 Comp_List : Node_Id;
7870 Comp_Decl : Node_Id;
7871 Sloc_N : Source_Ptr;
7874 if Null_Present (Def) then
7875 Set_Component_List (Def,
7876 Make_Component_List (Sloc (Def),
7877 Component_Items => Empty_List,
7878 Variant_Part => Empty,
7879 Null_Present => True));
7882 Comp_List := Component_List (Def);
7884 if Null_Present (Comp_List)
7885 or else Is_Empty_List (Component_Items (Comp_List))
7887 Sloc_N := Sloc (Comp_List);
7889 Sloc_N := Sloc (First (Component_Items (Comp_List)));
7893 Make_Component_Declaration (Sloc_N,
7894 Defining_Identifier => First_Tag_Component (T),
7895 Component_Definition =>
7896 Make_Component_Definition (Sloc_N,
7897 Aliased_Present => False,
7898 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
7900 if Null_Present (Comp_List)
7901 or else Is_Empty_List (Component_Items (Comp_List))
7903 Set_Component_Items (Comp_List, New_List (Comp_Decl));
7904 Set_Null_Present (Comp_List, False);
7907 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
7910 -- We don't Analyze the whole expansion because the tag component has
7911 -- already been analyzed previously. Here we just insure that the tree
7912 -- is coherent with the semantic decoration
7914 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
7917 when RE_Not_Available =>
7919 end Expand_Tagged_Root;
7921 ------------------------------
7922 -- Freeze_Stream_Operations --
7923 ------------------------------
7925 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
7926 Names : constant array (1 .. 4) of TSS_Name_Type :=
7931 Stream_Op : Entity_Id;
7934 -- Primitive operations of tagged types are frozen when the dispatch
7935 -- table is constructed.
7937 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
7941 for J in Names'Range loop
7942 Stream_Op := TSS (Typ, Names (J));
7944 if Present (Stream_Op)
7945 and then Is_Subprogram (Stream_Op)
7946 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
7947 N_Subprogram_Declaration
7948 and then not Is_Frozen (Stream_Op)
7950 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
7953 end Freeze_Stream_Operations;
7959 -- Full type declarations are expanded at the point at which the type is
7960 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
7961 -- declarations generated by the freezing (e.g. the procedure generated
7962 -- for initialization) are chained in the Actions field list of the freeze
7963 -- node using Append_Freeze_Actions.
7965 -- WARNING: This routine manages Ghost regions. Return statements must be
7966 -- replaced by gotos which jump to the end of the routine and restore the
7969 function Freeze_Type (N : Node_Id) return Boolean is
7970 procedure Process_RACW_Types (Typ : Entity_Id);
7971 -- Validate and generate stubs for all RACW types associated with type
7974 procedure Process_Pending_Access_Types (Typ : Entity_Id);
7975 -- Associate type Typ's Finalize_Address primitive with the finalization
7976 -- masters of pending access-to-Typ types.
7978 ------------------------
7979 -- Process_RACW_Types --
7980 ------------------------
7982 procedure Process_RACW_Types (Typ : Entity_Id) is
7983 List : constant Elist_Id := Access_Types_To_Process (N);
7985 Seen : Boolean := False;
7988 if Present (List) then
7989 E := First_Elmt (List);
7990 while Present (E) loop
7991 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
7992 Validate_RACW_Primitives (Node (E));
8000 -- If there are RACWs designating this type, make stubs now
8003 Remote_Types_Tagged_Full_View_Encountered (Typ);
8005 end Process_RACW_Types;
8007 ----------------------------------
8008 -- Process_Pending_Access_Types --
8009 ----------------------------------
8011 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
8015 -- Finalize_Address is not generated in CodePeer mode because the
8016 -- body contains address arithmetic. This processing is disabled.
8018 if CodePeer_Mode then
8021 -- Certain itypes are generated for contexts that cannot allocate
8022 -- objects and should not set primitive Finalize_Address.
8024 elsif Is_Itype (Typ)
8025 and then Nkind (Associated_Node_For_Itype (Typ)) =
8026 N_Explicit_Dereference
8030 -- When an access type is declared after the incomplete view of a
8031 -- Taft-amendment type, the access type is considered pending in
8032 -- case the full view of the Taft-amendment type is controlled. If
8033 -- this is indeed the case, associate the Finalize_Address routine
8034 -- of the full view with the finalization masters of all pending
8035 -- access types. This scenario applies to anonymous access types as
8038 elsif Needs_Finalization (Typ)
8039 and then Present (Pending_Access_Types (Typ))
8041 E := First_Elmt (Pending_Access_Types (Typ));
8042 while Present (E) loop
8045 -- Set_Finalize_Address
8046 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
8048 Append_Freeze_Action (Typ,
8049 Make_Set_Finalize_Address_Call
8051 Ptr_Typ => Node (E)));
8056 end Process_Pending_Access_Types;
8060 Def_Id : constant Entity_Id := Entity (N);
8062 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
8063 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
8064 -- Save the Ghost-related attributes to restore on exit
8066 Result : Boolean := False;
8068 -- Start of processing for Freeze_Type
8071 -- The type being frozen may be subject to pragma Ghost. Set the mode
8072 -- now to ensure that any nodes generated during freezing are properly
8075 Set_Ghost_Mode (Def_Id);
8077 -- Process any remote access-to-class-wide types designating the type
8080 Process_RACW_Types (Def_Id);
8082 -- Freeze processing for record types
8084 if Is_Record_Type (Def_Id) then
8085 if Ekind (Def_Id) = E_Record_Type then
8086 Expand_Freeze_Record_Type (N);
8087 elsif Is_Class_Wide_Type (Def_Id) then
8088 Expand_Freeze_Class_Wide_Type (N);
8091 -- Freeze processing for array types
8093 elsif Is_Array_Type (Def_Id) then
8094 Expand_Freeze_Array_Type (N);
8096 -- Freeze processing for access types
8098 -- For pool-specific access types, find out the pool object used for
8099 -- this type, needs actual expansion of it in some cases. Here are the
8100 -- different cases :
8102 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
8103 -- ---> don't use any storage pool
8105 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
8107 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
8109 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
8110 -- ---> Storage Pool is the specified one
8112 -- See GNAT Pool packages in the Run-Time for more details
8114 elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then
8116 Loc : constant Source_Ptr := Sloc (N);
8117 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
8119 Freeze_Action_Typ : Entity_Id;
8120 Pool_Object : Entity_Id;
8125 -- Rep Clause "for Def_Id'Storage_Size use 0;"
8126 -- ---> don't use any storage pool
8128 if No_Pool_Assigned (Def_Id) then
8133 -- Rep Clause : for Def_Id'Storage_Size use Expr.
8135 -- Def_Id__Pool : Stack_Bounded_Pool
8136 -- (Expr, DT'Size, DT'Alignment);
8138 elsif Has_Storage_Size_Clause (Def_Id) then
8144 -- For unconstrained composite types we give a size of zero
8145 -- so that the pool knows that it needs a special algorithm
8146 -- for variable size object allocation.
8148 if Is_Composite_Type (Desig_Type)
8149 and then not Is_Constrained (Desig_Type)
8151 DT_Size := Make_Integer_Literal (Loc, 0);
8152 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
8156 Make_Attribute_Reference (Loc,
8157 Prefix => New_Occurrence_Of (Desig_Type, Loc),
8158 Attribute_Name => Name_Max_Size_In_Storage_Elements);
8161 Make_Attribute_Reference (Loc,
8162 Prefix => New_Occurrence_Of (Desig_Type, Loc),
8163 Attribute_Name => Name_Alignment);
8167 Make_Defining_Identifier (Loc,
8168 Chars => New_External_Name (Chars (Def_Id), 'P'));
8170 -- We put the code associated with the pools in the entity
8171 -- that has the later freeze node, usually the access type
8172 -- but it can also be the designated_type; because the pool
8173 -- code requires both those types to be frozen
8175 if Is_Frozen (Desig_Type)
8176 and then (No (Freeze_Node (Desig_Type))
8177 or else Analyzed (Freeze_Node (Desig_Type)))
8179 Freeze_Action_Typ := Def_Id;
8181 -- A Taft amendment type cannot get the freeze actions
8182 -- since the full view is not there.
8184 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
8185 and then No (Full_View (Desig_Type))
8187 Freeze_Action_Typ := Def_Id;
8190 Freeze_Action_Typ := Desig_Type;
8193 Append_Freeze_Action (Freeze_Action_Typ,
8194 Make_Object_Declaration (Loc,
8195 Defining_Identifier => Pool_Object,
8196 Object_Definition =>
8197 Make_Subtype_Indication (Loc,
8200 (RTE (RE_Stack_Bounded_Pool), Loc),
8203 Make_Index_Or_Discriminant_Constraint (Loc,
8204 Constraints => New_List (
8206 -- First discriminant is the Pool Size
8209 Storage_Size_Variable (Def_Id), Loc),
8211 -- Second discriminant is the element size
8215 -- Third discriminant is the alignment
8220 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
8224 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
8225 -- ---> Storage Pool is the specified one
8227 -- When compiling in Ada 2012 mode, ensure that the accessibility
8228 -- level of the subpool access type is not deeper than that of the
8229 -- pool_with_subpools.
8231 elsif Ada_Version >= Ada_2012
8232 and then Present (Associated_Storage_Pool (Def_Id))
8233 and then RTU_Loaded (System_Storage_Pools_Subpools)
8236 Loc : constant Source_Ptr := Sloc (Def_Id);
8237 Pool : constant Entity_Id :=
8238 Associated_Storage_Pool (Def_Id);
8241 -- It is known that the accessibility level of the access
8242 -- type is deeper than that of the pool.
8244 if Type_Access_Level (Def_Id)
8245 > Static_Accessibility_Level (Pool, Object_Decl_Level)
8246 and then Is_Class_Wide_Type (Etype (Pool))
8247 and then not Accessibility_Checks_Suppressed (Def_Id)
8248 and then not Accessibility_Checks_Suppressed (Pool)
8250 -- When the pool is of a class-wide type, it may or may
8251 -- not support subpools depending on the path of
8252 -- derivation. Generate:
8254 -- if Def_Id in RSPWS'Class then
8255 -- raise Program_Error;
8258 Append_Freeze_Action (Def_Id,
8259 Make_If_Statement (Loc,
8262 Left_Opnd => New_Occurrence_Of (Pool, Loc),
8267 (RE_Root_Storage_Pool_With_Subpools)),
8269 Then_Statements => New_List (
8270 Make_Raise_Program_Error (Loc,
8271 Reason => PE_Accessibility_Check_Failed))));
8276 -- For access-to-controlled types (including class-wide types and
8277 -- Taft-amendment types, which potentially have controlled
8278 -- components), expand the list controller object that will store
8279 -- the dynamically allocated objects. Don't do this transformation
8280 -- for expander-generated access types, except do it for types
8281 -- that are the full view of types derived from other private
8282 -- types and for access types used to implement indirect temps.
8283 -- Also suppress the list controller in the case of a designated
8284 -- type with convention Java, since this is used when binding to
8285 -- Java API specs, where there's no equivalent of a finalization
8286 -- list and we don't want to pull in the finalization support if
8289 if not Comes_From_Source (Def_Id)
8290 and then not Has_Private_Declaration (Def_Id)
8291 and then not Old_Attr_Util.Indirect_Temps
8292 .Is_Access_Type_For_Indirect_Temp (Def_Id)
8296 -- An exception is made for types defined in the run-time because
8297 -- Ada.Tags.Tag itself is such a type and cannot afford this
8298 -- unnecessary overhead that would generates a loop in the
8299 -- expansion scheme. Another exception is if Restrictions
8300 -- (No_Finalization) is active, since then we know nothing is
8303 elsif Restriction_Active (No_Finalization)
8304 or else In_Runtime (Def_Id)
8308 -- Create a finalization master for an access-to-controlled type
8309 -- or an access-to-incomplete type. It is assumed that the full
8310 -- view will be controlled.
8312 elsif Needs_Finalization (Desig_Type)
8313 or else (Is_Incomplete_Type (Desig_Type)
8314 and then No (Full_View (Desig_Type)))
8316 Build_Finalization_Master (Def_Id);
8318 -- Create a finalization master when the designated type contains
8319 -- a private component. It is assumed that the full view will be
8322 elsif Has_Private_Component (Desig_Type) then
8323 Build_Finalization_Master
8325 For_Private => True,
8326 Context_Scope => Scope (Def_Id),
8327 Insertion_Node => Declaration_Node (Desig_Type));
8331 -- Freeze processing for enumeration types
8333 elsif Ekind (Def_Id) = E_Enumeration_Type then
8335 -- We only have something to do if we have a non-standard
8336 -- representation (i.e. at least one literal whose pos value
8337 -- is not the same as its representation)
8339 if Has_Non_Standard_Rep (Def_Id) then
8340 Expand_Freeze_Enumeration_Type (N);
8343 -- Private types that are completed by a derivation from a private
8344 -- type have an internally generated full view, that needs to be
8345 -- frozen. This must be done explicitly because the two views share
8346 -- the freeze node, and the underlying full view is not visible when
8347 -- the freeze node is analyzed.
8349 elsif Is_Private_Type (Def_Id)
8350 and then Is_Derived_Type (Def_Id)
8351 and then Present (Full_View (Def_Id))
8352 and then Is_Itype (Full_View (Def_Id))
8353 and then Has_Private_Declaration (Full_View (Def_Id))
8354 and then Freeze_Node (Full_View (Def_Id)) = N
8356 Set_Entity (N, Full_View (Def_Id));
8357 Result := Freeze_Type (N);
8358 Set_Entity (N, Def_Id);
8360 -- All other types require no expander action. There are such cases
8361 -- (e.g. task types and protected types). In such cases, the freeze
8362 -- nodes are there for use by Gigi.
8366 -- Complete the initialization of all pending access types' finalization
8367 -- masters now that the designated type has been is frozen and primitive
8368 -- Finalize_Address generated.
8370 Process_Pending_Access_Types (Def_Id);
8371 Freeze_Stream_Operations (N, Def_Id);
8373 -- Generate the [spec and] body of the invariant procedure tasked with
8374 -- the runtime verification of all invariants that pertain to the type.
8375 -- This includes invariants on the partial and full view, inherited
8376 -- class-wide invariants from parent types or interfaces, and invariants
8377 -- on array elements or record components.
8379 if Is_Interface (Def_Id) then
8381 -- Interfaces are treated as the partial view of a private type in
8382 -- order to achieve uniformity with the general case. As a result, an
8383 -- interface receives only a "partial" invariant procedure which is
8386 if Has_Own_Invariants (Def_Id) then
8387 Build_Invariant_Procedure_Body
8389 Partial_Invariant => Is_Interface (Def_Id));
8392 -- Non-interface types
8394 -- Do not generate invariant procedure within other assertion
8395 -- subprograms, which may involve local declarations of local
8396 -- subtypes to which these checks do not apply.
8399 if Has_Invariants (Def_Id) then
8400 if not Predicate_Check_In_Scope (Def_Id)
8401 or else (Ekind (Current_Scope) = E_Function
8402 and then Is_Predicate_Function (Current_Scope))
8406 Build_Invariant_Procedure_Body (Def_Id);
8410 -- Generate the [spec and] body of the procedure tasked with the
8411 -- run-time verification of pragma Default_Initial_Condition's
8414 if Has_DIC (Def_Id) then
8415 Build_DIC_Procedure_Body (Def_Id);
8419 Restore_Ghost_Region (Saved_GM, Saved_IGR);
8424 when RE_Not_Available =>
8425 Restore_Ghost_Region (Saved_GM, Saved_IGR);
8430 -------------------------
8431 -- Get_Simple_Init_Val --
8432 -------------------------
8434 function Get_Simple_Init_Val
8437 Size : Uint := No_Uint) return Node_Id
8439 IV_Attribute : constant Boolean :=
8440 Nkind (N) = N_Attribute_Reference
8441 and then Attribute_Name (N) = Name_Invalid_Value;
8443 Loc : constant Source_Ptr := Sloc (N);
8445 procedure Extract_Subtype_Bounds
8446 (Lo_Bound : out Uint;
8447 Hi_Bound : out Uint);
8448 -- Inspect subtype Typ as well its ancestor subtypes and derived types
8449 -- to determine the best known information about the bounds of the type.
8450 -- The output parameters are set as follows:
8452 -- * Lo_Bound - Set to No_Unit when there is no information available,
8453 -- or to the known low bound.
8455 -- * Hi_Bound - Set to No_Unit when there is no information available,
8456 -- or to the known high bound.
8458 function Simple_Init_Array_Type return Node_Id;
8459 -- Build an expression to initialize array type Typ
8461 function Simple_Init_Defaulted_Type return Node_Id;
8462 -- Build an expression to initialize type Typ which is subject to
8463 -- aspect Default_Value.
8465 function Simple_Init_Initialize_Scalars_Type
8466 (Size_To_Use : Uint) return Node_Id;
8467 -- Build an expression to initialize scalar type Typ which is subject to
8468 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
8470 function Simple_Init_Normalize_Scalars_Type
8471 (Size_To_Use : Uint) return Node_Id;
8472 -- Build an expression to initialize scalar type Typ which is subject to
8473 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
8475 function Simple_Init_Private_Type return Node_Id;
8476 -- Build an expression to initialize private type Typ
8478 function Simple_Init_Scalar_Type return Node_Id;
8479 -- Build an expression to initialize scalar type Typ
8481 ----------------------------
8482 -- Extract_Subtype_Bounds --
8483 ----------------------------
8485 procedure Extract_Subtype_Bounds
8486 (Lo_Bound : out Uint;
8487 Hi_Bound : out Uint)
8497 Lo_Bound := No_Uint;
8498 Hi_Bound := No_Uint;
8500 -- Loop to climb ancestor subtypes and derived types
8504 if not Is_Discrete_Type (ST1) then
8508 Lo := Type_Low_Bound (ST1);
8509 Hi := Type_High_Bound (ST1);
8511 if Compile_Time_Known_Value (Lo) then
8512 Lo_Val := Expr_Value (Lo);
8514 if No (Lo_Bound) or else Lo_Bound < Lo_Val then
8519 if Compile_Time_Known_Value (Hi) then
8520 Hi_Val := Expr_Value (Hi);
8522 if No (Hi_Bound) or else Hi_Bound > Hi_Val then
8527 ST2 := Ancestor_Subtype (ST1);
8533 exit when ST1 = ST2;
8536 end Extract_Subtype_Bounds;
8538 ----------------------------
8539 -- Simple_Init_Array_Type --
8540 ----------------------------
8542 function Simple_Init_Array_Type return Node_Id is
8543 Comp_Typ : constant Entity_Id := Component_Type (Typ);
8545 function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
8546 -- Initialize a single array dimension with index constraint Index
8548 --------------------
8549 -- Simple_Init_Dimension --
8550 --------------------
8552 function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
8554 -- Process the current dimension
8556 if Present (Index) then
8558 -- Build a suitable "others" aggregate for the next dimension,
8559 -- or initialize the component itself. Generate:
8564 Make_Aggregate (Loc,
8565 Component_Associations => New_List (
8566 Make_Component_Association (Loc,
8567 Choices => New_List (Make_Others_Choice (Loc)),
8569 Simple_Init_Dimension (Next_Index (Index)))));
8571 -- Otherwise all dimensions have been processed. Initialize the
8572 -- component itself.
8579 Size => Esize (Comp_Typ));
8581 end Simple_Init_Dimension;
8583 -- Start of processing for Simple_Init_Array_Type
8586 return Simple_Init_Dimension (First_Index (Typ));
8587 end Simple_Init_Array_Type;
8589 --------------------------------
8590 -- Simple_Init_Defaulted_Type --
8591 --------------------------------
8593 function Simple_Init_Defaulted_Type return Node_Id is
8594 Subtyp : Entity_Id := First_Subtype (Typ);
8597 -- When the first subtype is private, retrieve the expression of the
8598 -- Default_Value from the underlying type.
8600 if Is_Private_Type (Subtyp) then
8601 Subtyp := Full_View (Subtyp);
8604 -- Use the Sloc of the context node when constructing the initial
8605 -- value because the expression of Default_Value may come from a
8606 -- different unit. Updating the Sloc will result in accurate error
8614 (Source => Default_Aspect_Value (Subtyp),
8616 end Simple_Init_Defaulted_Type;
8618 -----------------------------------------
8619 -- Simple_Init_Initialize_Scalars_Type --
8620 -----------------------------------------
8622 function Simple_Init_Initialize_Scalars_Type
8623 (Size_To_Use : Uint) return Node_Id
8625 Float_Typ : Entity_Id;
8628 Scal_Typ : Scalar_Id;
8631 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
8635 if Is_Floating_Point_Type (Typ) then
8636 Float_Typ := Root_Type (Typ);
8638 if Float_Typ = Standard_Short_Float then
8639 Scal_Typ := Name_Short_Float;
8640 elsif Float_Typ = Standard_Float then
8641 Scal_Typ := Name_Float;
8642 elsif Float_Typ = Standard_Long_Float then
8643 Scal_Typ := Name_Long_Float;
8644 else pragma Assert (Float_Typ = Standard_Long_Long_Float);
8645 Scal_Typ := Name_Long_Long_Float;
8648 -- If zero is invalid, it is a convenient value to use that is for
8649 -- sure an appropriate invalid value in all situations.
8651 elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then
8652 return Make_Integer_Literal (Loc, 0);
8656 elsif Is_Unsigned_Type (Typ) then
8657 if Size_To_Use <= 8 then
8658 Scal_Typ := Name_Unsigned_8;
8659 elsif Size_To_Use <= 16 then
8660 Scal_Typ := Name_Unsigned_16;
8661 elsif Size_To_Use <= 32 then
8662 Scal_Typ := Name_Unsigned_32;
8663 elsif Size_To_Use <= 64 then
8664 Scal_Typ := Name_Unsigned_64;
8666 Scal_Typ := Name_Unsigned_128;
8672 if Size_To_Use <= 8 then
8673 Scal_Typ := Name_Signed_8;
8674 elsif Size_To_Use <= 16 then
8675 Scal_Typ := Name_Signed_16;
8676 elsif Size_To_Use <= 32 then
8677 Scal_Typ := Name_Signed_32;
8678 elsif Size_To_Use <= 64 then
8679 Scal_Typ := Name_Signed_64;
8681 Scal_Typ := Name_Signed_128;
8685 -- Use the values specified by pragma Initialize_Scalars or the ones
8686 -- provided by the binder. Higher precedence is given to the pragma.
8688 return Invalid_Scalar_Value (Loc, Scal_Typ);
8689 end Simple_Init_Initialize_Scalars_Type;
8691 ----------------------------------------
8692 -- Simple_Init_Normalize_Scalars_Type --
8693 ----------------------------------------
8695 function Simple_Init_Normalize_Scalars_Type
8696 (Size_To_Use : Uint) return Node_Id
8698 Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1);
8705 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
8707 -- If zero is invalid, it is a convenient value to use that is for
8708 -- sure an appropriate invalid value in all situations.
8710 if Present (Lo_Bound) and then Lo_Bound > Uint_0 then
8711 Expr := Make_Integer_Literal (Loc, 0);
8713 -- Cases where all one bits is the appropriate invalid value
8715 -- For modular types, all 1 bits is either invalid or valid. If it
8716 -- is valid, then there is nothing that can be done since there are
8717 -- no invalid values (we ruled out zero already).
8719 -- For signed integer types that have no negative values, either
8720 -- there is room for negative values, or there is not. If there
8721 -- is, then all 1-bits may be interpreted as minus one, which is
8722 -- certainly invalid. Alternatively it is treated as the largest
8723 -- positive value, in which case the observation for modular types
8726 -- For float types, all 1-bits is a NaN (not a number), which is
8727 -- certainly an appropriately invalid value.
8729 elsif Is_Enumeration_Type (Typ)
8730 or else Is_Floating_Point_Type (Typ)
8731 or else Is_Unsigned_Type (Typ)
8733 Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
8735 -- Resolve as Long_Long_Long_Unsigned, because the largest number
8736 -- we can generate is out of range of universal integer.
8738 Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned);
8740 -- Case of signed types
8743 -- Normally we like to use the most negative number. The one
8744 -- exception is when this number is in the known subtype range and
8745 -- the largest positive number is not in the known subtype range.
8747 -- For this exceptional case, use largest positive value
8749 if Present (Lo_Bound) and then Present (Hi_Bound)
8750 and then Lo_Bound <= (-(2 ** Signed_Size))
8751 and then Hi_Bound < 2 ** Signed_Size
8753 Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
8755 -- Normal case of largest negative value
8758 Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
8763 end Simple_Init_Normalize_Scalars_Type;
8765 ------------------------------
8766 -- Simple_Init_Private_Type --
8767 ------------------------------
8769 function Simple_Init_Private_Type return Node_Id is
8770 Under_Typ : constant Entity_Id := Underlying_Type (Typ);
8774 -- The availability of the underlying view must be checked by routine
8775 -- Needs_Simple_Initialization.
8777 pragma Assert (Present (Under_Typ));
8779 Expr := Get_Simple_Init_Val (Under_Typ, N, Size);
8781 -- If the initial value is null or an aggregate, qualify it with the
8782 -- underlying type in order to provide a proper context.
8784 if Nkind (Expr) in N_Aggregate | N_Null then
8786 Make_Qualified_Expression (Loc,
8787 Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc),
8788 Expression => Expr);
8791 Expr := Unchecked_Convert_To (Typ, Expr);
8793 -- Do not truncate the result when scalar types are involved and
8794 -- Initialize/Normalize_Scalars is in effect.
8796 if Nkind (Expr) = N_Unchecked_Type_Conversion
8797 and then Is_Scalar_Type (Under_Typ)
8799 Set_No_Truncation (Expr);
8803 end Simple_Init_Private_Type;
8805 -----------------------------
8806 -- Simple_Init_Scalar_Type --
8807 -----------------------------
8809 function Simple_Init_Scalar_Type return Node_Id is
8814 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
8816 -- Determine the size of the object. This is either the size provided
8817 -- by the caller, or the Esize of the scalar type.
8819 if No (Size) or else Size <= Uint_0 then
8820 Size_To_Use := UI_Max (Uint_1, Esize (Typ));
8822 Size_To_Use := Size;
8825 -- The maximum size to use is System_Max_Integer_Size bits. This
8826 -- will create values of type Long_Long_Long_Unsigned and the range
8827 -- must fit this type.
8829 if Present (Size_To_Use)
8830 and then Size_To_Use > System_Max_Integer_Size
8832 Size_To_Use := UI_From_Int (System_Max_Integer_Size);
8835 if Normalize_Scalars and then not IV_Attribute then
8836 Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use);
8838 Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use);
8841 -- The final expression is obtained by doing an unchecked conversion
8842 -- of this result to the base type of the required subtype. Use the
8843 -- base type to prevent the unchecked conversion from chopping bits,
8844 -- and then we set Kill_Range_Check to preserve the "bad" value.
8846 Expr := Unchecked_Convert_To (Base_Type (Typ), Expr);
8848 -- Ensure that the expression is not truncated since the "bad" bits
8849 -- are desired, and also kill the range checks.
8851 if Nkind (Expr) = N_Unchecked_Type_Conversion then
8852 Set_Kill_Range_Check (Expr);
8853 Set_No_Truncation (Expr);
8857 end Simple_Init_Scalar_Type;
8859 -- Start of processing for Get_Simple_Init_Val
8862 if Is_Private_Type (Typ) then
8863 return Simple_Init_Private_Type;
8865 elsif Is_Scalar_Type (Typ) then
8866 if Has_Default_Aspect (Typ) then
8867 return Simple_Init_Defaulted_Type;
8869 return Simple_Init_Scalar_Type;
8872 -- Array type with Initialize or Normalize_Scalars
8874 elsif Is_Array_Type (Typ) then
8875 pragma Assert (Init_Or_Norm_Scalars);
8876 return Simple_Init_Array_Type;
8878 -- Access type is initialized to null
8880 elsif Is_Access_Type (Typ) then
8881 return Make_Null (Loc);
8883 -- No other possibilities should arise, since we should only be calling
8884 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
8885 -- indicating one of the above cases held.
8888 raise Program_Error;
8892 when RE_Not_Available =>
8894 end Get_Simple_Init_Val;
8896 ------------------------------
8897 -- Has_New_Non_Standard_Rep --
8898 ------------------------------
8900 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
8902 if not Is_Derived_Type (T) then
8903 return Has_Non_Standard_Rep (T)
8904 or else Has_Non_Standard_Rep (Root_Type (T));
8906 -- If Has_Non_Standard_Rep is not set on the derived type, the
8907 -- representation is fully inherited.
8909 elsif not Has_Non_Standard_Rep (T) then
8913 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
8915 -- May need a more precise check here: the First_Rep_Item may be a
8916 -- stream attribute, which does not affect the representation of the
8920 end Has_New_Non_Standard_Rep;
8922 ----------------------
8923 -- Inline_Init_Proc --
8924 ----------------------
8926 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
8928 -- The initialization proc of protected records is not worth inlining.
8929 -- In addition, when compiled for another unit for inlining purposes,
8930 -- it may make reference to entities that have not been elaborated yet.
8931 -- The initialization proc of records that need finalization contains
8932 -- a nested clean-up procedure that makes it impractical to inline as
8933 -- well, except for simple controlled types themselves. And similar
8934 -- considerations apply to task types.
8936 if Is_Concurrent_Type (Typ) then
8939 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
8942 elsif Has_Task (Typ) then
8948 end Inline_Init_Proc;
8954 function In_Runtime (E : Entity_Id) return Boolean is
8959 while Scope (S1) /= Standard_Standard loop
8963 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
8966 ----------------------------
8967 -- Initialization_Warning --
8968 ----------------------------
8970 procedure Initialization_Warning (E : Entity_Id) is
8971 Warning_Needed : Boolean;
8974 Warning_Needed := False;
8976 if Ekind (Current_Scope) = E_Package
8977 and then Static_Elaboration_Desired (Current_Scope)
8980 if Is_Record_Type (E) then
8981 if Has_Discriminants (E)
8982 or else Is_Limited_Type (E)
8983 or else Has_Non_Standard_Rep (E)
8985 Warning_Needed := True;
8988 -- Verify that at least one component has an initialization
8989 -- expression. No need for a warning on a type if all its
8990 -- components have no initialization.
8996 Comp := First_Component (E);
8997 while Present (Comp) loop
8999 (Nkind (Parent (Comp)) = N_Component_Declaration);
9001 if Present (Expression (Parent (Comp))) then
9002 Warning_Needed := True;
9006 Next_Component (Comp);
9011 if Warning_Needed then
9013 ("objects of the type cannot be initialized statically "
9014 & "by default??", Parent (E));
9019 Error_Msg_N ("object cannot be initialized statically??", E);
9022 end Initialization_Warning;
9028 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id
9030 Loc : constant Source_Ptr := Sloc (Typ);
9031 Unc_Arr : constant Boolean :=
9032 Is_Array_Type (Typ) and then not Is_Constrained (Typ);
9033 With_Prot : constant Boolean :=
9035 or else (Is_Record_Type (Typ)
9036 and then Is_Protected_Record_Type (Typ));
9037 With_Task : constant Boolean :=
9038 not Global_No_Tasking
9041 or else (Is_Record_Type (Typ)
9042 and then Is_Task_Record_Type (Typ)));
9046 -- The first parameter is always _Init : [in] out Typ. Note that we need
9047 -- it to be in/out in the case of an unconstrained array, because of the
9048 -- need to have the bounds, and in the case of protected or task record
9049 -- value, because there are default record fields that may be referenced
9050 -- in the generated initialization routine.
9052 Formals := New_List (
9053 Make_Parameter_Specification (Loc,
9054 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
9055 In_Present => Unc_Arr or else With_Prot or else With_Task,
9056 Out_Present => True,
9057 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
9059 -- For task record value, or type that contains tasks, add two more
9060 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
9061 -- We also add these parameters for the task record type case.
9065 Make_Parameter_Specification (Loc,
9066 Defining_Identifier =>
9067 Make_Defining_Identifier (Loc, Name_uMaster),
9069 New_Occurrence_Of (Standard_Integer, Loc)));
9071 Set_Has_Master_Entity (Proc_Id);
9073 -- Add _Chain (not done for sequential elaboration policy, see
9074 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
9076 if Partition_Elaboration_Policy /= 'S' then
9078 Make_Parameter_Specification (Loc,
9079 Defining_Identifier =>
9080 Make_Defining_Identifier (Loc, Name_uChain),
9082 Out_Present => True,
9084 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
9088 Make_Parameter_Specification (Loc,
9089 Defining_Identifier =>
9090 Make_Defining_Identifier (Loc, Name_uTask_Name),
9092 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
9095 -- Due to certain edge cases such as arrays with null-excluding
9096 -- components being built with the secondary stack it becomes necessary
9097 -- to add a formal to the Init_Proc which controls whether we raise
9098 -- Constraint_Errors on generated calls for internal object
9101 if Needs_Conditional_Null_Excluding_Check (Typ) then
9103 Make_Parameter_Specification (Loc,
9104 Defining_Identifier =>
9105 Make_Defining_Identifier (Loc,
9106 New_External_Name (Chars
9107 (Component_Type (Typ)), "_skip_null_excluding_check")),
9108 Expression => New_Occurrence_Of (Standard_False, Loc),
9111 New_Occurrence_Of (Standard_Boolean, Loc)));
9117 when RE_Not_Available =>
9121 -------------------------
9122 -- Init_Secondary_Tags --
9123 -------------------------
9125 procedure Init_Secondary_Tags
9128 Init_Tags_List : List_Id;
9129 Stmts_List : List_Id;
9130 Fixed_Comps : Boolean := True;
9131 Variable_Comps : Boolean := True)
9133 Loc : constant Source_Ptr := Sloc (Target);
9135 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
9136 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
9138 procedure Initialize_Tag
9141 Tag_Comp : Entity_Id;
9142 Iface_Tag : Node_Id);
9143 -- Initialize the tag of the secondary dispatch table of Typ associated
9144 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
9145 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
9146 -- of Typ CPP tagged type we generate code to inherit the contents of
9147 -- the dispatch table directly from the ancestor.
9149 --------------------
9150 -- Initialize_Tag --
9151 --------------------
9153 procedure Initialize_Tag
9156 Tag_Comp : Entity_Id;
9157 Iface_Tag : Node_Id)
9159 Comp_Typ : Entity_Id;
9160 Offset_To_Top_Comp : Entity_Id := Empty;
9163 -- Initialize pointer to secondary DT associated with the interface
9165 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
9166 Append_To (Init_Tags_List,
9167 Make_Assignment_Statement (Loc,
9169 Make_Selected_Component (Loc,
9170 Prefix => New_Copy_Tree (Target),
9171 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
9173 New_Occurrence_Of (Iface_Tag, Loc)));
9176 Comp_Typ := Scope (Tag_Comp);
9178 -- Initialize the entries of the table of interfaces. We generate a
9179 -- different call when the parent of the type has variable size
9182 if Comp_Typ /= Etype (Comp_Typ)
9183 and then Is_Variable_Size_Record (Etype (Comp_Typ))
9184 and then Chars (Tag_Comp) /= Name_uTag
9186 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
9188 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
9189 -- configurable run-time environment.
9191 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
9193 ("variable size record with interface types", Typ);
9198 -- Set_Dynamic_Offset_To_Top
9200 -- Prim_T => Typ'Tag,
9201 -- Interface_T => Iface'Tag,
9202 -- Offset_Value => n,
9203 -- Offset_Func => Fn'Address)
9205 Append_To (Stmts_List,
9206 Make_Procedure_Call_Statement (Loc,
9208 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
9209 Parameter_Associations => New_List (
9210 Make_Attribute_Reference (Loc,
9211 Prefix => New_Copy_Tree (Target),
9212 Attribute_Name => Name_Address),
9214 Unchecked_Convert_To (RTE (RE_Tag),
9216 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
9218 Unchecked_Convert_To (RTE (RE_Tag),
9220 (Node (First_Elmt (Access_Disp_Table (Iface))),
9223 Unchecked_Convert_To
9224 (RTE (RE_Storage_Offset),
9226 Make_Attribute_Reference (Loc,
9228 Make_Selected_Component (Loc,
9229 Prefix => New_Copy_Tree (Target),
9231 New_Occurrence_Of (Tag_Comp, Loc)),
9232 Attribute_Name => Name_Position))),
9234 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
9235 Make_Attribute_Reference (Loc,
9236 Prefix => New_Occurrence_Of
9237 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
9238 Attribute_Name => Name_Address)))));
9240 -- In this case the next component stores the value of the offset
9243 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
9244 pragma Assert (Present (Offset_To_Top_Comp));
9246 Append_To (Init_Tags_List,
9247 Make_Assignment_Statement (Loc,
9249 Make_Selected_Component (Loc,
9250 Prefix => New_Copy_Tree (Target),
9252 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
9256 Make_Attribute_Reference (Loc,
9258 Make_Selected_Component (Loc,
9259 Prefix => New_Copy_Tree (Target),
9260 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
9261 Attribute_Name => Name_Position))));
9263 -- Normal case: No discriminants in the parent type
9266 -- Don't need to set any value if the offset-to-top field is
9267 -- statically set or if this interface shares the primary
9270 if not Building_Static_Secondary_DT (Typ)
9271 and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
9273 Append_To (Stmts_List,
9274 Build_Set_Static_Offset_To_Top (Loc,
9275 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
9277 Unchecked_Convert_To (RTE (RE_Storage_Offset),
9279 Make_Attribute_Reference (Loc,
9281 Make_Selected_Component (Loc,
9282 Prefix => New_Copy_Tree (Target),
9284 New_Occurrence_Of (Tag_Comp, Loc)),
9285 Attribute_Name => Name_Position)))));
9289 -- Register_Interface_Offset
9290 -- (Prim_T => Typ'Tag,
9291 -- Interface_T => Iface'Tag,
9292 -- Is_Constant => True,
9293 -- Offset_Value => n,
9294 -- Offset_Func => null);
9296 if not Building_Static_Secondary_DT (Typ)
9297 and then RTE_Available (RE_Register_Interface_Offset)
9299 Append_To (Stmts_List,
9300 Make_Procedure_Call_Statement (Loc,
9303 (RTE (RE_Register_Interface_Offset), Loc),
9304 Parameter_Associations => New_List (
9305 Unchecked_Convert_To (RTE (RE_Tag),
9307 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
9309 Unchecked_Convert_To (RTE (RE_Tag),
9311 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
9313 New_Occurrence_Of (Standard_True, Loc),
9315 Unchecked_Convert_To (RTE (RE_Storage_Offset),
9317 Make_Attribute_Reference (Loc,
9319 Make_Selected_Component (Loc,
9320 Prefix => New_Copy_Tree (Target),
9322 New_Occurrence_Of (Tag_Comp, Loc)),
9323 Attribute_Name => Name_Position))),
9332 Full_Typ : Entity_Id;
9333 Ifaces_List : Elist_Id;
9334 Ifaces_Comp_List : Elist_Id;
9335 Ifaces_Tag_List : Elist_Id;
9336 Iface_Elmt : Elmt_Id;
9337 Iface_Comp_Elmt : Elmt_Id;
9338 Iface_Tag_Elmt : Elmt_Id;
9340 In_Variable_Pos : Boolean;
9342 -- Start of processing for Init_Secondary_Tags
9345 -- Handle private types
9347 if Present (Full_View (Typ)) then
9348 Full_Typ := Full_View (Typ);
9353 Collect_Interfaces_Info
9354 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
9356 Iface_Elmt := First_Elmt (Ifaces_List);
9357 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
9358 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
9359 while Present (Iface_Elmt) loop
9360 Tag_Comp := Node (Iface_Comp_Elmt);
9362 -- Check if parent of record type has variable size components
9364 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
9365 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
9367 -- If we are compiling under the CPP full ABI compatibility mode and
9368 -- the ancestor is a CPP_Pragma tagged type then we generate code to
9369 -- initialize the secondary tag components from tags that reference
9370 -- secondary tables filled with copy of parent slots.
9372 if Is_CPP_Class (Root_Type (Full_Typ)) then
9374 -- Reject interface components located at variable offset in
9375 -- C++ derivations. This is currently unsupported.
9377 if not Fixed_Comps and then In_Variable_Pos then
9379 -- Locate the first dynamic component of the record. Done to
9380 -- improve the text of the warning.
9384 Comp_Typ : Entity_Id;
9387 Comp := First_Entity (Typ);
9388 while Present (Comp) loop
9389 Comp_Typ := Etype (Comp);
9391 if Ekind (Comp) /= E_Discriminant
9392 and then not Is_Tag (Comp)
9395 (Is_Record_Type (Comp_Typ)
9397 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
9399 (Is_Array_Type (Comp_Typ)
9400 and then Is_Variable_Size_Array (Comp_Typ));
9406 pragma Assert (Present (Comp));
9408 -- Move this check to sem???
9409 Error_Msg_Node_2 := Comp;
9411 ("parent type & with dynamic component & cannot be parent"
9412 & " of 'C'P'P derivation if new interfaces are present",
9413 Typ, Scope (Original_Record_Component (Comp)));
9416 Sloc (Scope (Original_Record_Component (Comp)));
9418 ("type derived from 'C'P'P type & defined #",
9419 Typ, Scope (Original_Record_Component (Comp)));
9421 -- Avoid duplicated warnings
9426 -- Initialize secondary tags
9431 Iface => Node (Iface_Elmt),
9432 Tag_Comp => Tag_Comp,
9433 Iface_Tag => Node (Iface_Tag_Elmt));
9436 -- Otherwise generate code to initialize the tag
9439 if (In_Variable_Pos and then Variable_Comps)
9440 or else (not In_Variable_Pos and then Fixed_Comps)
9444 Iface => Node (Iface_Elmt),
9445 Tag_Comp => Tag_Comp,
9446 Iface_Tag => Node (Iface_Tag_Elmt));
9450 Next_Elmt (Iface_Elmt);
9451 Next_Elmt (Iface_Comp_Elmt);
9452 Next_Elmt (Iface_Tag_Elmt);
9454 end Init_Secondary_Tags;
9456 ----------------------------
9457 -- Is_Null_Statement_List --
9458 ----------------------------
9460 function Is_Null_Statement_List (Stmts : List_Id) return Boolean is
9464 -- We must skip SCIL nodes because they may have been added to the list
9465 -- by Insert_Actions.
9467 Stmt := First_Non_SCIL_Node (Stmts);
9468 while Present (Stmt) loop
9469 if Nkind (Stmt) = N_Case_Statement then
9473 Alt := First (Alternatives (Stmt));
9474 while Present (Alt) loop
9475 if not Is_Null_Statement_List (Statements (Alt)) then
9483 elsif Nkind (Stmt) /= N_Null_Statement then
9487 Stmt := Next_Non_SCIL_Node (Stmt);
9491 end Is_Null_Statement_List;
9493 ------------------------------
9494 -- Is_User_Defined_Equality --
9495 ------------------------------
9497 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
9499 return Chars (Prim) = Name_Op_Eq
9500 and then Etype (First_Formal (Prim)) =
9501 Etype (Next_Formal (First_Formal (Prim)))
9502 and then Base_Type (Etype (Prim)) = Standard_Boolean;
9503 end Is_User_Defined_Equality;
9505 ----------------------------------------
9506 -- Make_Controlling_Function_Wrappers --
9507 ----------------------------------------
9509 procedure Make_Controlling_Function_Wrappers
9510 (Tag_Typ : Entity_Id;
9511 Decl_List : out List_Id;
9512 Body_List : out List_Id)
9514 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9515 Prim_Elmt : Elmt_Id;
9517 Actual_List : List_Id;
9518 Formal_List : List_Id;
9520 Par_Formal : Entity_Id;
9521 Formal_Node : Node_Id;
9522 Func_Body : Node_Id;
9523 Func_Decl : Node_Id;
9524 Func_Spec : Node_Id;
9525 Return_Stmt : Node_Id;
9528 Decl_List := New_List;
9529 Body_List := New_List;
9531 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
9532 while Present (Prim_Elmt) loop
9533 Subp := Node (Prim_Elmt);
9535 -- If a primitive function with a controlling result of the type has
9536 -- not been overridden by the user, then we must create a wrapper
9537 -- function here that effectively overrides it and invokes the
9538 -- (non-abstract) parent function. This can only occur for a null
9539 -- extension. Note that functions with anonymous controlling access
9540 -- results don't qualify and must be overridden. We also exclude
9541 -- Input attributes, since each type will have its own version of
9542 -- Input constructed by the expander. The test for Comes_From_Source
9543 -- is needed to distinguish inherited operations from renamings
9544 -- (which also have Alias set). We exclude internal entities with
9545 -- Interface_Alias to avoid generating duplicated wrappers since
9546 -- the primitive which covers the interface is also available in
9547 -- the list of primitive operations.
9549 -- The function may be abstract, or require_Overriding may be set
9550 -- for it, because tests for null extensions may already have reset
9551 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
9552 -- set, functions that need wrappers are recognized by having an
9553 -- alias that returns the parent type.
9555 if Comes_From_Source (Subp)
9556 or else No (Alias (Subp))
9557 or else Present (Interface_Alias (Subp))
9558 or else Ekind (Subp) /= E_Function
9559 or else not Has_Controlling_Result (Subp)
9560 or else Is_Access_Type (Etype (Subp))
9561 or else Is_Abstract_Subprogram (Alias (Subp))
9562 or else Is_TSS (Subp, TSS_Stream_Input)
9566 elsif Is_Abstract_Subprogram (Subp)
9567 or else Requires_Overriding (Subp)
9569 (Is_Null_Extension (Etype (Subp))
9570 and then Etype (Alias (Subp)) /= Etype (Subp))
9572 -- If there is a non-overloadable homonym in the current
9573 -- scope, the implicit declaration remains invisible.
9574 -- We check the current entity with the same name, or its
9575 -- homonym in case the derivation takes place after the
9576 -- hiding object declaration.
9578 if Present (Current_Entity (Subp)) then
9580 Curr : constant Entity_Id := Current_Entity (Subp);
9581 Prev : constant Entity_Id := Homonym (Curr);
9583 if (Comes_From_Source (Curr)
9584 and then Scope (Curr) = Current_Scope
9585 and then not Is_Overloadable (Curr))
9588 and then Comes_From_Source (Prev)
9589 and then Scope (Prev) = Current_Scope
9590 and then not Is_Overloadable (Prev))
9597 Formal_List := No_List;
9598 Formal := First_Formal (Subp);
9600 if Present (Formal) then
9601 Formal_List := New_List;
9603 while Present (Formal) loop
9605 (Make_Parameter_Specification
9607 Defining_Identifier =>
9608 Make_Defining_Identifier (Sloc (Formal),
9609 Chars => Chars (Formal)),
9610 In_Present => In_Present (Parent (Formal)),
9611 Out_Present => Out_Present (Parent (Formal)),
9612 Null_Exclusion_Present =>
9613 Null_Exclusion_Present (Parent (Formal)),
9615 New_Occurrence_Of (Etype (Formal), Loc),
9617 New_Copy_Tree (Expression (Parent (Formal)))),
9620 Next_Formal (Formal);
9625 Make_Function_Specification (Loc,
9626 Defining_Unit_Name =>
9627 Make_Defining_Identifier (Loc,
9628 Chars => Chars (Subp)),
9629 Parameter_Specifications => Formal_List,
9630 Result_Definition =>
9631 New_Occurrence_Of (Etype (Subp), Loc));
9633 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
9634 Append_To (Decl_List, Func_Decl);
9636 -- Build a wrapper body that calls the parent function. The body
9637 -- contains a single return statement that returns an extension
9638 -- aggregate whose ancestor part is a call to the parent function,
9639 -- passing the formals as actuals (with any controlling arguments
9640 -- converted to the types of the corresponding formals of the
9641 -- parent function, which might be anonymous access types), and
9642 -- having a null extension.
9644 Formal := First_Formal (Subp);
9645 Par_Formal := First_Formal (Alias (Subp));
9646 Formal_Node := First (Formal_List);
9648 if Present (Formal) then
9649 Actual_List := New_List;
9651 Actual_List := No_List;
9654 while Present (Formal) loop
9655 if Is_Controlling_Formal (Formal) then
9656 Append_To (Actual_List,
9657 Make_Type_Conversion (Loc,
9659 New_Occurrence_Of (Etype (Par_Formal), Loc),
9662 (Defining_Identifier (Formal_Node), Loc)));
9667 (Defining_Identifier (Formal_Node), Loc));
9670 Next_Formal (Formal);
9671 Next_Formal (Par_Formal);
9676 Make_Simple_Return_Statement (Loc,
9678 Make_Extension_Aggregate (Loc,
9680 Make_Function_Call (Loc,
9682 New_Occurrence_Of (Alias (Subp), Loc),
9683 Parameter_Associations => Actual_List),
9684 Null_Record_Present => True));
9687 Make_Subprogram_Body (Loc,
9688 Specification => New_Copy_Tree (Func_Spec),
9689 Declarations => Empty_List,
9690 Handled_Statement_Sequence =>
9691 Make_Handled_Sequence_Of_Statements (Loc,
9692 Statements => New_List (Return_Stmt)));
9694 Set_Defining_Unit_Name
9695 (Specification (Func_Body),
9696 Make_Defining_Identifier (Loc, Chars (Subp)));
9698 Append_To (Body_List, Func_Body);
9700 -- Replace the inherited function with the wrapper function in the
9701 -- primitive operations list. We add the minimum decoration needed
9702 -- to override interface primitives.
9704 Mutate_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
9705 Set_Is_Wrapper (Defining_Unit_Name (Func_Spec));
9707 Override_Dispatching_Operation
9708 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
9712 Next_Elmt (Prim_Elmt);
9714 end Make_Controlling_Function_Wrappers;
9720 function Make_Eq_Body
9722 Eq_Name : Name_Id) return Node_Id
9724 Loc : constant Source_Ptr := Sloc (Parent (Typ));
9726 Def : constant Node_Id := Parent (Typ);
9727 Stmts : constant List_Id := New_List;
9728 Variant_Case : Boolean := Has_Discriminants (Typ);
9729 Comps : Node_Id := Empty;
9730 Typ_Def : Node_Id := Type_Definition (Def);
9734 Predef_Spec_Or_Body (Loc,
9737 Profile => New_List (
9738 Make_Parameter_Specification (Loc,
9739 Defining_Identifier =>
9740 Make_Defining_Identifier (Loc, Name_X),
9741 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
9743 Make_Parameter_Specification (Loc,
9744 Defining_Identifier =>
9745 Make_Defining_Identifier (Loc, Name_Y),
9746 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9748 Ret_Type => Standard_Boolean,
9751 if Variant_Case then
9752 if Nkind (Typ_Def) = N_Derived_Type_Definition then
9753 Typ_Def := Record_Extension_Part (Typ_Def);
9756 if Present (Typ_Def) then
9757 Comps := Component_List (Typ_Def);
9761 Present (Comps) and then Present (Variant_Part (Comps));
9764 if Variant_Case then
9766 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
9767 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
9769 Make_Simple_Return_Statement (Loc,
9770 Expression => New_Occurrence_Of (Standard_True, Loc)));
9774 Make_Simple_Return_Statement (Loc,
9776 Expand_Record_Equality
9779 Lhs => Make_Identifier (Loc, Name_X),
9780 Rhs => Make_Identifier (Loc, Name_Y),
9781 Bodies => Declarations (Decl))));
9784 Set_Handled_Statement_Sequence
9785 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
9793 -- <Make_Eq_If shared components>
9796 -- when V1 => <Make_Eq_Case> on subcomponents
9798 -- when Vn => <Make_Eq_Case> on subcomponents
9801 function Make_Eq_Case
9804 Discrs : Elist_Id := New_Elmt_List) return List_Id
9806 Loc : constant Source_Ptr := Sloc (E);
9807 Result : constant List_Id := New_List;
9811 function Corresponding_Formal (C : Node_Id) return Entity_Id;
9812 -- Given the discriminant that controls a given variant of an unchecked
9813 -- union, find the formal of the equality function that carries the
9814 -- inferred value of the discriminant.
9816 function External_Name (E : Entity_Id) return Name_Id;
9817 -- The value of a given discriminant is conveyed in the corresponding
9818 -- formal parameter of the equality routine. The name of this formal
9819 -- parameter carries a one-character suffix which is removed here.
9821 --------------------------
9822 -- Corresponding_Formal --
9823 --------------------------
9825 function Corresponding_Formal (C : Node_Id) return Entity_Id is
9826 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
9830 Elm := First_Elmt (Discrs);
9831 while Present (Elm) loop
9832 if Chars (Discr) = External_Name (Node (Elm)) then
9839 -- A formal of the proper name must be found
9841 raise Program_Error;
9842 end Corresponding_Formal;
9848 function External_Name (E : Entity_Id) return Name_Id is
9850 Get_Name_String (Chars (E));
9851 Name_Len := Name_Len - 1;
9855 -- Start of processing for Make_Eq_Case
9858 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
9860 if No (Variant_Part (CL)) then
9864 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
9866 if No (Variant) then
9870 Alt_List := New_List;
9871 while Present (Variant) loop
9872 Append_To (Alt_List,
9873 Make_Case_Statement_Alternative (Loc,
9874 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
9876 Make_Eq_Case (E, Component_List (Variant), Discrs)));
9877 Next_Non_Pragma (Variant);
9880 -- If we have an Unchecked_Union, use one of the parameters of the
9881 -- enclosing equality routine that captures the discriminant, to use
9882 -- as the expression in the generated case statement.
9884 if Is_Unchecked_Union (E) then
9886 Make_Case_Statement (Loc,
9888 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
9889 Alternatives => Alt_List));
9893 Make_Case_Statement (Loc,
9895 Make_Selected_Component (Loc,
9896 Prefix => Make_Identifier (Loc, Name_X),
9897 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
9898 Alternatives => Alt_List));
9919 -- or a null statement if the list L is empty
9921 -- Equality may be user-defined for a given component type, in which case
9922 -- a function call is constructed instead of an operator node. This is an
9923 -- Ada 2012 change in the composability of equality for untagged composite
9928 L : List_Id) return Node_Id
9930 Loc : constant Source_Ptr := Sloc (E);
9934 Field_Name : Name_Id;
9935 Next_Test : Node_Id;
9940 return Make_Null_Statement (Loc);
9945 C := First_Non_Pragma (L);
9946 while Present (C) loop
9947 Typ := Etype (Defining_Identifier (C));
9948 Field_Name := Chars (Defining_Identifier (C));
9950 -- The tags must not be compared: they are not part of the value.
9951 -- Ditto for parent interfaces because their equality operator is
9954 -- Note also that in the following, we use Make_Identifier for
9955 -- the component names. Use of New_Occurrence_Of to identify the
9956 -- components would be incorrect because the wrong entities for
9957 -- discriminants could be picked up in the private type case.
9959 if Field_Name = Name_uParent
9960 and then Is_Interface (Typ)
9964 elsif Field_Name /= Name_uTag then
9966 Lhs : constant Node_Id :=
9967 Make_Selected_Component (Loc,
9968 Prefix => Make_Identifier (Loc, Name_X),
9969 Selector_Name => Make_Identifier (Loc, Field_Name));
9971 Rhs : constant Node_Id :=
9972 Make_Selected_Component (Loc,
9973 Prefix => Make_Identifier (Loc, Name_Y),
9974 Selector_Name => Make_Identifier (Loc, Field_Name));
9978 -- Build equality code with a user-defined operator, if
9979 -- available, and with the predefined "=" otherwise. For
9980 -- compatibility with older Ada versions, we also use the
9981 -- predefined operation if the component-type equality is
9982 -- abstract, rather than raising Program_Error.
9984 if Ada_Version < Ada_2012 then
9985 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
9988 Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
9990 if No (Eq_Call) then
9991 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
9993 -- If a component has a defined abstract equality, its
9994 -- application raises Program_Error on that component
9995 -- and therefore on the current variant.
9997 elsif Nkind (Eq_Call) = N_Raise_Program_Error then
9998 Set_Etype (Eq_Call, Standard_Boolean);
9999 Next_Test := Make_Op_Not (Loc, Eq_Call);
10002 Next_Test := Make_Op_Not (Loc, Eq_Call);
10007 Evolve_Or_Else (Cond, Next_Test);
10010 Next_Non_Pragma (C);
10014 return Make_Null_Statement (Loc);
10018 Make_Implicit_If_Statement (E,
10020 Then_Statements => New_List (
10021 Make_Simple_Return_Statement (Loc,
10022 Expression => New_Occurrence_Of (Standard_False, Loc))));
10027 -------------------
10028 -- Make_Neq_Body --
10029 -------------------
10031 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
10033 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
10034 -- Returns true if Prim is a renaming of an unresolved predefined
10035 -- inequality operation.
10037 --------------------------------
10038 -- Is_Predefined_Neq_Renaming --
10039 --------------------------------
10041 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
10043 return Chars (Prim) /= Name_Op_Ne
10044 and then Present (Alias (Prim))
10045 and then Comes_From_Source (Prim)
10046 and then Is_Intrinsic_Subprogram (Alias (Prim))
10047 and then Chars (Alias (Prim)) = Name_Op_Ne;
10048 end Is_Predefined_Neq_Renaming;
10052 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
10053 Stmts : constant List_Id := New_List;
10055 Eq_Prim : Entity_Id;
10056 Left_Op : Entity_Id;
10057 Renaming_Prim : Entity_Id;
10058 Right_Op : Entity_Id;
10059 Target : Entity_Id;
10061 -- Start of processing for Make_Neq_Body
10064 -- For a call on a renaming of a dispatching subprogram that is
10065 -- overridden, if the overriding occurred before the renaming, then
10066 -- the body executed is that of the overriding declaration, even if the
10067 -- overriding declaration is not visible at the place of the renaming;
10068 -- otherwise, the inherited or predefined subprogram is called, see
10071 -- Stage 1: Search for a renaming of the inequality primitive and also
10072 -- search for an overriding of the equality primitive located before the
10073 -- renaming declaration.
10081 Renaming_Prim := Empty;
10083 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
10084 while Present (Elmt) loop
10085 Prim := Node (Elmt);
10087 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
10088 if No (Renaming_Prim) then
10089 pragma Assert (No (Eq_Prim));
10093 elsif Is_Predefined_Neq_Renaming (Prim) then
10094 Renaming_Prim := Prim;
10101 -- No further action needed if no renaming was found
10103 if No (Renaming_Prim) then
10107 -- Stage 2: Replace the renaming declaration by a subprogram declaration
10108 -- (required to add its body)
10110 Decl := Parent (Parent (Renaming_Prim));
10112 Make_Subprogram_Declaration (Loc,
10113 Specification => Specification (Decl)));
10114 Set_Analyzed (Decl);
10116 -- Remove the decoration of intrinsic renaming subprogram
10118 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
10119 Set_Convention (Renaming_Prim, Convention_Ada);
10120 Set_Alias (Renaming_Prim, Empty);
10121 Set_Has_Completion (Renaming_Prim, False);
10123 -- Stage 3: Build the corresponding body
10125 Left_Op := First_Formal (Renaming_Prim);
10126 Right_Op := Next_Formal (Left_Op);
10129 Predef_Spec_Or_Body (Loc,
10130 Tag_Typ => Tag_Typ,
10131 Name => Chars (Renaming_Prim),
10132 Profile => New_List (
10133 Make_Parameter_Specification (Loc,
10134 Defining_Identifier =>
10135 Make_Defining_Identifier (Loc, Chars (Left_Op)),
10136 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10138 Make_Parameter_Specification (Loc,
10139 Defining_Identifier =>
10140 Make_Defining_Identifier (Loc, Chars (Right_Op)),
10141 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10143 Ret_Type => Standard_Boolean,
10146 -- If the overriding of the equality primitive occurred before the
10147 -- renaming, then generate:
10149 -- function <Neq_Name> (X : Y : Typ) return Boolean is
10151 -- return not Oeq (X, Y);
10154 if Present (Eq_Prim) then
10157 -- Otherwise build a nested subprogram which performs the predefined
10158 -- evaluation of the equality operator. That is, generate:
10160 -- function <Neq_Name> (X : Y : Typ) return Boolean is
10161 -- function Oeq (X : Y) return Boolean is
10163 -- <<body of default implementation>>
10166 -- return not Oeq (X, Y);
10171 Local_Subp : Node_Id;
10173 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
10174 Set_Declarations (Decl, New_List (Local_Subp));
10175 Target := Defining_Entity (Local_Subp);
10180 Make_Simple_Return_Statement (Loc,
10183 Make_Function_Call (Loc,
10184 Name => New_Occurrence_Of (Target, Loc),
10185 Parameter_Associations => New_List (
10186 Make_Identifier (Loc, Chars (Left_Op)),
10187 Make_Identifier (Loc, Chars (Right_Op)))))));
10189 Set_Handled_Statement_Sequence
10190 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
10194 -------------------------------
10195 -- Make_Null_Procedure_Specs --
10196 -------------------------------
10198 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
10199 Decl_List : constant List_Id := New_List;
10200 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10201 Formal : Entity_Id;
10202 Formal_List : List_Id;
10203 New_Param_Spec : Node_Id;
10204 Parent_Subp : Entity_Id;
10205 Prim_Elmt : Elmt_Id;
10209 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
10210 while Present (Prim_Elmt) loop
10211 Subp := Node (Prim_Elmt);
10213 -- If a null procedure inherited from an interface has not been
10214 -- overridden, then we build a null procedure declaration to
10215 -- override the inherited procedure.
10217 Parent_Subp := Alias (Subp);
10219 if Present (Parent_Subp)
10220 and then Is_Null_Interface_Primitive (Parent_Subp)
10222 Formal_List := No_List;
10223 Formal := First_Formal (Subp);
10225 if Present (Formal) then
10226 Formal_List := New_List;
10228 while Present (Formal) loop
10230 -- Copy the parameter spec including default expressions
10233 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
10235 -- Generate a new defining identifier for the new formal.
10236 -- required because New_Copy_Tree does not duplicate
10237 -- semantic fields (except itypes).
10239 Set_Defining_Identifier (New_Param_Spec,
10240 Make_Defining_Identifier (Sloc (Formal),
10241 Chars => Chars (Formal)));
10243 -- For controlling arguments we must change their
10244 -- parameter type to reference the tagged type (instead
10245 -- of the interface type)
10247 if Is_Controlling_Formal (Formal) then
10248 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
10250 Set_Parameter_Type (New_Param_Spec,
10251 New_Occurrence_Of (Tag_Typ, Loc));
10254 (Nkind (Parameter_Type (Parent (Formal))) =
10255 N_Access_Definition);
10256 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
10257 New_Occurrence_Of (Tag_Typ, Loc));
10261 Append (New_Param_Spec, Formal_List);
10263 Next_Formal (Formal);
10267 Append_To (Decl_List,
10268 Make_Subprogram_Declaration (Loc,
10269 Make_Procedure_Specification (Loc,
10270 Defining_Unit_Name =>
10271 Make_Defining_Identifier (Loc, Chars (Subp)),
10272 Parameter_Specifications => Formal_List,
10273 Null_Present => True)));
10276 Next_Elmt (Prim_Elmt);
10280 end Make_Null_Procedure_Specs;
10282 -------------------------------------
10283 -- Make_Predefined_Primitive_Specs --
10284 -------------------------------------
10286 procedure Make_Predefined_Primitive_Specs
10287 (Tag_Typ : Entity_Id;
10288 Predef_List : out List_Id;
10289 Renamed_Eq : out Entity_Id)
10291 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
10292 -- Returns true if Prim is a renaming of an unresolved predefined
10293 -- equality operation.
10295 -------------------------------
10296 -- Is_Predefined_Eq_Renaming --
10297 -------------------------------
10299 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
10301 return Chars (Prim) /= Name_Op_Eq
10302 and then Present (Alias (Prim))
10303 and then Comes_From_Source (Prim)
10304 and then Is_Intrinsic_Subprogram (Alias (Prim))
10305 and then Chars (Alias (Prim)) = Name_Op_Eq;
10306 end Is_Predefined_Eq_Renaming;
10310 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10311 Res : constant List_Id := New_List;
10312 Eq_Name : Name_Id := Name_Op_Eq;
10313 Eq_Needed : Boolean;
10317 Has_Predef_Eq_Renaming : Boolean := False;
10318 -- Set to True if Tag_Typ has a primitive that renames the predefined
10319 -- equality operator. Used to implement (RM 8-5-4(8)).
10323 -- Start of processing for Make_Predefined_Primitive_Specs
10326 Renamed_Eq := Empty;
10330 Append_To (Res, Predef_Spec_Or_Body (Loc,
10331 Tag_Typ => Tag_Typ,
10332 Name => Name_uSize,
10333 Profile => New_List (
10334 Make_Parameter_Specification (Loc,
10335 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10336 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10338 Ret_Type => Standard_Long_Long_Integer));
10340 -- Spec of Put_Image
10342 if (not No_Run_Time_Mode)
10343 and then RTE_Available (RE_Root_Buffer_Type)
10345 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
10346 -- (like any tagged type) will be rejected. Given this, avoid
10347 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
10350 Append_To (Res, Predef_Spec_Or_Body (Loc,
10351 Tag_Typ => Tag_Typ,
10352 Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
10353 Profile => Build_Put_Image_Profile (Loc, Tag_Typ)));
10356 -- Specs for dispatching stream attributes
10359 Stream_Op_TSS_Names :
10360 constant array (Positive range <>) of TSS_Name_Type :=
10364 TSS_Stream_Output);
10367 for Op in Stream_Op_TSS_Names'Range loop
10368 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
10370 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
10371 Stream_Op_TSS_Names (Op)));
10376 -- Spec of "=" is expanded if the type is not limited and if a user
10377 -- defined "=" was not already declared for the non-full view of a
10378 -- private extension
10380 if not Is_Limited_Type (Tag_Typ) then
10382 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10383 while Present (Prim) loop
10385 -- If a primitive is encountered that renames the predefined
10386 -- equality operator before reaching any explicit equality
10387 -- primitive, then we still need to create a predefined equality
10388 -- function, because calls to it can occur via the renaming. A
10389 -- new name is created for the equality to avoid conflicting with
10390 -- any user-defined equality. (Note that this doesn't account for
10391 -- renamings of equality nested within subpackages???)
10393 if Is_Predefined_Eq_Renaming (Node (Prim)) then
10394 Has_Predef_Eq_Renaming := True;
10395 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
10397 -- User-defined equality
10399 elsif Is_User_Defined_Equality (Node (Prim)) then
10400 if No (Alias (Node (Prim)))
10401 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
10402 N_Subprogram_Renaming_Declaration
10404 Eq_Needed := False;
10407 -- If the parent is not an interface type and has an abstract
10408 -- equality function explicitly defined in the sources, then
10409 -- the inherited equality is abstract as well, and no body can
10410 -- be created for it.
10412 elsif not Is_Interface (Etype (Tag_Typ))
10413 and then Present (Alias (Node (Prim)))
10414 and then Comes_From_Source (Alias (Node (Prim)))
10415 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
10417 Eq_Needed := False;
10420 -- If the type has an equality function corresponding with
10421 -- a primitive defined in an interface type, the inherited
10422 -- equality is abstract as well, and no body can be created
10425 elsif Present (Alias (Node (Prim)))
10426 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
10429 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
10431 Eq_Needed := False;
10439 -- If a renaming of predefined equality was found but there was no
10440 -- user-defined equality (so Eq_Needed is still true), then set the
10441 -- name back to Name_Op_Eq. But in the case where a user-defined
10442 -- equality was located after such a renaming, then the predefined
10443 -- equality function is still needed, so Eq_Needed must be set back
10446 if Eq_Name /= Name_Op_Eq then
10448 Eq_Name := Name_Op_Eq;
10455 Eq_Spec := Predef_Spec_Or_Body (Loc,
10456 Tag_Typ => Tag_Typ,
10458 Profile => New_List (
10459 Make_Parameter_Specification (Loc,
10460 Defining_Identifier =>
10461 Make_Defining_Identifier (Loc, Name_X),
10462 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10464 Make_Parameter_Specification (Loc,
10465 Defining_Identifier =>
10466 Make_Defining_Identifier (Loc, Name_Y),
10467 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10468 Ret_Type => Standard_Boolean);
10469 Append_To (Res, Eq_Spec);
10471 if Has_Predef_Eq_Renaming then
10472 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
10474 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10475 while Present (Prim) loop
10477 -- Any renamings of equality that appeared before an
10478 -- overriding equality must be updated to refer to the
10479 -- entity for the predefined equality, otherwise calls via
10480 -- the renaming would get incorrectly resolved to call the
10481 -- user-defined equality function.
10483 if Is_Predefined_Eq_Renaming (Node (Prim)) then
10484 Set_Alias (Node (Prim), Renamed_Eq);
10486 -- Exit upon encountering a user-defined equality
10488 elsif Chars (Node (Prim)) = Name_Op_Eq
10489 and then No (Alias (Node (Prim)))
10499 -- Spec for dispatching assignment
10501 Append_To (Res, Predef_Spec_Or_Body (Loc,
10502 Tag_Typ => Tag_Typ,
10503 Name => Name_uAssign,
10504 Profile => New_List (
10505 Make_Parameter_Specification (Loc,
10506 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10507 Out_Present => True,
10508 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
10510 Make_Parameter_Specification (Loc,
10511 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
10512 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
10515 -- Ada 2005: Generate declarations for the following primitive
10516 -- operations for limited interfaces and synchronized types that
10517 -- implement a limited interface.
10519 -- Disp_Asynchronous_Select
10520 -- Disp_Conditional_Select
10521 -- Disp_Get_Prim_Op_Kind
10522 -- Disp_Get_Task_Id
10524 -- Disp_Timed_Select
10526 -- Disable the generation of these bodies if No_Dispatching_Calls,
10527 -- Ravenscar or ZFP is active.
10529 if Ada_Version >= Ada_2005
10530 and then not Restriction_Active (No_Dispatching_Calls)
10531 and then not Restriction_Active (No_Select_Statements)
10532 and then RTE_Available (RE_Select_Specific_Data)
10534 -- These primitives are defined abstract in interface types
10536 if Is_Interface (Tag_Typ)
10537 and then Is_Limited_Record (Tag_Typ)
10540 Make_Abstract_Subprogram_Declaration (Loc,
10542 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
10545 Make_Abstract_Subprogram_Declaration (Loc,
10547 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
10550 Make_Abstract_Subprogram_Declaration (Loc,
10552 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
10555 Make_Abstract_Subprogram_Declaration (Loc,
10557 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
10560 Make_Abstract_Subprogram_Declaration (Loc,
10562 Make_Disp_Requeue_Spec (Tag_Typ)));
10565 Make_Abstract_Subprogram_Declaration (Loc,
10567 Make_Disp_Timed_Select_Spec (Tag_Typ)));
10569 -- If ancestor is an interface type, declare non-abstract primitives
10570 -- to override the abstract primitives of the interface type.
10572 -- In VM targets we define these primitives in all root tagged types
10573 -- that are not interface types. Done because in VM targets we don't
10574 -- have secondary dispatch tables and any derivation of Tag_Typ may
10575 -- cover limited interfaces (which always have these primitives since
10576 -- they may be ancestors of synchronized interface types).
10578 elsif (not Is_Interface (Tag_Typ)
10579 and then Is_Interface (Etype (Tag_Typ))
10580 and then Is_Limited_Record (Etype (Tag_Typ)))
10582 (Is_Concurrent_Record_Type (Tag_Typ)
10583 and then Has_Interfaces (Tag_Typ))
10585 (not Tagged_Type_Expansion
10586 and then not Is_Interface (Tag_Typ)
10587 and then Tag_Typ = Root_Type (Tag_Typ))
10590 Make_Subprogram_Declaration (Loc,
10592 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
10595 Make_Subprogram_Declaration (Loc,
10597 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
10600 Make_Subprogram_Declaration (Loc,
10602 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
10605 Make_Subprogram_Declaration (Loc,
10607 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
10610 Make_Subprogram_Declaration (Loc,
10612 Make_Disp_Requeue_Spec (Tag_Typ)));
10615 Make_Subprogram_Declaration (Loc,
10617 Make_Disp_Timed_Select_Spec (Tag_Typ)));
10621 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
10622 -- regardless of whether they are controlled or may contain controlled
10625 -- Do not generate the routines if finalization is disabled
10627 if Restriction_Active (No_Finalization) then
10631 if not Is_Limited_Type (Tag_Typ) then
10632 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
10635 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
10638 Predef_List := Res;
10639 end Make_Predefined_Primitive_Specs;
10641 -------------------------
10642 -- Make_Tag_Assignment --
10643 -------------------------
10645 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
10646 Loc : constant Source_Ptr := Sloc (N);
10647 Def_If : constant Entity_Id := Defining_Identifier (N);
10648 Expr : constant Node_Id := Expression (N);
10649 Typ : constant Entity_Id := Etype (Def_If);
10650 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
10654 -- This expansion activity is called during analysis.
10656 if Is_Tagged_Type (Typ)
10657 and then not Is_Class_Wide_Type (Typ)
10658 and then not Is_CPP_Class (Typ)
10659 and then Tagged_Type_Expansion
10660 and then Nkind (Expr) /= N_Aggregate
10661 and then (Nkind (Expr) /= N_Qualified_Expression
10662 or else Nkind (Expression (Expr)) /= N_Aggregate)
10665 Make_Selected_Component (Loc,
10666 Prefix => New_Occurrence_Of (Def_If, Loc),
10668 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
10669 Set_Assignment_OK (New_Ref);
10672 Make_Assignment_Statement (Loc,
10675 Unchecked_Convert_To (RTE (RE_Tag),
10676 New_Occurrence_Of (Node
10677 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
10681 end Make_Tag_Assignment;
10683 ----------------------
10684 -- Predef_Deep_Spec --
10685 ----------------------
10687 function Predef_Deep_Spec
10689 Tag_Typ : Entity_Id;
10690 Name : TSS_Name_Type;
10691 For_Body : Boolean := False) return Node_Id
10696 -- V : in out Tag_Typ
10698 Formals := New_List (
10699 Make_Parameter_Specification (Loc,
10700 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
10701 In_Present => True,
10702 Out_Present => True,
10703 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
10705 -- F : Boolean := True
10707 if Name = TSS_Deep_Adjust
10708 or else Name = TSS_Deep_Finalize
10710 Append_To (Formals,
10711 Make_Parameter_Specification (Loc,
10712 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
10713 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
10714 Expression => New_Occurrence_Of (Standard_True, Loc)));
10718 Predef_Spec_Or_Body (Loc,
10719 Name => Make_TSS_Name (Tag_Typ, Name),
10720 Tag_Typ => Tag_Typ,
10721 Profile => Formals,
10722 For_Body => For_Body);
10725 when RE_Not_Available =>
10727 end Predef_Deep_Spec;
10729 -------------------------
10730 -- Predef_Spec_Or_Body --
10731 -------------------------
10733 function Predef_Spec_Or_Body
10735 Tag_Typ : Entity_Id;
10738 Ret_Type : Entity_Id := Empty;
10739 For_Body : Boolean := False) return Node_Id
10741 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
10745 Set_Is_Public (Id, Is_Public (Tag_Typ));
10747 -- The internal flag is set to mark these declarations because they have
10748 -- specific properties. First, they are primitives even if they are not
10749 -- defined in the type scope (the freezing point is not necessarily in
10750 -- the same scope). Second, the predefined equality can be overridden by
10751 -- a user-defined equality, no body will be generated in this case.
10753 Set_Is_Internal (Id);
10755 if not Debug_Generated_Code then
10756 Set_Debug_Info_Off (Id);
10759 if No (Ret_Type) then
10761 Make_Procedure_Specification (Loc,
10762 Defining_Unit_Name => Id,
10763 Parameter_Specifications => Profile);
10766 Make_Function_Specification (Loc,
10767 Defining_Unit_Name => Id,
10768 Parameter_Specifications => Profile,
10769 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
10772 -- Declare an abstract subprogram for primitive subprograms of an
10773 -- interface type (except for "=").
10775 if Is_Interface (Tag_Typ) then
10776 if Name /= Name_Op_Eq then
10777 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
10779 -- The equality function (if any) for an interface type is defined
10780 -- to be nonabstract, so we create an expression function for it that
10781 -- always returns False. Note that the function can never actually be
10782 -- invoked because interface types are abstract, so there aren't any
10783 -- objects of such types (and their equality operation will always
10787 return Make_Expression_Function
10788 (Loc, Spec, New_Occurrence_Of (Standard_False, Loc));
10791 -- If body case, return empty subprogram body. Note that this is ill-
10792 -- formed, because there is not even a null statement, and certainly not
10793 -- a return in the function case. The caller is expected to do surgery
10794 -- on the body to add the appropriate stuff.
10796 elsif For_Body then
10797 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
10799 -- For the case of an Input attribute predefined for an abstract type,
10800 -- generate an abstract specification. This will never be called, but we
10801 -- need the slot allocated in the dispatching table so that attributes
10802 -- typ'Class'Input and typ'Class'Output will work properly.
10804 elsif Is_TSS (Name, TSS_Stream_Input)
10805 and then Is_Abstract_Type (Tag_Typ)
10807 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
10809 -- Normal spec case, where we return a subprogram declaration
10812 return Make_Subprogram_Declaration (Loc, Spec);
10814 end Predef_Spec_Or_Body;
10816 -----------------------------
10817 -- Predef_Stream_Attr_Spec --
10818 -----------------------------
10820 function Predef_Stream_Attr_Spec
10822 Tag_Typ : Entity_Id;
10823 Name : TSS_Name_Type;
10824 For_Body : Boolean := False) return Node_Id
10826 Ret_Type : Entity_Id;
10829 if Name = TSS_Stream_Input then
10830 Ret_Type := Tag_Typ;
10836 Predef_Spec_Or_Body
10838 Name => Make_TSS_Name (Tag_Typ, Name),
10839 Tag_Typ => Tag_Typ,
10840 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
10841 Ret_Type => Ret_Type,
10842 For_Body => For_Body);
10843 end Predef_Stream_Attr_Spec;
10845 ---------------------------------
10846 -- Predefined_Primitive_Bodies --
10847 ---------------------------------
10849 function Predefined_Primitive_Bodies
10850 (Tag_Typ : Entity_Id;
10851 Renamed_Eq : Entity_Id) return List_Id
10853 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10854 Res : constant List_Id := New_List;
10855 Adj_Call : Node_Id;
10857 Fin_Call : Node_Id;
10859 Eq_Needed : Boolean;
10863 pragma Warnings (Off, Ent);
10868 pragma Assert (not Is_Interface (Tag_Typ));
10870 -- See if we have a predefined "=" operator
10872 if Present (Renamed_Eq) then
10874 Eq_Name := Chars (Renamed_Eq);
10876 -- If the parent is an interface type then it has defined all the
10877 -- predefined primitives abstract and we need to check if the type
10878 -- has some user defined "=" function which matches the profile of
10879 -- the Ada predefined equality operator to avoid generating it.
10881 elsif Is_Interface (Etype (Tag_Typ)) then
10883 Eq_Name := Name_Op_Eq;
10885 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10886 while Present (Prim) loop
10887 if Chars (Node (Prim)) = Name_Op_Eq
10888 and then not Is_Internal (Node (Prim))
10889 and then Present (First_Entity (Node (Prim)))
10891 -- The predefined equality primitive must have exactly two
10892 -- formals whose type is this tagged type
10894 and then Present (Last_Entity (Node (Prim)))
10895 and then Next_Entity (First_Entity (Node (Prim)))
10896 = Last_Entity (Node (Prim))
10897 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
10898 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
10900 Eq_Needed := False;
10901 Eq_Name := No_Name;
10909 Eq_Needed := False;
10910 Eq_Name := No_Name;
10912 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
10913 while Present (Prim) loop
10914 if Chars (Node (Prim)) = Name_Op_Eq
10915 and then Is_Internal (Node (Prim))
10918 Eq_Name := Name_Op_Eq;
10928 Decl := Predef_Spec_Or_Body (Loc,
10929 Tag_Typ => Tag_Typ,
10930 Name => Name_uSize,
10931 Profile => New_List (
10932 Make_Parameter_Specification (Loc,
10933 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
10934 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
10936 Ret_Type => Standard_Long_Long_Integer,
10939 Set_Handled_Statement_Sequence (Decl,
10940 Make_Handled_Sequence_Of_Statements (Loc, New_List (
10941 Make_Simple_Return_Statement (Loc,
10943 Make_Attribute_Reference (Loc,
10944 Prefix => Make_Identifier (Loc, Name_X),
10945 Attribute_Name => Name_Size)))));
10947 Append_To (Res, Decl);
10949 -- Body of Put_Image
10951 if No (TSS (Tag_Typ, TSS_Put_Image))
10952 and then (not No_Run_Time_Mode)
10953 and then RTE_Available (RE_Root_Buffer_Type)
10955 Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
10956 Append_To (Res, Decl);
10959 -- Bodies for Dispatching stream IO routines. We need these only for
10960 -- non-limited types (in the limited case there is no dispatching).
10961 -- We also skip them if dispatching or finalization are not available
10962 -- or if stream operations are prohibited by restriction No_Streams or
10963 -- from use of pragma/aspect No_Tagged_Streams.
10965 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
10966 and then No (TSS (Tag_Typ, TSS_Stream_Read))
10968 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
10969 Append_To (Res, Decl);
10972 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
10973 and then No (TSS (Tag_Typ, TSS_Stream_Write))
10975 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
10976 Append_To (Res, Decl);
10979 -- Skip body of _Input for the abstract case, since the corresponding
10980 -- spec is abstract (see Predef_Spec_Or_Body).
10982 if not Is_Abstract_Type (Tag_Typ)
10983 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
10984 and then No (TSS (Tag_Typ, TSS_Stream_Input))
10986 Build_Record_Or_Elementary_Input_Function
10987 (Loc, Tag_Typ, Decl, Ent);
10988 Append_To (Res, Decl);
10991 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
10992 and then No (TSS (Tag_Typ, TSS_Stream_Output))
10994 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
10995 Append_To (Res, Decl);
10998 -- Ada 2005: Generate bodies for the following primitive operations for
10999 -- limited interfaces and synchronized types that implement a limited
11002 -- disp_asynchronous_select
11003 -- disp_conditional_select
11004 -- disp_get_prim_op_kind
11005 -- disp_get_task_id
11006 -- disp_timed_select
11008 -- The interface versions will have null bodies
11010 -- Disable the generation of these bodies if No_Dispatching_Calls,
11011 -- Ravenscar or ZFP is active.
11013 -- In VM targets we define these primitives in all root tagged types
11014 -- that are not interface types. Done because in VM targets we don't
11015 -- have secondary dispatch tables and any derivation of Tag_Typ may
11016 -- cover limited interfaces (which always have these primitives since
11017 -- they may be ancestors of synchronized interface types).
11019 if Ada_Version >= Ada_2005
11020 and then not Is_Interface (Tag_Typ)
11022 ((Is_Interface (Etype (Tag_Typ))
11023 and then Is_Limited_Record (Etype (Tag_Typ)))
11025 (Is_Concurrent_Record_Type (Tag_Typ)
11026 and then Has_Interfaces (Tag_Typ))
11028 (not Tagged_Type_Expansion
11029 and then Tag_Typ = Root_Type (Tag_Typ)))
11030 and then not Restriction_Active (No_Dispatching_Calls)
11031 and then not Restriction_Active (No_Select_Statements)
11032 and then RTE_Available (RE_Select_Specific_Data)
11034 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
11035 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
11036 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
11037 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
11038 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
11039 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
11042 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
11044 -- Body for equality
11047 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
11048 Append_To (Res, Decl);
11051 -- Body for inequality (if required)
11053 Decl := Make_Neq_Body (Tag_Typ);
11055 if Present (Decl) then
11056 Append_To (Res, Decl);
11059 -- Body for dispatching assignment
11062 Predef_Spec_Or_Body (Loc,
11063 Tag_Typ => Tag_Typ,
11064 Name => Name_uAssign,
11065 Profile => New_List (
11066 Make_Parameter_Specification (Loc,
11067 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
11068 Out_Present => True,
11069 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
11071 Make_Parameter_Specification (Loc,
11072 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
11073 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
11076 Set_Handled_Statement_Sequence (Decl,
11077 Make_Handled_Sequence_Of_Statements (Loc, New_List (
11078 Make_Assignment_Statement (Loc,
11079 Name => Make_Identifier (Loc, Name_X),
11080 Expression => Make_Identifier (Loc, Name_Y)))));
11082 Append_To (Res, Decl);
11085 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
11086 -- tagged types which do not contain controlled components.
11088 -- Do not generate the routines if finalization is disabled
11090 if Restriction_Active (No_Finalization) then
11093 elsif not Has_Controlled_Component (Tag_Typ) then
11094 if not Is_Limited_Type (Tag_Typ) then
11096 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
11098 if Is_Controlled (Tag_Typ) then
11101 Obj_Ref => Make_Identifier (Loc, Name_V),
11105 if No (Adj_Call) then
11106 Adj_Call := Make_Null_Statement (Loc);
11109 Set_Handled_Statement_Sequence (Decl,
11110 Make_Handled_Sequence_Of_Statements (Loc,
11111 Statements => New_List (Adj_Call)));
11113 Append_To (Res, Decl);
11117 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
11119 if Is_Controlled (Tag_Typ) then
11122 (Obj_Ref => Make_Identifier (Loc, Name_V),
11126 if No (Fin_Call) then
11127 Fin_Call := Make_Null_Statement (Loc);
11130 Set_Handled_Statement_Sequence (Decl,
11131 Make_Handled_Sequence_Of_Statements (Loc,
11132 Statements => New_List (Fin_Call)));
11134 Append_To (Res, Decl);
11138 end Predefined_Primitive_Bodies;
11140 ---------------------------------
11141 -- Predefined_Primitive_Freeze --
11142 ---------------------------------
11144 function Predefined_Primitive_Freeze
11145 (Tag_Typ : Entity_Id) return List_Id
11147 Res : constant List_Id := New_List;
11152 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
11153 while Present (Prim) loop
11154 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
11155 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
11157 if Present (Frnodes) then
11158 Append_List_To (Res, Frnodes);
11166 end Predefined_Primitive_Freeze;
11168 -------------------------
11169 -- Stream_Operation_OK --
11170 -------------------------
11172 function Stream_Operation_OK
11174 Operation : TSS_Name_Type) return Boolean
11176 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
11179 -- Special case of a limited type extension: a default implementation
11180 -- of the stream attributes Read or Write exists if that attribute
11181 -- has been specified or is available for an ancestor type; a default
11182 -- implementation of the attribute Output (resp. Input) exists if the
11183 -- attribute has been specified or Write (resp. Read) is available for
11184 -- an ancestor type. The last condition only applies under Ada 2005.
11186 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
11187 if Operation = TSS_Stream_Read then
11188 Has_Predefined_Or_Specified_Stream_Attribute :=
11189 Has_Specified_Stream_Read (Typ);
11191 elsif Operation = TSS_Stream_Write then
11192 Has_Predefined_Or_Specified_Stream_Attribute :=
11193 Has_Specified_Stream_Write (Typ);
11195 elsif Operation = TSS_Stream_Input then
11196 Has_Predefined_Or_Specified_Stream_Attribute :=
11197 Has_Specified_Stream_Input (Typ)
11199 (Ada_Version >= Ada_2005
11200 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
11202 elsif Operation = TSS_Stream_Output then
11203 Has_Predefined_Or_Specified_Stream_Attribute :=
11204 Has_Specified_Stream_Output (Typ)
11206 (Ada_Version >= Ada_2005
11207 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
11210 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
11212 if not Has_Predefined_Or_Specified_Stream_Attribute
11213 and then Is_Derived_Type (Typ)
11214 and then (Operation = TSS_Stream_Read
11215 or else Operation = TSS_Stream_Write)
11217 Has_Predefined_Or_Specified_Stream_Attribute :=
11219 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
11223 -- If the type is not limited, or else is limited but the attribute is
11224 -- explicitly specified or is predefined for the type, then return True,
11225 -- unless other conditions prevail, such as restrictions prohibiting
11226 -- streams or dispatching operations. We also return True for limited
11227 -- interfaces, because they may be extended by nonlimited types and
11228 -- permit inheritance in this case (addresses cases where an abstract
11229 -- extension doesn't get 'Input declared, as per comments below, but
11230 -- 'Class'Input must still be allowed). Note that attempts to apply
11231 -- stream attributes to a limited interface or its class-wide type
11232 -- (or limited extensions thereof) will still get properly rejected
11233 -- by Check_Stream_Attribute.
11235 -- We exclude the Input operation from being a predefined subprogram in
11236 -- the case where the associated type is an abstract extension, because
11237 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
11238 -- we don't want an abstract version created because types derived from
11239 -- the abstract type may not even have Input available (for example if
11240 -- derived from a private view of the abstract type that doesn't have
11241 -- a visible Input).
11243 -- Do not generate stream routines for type Finalization_Master because
11244 -- a master may never appear in types and therefore cannot be read or
11248 (not Is_Limited_Type (Typ)
11249 or else Is_Interface (Typ)
11250 or else Has_Predefined_Or_Specified_Stream_Attribute)
11252 (Operation /= TSS_Stream_Input
11253 or else not Is_Abstract_Type (Typ)
11254 or else not Is_Derived_Type (Typ))
11255 and then not Has_Unknown_Discriminants (Typ)
11256 and then not Is_Concurrent_Interface (Typ)
11257 and then not Restriction_Active (No_Streams)
11258 and then not Restriction_Active (No_Dispatch)
11259 and then No (No_Tagged_Streams_Pragma (Typ))
11260 and then not No_Run_Time_Mode
11261 and then RTE_Available (RE_Tag)
11262 and then No (Type_Without_Stream_Operation (Typ))
11263 and then RTE_Available (RE_Root_Stream_Type)
11264 and then not Is_RTE (Typ, RE_Finalization_Master);
11265 end Stream_Operation_OK;