1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Exp_Aggr; use Exp_Aggr;
31 with Exp_Atag; use Exp_Atag;
32 with Exp_Ch4; use Exp_Ch4;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_Ch7; use Exp_Ch7;
35 with Exp_Ch9; use Exp_Ch9;
36 with Exp_Ch11; use Exp_Ch11;
37 with Exp_Dbug; use Exp_Dbug;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Smem; use Exp_Smem;
41 with Exp_Strm; use Exp_Strm;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Namet; use Namet;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Restrict; use Restrict;
50 with Rident; use Rident;
51 with Rtsfind; use Rtsfind;
53 with Sem_Aux; use Sem_Aux;
54 with Sem_Attr; use Sem_Attr;
55 with Sem_Cat; use Sem_Cat;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch6; use Sem_Ch6;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Disp; use Sem_Disp;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Mech; use Sem_Mech;
62 with Sem_Res; use Sem_Res;
63 with Sem_SCIL; use Sem_SCIL;
64 with Sem_Type; use Sem_Type;
65 with Sem_Util; use Sem_Util;
66 with Sinfo; use Sinfo;
67 with Stand; use Stand;
68 with Snames; use Snames;
69 with Targparm; use Targparm;
70 with Tbuild; use Tbuild;
71 with Ttypes; use Ttypes;
72 with Validsw; use Validsw;
74 package body Exp_Ch3 is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Adjust_Discriminants (Rtype : Entity_Id);
81 -- This is used when freezing a record type. It attempts to construct
82 -- more restrictive subtypes for discriminants so that the max size of
83 -- the record can be calculated more accurately. See the body of this
84 -- procedure for details.
86 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
87 -- Build initialization procedure for given array type. Nod is a node
88 -- used for attachment of any actions required in its construction.
89 -- It also supplies the source location used for the procedure.
91 function Build_Array_Invariant_Proc
93 Nod : Node_Id) return Node_Id;
94 -- If the component of type of array type has invariants, build procedure
95 -- that checks invariant on all components of the array. Ada 2012 specifies
96 -- that an invariant on some type T must be applied to in-out parameters
97 -- and return values that include a part of type T. If the array type has
98 -- an otherwise specified invariant, the component check procedure is
99 -- called from within the user-specified invariant. Otherwise this becomes
100 -- the invariant procedure for the array type.
102 function Build_Record_Invariant_Proc
104 Nod : Node_Id) return Node_Id;
105 -- Ditto for record types.
107 function Build_Discriminant_Formals
109 Use_Dl : Boolean) return List_Id;
110 -- This function uses the discriminants of a type to build a list of
111 -- formal parameters, used in Build_Init_Procedure among other places.
112 -- If the flag Use_Dl is set, the list is built using the already
113 -- defined discriminals of the type, as is the case for concurrent
114 -- types with discriminants. Otherwise new identifiers are created,
115 -- with the source names of the discriminants.
117 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
118 -- This function builds a static aggregate that can serve as the initial
119 -- value for an array type whose bounds are static, and whose component
120 -- type is a composite type that has a static equivalent aggregate.
121 -- The equivalent array aggregate is used both for object initialization
122 -- and for component initialization, when used in the following function.
124 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
125 -- This function builds a static aggregate that can serve as the initial
126 -- value for a record type whose components are scalar and initialized
127 -- with compile-time values, or arrays with similar initialization or
128 -- defaults. When possible, initialization of an object of the type can
129 -- be achieved by using a copy of the aggregate as an initial value, thus
130 -- removing the implicit call that would otherwise constitute elaboration
133 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
134 -- Build record initialization procedure. N is the type declaration
135 -- node, and Rec_Ent is the corresponding entity for the record type.
137 procedure Build_Slice_Assignment (Typ : Entity_Id);
138 -- Build assignment procedure for one-dimensional arrays of controlled
139 -- types. Other array and slice assignments are expanded in-line, but
140 -- the code expansion for controlled components (when control actions
141 -- are active) can lead to very large blocks that GCC3 handles poorly.
143 procedure Build_Untagged_Equality (Typ : Entity_Id);
144 -- AI05-0123: Equality on untagged records composes. This procedure
145 -- builds the equality routine for an untagged record that has components
146 -- of a record type that has user-defined primitive equality operations.
147 -- The resulting operation is a TSS subprogram.
149 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
150 -- Create An Equality function for the non-tagged variant record 'Typ'
151 -- and attach it to the TSS list
153 procedure Check_Stream_Attributes (Typ : Entity_Id);
154 -- Check that if a limited extension has a parent with user-defined stream
155 -- attributes, and does not itself have user-defined stream-attributes,
156 -- then any limited component of the extension also has the corresponding
157 -- user-defined stream attributes.
159 procedure Clean_Task_Names
161 Proc_Id : Entity_Id);
162 -- If an initialization procedure includes calls to generate names
163 -- for task subcomponents, indicate that secondary stack cleanup is
164 -- needed after an initialization. Typ is the component type, and Proc_Id
165 -- the initialization procedure for the enclosing composite type.
167 procedure Expand_Tagged_Root (T : Entity_Id);
168 -- Add a field _Tag at the beginning of the record. This field carries
169 -- the value of the access to the Dispatch table. This procedure is only
170 -- called on root type, the _Tag field being inherited by the descendants.
172 procedure Expand_Freeze_Array_Type (N : Node_Id);
173 -- Freeze an array type. Deals with building the initialization procedure,
174 -- creating the packed array type for a packed array and also with the
175 -- creation of the controlling procedures for the controlled case. The
176 -- argument N is the N_Freeze_Entity node for the type.
178 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
179 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
180 -- of finalizing controlled derivations from the class-wide's root type.
182 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
183 -- Freeze enumeration type with non-standard representation. Builds the
184 -- array and function needed to convert between enumeration pos and
185 -- enumeration representation values. N is the N_Freeze_Entity node
188 procedure Expand_Freeze_Record_Type (N : Node_Id);
189 -- Freeze record type. Builds all necessary discriminant checking
190 -- and other ancillary functions, and builds dispatch tables where
191 -- needed. The argument N is the N_Freeze_Entity node. This processing
192 -- applies only to E_Record_Type entities, not to class wide types,
193 -- record subtypes, or private types.
195 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
196 -- Treat user-defined stream operations as renaming_as_body if the
197 -- subprogram they rename is not frozen when the type is frozen.
199 procedure Insert_Component_Invariant_Checks
203 -- If a composite type has invariants and also has components with defined
204 -- invariants. the component invariant procedure is inserted into the user-
205 -- defined invariant procedure and added to the checks to be performed.
207 procedure Initialization_Warning (E : Entity_Id);
208 -- If static elaboration of the package is requested, indicate
209 -- when a type does meet the conditions for static initialization. If
210 -- E is a type, it has components that have no static initialization.
211 -- if E is an entity, its initial expression is not compile-time known.
213 function Init_Formals (Typ : Entity_Id) return List_Id;
214 -- This function builds the list of formals for an initialization routine.
215 -- The first formal is always _Init with the given type. For task value
216 -- record types and types containing tasks, three additional formals are
219 -- _Master : Master_Id
220 -- _Chain : in out Activation_Chain
221 -- _Task_Name : String
223 -- The caller must append additional entries for discriminants if required.
225 function In_Runtime (E : Entity_Id) return Boolean;
226 -- Check if E is defined in the RTL (in a child of Ada or System). Used
227 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
229 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
230 -- Returns true if Prim is a user defined equality function
232 function Make_Eq_Body
234 Eq_Name : Name_Id) return Node_Id;
235 -- Build the body of a primitive equality operation for a tagged record
236 -- type, or in Ada 2012 for any record type that has components with a
237 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
239 function Make_Eq_Case
242 Discrs : Elist_Id := New_Elmt_List) return List_Id;
243 -- Building block for variant record equality. Defined to share the code
244 -- between the tagged and non-tagged case. Given a Component_List node CL,
245 -- it generates an 'if' followed by a 'case' statement that compares all
246 -- components of local temporaries named X and Y (that are declared as
247 -- formals at some upper level). E provides the Sloc to be used for the
250 -- IF E is an unchecked_union, Discrs is the list of formals created for
251 -- the inferred discriminants of one operand. These formals are used in
252 -- the generated case statements for each variant of the unchecked union.
256 L : List_Id) return Node_Id;
257 -- Building block for variant record equality. Defined to share the code
258 -- between the tagged and non-tagged case. Given the list of components
259 -- (or discriminants) L, it generates a return statement that compares all
260 -- components of local temporaries named X and Y (that are declared as
261 -- formals at some upper level). E provides the Sloc to be used for the
264 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
265 -- Search for a renaming of the inequality dispatching primitive of
266 -- this tagged type. If found then build and return the corresponding
267 -- rename-as-body inequality subprogram; otherwise return Empty.
269 procedure Make_Predefined_Primitive_Specs
270 (Tag_Typ : Entity_Id;
271 Predef_List : out List_Id;
272 Renamed_Eq : out Entity_Id);
273 -- Create a list with the specs of the predefined primitive operations.
274 -- For tagged types that are interfaces all these primitives are defined
277 -- The following entries are present for all tagged types, and provide
278 -- the results of the corresponding attribute applied to the object.
279 -- Dispatching is required in general, since the result of the attribute
280 -- will vary with the actual object subtype.
282 -- _size provides result of 'Size attribute
283 -- typSR provides result of 'Read attribute
284 -- typSW provides result of 'Write attribute
285 -- typSI provides result of 'Input attribute
286 -- typSO provides result of 'Output attribute
288 -- The following entries are additionally present for non-limited tagged
289 -- types, and implement additional dispatching operations for predefined
292 -- _equality implements "=" operator
293 -- _assign implements assignment operation
294 -- typDF implements deep finalization
295 -- typDA implements deep adjust
297 -- The latter two are empty procedures unless the type contains some
298 -- controlled components that require finalization actions (the deep
299 -- in the name refers to the fact that the action applies to components).
301 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
302 -- returns the value Empty, or else the defining unit name for the
303 -- predefined equality function in the case where the type has a primitive
304 -- operation that is a renaming of predefined equality (but only if there
305 -- is also an overriding user-defined equality function). The returned
306 -- Renamed_Eq will be passed to the corresponding parameter of
307 -- Predefined_Primitive_Bodies.
309 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
310 -- returns True if there are representation clauses for type T that are not
311 -- inherited. If the result is false, the init_proc and the discriminant
312 -- checking functions of the parent can be reused by a derived type.
314 procedure Make_Controlling_Function_Wrappers
315 (Tag_Typ : Entity_Id;
316 Decl_List : out List_Id;
317 Body_List : out List_Id);
318 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
319 -- associated with inherited functions with controlling results which
320 -- are not overridden. The body of each wrapper function consists solely
321 -- of a return statement whose expression is an extension aggregate
322 -- invoking the inherited subprogram's parent subprogram and extended
323 -- with a null association list.
325 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
326 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
327 -- null procedures inherited from an interface type that have not been
328 -- overridden. Only one null procedure will be created for a given set of
329 -- inherited null procedures with homographic profiles.
331 function Predef_Spec_Or_Body
336 Ret_Type : Entity_Id := Empty;
337 For_Body : Boolean := False) return Node_Id;
338 -- This function generates the appropriate expansion for a predefined
339 -- primitive operation specified by its name, parameter profile and
340 -- return type (Empty means this is a procedure). If For_Body is false,
341 -- then the returned node is a subprogram declaration. If For_Body is
342 -- true, then the returned node is a empty subprogram body containing
343 -- no declarations and no statements.
345 function Predef_Stream_Attr_Spec
348 Name : TSS_Name_Type;
349 For_Body : Boolean := False) return Node_Id;
350 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
351 -- input and output attribute whose specs are constructed in Exp_Strm.
353 function Predef_Deep_Spec
356 Name : TSS_Name_Type;
357 For_Body : Boolean := False) return Node_Id;
358 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
359 -- and _deep_finalize
361 function Predefined_Primitive_Bodies
362 (Tag_Typ : Entity_Id;
363 Renamed_Eq : Entity_Id) return List_Id;
364 -- Create the bodies of the predefined primitives that are described in
365 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
366 -- the defining unit name of the type's predefined equality as returned
367 -- by Make_Predefined_Primitive_Specs.
369 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
370 -- Freeze entities of all predefined primitive operations. This is needed
371 -- because the bodies of these operations do not normally do any freezing.
373 function Stream_Operation_OK
375 Operation : TSS_Name_Type) return Boolean;
376 -- Check whether the named stream operation must be emitted for a given
377 -- type. The rules for inheritance of stream attributes by type extensions
378 -- are enforced by this function. Furthermore, various restrictions prevent
379 -- the generation of these operations, as a useful optimization or for
380 -- certification purposes.
382 --------------------------
383 -- Adjust_Discriminants --
384 --------------------------
386 -- This procedure attempts to define subtypes for discriminants that are
387 -- more restrictive than those declared. Such a replacement is possible if
388 -- we can demonstrate that values outside the restricted range would cause
389 -- constraint errors in any case. The advantage of restricting the
390 -- discriminant types in this way is that the maximum size of the variant
391 -- record can be calculated more conservatively.
393 -- An example of a situation in which we can perform this type of
394 -- restriction is the following:
396 -- subtype B is range 1 .. 10;
397 -- type Q is array (B range <>) of Integer;
399 -- type V (N : Natural) is record
403 -- In this situation, we can restrict the upper bound of N to 10, since
404 -- any larger value would cause a constraint error in any case.
406 -- There are many situations in which such restriction is possible, but
407 -- for now, we just look for cases like the above, where the component
408 -- in question is a one dimensional array whose upper bound is one of
409 -- the record discriminants. Also the component must not be part of
410 -- any variant part, since then the component does not always exist.
412 procedure Adjust_Discriminants (Rtype : Entity_Id) is
413 Loc : constant Source_Ptr := Sloc (Rtype);
430 Comp := First_Component (Rtype);
431 while Present (Comp) loop
433 -- If our parent is a variant, quit, we do not look at components
434 -- that are in variant parts, because they may not always exist.
436 P := Parent (Comp); -- component declaration
437 P := Parent (P); -- component list
439 exit when Nkind (Parent (P)) = N_Variant;
441 -- We are looking for a one dimensional array type
443 Ctyp := Etype (Comp);
445 if not Is_Array_Type (Ctyp)
446 or else Number_Dimensions (Ctyp) > 1
451 -- The lower bound must be constant, and the upper bound is a
452 -- discriminant (which is a discriminant of the current record).
454 Ityp := Etype (First_Index (Ctyp));
455 Lo := Type_Low_Bound (Ityp);
456 Hi := Type_High_Bound (Ityp);
458 if not Compile_Time_Known_Value (Lo)
459 or else Nkind (Hi) /= N_Identifier
460 or else No (Entity (Hi))
461 or else Ekind (Entity (Hi)) /= E_Discriminant
466 -- We have an array with appropriate bounds
468 Loval := Expr_Value (Lo);
469 Discr := Entity (Hi);
470 Dtyp := Etype (Discr);
472 -- See if the discriminant has a known upper bound
474 Dhi := Type_High_Bound (Dtyp);
476 if not Compile_Time_Known_Value (Dhi) then
480 Dhiv := Expr_Value (Dhi);
482 -- See if base type of component array has known upper bound
484 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
486 if not Compile_Time_Known_Value (Ahi) then
490 Ahiv := Expr_Value (Ahi);
492 -- The condition for doing the restriction is that the high bound
493 -- of the discriminant is greater than the low bound of the array,
494 -- and is also greater than the high bound of the base type index.
496 if Dhiv > Loval and then Dhiv > Ahiv then
498 -- We can reset the upper bound of the discriminant type to
499 -- whichever is larger, the low bound of the component, or
500 -- the high bound of the base type array index.
502 -- We build a subtype that is declared as
504 -- subtype Tnn is discr_type range discr_type'First .. max;
506 -- And insert this declaration into the tree. The type of the
507 -- discriminant is then reset to this more restricted subtype.
509 Tnn := Make_Temporary (Loc, 'T');
511 Insert_Action (Declaration_Node (Rtype),
512 Make_Subtype_Declaration (Loc,
513 Defining_Identifier => Tnn,
514 Subtype_Indication =>
515 Make_Subtype_Indication (Loc,
516 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
518 Make_Range_Constraint (Loc,
522 Make_Attribute_Reference (Loc,
523 Attribute_Name => Name_First,
524 Prefix => New_Occurrence_Of (Dtyp, Loc)),
526 Make_Integer_Literal (Loc,
527 Intval => UI_Max (Loval, Ahiv)))))));
529 Set_Etype (Discr, Tnn);
533 Next_Component (Comp);
535 end Adjust_Discriminants;
537 ---------------------------
538 -- Build_Array_Init_Proc --
539 ---------------------------
541 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
542 Comp_Type : constant Entity_Id := Component_Type (A_Type);
543 Body_Stmts : List_Id;
544 Has_Default_Init : Boolean;
545 Index_List : List_Id;
549 function Init_Component return List_Id;
550 -- Create one statement to initialize one array component, designated
551 -- by a full set of indexes.
553 function Init_One_Dimension (N : Int) return List_Id;
554 -- Create loop to initialize one dimension of the array. The single
555 -- statement in the loop body initializes the inner dimensions if any,
556 -- or else the single component. Note that this procedure is called
557 -- recursively, with N being the dimension to be initialized. A call
558 -- with N greater than the number of dimensions simply generates the
559 -- component initialization, terminating the recursion.
565 function Init_Component return List_Id is
570 Make_Indexed_Component (Loc,
571 Prefix => Make_Identifier (Loc, Name_uInit),
572 Expressions => Index_List);
574 if Has_Default_Aspect (A_Type) then
575 Set_Assignment_OK (Comp);
577 Make_Assignment_Statement (Loc,
580 Convert_To (Comp_Type,
581 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
583 elsif Needs_Simple_Initialization (Comp_Type) then
584 Set_Assignment_OK (Comp);
586 Make_Assignment_Statement (Loc,
590 (Comp_Type, Nod, Component_Size (A_Type))));
593 Clean_Task_Names (Comp_Type, Proc_Id);
595 Build_Initialization_Call
596 (Loc, Comp, Comp_Type,
597 In_Init_Proc => True,
598 Enclos_Type => A_Type);
602 ------------------------
603 -- Init_One_Dimension --
604 ------------------------
606 function Init_One_Dimension (N : Int) return List_Id is
610 -- If the component does not need initializing, then there is nothing
611 -- to do here, so we return a null body. This occurs when generating
612 -- the dummy Init_Proc needed for Initialize_Scalars processing.
614 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
615 and then not Needs_Simple_Initialization (Comp_Type)
616 and then not Has_Task (Comp_Type)
617 and then not Has_Default_Aspect (A_Type)
619 return New_List (Make_Null_Statement (Loc));
621 -- If all dimensions dealt with, we simply initialize the component
623 elsif N > Number_Dimensions (A_Type) then
624 return Init_Component;
626 -- Here we generate the required loop
630 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
632 Append (New_Occurrence_Of (Index, Loc), Index_List);
635 Make_Implicit_Loop_Statement (Nod,
638 Make_Iteration_Scheme (Loc,
639 Loop_Parameter_Specification =>
640 Make_Loop_Parameter_Specification (Loc,
641 Defining_Identifier => Index,
642 Discrete_Subtype_Definition =>
643 Make_Attribute_Reference (Loc,
644 Prefix => Make_Identifier (Loc, Name_uInit),
645 Attribute_Name => Name_Range,
646 Expressions => New_List (
647 Make_Integer_Literal (Loc, N))))),
648 Statements => Init_One_Dimension (N + 1)));
650 end Init_One_Dimension;
652 -- Start of processing for Build_Array_Init_Proc
655 -- The init proc is created when analyzing the freeze node for the type,
656 -- but it properly belongs with the array type declaration. However, if
657 -- the freeze node is for a subtype of a type declared in another unit
658 -- it seems preferable to use the freeze node as the source location of
659 -- the init proc. In any case this is preferable for gcov usage, and
660 -- the Sloc is not otherwise used by the compiler.
662 if In_Open_Scopes (Scope (A_Type)) then
663 Loc := Sloc (A_Type);
668 -- Nothing to generate in the following cases:
670 -- 1. Initialization is suppressed for the type
671 -- 2. The type is a value type, in the CIL sense.
672 -- 3. The type has CIL/JVM convention.
673 -- 4. An initialization already exists for the base type
675 if Initialization_Suppressed (A_Type)
676 or else Is_Value_Type (Comp_Type)
677 or else Convention (A_Type) = Convention_CIL
678 or else Convention (A_Type) = Convention_Java
679 or else Present (Base_Init_Proc (A_Type))
684 Index_List := New_List;
686 -- We need an initialization procedure if any of the following is true:
688 -- 1. The component type has an initialization procedure
689 -- 2. The component type needs simple initialization
690 -- 3. Tasks are present
691 -- 4. The type is marked as a public entity
692 -- 5. The array type has a Default_Component_Value aspect
694 -- The reason for the public entity test is to deal properly with the
695 -- Initialize_Scalars pragma. This pragma can be set in the client and
696 -- not in the declaring package, this means the client will make a call
697 -- to the initialization procedure (because one of conditions 1-3 must
698 -- apply in this case), and we must generate a procedure (even if it is
699 -- null) to satisfy the call in this case.
701 -- Exception: do not build an array init_proc for a type whose root
702 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
703 -- is no place to put the code, and in any case we handle initialization
704 -- of such types (in the Initialize_Scalars case, that's the only time
705 -- the issue arises) in a special manner anyway which does not need an
708 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
709 or else Needs_Simple_Initialization (Comp_Type)
710 or else Has_Task (Comp_Type)
711 or else Has_Default_Aspect (A_Type);
714 or else (not Restriction_Active (No_Initialize_Scalars)
715 and then Is_Public (A_Type)
716 and then Root_Type (A_Type) /= Standard_String
717 and then Root_Type (A_Type) /= Standard_Wide_String
718 and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
721 Make_Defining_Identifier (Loc,
722 Chars => Make_Init_Proc_Name (A_Type));
724 -- If No_Default_Initialization restriction is active, then we don't
725 -- want to build an init_proc, but we need to mark that an init_proc
726 -- would be needed if this restriction was not active (so that we can
727 -- detect attempts to call it), so set a dummy init_proc in place.
728 -- This is only done though when actual default initialization is
729 -- needed (and not done when only Is_Public is True), since otherwise
730 -- objects such as arrays of scalars could be wrongly flagged as
731 -- violating the restriction.
733 if Restriction_Active (No_Default_Initialization) then
734 if Has_Default_Init then
735 Set_Init_Proc (A_Type, Proc_Id);
741 Body_Stmts := Init_One_Dimension (1);
744 Make_Subprogram_Body (Loc,
746 Make_Procedure_Specification (Loc,
747 Defining_Unit_Name => Proc_Id,
748 Parameter_Specifications => Init_Formals (A_Type)),
749 Declarations => New_List,
750 Handled_Statement_Sequence =>
751 Make_Handled_Sequence_Of_Statements (Loc,
752 Statements => Body_Stmts)));
754 Set_Ekind (Proc_Id, E_Procedure);
755 Set_Is_Public (Proc_Id, Is_Public (A_Type));
756 Set_Is_Internal (Proc_Id);
757 Set_Has_Completion (Proc_Id);
759 if not Debug_Generated_Code then
760 Set_Debug_Info_Off (Proc_Id);
763 -- Set inlined unless controlled stuff or tasks around, in which
764 -- case we do not want to inline, because nested stuff may cause
765 -- difficulties in inter-unit inlining, and furthermore there is
766 -- in any case no point in inlining such complex init procs.
768 if not Has_Task (Proc_Id)
769 and then not Needs_Finalization (Proc_Id)
771 Set_Is_Inlined (Proc_Id);
774 -- Associate Init_Proc with type, and determine if the procedure
775 -- is null (happens because of the Initialize_Scalars pragma case,
776 -- where we have to generate a null procedure in case it is called
777 -- by a client with Initialize_Scalars set). Such procedures have
778 -- to be generated, but do not have to be called, so we mark them
779 -- as null to suppress the call.
781 Set_Init_Proc (A_Type, Proc_Id);
783 if List_Length (Body_Stmts) = 1
785 -- We must skip SCIL nodes because they may have been added to this
786 -- list by Insert_Actions.
788 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
790 Set_Is_Null_Init_Proc (Proc_Id);
793 -- Try to build a static aggregate to statically initialize
794 -- objects of the type. This can only be done for constrained
795 -- one-dimensional arrays with static bounds.
797 Set_Static_Initialization
799 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
802 end Build_Array_Init_Proc;
804 --------------------------------
805 -- Build_Array_Invariant_Proc --
806 --------------------------------
808 function Build_Array_Invariant_Proc
810 Nod : Node_Id) return Node_Id
812 Loc : constant Source_Ptr := Sloc (Nod);
814 Object_Name : constant Name_Id := New_Internal_Name ('I');
815 -- Name for argument of invariant procedure
817 Object_Entity : constant Node_Id :=
818 Make_Defining_Identifier (Loc, Object_Name);
819 -- The procedure declaration entity for the argument
821 Body_Stmts : List_Id;
822 Index_List : List_Id;
826 function Build_Component_Invariant_Call return Node_Id;
827 -- Create one statement to verify invariant on one array component,
828 -- designated by a full set of indexes.
830 function Check_One_Dimension (N : Int) return List_Id;
831 -- Create loop to check on one dimension of the array. The single
832 -- statement in the loop body checks the inner dimensions if any, or
833 -- else a single component. This procedure is called recursively, with
834 -- N being the dimension to be initialized. A call with N greater than
835 -- the number of dimensions generates the component initialization
836 -- and terminates the recursion.
838 ------------------------------------
839 -- Build_Component_Invariant_Call --
840 ------------------------------------
842 function Build_Component_Invariant_Call return Node_Id is
846 Make_Indexed_Component (Loc,
847 Prefix => New_Occurrence_Of (Object_Entity, Loc),
848 Expressions => Index_List);
850 Make_Procedure_Call_Statement (Loc,
853 (Invariant_Procedure (Component_Type (A_Type)), Loc),
854 Parameter_Associations => New_List (Comp));
855 end Build_Component_Invariant_Call;
857 -------------------------
858 -- Check_One_Dimension --
859 -------------------------
861 function Check_One_Dimension (N : Int) return List_Id is
865 -- If all dimensions dealt with, we simply check invariant of the
868 if N > Number_Dimensions (A_Type) then
869 return New_List (Build_Component_Invariant_Call);
871 -- Else generate one loop and recurse
875 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
877 Append (New_Occurrence_Of (Index, Loc), Index_List);
880 Make_Implicit_Loop_Statement (Nod,
883 Make_Iteration_Scheme (Loc,
884 Loop_Parameter_Specification =>
885 Make_Loop_Parameter_Specification (Loc,
886 Defining_Identifier => Index,
887 Discrete_Subtype_Definition =>
888 Make_Attribute_Reference (Loc,
890 New_Occurrence_Of (Object_Entity, Loc),
891 Attribute_Name => Name_Range,
892 Expressions => New_List (
893 Make_Integer_Literal (Loc, N))))),
894 Statements => Check_One_Dimension (N + 1)));
896 end Check_One_Dimension;
898 -- Start of processing for Build_Array_Invariant_Proc
901 Index_List := New_List;
904 Make_Defining_Identifier (Loc,
905 Chars => New_External_Name (Chars (A_Type), "CInvariant"));
907 Body_Stmts := Check_One_Dimension (1);
910 Make_Subprogram_Body (Loc,
912 Make_Procedure_Specification (Loc,
913 Defining_Unit_Name => Proc_Id,
914 Parameter_Specifications => New_List (
915 Make_Parameter_Specification (Loc,
916 Defining_Identifier => Object_Entity,
917 Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
919 Declarations => Empty_List,
920 Handled_Statement_Sequence =>
921 Make_Handled_Sequence_Of_Statements (Loc,
922 Statements => Body_Stmts));
924 Set_Ekind (Proc_Id, E_Procedure);
925 Set_Is_Public (Proc_Id, Is_Public (A_Type));
926 Set_Is_Internal (Proc_Id);
927 Set_Has_Completion (Proc_Id);
929 if not Debug_Generated_Code then
930 Set_Debug_Info_Off (Proc_Id);
934 end Build_Array_Invariant_Proc;
936 --------------------------------
937 -- Build_Discr_Checking_Funcs --
938 --------------------------------
940 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
943 Enclosing_Func_Id : Entity_Id;
948 function Build_Case_Statement
949 (Case_Id : Entity_Id;
950 Variant : Node_Id) return Node_Id;
951 -- Build a case statement containing only two alternatives. The first
952 -- alternative corresponds exactly to the discrete choices given on the
953 -- variant with contains the components that we are generating the
954 -- checks for. If the discriminant is one of these return False. The
955 -- second alternative is an OTHERS choice that will return True
956 -- indicating the discriminant did not match.
958 function Build_Dcheck_Function
959 (Case_Id : Entity_Id;
960 Variant : Node_Id) return Entity_Id;
961 -- Build the discriminant checking function for a given variant
963 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
964 -- Builds the discriminant checking function for each variant of the
965 -- given variant part of the record type.
967 --------------------------
968 -- Build_Case_Statement --
969 --------------------------
971 function Build_Case_Statement
972 (Case_Id : Entity_Id;
973 Variant : Node_Id) return Node_Id
975 Alt_List : constant List_Id := New_List;
976 Actuals_List : List_Id;
978 Case_Alt_Node : Node_Id;
980 Choice_List : List_Id;
982 Return_Node : Node_Id;
985 Case_Node := New_Node (N_Case_Statement, Loc);
987 -- Replace the discriminant which controls the variant with the name
988 -- of the formal of the checking function.
990 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
992 Choice := First (Discrete_Choices (Variant));
994 if Nkind (Choice) = N_Others_Choice then
995 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
997 Choice_List := New_Copy_List (Discrete_Choices (Variant));
1000 if not Is_Empty_List (Choice_List) then
1001 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
1002 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
1004 -- In case this is a nested variant, we need to return the result
1005 -- of the discriminant checking function for the immediately
1006 -- enclosing variant.
1008 if Present (Enclosing_Func_Id) then
1009 Actuals_List := New_List;
1011 D := First_Discriminant (Rec_Id);
1012 while Present (D) loop
1013 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
1014 Next_Discriminant (D);
1018 Make_Simple_Return_Statement (Loc,
1020 Make_Function_Call (Loc,
1022 New_Occurrence_Of (Enclosing_Func_Id, Loc),
1023 Parameter_Associations =>
1028 Make_Simple_Return_Statement (Loc,
1030 New_Occurrence_Of (Standard_False, Loc));
1033 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1034 Append (Case_Alt_Node, Alt_List);
1037 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
1038 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
1039 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
1042 Make_Simple_Return_Statement (Loc,
1044 New_Occurrence_Of (Standard_True, Loc));
1046 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1047 Append (Case_Alt_Node, Alt_List);
1049 Set_Alternatives (Case_Node, Alt_List);
1051 end Build_Case_Statement;
1053 ---------------------------
1054 -- Build_Dcheck_Function --
1055 ---------------------------
1057 function Build_Dcheck_Function
1058 (Case_Id : Entity_Id;
1059 Variant : Node_Id) return Entity_Id
1061 Body_Node : Node_Id;
1062 Func_Id : Entity_Id;
1063 Parameter_List : List_Id;
1064 Spec_Node : Node_Id;
1067 Body_Node := New_Node (N_Subprogram_Body, Loc);
1068 Sequence := Sequence + 1;
1071 Make_Defining_Identifier (Loc,
1072 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
1073 Set_Is_Discriminant_Check_Function (Func_Id);
1075 Spec_Node := New_Node (N_Function_Specification, Loc);
1076 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1078 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
1080 Set_Parameter_Specifications (Spec_Node, Parameter_List);
1081 Set_Result_Definition (Spec_Node,
1082 New_Occurrence_Of (Standard_Boolean, Loc));
1083 Set_Specification (Body_Node, Spec_Node);
1084 Set_Declarations (Body_Node, New_List);
1086 Set_Handled_Statement_Sequence (Body_Node,
1087 Make_Handled_Sequence_Of_Statements (Loc,
1088 Statements => New_List (
1089 Build_Case_Statement (Case_Id, Variant))));
1091 Set_Ekind (Func_Id, E_Function);
1092 Set_Mechanism (Func_Id, Default_Mechanism);
1093 Set_Is_Inlined (Func_Id, True);
1094 Set_Is_Pure (Func_Id, True);
1095 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
1096 Set_Is_Internal (Func_Id, True);
1098 if not Debug_Generated_Code then
1099 Set_Debug_Info_Off (Func_Id);
1102 Analyze (Body_Node);
1104 Append_Freeze_Action (Rec_Id, Body_Node);
1105 Set_Dcheck_Function (Variant, Func_Id);
1107 end Build_Dcheck_Function;
1109 ----------------------------
1110 -- Build_Dcheck_Functions --
1111 ----------------------------
1113 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
1114 Component_List_Node : Node_Id;
1116 Discr_Name : Entity_Id;
1117 Func_Id : Entity_Id;
1119 Saved_Enclosing_Func_Id : Entity_Id;
1122 -- Build the discriminant-checking function for each variant, and
1123 -- label all components of that variant with the function's name.
1124 -- We only Generate a discriminant-checking function when the
1125 -- variant is not empty, to prevent the creation of dead code.
1126 -- The exception to that is when Frontend_Layout_On_Target is set,
1127 -- because the variant record size function generated in package
1128 -- Layout needs to generate calls to all discriminant-checking
1129 -- functions, including those for empty variants.
1131 Discr_Name := Entity (Name (Variant_Part_Node));
1132 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
1134 while Present (Variant) loop
1135 Component_List_Node := Component_List (Variant);
1137 if not Null_Present (Component_List_Node)
1138 or else Frontend_Layout_On_Target
1140 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
1142 First_Non_Pragma (Component_Items (Component_List_Node));
1144 while Present (Decl) loop
1145 Set_Discriminant_Checking_Func
1146 (Defining_Identifier (Decl), Func_Id);
1148 Next_Non_Pragma (Decl);
1151 if Present (Variant_Part (Component_List_Node)) then
1152 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
1153 Enclosing_Func_Id := Func_Id;
1154 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
1155 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
1159 Next_Non_Pragma (Variant);
1161 end Build_Dcheck_Functions;
1163 -- Start of processing for Build_Discr_Checking_Funcs
1166 -- Only build if not done already
1168 if not Discr_Check_Funcs_Built (N) then
1169 Type_Def := Type_Definition (N);
1171 if Nkind (Type_Def) = N_Record_Definition then
1172 if No (Component_List (Type_Def)) then -- null record.
1175 V := Variant_Part (Component_List (Type_Def));
1178 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1179 if No (Component_List (Record_Extension_Part (Type_Def))) then
1183 (Component_List (Record_Extension_Part (Type_Def)));
1187 Rec_Id := Defining_Identifier (N);
1189 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1191 Enclosing_Func_Id := Empty;
1192 Build_Dcheck_Functions (V);
1195 Set_Discr_Check_Funcs_Built (N);
1197 end Build_Discr_Checking_Funcs;
1199 --------------------------------
1200 -- Build_Discriminant_Formals --
1201 --------------------------------
1203 function Build_Discriminant_Formals
1204 (Rec_Id : Entity_Id;
1205 Use_Dl : Boolean) return List_Id
1207 Loc : Source_Ptr := Sloc (Rec_Id);
1208 Parameter_List : constant List_Id := New_List;
1211 Formal_Type : Entity_Id;
1212 Param_Spec_Node : Node_Id;
1215 if Has_Discriminants (Rec_Id) then
1216 D := First_Discriminant (Rec_Id);
1217 while Present (D) loop
1221 Formal := Discriminal (D);
1222 Formal_Type := Etype (Formal);
1224 Formal := Make_Defining_Identifier (Loc, Chars (D));
1225 Formal_Type := Etype (D);
1229 Make_Parameter_Specification (Loc,
1230 Defining_Identifier => Formal,
1232 New_Occurrence_Of (Formal_Type, Loc));
1233 Append (Param_Spec_Node, Parameter_List);
1234 Next_Discriminant (D);
1238 return Parameter_List;
1239 end Build_Discriminant_Formals;
1241 --------------------------------------
1242 -- Build_Equivalent_Array_Aggregate --
1243 --------------------------------------
1245 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1246 Loc : constant Source_Ptr := Sloc (T);
1247 Comp_Type : constant Entity_Id := Component_Type (T);
1248 Index_Type : constant Entity_Id := Etype (First_Index (T));
1249 Proc : constant Entity_Id := Base_Init_Proc (T);
1255 if not Is_Constrained (T)
1256 or else Number_Dimensions (T) > 1
1259 Initialization_Warning (T);
1263 Lo := Type_Low_Bound (Index_Type);
1264 Hi := Type_High_Bound (Index_Type);
1266 if not Compile_Time_Known_Value (Lo)
1267 or else not Compile_Time_Known_Value (Hi)
1269 Initialization_Warning (T);
1273 if Is_Record_Type (Comp_Type)
1274 and then Present (Base_Init_Proc (Comp_Type))
1276 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1279 Initialization_Warning (T);
1284 Initialization_Warning (T);
1288 Aggr := Make_Aggregate (Loc, No_List, New_List);
1289 Set_Etype (Aggr, T);
1290 Set_Aggregate_Bounds (Aggr,
1292 Low_Bound => New_Copy (Lo),
1293 High_Bound => New_Copy (Hi)));
1294 Set_Parent (Aggr, Parent (Proc));
1296 Append_To (Component_Associations (Aggr),
1297 Make_Component_Association (Loc,
1301 Low_Bound => New_Copy (Lo),
1302 High_Bound => New_Copy (Hi))),
1303 Expression => Expr));
1305 if Static_Array_Aggregate (Aggr) then
1308 Initialization_Warning (T);
1311 end Build_Equivalent_Array_Aggregate;
1313 ---------------------------------------
1314 -- Build_Equivalent_Record_Aggregate --
1315 ---------------------------------------
1317 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1320 Comp_Type : Entity_Id;
1322 -- Start of processing for Build_Equivalent_Record_Aggregate
1325 if not Is_Record_Type (T)
1326 or else Has_Discriminants (T)
1327 or else Is_Limited_Type (T)
1328 or else Has_Non_Standard_Rep (T)
1330 Initialization_Warning (T);
1334 Comp := First_Component (T);
1336 -- A null record needs no warning
1342 while Present (Comp) loop
1344 -- Array components are acceptable if initialized by a positional
1345 -- aggregate with static components.
1347 if Is_Array_Type (Etype (Comp)) then
1348 Comp_Type := Component_Type (Etype (Comp));
1350 if Nkind (Parent (Comp)) /= N_Component_Declaration
1351 or else No (Expression (Parent (Comp)))
1352 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1354 Initialization_Warning (T);
1357 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1359 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1361 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1363 Initialization_Warning (T);
1367 not Static_Array_Aggregate (Expression (Parent (Comp)))
1369 Initialization_Warning (T);
1373 elsif Is_Scalar_Type (Etype (Comp)) then
1374 Comp_Type := Etype (Comp);
1376 if Nkind (Parent (Comp)) /= N_Component_Declaration
1377 or else No (Expression (Parent (Comp)))
1378 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1379 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1381 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1383 Initialization_Warning (T);
1387 -- For now, other types are excluded
1390 Initialization_Warning (T);
1394 Next_Component (Comp);
1397 -- All components have static initialization. Build positional aggregate
1398 -- from the given expressions or defaults.
1400 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1401 Set_Parent (Agg, Parent (T));
1403 Comp := First_Component (T);
1404 while Present (Comp) loop
1406 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1407 Next_Component (Comp);
1410 Analyze_And_Resolve (Agg, T);
1412 end Build_Equivalent_Record_Aggregate;
1414 -------------------------------
1415 -- Build_Initialization_Call --
1416 -------------------------------
1418 -- References to a discriminant inside the record type declaration can
1419 -- appear either in the subtype_indication to constrain a record or an
1420 -- array, or as part of a larger expression given for the initial value
1421 -- of a component. In both of these cases N appears in the record
1422 -- initialization procedure and needs to be replaced by the formal
1423 -- parameter of the initialization procedure which corresponds to that
1426 -- In the example below, references to discriminants D1 and D2 in proc_1
1427 -- are replaced by references to formals with the same name
1430 -- A similar replacement is done for calls to any record initialization
1431 -- procedure for any components that are themselves of a record type.
1433 -- type R (D1, D2 : Integer) is record
1434 -- X : Integer := F * D1;
1435 -- Y : Integer := F * D2;
1438 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1442 -- Out_2.X := F * D1;
1443 -- Out_2.Y := F * D2;
1446 function Build_Initialization_Call
1450 In_Init_Proc : Boolean := False;
1451 Enclos_Type : Entity_Id := Empty;
1452 Discr_Map : Elist_Id := New_Elmt_List;
1453 With_Default_Init : Boolean := False;
1454 Constructor_Ref : Node_Id := Empty) return List_Id
1456 Res : constant List_Id := New_List;
1462 First_Arg : Node_Id;
1463 Full_Init_Type : Entity_Id;
1464 Full_Type : Entity_Id := Typ;
1465 Init_Type : Entity_Id;
1469 pragma Assert (Constructor_Ref = Empty
1470 or else Is_CPP_Constructor_Call (Constructor_Ref));
1472 if No (Constructor_Ref) then
1473 Proc := Base_Init_Proc (Typ);
1475 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1478 pragma Assert (Present (Proc));
1479 Init_Type := Etype (First_Formal (Proc));
1480 Full_Init_Type := Underlying_Type (Init_Type);
1482 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1483 -- is active (in which case we make the call anyway, since in the
1484 -- actual compiled client it may be non null).
1485 -- Also nothing to do for value types.
1487 if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars)
1488 or else Is_Value_Type (Typ)
1490 (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ)))
1495 -- Go to full view if private type. In the case of successive
1496 -- private derivations, this can require more than one step.
1498 while Is_Private_Type (Full_Type)
1499 and then Present (Full_View (Full_Type))
1501 Full_Type := Full_View (Full_Type);
1504 -- If Typ is derived, the procedure is the initialization procedure for
1505 -- the root type. Wrap the argument in an conversion to make it type
1506 -- honest. Actually it isn't quite type honest, because there can be
1507 -- conflicts of views in the private type case. That is why we set
1508 -- Conversion_OK in the conversion node.
1510 if (Is_Record_Type (Typ)
1511 or else Is_Array_Type (Typ)
1512 or else Is_Private_Type (Typ))
1513 and then Init_Type /= Base_Type (Typ)
1515 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1516 Set_Etype (First_Arg, Init_Type);
1519 First_Arg := Id_Ref;
1522 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1524 -- In the tasks case, add _Master as the value of the _Master parameter
1525 -- and _Chain as the value of the _Chain parameter. At the outer level,
1526 -- these will be variables holding the corresponding values obtained
1527 -- from GNARL. At inner levels, they will be the parameters passed down
1528 -- through the outer routines.
1530 if Has_Task (Full_Type) then
1531 if Restriction_Active (No_Task_Hierarchy) then
1533 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1535 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1538 -- Add _Chain (not done for sequential elaboration policy, see
1539 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1541 if Partition_Elaboration_Policy /= 'S' then
1542 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1545 -- Ada 2005 (AI-287): In case of default initialized components
1546 -- with tasks, we generate a null string actual parameter.
1547 -- This is just a workaround that must be improved later???
1549 if With_Default_Init then
1551 Make_String_Literal (Loc,
1556 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1557 Decl := Last (Decls);
1560 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1561 Append_List (Decls, Res);
1569 -- Add discriminant values if discriminants are present
1571 if Has_Discriminants (Full_Init_Type) then
1572 Discr := First_Discriminant (Full_Init_Type);
1574 while Present (Discr) loop
1576 -- If this is a discriminated concurrent type, the init_proc
1577 -- for the corresponding record is being called. Use that type
1578 -- directly to find the discriminant value, to handle properly
1579 -- intervening renamed discriminants.
1582 T : Entity_Id := Full_Type;
1585 if Is_Protected_Type (T) then
1586 T := Corresponding_Record_Type (T);
1588 elsif Is_Private_Type (T)
1589 and then Present (Underlying_Full_View (T))
1590 and then Is_Protected_Type (Underlying_Full_View (T))
1592 T := Corresponding_Record_Type (Underlying_Full_View (T));
1596 Get_Discriminant_Value (
1599 Discriminant_Constraint (Full_Type));
1602 -- If the target has access discriminants, and is constrained by
1603 -- an access to the enclosing construct, i.e. a current instance,
1604 -- replace the reference to the type by a reference to the object.
1606 if Nkind (Arg) = N_Attribute_Reference
1607 and then Is_Access_Type (Etype (Arg))
1608 and then Is_Entity_Name (Prefix (Arg))
1609 and then Is_Type (Entity (Prefix (Arg)))
1612 Make_Attribute_Reference (Loc,
1613 Prefix => New_Copy (Prefix (Id_Ref)),
1614 Attribute_Name => Name_Unrestricted_Access);
1616 elsif In_Init_Proc then
1618 -- Replace any possible references to the discriminant in the
1619 -- call to the record initialization procedure with references
1620 -- to the appropriate formal parameter.
1622 if Nkind (Arg) = N_Identifier
1623 and then Ekind (Entity (Arg)) = E_Discriminant
1625 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1627 -- Otherwise make a copy of the default expression. Note that
1628 -- we use the current Sloc for this, because we do not want the
1629 -- call to appear to be at the declaration point. Within the
1630 -- expression, replace discriminants with their discriminals.
1634 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1638 if Is_Constrained (Full_Type) then
1639 Arg := Duplicate_Subexpr_No_Checks (Arg);
1641 -- The constraints come from the discriminant default exps,
1642 -- they must be reevaluated, so we use New_Copy_Tree but we
1643 -- ensure the proper Sloc (for any embedded calls).
1645 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1649 -- Ada 2005 (AI-287): In case of default initialized components,
1650 -- if the component is constrained with a discriminant of the
1651 -- enclosing type, we need to generate the corresponding selected
1652 -- component node to access the discriminant value. In other cases
1653 -- this is not required, either because we are inside the init
1654 -- proc and we use the corresponding formal, or else because the
1655 -- component is constrained by an expression.
1657 if With_Default_Init
1658 and then Nkind (Id_Ref) = N_Selected_Component
1659 and then Nkind (Arg) = N_Identifier
1660 and then Ekind (Entity (Arg)) = E_Discriminant
1663 Make_Selected_Component (Loc,
1664 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1665 Selector_Name => Arg));
1667 Append_To (Args, Arg);
1670 Next_Discriminant (Discr);
1674 -- If this is a call to initialize the parent component of a derived
1675 -- tagged type, indicate that the tag should not be set in the parent.
1677 if Is_Tagged_Type (Full_Init_Type)
1678 and then not Is_CPP_Class (Full_Init_Type)
1679 and then Nkind (Id_Ref) = N_Selected_Component
1680 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1682 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1684 elsif Present (Constructor_Ref) then
1685 Append_List_To (Args,
1686 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1690 Make_Procedure_Call_Statement (Loc,
1691 Name => New_Occurrence_Of (Proc, Loc),
1692 Parameter_Associations => Args));
1694 if Needs_Finalization (Typ)
1695 and then Nkind (Id_Ref) = N_Selected_Component
1697 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1700 (Obj_Ref => New_Copy_Tree (First_Arg),
1705 -- When the object is either protected or a task, create static strings
1706 -- which denote the names of entries and families. Associate the strings
1707 -- with the concurrent object's Protection_Entries or ATCB. This is a
1708 -- VMS Debug feature.
1710 if OpenVMS_On_Target
1711 and then Is_Concurrent_Type (Typ)
1712 and then Entry_Names_OK
1714 Build_Entry_Names (Id_Ref, Typ, Res);
1720 when RE_Not_Available =>
1722 end Build_Initialization_Call;
1724 ----------------------------
1725 -- Build_Record_Init_Proc --
1726 ----------------------------
1728 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1729 Decls : constant List_Id := New_List;
1730 Discr_Map : constant Elist_Id := New_Elmt_List;
1731 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1733 Proc_Id : Entity_Id;
1734 Rec_Type : Entity_Id;
1735 Set_Tag : Entity_Id := Empty;
1737 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1738 -- Build an assignment statement which assigns the default expression
1739 -- to its corresponding record component if defined. The left hand side
1740 -- of the assignment is marked Assignment_OK so that initialization of
1741 -- limited private records works correctly. This routine may also build
1742 -- an adjustment call if the component is controlled.
1744 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1745 -- If the record has discriminants, add assignment statements to
1746 -- Statement_List to initialize the discriminant values from the
1747 -- arguments of the initialization procedure.
1749 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1750 -- Build a list representing a sequence of statements which initialize
1751 -- components of the given component list. This may involve building
1752 -- case statements for the variant parts. Append any locally declared
1753 -- objects on list Decls.
1755 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1756 -- Given a non-tagged type-derivation that declares discriminants,
1759 -- type R (R1, R2 : Integer) is record ... end record;
1761 -- type D (D1 : Integer) is new R (1, D1);
1763 -- we make the _init_proc of D be
1765 -- procedure _init_proc (X : D; D1 : Integer) is
1767 -- _init_proc (R (X), 1, D1);
1770 -- This function builds the call statement in this _init_proc.
1772 procedure Build_CPP_Init_Procedure;
1773 -- Build the tree corresponding to the procedure specification and body
1774 -- of the IC procedure that initializes the C++ part of the dispatch
1775 -- table of an Ada tagged type that is a derivation of a CPP type.
1776 -- Install it as the CPP_Init TSS.
1778 procedure Build_Init_Procedure;
1779 -- Build the tree corresponding to the procedure specification and body
1780 -- of the initialization procedure and install it as the _init TSS.
1782 procedure Build_Offset_To_Top_Functions;
1783 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1784 -- and body of Offset_To_Top, a function used in conjuction with types
1785 -- having secondary dispatch tables.
1787 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1788 -- Add range checks to components of discriminated records. S is a
1789 -- subtype indication of a record component. Check_List is a list
1790 -- to which the check actions are appended.
1792 function Component_Needs_Simple_Initialization
1793 (T : Entity_Id) return Boolean;
1794 -- Determine if a component needs simple initialization, given its type
1795 -- T. This routine is the same as Needs_Simple_Initialization except for
1796 -- components of type Tag and Interface_Tag. These two access types do
1797 -- not require initialization since they are explicitly initialized by
1800 function Parent_Subtype_Renaming_Discrims return Boolean;
1801 -- Returns True for base types N that rename discriminants, else False
1803 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1804 -- Determine whether a record initialization procedure needs to be
1805 -- generated for the given record type.
1807 ----------------------
1808 -- Build_Assignment --
1809 ----------------------
1811 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1812 N_Loc : constant Source_Ptr := Sloc (N);
1813 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1815 Kind : Node_Kind := Nkind (N);
1821 Make_Selected_Component (N_Loc,
1822 Prefix => Make_Identifier (Loc, Name_uInit),
1823 Selector_Name => New_Occurrence_Of (Id, N_Loc));
1824 Set_Assignment_OK (Lhs);
1826 -- Case of an access attribute applied to the current instance.
1827 -- Replace the reference to the type by a reference to the actual
1828 -- object. (Note that this handles the case of the top level of
1829 -- the expression being given by such an attribute, but does not
1830 -- cover uses nested within an initial value expression. Nested
1831 -- uses are unlikely to occur in practice, but are theoretically
1832 -- possible.) It is not clear how to handle them without fully
1833 -- traversing the expression. ???
1835 if Kind = N_Attribute_Reference
1836 and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
1837 Name_Unrestricted_Access)
1838 and then Is_Entity_Name (Prefix (N))
1839 and then Is_Type (Entity (Prefix (N)))
1840 and then Entity (Prefix (N)) = Rec_Type
1843 Make_Attribute_Reference (N_Loc,
1845 Make_Identifier (N_Loc, Name_uInit),
1846 Attribute_Name => Name_Unrestricted_Access);
1849 -- Take a copy of Exp to ensure that later copies of this component
1850 -- declaration in derived types see the original tree, not a node
1851 -- rewritten during expansion of the init_proc. If the copy contains
1852 -- itypes, the scope of the new itypes is the init_proc being built.
1854 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1857 Make_Assignment_Statement (Loc,
1859 Expression => Exp));
1861 Set_No_Ctrl_Actions (First (Res));
1863 -- Adjust the tag if tagged (because of possible view conversions).
1864 -- Suppress the tag adjustment when VM_Target because VM tags are
1865 -- represented implicitly in objects.
1867 if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
1869 Make_Assignment_Statement (N_Loc,
1871 Make_Selected_Component (N_Loc,
1873 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1875 New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
1878 Unchecked_Convert_To (RTE (RE_Tag),
1882 (Access_Disp_Table (Underlying_Type (Typ)))),
1886 -- Adjust the component if controlled except if it is an aggregate
1887 -- that will be expanded inline.
1889 if Kind = N_Qualified_Expression then
1890 Kind := Nkind (Expression (N));
1893 if Needs_Finalization (Typ)
1894 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1895 and then not Is_Limited_View (Typ)
1899 (Obj_Ref => New_Copy_Tree (Lhs),
1900 Typ => Etype (Id)));
1906 when RE_Not_Available =>
1908 end Build_Assignment;
1910 ------------------------------------
1911 -- Build_Discriminant_Assignments --
1912 ------------------------------------
1914 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1915 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1920 if Has_Discriminants (Rec_Type)
1921 and then not Is_Unchecked_Union (Rec_Type)
1923 D := First_Discriminant (Rec_Type);
1924 while Present (D) loop
1926 -- Don't generate the assignment for discriminants in derived
1927 -- tagged types if the discriminant is a renaming of some
1928 -- ancestor discriminant. This initialization will be done
1929 -- when initializing the _parent field of the derived record.
1932 and then Present (Corresponding_Discriminant (D))
1938 Append_List_To (Statement_List,
1939 Build_Assignment (D,
1940 New_Occurrence_Of (Discriminal (D), D_Loc)));
1943 Next_Discriminant (D);
1946 end Build_Discriminant_Assignments;
1948 --------------------------
1949 -- Build_Init_Call_Thru --
1950 --------------------------
1952 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1953 Parent_Proc : constant Entity_Id :=
1954 Base_Init_Proc (Etype (Rec_Type));
1956 Parent_Type : constant Entity_Id :=
1957 Etype (First_Formal (Parent_Proc));
1959 Uparent_Type : constant Entity_Id :=
1960 Underlying_Type (Parent_Type);
1962 First_Discr_Param : Node_Id;
1966 First_Arg : Node_Id;
1967 Parent_Discr : Entity_Id;
1971 -- First argument (_Init) is the object to be initialized.
1972 -- ??? not sure where to get a reasonable Loc for First_Arg
1975 OK_Convert_To (Parent_Type,
1977 (Defining_Identifier (First (Parameters)), Loc));
1979 Set_Etype (First_Arg, Parent_Type);
1981 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1983 -- In the tasks case,
1984 -- add _Master as the value of the _Master parameter
1985 -- add _Chain as the value of the _Chain parameter.
1986 -- add _Task_Name as the value of the _Task_Name parameter.
1987 -- At the outer level, these will be variables holding the
1988 -- corresponding values obtained from GNARL or the expander.
1990 -- At inner levels, they will be the parameters passed down through
1991 -- the outer routines.
1993 First_Discr_Param := Next (First (Parameters));
1995 if Has_Task (Rec_Type) then
1996 if Restriction_Active (No_Task_Hierarchy) then
1998 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
2000 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2003 -- Add _Chain (not done for sequential elaboration policy, see
2004 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2006 if Partition_Elaboration_Policy /= 'S' then
2007 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2010 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2011 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2014 -- Append discriminant values
2016 if Has_Discriminants (Uparent_Type) then
2017 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2019 Parent_Discr := First_Discriminant (Uparent_Type);
2020 while Present (Parent_Discr) loop
2022 -- Get the initial value for this discriminant
2023 -- ??? needs to be cleaned up to use parent_Discr_Constr
2027 Discr : Entity_Id :=
2028 First_Stored_Discriminant (Uparent_Type);
2030 Discr_Value : Elmt_Id :=
2031 First_Elmt (Stored_Constraint (Rec_Type));
2034 while Original_Record_Component (Parent_Discr) /= Discr loop
2035 Next_Stored_Discriminant (Discr);
2036 Next_Elmt (Discr_Value);
2039 Arg := Node (Discr_Value);
2042 -- Append it to the list
2044 if Nkind (Arg) = N_Identifier
2045 and then Ekind (Entity (Arg)) = E_Discriminant
2048 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2050 -- Case of access discriminants. We replace the reference
2051 -- to the type by a reference to the actual object.
2053 -- Is above comment right??? Use of New_Copy below seems mighty
2057 Append_To (Args, New_Copy (Arg));
2060 Next_Discriminant (Parent_Discr);
2066 Make_Procedure_Call_Statement (Loc,
2068 New_Occurrence_Of (Parent_Proc, Loc),
2069 Parameter_Associations => Args));
2072 end Build_Init_Call_Thru;
2074 -----------------------------------
2075 -- Build_Offset_To_Top_Functions --
2076 -----------------------------------
2078 procedure Build_Offset_To_Top_Functions is
2080 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2082 -- function Fxx (O : Address) return Storage_Offset is
2083 -- type Acc is access all <Typ>;
2085 -- return Acc!(O).Iface_Comp'Position;
2088 ----------------------------------
2089 -- Build_Offset_To_Top_Function --
2090 ----------------------------------
2092 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2093 Body_Node : Node_Id;
2094 Func_Id : Entity_Id;
2095 Spec_Node : Node_Id;
2096 Acc_Type : Entity_Id;
2099 Func_Id := Make_Temporary (Loc, 'F');
2100 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2103 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2105 Spec_Node := New_Node (N_Function_Specification, Loc);
2106 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2107 Set_Parameter_Specifications (Spec_Node, New_List (
2108 Make_Parameter_Specification (Loc,
2109 Defining_Identifier =>
2110 Make_Defining_Identifier (Loc, Name_uO),
2113 New_Occurrence_Of (RTE (RE_Address), Loc))));
2114 Set_Result_Definition (Spec_Node,
2115 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2118 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2120 -- return O.Iface_Comp'Position;
2123 Body_Node := New_Node (N_Subprogram_Body, Loc);
2124 Set_Specification (Body_Node, Spec_Node);
2126 Acc_Type := Make_Temporary (Loc, 'T');
2127 Set_Declarations (Body_Node, New_List (
2128 Make_Full_Type_Declaration (Loc,
2129 Defining_Identifier => Acc_Type,
2131 Make_Access_To_Object_Definition (Loc,
2132 All_Present => True,
2133 Null_Exclusion_Present => False,
2134 Constant_Present => False,
2135 Subtype_Indication =>
2136 New_Occurrence_Of (Rec_Type, Loc)))));
2138 Set_Handled_Statement_Sequence (Body_Node,
2139 Make_Handled_Sequence_Of_Statements (Loc,
2140 Statements => New_List (
2141 Make_Simple_Return_Statement (Loc,
2143 Make_Attribute_Reference (Loc,
2145 Make_Selected_Component (Loc,
2147 Unchecked_Convert_To (Acc_Type,
2148 Make_Identifier (Loc, Name_uO)),
2150 New_Occurrence_Of (Iface_Comp, Loc)),
2151 Attribute_Name => Name_Position)))));
2153 Set_Ekind (Func_Id, E_Function);
2154 Set_Mechanism (Func_Id, Default_Mechanism);
2155 Set_Is_Internal (Func_Id, True);
2157 if not Debug_Generated_Code then
2158 Set_Debug_Info_Off (Func_Id);
2161 Analyze (Body_Node);
2163 Append_Freeze_Action (Rec_Type, Body_Node);
2164 end Build_Offset_To_Top_Function;
2168 Iface_Comp : Node_Id;
2169 Iface_Comp_Elmt : Elmt_Id;
2170 Ifaces_Comp_List : Elist_Id;
2172 -- Start of processing for Build_Offset_To_Top_Functions
2175 -- Offset_To_Top_Functions are built only for derivations of types
2176 -- with discriminants that cover interface types.
2177 -- Nothing is needed either in case of virtual machines, since
2178 -- interfaces are handled directly by the VM.
2180 if not Is_Tagged_Type (Rec_Type)
2181 or else Etype (Rec_Type) = Rec_Type
2182 or else not Has_Discriminants (Etype (Rec_Type))
2183 or else not Tagged_Type_Expansion
2188 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2190 -- For each interface type with secondary dispatch table we generate
2191 -- the Offset_To_Top_Functions (required to displace the pointer in
2192 -- interface conversions)
2194 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2195 while Present (Iface_Comp_Elmt) loop
2196 Iface_Comp := Node (Iface_Comp_Elmt);
2197 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2199 -- If the interface is a parent of Rec_Type it shares the primary
2200 -- dispatch table and hence there is no need to build the function
2202 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2203 Use_Full_View => True)
2205 Build_Offset_To_Top_Function (Iface_Comp);
2208 Next_Elmt (Iface_Comp_Elmt);
2210 end Build_Offset_To_Top_Functions;
2212 ------------------------------
2213 -- Build_CPP_Init_Procedure --
2214 ------------------------------
2216 procedure Build_CPP_Init_Procedure is
2217 Body_Node : Node_Id;
2218 Body_Stmts : List_Id;
2219 Flag_Id : Entity_Id;
2220 Flag_Decl : Node_Id;
2221 Handled_Stmt_Node : Node_Id;
2222 Init_Tags_List : List_Id;
2223 Proc_Id : Entity_Id;
2224 Proc_Spec_Node : Node_Id;
2227 -- Check cases requiring no IC routine
2229 if not Is_CPP_Class (Root_Type (Rec_Type))
2230 or else Is_CPP_Class (Rec_Type)
2231 or else CPP_Num_Prims (Rec_Type) = 0
2232 or else not Tagged_Type_Expansion
2233 or else No_Run_Time_Mode
2240 -- Flag : Boolean := False;
2242 -- procedure Typ_IC is
2245 -- Copy C++ dispatch table slots from parent
2246 -- Update C++ slots of overridden primitives
2250 Flag_Id := Make_Temporary (Loc, 'F');
2253 Make_Object_Declaration (Loc,
2254 Defining_Identifier => Flag_Id,
2255 Object_Definition =>
2256 New_Occurrence_Of (Standard_Boolean, Loc),
2258 New_Occurrence_Of (Standard_True, Loc));
2260 Analyze (Flag_Decl);
2261 Append_Freeze_Action (Rec_Type, Flag_Decl);
2263 Body_Stmts := New_List;
2264 Body_Node := New_Node (N_Subprogram_Body, Loc);
2266 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2269 Make_Defining_Identifier (Loc,
2270 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2272 Set_Ekind (Proc_Id, E_Procedure);
2273 Set_Is_Internal (Proc_Id);
2275 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2277 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2278 Set_Specification (Body_Node, Proc_Spec_Node);
2279 Set_Declarations (Body_Node, New_List);
2281 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2283 Append_To (Init_Tags_List,
2284 Make_Assignment_Statement (Loc,
2286 New_Occurrence_Of (Flag_Id, Loc),
2288 New_Occurrence_Of (Standard_False, Loc)));
2290 Append_To (Body_Stmts,
2291 Make_If_Statement (Loc,
2292 Condition => New_Occurrence_Of (Flag_Id, Loc),
2293 Then_Statements => Init_Tags_List));
2295 Handled_Stmt_Node :=
2296 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2297 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2298 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2299 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2301 if not Debug_Generated_Code then
2302 Set_Debug_Info_Off (Proc_Id);
2305 -- Associate CPP_Init_Proc with type
2307 Set_Init_Proc (Rec_Type, Proc_Id);
2308 end Build_CPP_Init_Procedure;
2310 --------------------------
2311 -- Build_Init_Procedure --
2312 --------------------------
2314 procedure Build_Init_Procedure is
2315 Body_Stmts : List_Id;
2316 Body_Node : Node_Id;
2317 Handled_Stmt_Node : Node_Id;
2318 Init_Tags_List : List_Id;
2319 Parameters : List_Id;
2320 Proc_Spec_Node : Node_Id;
2321 Record_Extension_Node : Node_Id;
2324 Body_Stmts := New_List;
2325 Body_Node := New_Node (N_Subprogram_Body, Loc);
2326 Set_Ekind (Proc_Id, E_Procedure);
2328 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2329 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2331 Parameters := Init_Formals (Rec_Type);
2332 Append_List_To (Parameters,
2333 Build_Discriminant_Formals (Rec_Type, True));
2335 -- For tagged types, we add a flag to indicate whether the routine
2336 -- is called to initialize a parent component in the init_proc of
2337 -- a type extension. If the flag is false, we do not set the tag
2338 -- because it has been set already in the extension.
2340 if Is_Tagged_Type (Rec_Type) then
2341 Set_Tag := Make_Temporary (Loc, 'P');
2343 Append_To (Parameters,
2344 Make_Parameter_Specification (Loc,
2345 Defining_Identifier => Set_Tag,
2347 New_Occurrence_Of (Standard_Boolean, Loc),
2349 New_Occurrence_Of (Standard_True, Loc)));
2352 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2353 Set_Specification (Body_Node, Proc_Spec_Node);
2354 Set_Declarations (Body_Node, Decls);
2356 -- N is a Derived_Type_Definition that renames the parameters of the
2357 -- ancestor type. We initialize it by expanding our discriminants and
2358 -- call the ancestor _init_proc with a type-converted object.
2360 if Parent_Subtype_Renaming_Discrims then
2361 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2363 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2364 Build_Discriminant_Assignments (Body_Stmts);
2366 if not Null_Present (Type_Definition (N)) then
2367 Append_List_To (Body_Stmts,
2368 Build_Init_Statements (
2369 Component_List (Type_Definition (N))));
2372 -- N is a Derived_Type_Definition with a possible non-empty
2373 -- extension. The initialization of a type extension consists in the
2374 -- initialization of the components in the extension.
2377 Build_Discriminant_Assignments (Body_Stmts);
2379 Record_Extension_Node :=
2380 Record_Extension_Part (Type_Definition (N));
2382 if not Null_Present (Record_Extension_Node) then
2384 Stmts : constant List_Id :=
2385 Build_Init_Statements (
2386 Component_List (Record_Extension_Node));
2389 -- The parent field must be initialized first because the
2390 -- offset of the new discriminants may depend on it. This is
2391 -- not needed if the parent is an interface type because in
2392 -- such case the initialization of the _parent field was not
2395 if not Is_Interface (Etype (Rec_Ent)) then
2396 Prepend_To (Body_Stmts, Remove_Head (Stmts));
2399 Append_List_To (Body_Stmts, Stmts);
2404 -- Add here the assignment to instantiate the Tag
2406 -- The assignment corresponds to the code:
2408 -- _Init._Tag := Typ'Tag;
2410 -- Suppress the tag assignment when VM_Target because VM tags are
2411 -- represented implicitly in objects. It is also suppressed in case
2412 -- of CPP_Class types because in this case the tag is initialized in
2415 if Is_Tagged_Type (Rec_Type)
2416 and then Tagged_Type_Expansion
2417 and then not No_Run_Time_Mode
2419 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2420 -- the actual object and invoke the IP of the parent (in this
2421 -- order). The tag must be initialized before the call to the IP
2422 -- of the parent and the assignments to other components because
2423 -- the initial value of the components may depend on the tag (eg.
2424 -- through a dispatching operation on an access to the current
2425 -- type). The tag assignment is not done when initializing the
2426 -- parent component of a type extension, because in that case the
2427 -- tag is set in the extension.
2429 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2431 -- Initialize the primary tag component
2433 Init_Tags_List := New_List (
2434 Make_Assignment_Statement (Loc,
2436 Make_Selected_Component (Loc,
2437 Prefix => Make_Identifier (Loc, Name_uInit),
2440 (First_Tag_Component (Rec_Type), Loc)),
2444 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2446 -- Ada 2005 (AI-251): Initialize the secondary tags components
2447 -- located at fixed positions (tags whose position depends on
2448 -- variable size components are initialized later ---see below)
2450 if Ada_Version >= Ada_2005
2451 and then not Is_Interface (Rec_Type)
2452 and then Has_Interfaces (Rec_Type)
2456 Target => Make_Identifier (Loc, Name_uInit),
2457 Stmts_List => Init_Tags_List,
2458 Fixed_Comps => True,
2459 Variable_Comps => False);
2462 Prepend_To (Body_Stmts,
2463 Make_If_Statement (Loc,
2464 Condition => New_Occurrence_Of (Set_Tag, Loc),
2465 Then_Statements => Init_Tags_List));
2467 -- Case 2: CPP type. The imported C++ constructor takes care of
2468 -- tags initialization. No action needed here because the IP
2469 -- is built by Set_CPP_Constructors; in this case the IP is a
2470 -- wrapper that invokes the C++ constructor and copies the C++
2471 -- tags locally. Done to inherit the C++ slots in Ada derivations
2474 elsif Is_CPP_Class (Rec_Type) then
2475 pragma Assert (False);
2478 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2479 -- type derivations. Derivations of imported C++ classes add a
2480 -- complication, because we cannot inhibit tag setting in the
2481 -- constructor for the parent. Hence we initialize the tag after
2482 -- the call to the parent IP (that is, in reverse order compared
2483 -- with pure Ada hierarchies ---see comment on case 1).
2486 -- Initialize the primary tag
2488 Init_Tags_List := New_List (
2489 Make_Assignment_Statement (Loc,
2491 Make_Selected_Component (Loc,
2492 Prefix => Make_Identifier (Loc, Name_uInit),
2495 (First_Tag_Component (Rec_Type), Loc)),
2499 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2501 -- Ada 2005 (AI-251): Initialize the secondary tags components
2502 -- located at fixed positions (tags whose position depends on
2503 -- variable size components are initialized later ---see below)
2505 if Ada_Version >= Ada_2005
2506 and then not Is_Interface (Rec_Type)
2507 and then Has_Interfaces (Rec_Type)
2511 Target => Make_Identifier (Loc, Name_uInit),
2512 Stmts_List => Init_Tags_List,
2513 Fixed_Comps => True,
2514 Variable_Comps => False);
2517 -- Initialize the tag component after invocation of parent IP.
2520 -- parent_IP(_init.parent); // Invokes the C++ constructor
2521 -- [ typIC; ] // Inherit C++ slots from parent
2528 -- Search for the call to the IP of the parent. We assume
2529 -- that the first init_proc call is for the parent.
2531 Ins_Nod := First (Body_Stmts);
2532 while Present (Next (Ins_Nod))
2533 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2534 or else not Is_Init_Proc (Name (Ins_Nod)))
2539 -- The IC routine copies the inherited slots of the C+ part
2540 -- of the dispatch table from the parent and updates the
2541 -- overridden C++ slots.
2543 if CPP_Num_Prims (Rec_Type) > 0 then
2545 Init_DT : Entity_Id;
2549 Init_DT := CPP_Init_Proc (Rec_Type);
2550 pragma Assert (Present (Init_DT));
2553 Make_Procedure_Call_Statement (Loc,
2554 New_Occurrence_Of (Init_DT, Loc));
2555 Insert_After (Ins_Nod, New_Nod);
2557 -- Update location of init tag statements
2563 Insert_List_After (Ins_Nod, Init_Tags_List);
2567 -- Ada 2005 (AI-251): Initialize the secondary tag components
2568 -- located at variable positions. We delay the generation of this
2569 -- code until here because the value of the attribute 'Position
2570 -- applied to variable size components of the parent type that
2571 -- depend on discriminants is only safely read at runtime after
2572 -- the parent components have been initialized.
2574 if Ada_Version >= Ada_2005
2575 and then not Is_Interface (Rec_Type)
2576 and then Has_Interfaces (Rec_Type)
2577 and then Has_Discriminants (Etype (Rec_Type))
2578 and then Is_Variable_Size_Record (Etype (Rec_Type))
2580 Init_Tags_List := New_List;
2584 Target => Make_Identifier (Loc, Name_uInit),
2585 Stmts_List => Init_Tags_List,
2586 Fixed_Comps => False,
2587 Variable_Comps => True);
2589 if Is_Non_Empty_List (Init_Tags_List) then
2590 Append_List_To (Body_Stmts, Init_Tags_List);
2595 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2596 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2599 -- Local_DF_Id (_init, C1, ..., CN);
2603 and then Needs_Finalization (Rec_Type)
2604 and then not Is_Abstract_Type (Rec_Type)
2605 and then not Restriction_Active (No_Exception_Propagation)
2608 Local_DF_Id : Entity_Id;
2611 -- Create a local version of Deep_Finalize which has indication
2612 -- of partial initialization state.
2614 Local_DF_Id := Make_Temporary (Loc, 'F');
2617 Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id));
2619 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2620 Make_Exception_Handler (Loc,
2621 Exception_Choices => New_List (
2622 Make_Others_Choice (Loc)),
2624 Statements => New_List (
2625 Make_Procedure_Call_Statement (Loc,
2627 New_Occurrence_Of (Local_DF_Id, Loc),
2629 Parameter_Associations => New_List (
2630 Make_Identifier (Loc, Name_uInit),
2631 New_Occurrence_Of (Standard_False, Loc))),
2633 Make_Raise_Statement (Loc)))));
2636 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2639 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2641 if not Debug_Generated_Code then
2642 Set_Debug_Info_Off (Proc_Id);
2645 -- Associate Init_Proc with type, and determine if the procedure
2646 -- is null (happens because of the Initialize_Scalars pragma case,
2647 -- where we have to generate a null procedure in case it is called
2648 -- by a client with Initialize_Scalars set). Such procedures have
2649 -- to be generated, but do not have to be called, so we mark them
2650 -- as null to suppress the call.
2652 Set_Init_Proc (Rec_Type, Proc_Id);
2654 if List_Length (Body_Stmts) = 1
2656 -- We must skip SCIL nodes because they may have been added to this
2657 -- list by Insert_Actions.
2659 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2660 and then VM_Target = No_VM
2662 -- Even though the init proc may be null at this time it might get
2663 -- some stuff added to it later by the VM backend.
2665 Set_Is_Null_Init_Proc (Proc_Id);
2667 end Build_Init_Procedure;
2669 ---------------------------
2670 -- Build_Init_Statements --
2671 ---------------------------
2673 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2674 Checks : constant List_Id := New_List;
2675 Actions : List_Id := No_List;
2676 Comp_Loc : Source_Ptr;
2677 Counter_Id : Entity_Id := Empty;
2684 procedure Increment_Counter (Loc : Source_Ptr);
2685 -- Generate an "increment by one" statement for the current counter
2686 -- and append it to the list Stmts.
2688 procedure Make_Counter (Loc : Source_Ptr);
2689 -- Create a new counter for the current component list. The routine
2690 -- creates a new defining Id, adds an object declaration and sets
2691 -- the Id generator for the next variant.
2693 -----------------------
2694 -- Increment_Counter --
2695 -----------------------
2697 procedure Increment_Counter (Loc : Source_Ptr) is
2700 -- Counter := Counter + 1;
2703 Make_Assignment_Statement (Loc,
2704 Name => New_Occurrence_Of (Counter_Id, Loc),
2707 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
2708 Right_Opnd => Make_Integer_Literal (Loc, 1))));
2709 end Increment_Counter;
2715 procedure Make_Counter (Loc : Source_Ptr) is
2717 -- Increment the Id generator
2719 Counter := Counter + 1;
2721 -- Create the entity and declaration
2724 Make_Defining_Identifier (Loc,
2725 Chars => New_External_Name ('C', Counter));
2728 -- Cnn : Integer := 0;
2731 Make_Object_Declaration (Loc,
2732 Defining_Identifier => Counter_Id,
2733 Object_Definition =>
2734 New_Occurrence_Of (Standard_Integer, Loc),
2736 Make_Integer_Literal (Loc, 0)));
2739 -- Start of processing for Build_Init_Statements
2742 if Null_Present (Comp_List) then
2743 return New_List (Make_Null_Statement (Loc));
2748 -- Loop through visible declarations of task types and protected
2749 -- types moving any expanded code from the spec to the body of the
2752 if Is_Task_Record_Type (Rec_Type)
2753 or else Is_Protected_Record_Type (Rec_Type)
2756 Decl : constant Node_Id :=
2757 Parent (Corresponding_Concurrent_Type (Rec_Type));
2763 if Is_Task_Record_Type (Rec_Type) then
2764 Def := Task_Definition (Decl);
2766 Def := Protected_Definition (Decl);
2769 if Present (Def) then
2770 N1 := First (Visible_Declarations (Def));
2771 while Present (N1) loop
2775 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2776 or else Nkind (N2) in N_Raise_xxx_Error
2777 or else Nkind (N2) = N_Procedure_Call_Statement
2780 New_Copy_Tree (N2, New_Scope => Proc_Id));
2781 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2789 -- Loop through components, skipping pragmas, in 2 steps. The first
2790 -- step deals with regular components. The second step deals with
2791 -- components that have per object constraints and no explicit
2796 -- First pass : regular components
2798 Decl := First_Non_Pragma (Component_Items (Comp_List));
2799 while Present (Decl) loop
2800 Comp_Loc := Sloc (Decl);
2802 (Subtype_Indication (Component_Definition (Decl)), Checks);
2804 Id := Defining_Identifier (Decl);
2807 -- Leave any processing of per-object constrained component for
2810 if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
2813 -- Regular component cases
2816 -- Explicit initialization
2818 if Present (Expression (Decl)) then
2819 if Is_CPP_Constructor_Call (Expression (Decl)) then
2821 Build_Initialization_Call
2824 Make_Selected_Component (Comp_Loc,
2826 Make_Identifier (Comp_Loc, Name_uInit),
2828 New_Occurrence_Of (Id, Comp_Loc)),
2830 In_Init_Proc => True,
2831 Enclos_Type => Rec_Type,
2832 Discr_Map => Discr_Map,
2833 Constructor_Ref => Expression (Decl));
2835 Actions := Build_Assignment (Id, Expression (Decl));
2838 -- CPU, Dispatching_Domain, Priority and Size components are
2839 -- filled with the corresponding rep item expression of the
2840 -- concurrent type (if any).
2842 elsif Ekind (Scope (Id)) = E_Record_Type
2843 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
2844 and then Nam_In (Chars (Id), Name_uCPU,
2845 Name_uDispatching_Domain,
2854 if Chars (Id) = Name_uCPU then
2857 elsif Chars (Id) = Name_uDispatching_Domain then
2858 Nam := Name_Dispatching_Domain;
2860 elsif Chars (Id) = Name_uPriority then
2861 Nam := Name_Priority;
2864 -- Get the Rep Item (aspect specification, attribute
2865 -- definition clause or pragma) of the corresponding
2870 (Corresponding_Concurrent_Type (Scope (Id)),
2872 Check_Parents => False);
2874 if Present (Ritem) then
2878 if Nkind (Ritem) = N_Pragma then
2879 Exp := First (Pragma_Argument_Associations (Ritem));
2881 if Nkind (Exp) = N_Pragma_Argument_Association then
2882 Exp := Expression (Exp);
2885 -- Conversion for Priority expression
2887 if Nam = Name_Priority then
2888 if Pragma_Name (Ritem) = Name_Priority
2889 and then not GNAT_Mode
2891 Exp := Convert_To (RTE (RE_Priority), Exp);
2894 Convert_To (RTE (RE_Any_Priority), Exp);
2898 -- Aspect/Attribute definition clause case
2901 Exp := Expression (Ritem);
2903 -- Conversion for Priority expression
2905 if Nam = Name_Priority then
2906 if Chars (Ritem) = Name_Priority
2907 and then not GNAT_Mode
2909 Exp := Convert_To (RTE (RE_Priority), Exp);
2912 Convert_To (RTE (RE_Any_Priority), Exp);
2917 -- Conversion for Dispatching_Domain value
2919 if Nam = Name_Dispatching_Domain then
2921 Unchecked_Convert_To
2922 (RTE (RE_Dispatching_Domain_Access), Exp);
2925 Actions := Build_Assignment (Id, Exp);
2927 -- Nothing needed if no Rep Item
2934 -- Composite component with its own Init_Proc
2936 elsif not Is_Interface (Typ)
2937 and then Has_Non_Null_Base_Init_Proc (Typ)
2940 Build_Initialization_Call
2942 Make_Selected_Component (Comp_Loc,
2944 Make_Identifier (Comp_Loc, Name_uInit),
2945 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2947 In_Init_Proc => True,
2948 Enclos_Type => Rec_Type,
2949 Discr_Map => Discr_Map);
2951 Clean_Task_Names (Typ, Proc_Id);
2953 -- Simple initialization
2955 elsif Component_Needs_Simple_Initialization (Typ) then
2958 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
2960 -- Nothing needed for this case
2966 if Present (Checks) then
2967 Append_List_To (Stmts, Checks);
2970 if Present (Actions) then
2971 Append_List_To (Stmts, Actions);
2973 -- Preserve the initialization state in the current counter
2975 if Chars (Id) /= Name_uParent
2976 and then Needs_Finalization (Typ)
2978 if No (Counter_Id) then
2979 Make_Counter (Comp_Loc);
2982 Increment_Counter (Comp_Loc);
2987 Next_Non_Pragma (Decl);
2990 -- Set up tasks and protected object support. This needs to be done
2991 -- before any component with a per-object access discriminant
2992 -- constraint, or any variant part (which may contain such
2993 -- components) is initialized, because the initialization of these
2994 -- components may reference the enclosing concurrent object.
2996 -- For a task record type, add the task create call and calls to bind
2997 -- any interrupt (signal) entries.
2999 if Is_Task_Record_Type (Rec_Type) then
3001 -- In the case of the restricted run time the ATCB has already
3002 -- been preallocated.
3004 if Restricted_Profile then
3006 Make_Assignment_Statement (Loc,
3008 Make_Selected_Component (Loc,
3009 Prefix => Make_Identifier (Loc, Name_uInit),
3010 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3012 Make_Attribute_Reference (Loc,
3014 Make_Selected_Component (Loc,
3015 Prefix => Make_Identifier (Loc, Name_uInit),
3016 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3017 Attribute_Name => Name_Unchecked_Access)));
3020 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3023 Task_Type : constant Entity_Id :=
3024 Corresponding_Concurrent_Type (Rec_Type);
3025 Task_Decl : constant Node_Id := Parent (Task_Type);
3026 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3027 Decl_Loc : Source_Ptr;
3032 if Present (Task_Def) then
3033 Vis_Decl := First (Visible_Declarations (Task_Def));
3034 while Present (Vis_Decl) loop
3035 Decl_Loc := Sloc (Vis_Decl);
3037 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3038 if Get_Attribute_Id (Chars (Vis_Decl)) =
3041 Ent := Entity (Name (Vis_Decl));
3043 if Ekind (Ent) = E_Entry then
3045 Make_Procedure_Call_Statement (Decl_Loc,
3047 New_Occurrence_Of (RTE (
3048 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3049 Parameter_Associations => New_List (
3050 Make_Selected_Component (Decl_Loc,
3052 Make_Identifier (Decl_Loc, Name_uInit),
3055 (Decl_Loc, Name_uTask_Id)),
3056 Entry_Index_Expression
3057 (Decl_Loc, Ent, Empty, Task_Type),
3058 Expression (Vis_Decl))));
3069 -- For a protected type, add statements generated by
3070 -- Make_Initialize_Protection.
3072 if Is_Protected_Record_Type (Rec_Type) then
3073 Append_List_To (Stmts,
3074 Make_Initialize_Protection (Rec_Type));
3077 -- Second pass: components with per-object constraints
3080 Decl := First_Non_Pragma (Component_Items (Comp_List));
3081 while Present (Decl) loop
3082 Comp_Loc := Sloc (Decl);
3083 Id := Defining_Identifier (Decl);
3086 if Has_Access_Constraint (Id)
3087 and then No (Expression (Decl))
3089 if Has_Non_Null_Base_Init_Proc (Typ) then
3090 Append_List_To (Stmts,
3091 Build_Initialization_Call (Comp_Loc,
3092 Make_Selected_Component (Comp_Loc,
3094 Make_Identifier (Comp_Loc, Name_uInit),
3095 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3097 In_Init_Proc => True,
3098 Enclos_Type => Rec_Type,
3099 Discr_Map => Discr_Map));
3101 Clean_Task_Names (Typ, Proc_Id);
3103 -- Preserve initialization state in the current counter
3105 if Needs_Finalization (Typ) then
3106 if No (Counter_Id) then
3107 Make_Counter (Comp_Loc);
3110 Increment_Counter (Comp_Loc);
3113 elsif Component_Needs_Simple_Initialization (Typ) then
3114 Append_List_To (Stmts,
3116 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
3120 Next_Non_Pragma (Decl);
3124 -- Process the variant part
3126 if Present (Variant_Part (Comp_List)) then
3128 Variant_Alts : constant List_Id := New_List;
3129 Var_Loc : Source_Ptr;
3134 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3135 while Present (Variant) loop
3136 Var_Loc := Sloc (Variant);
3137 Append_To (Variant_Alts,
3138 Make_Case_Statement_Alternative (Var_Loc,
3140 New_Copy_List (Discrete_Choices (Variant)),
3142 Build_Init_Statements (Component_List (Variant))));
3143 Next_Non_Pragma (Variant);
3146 -- The expression of the case statement which is a reference
3147 -- to one of the discriminants is replaced by the appropriate
3148 -- formal parameter of the initialization procedure.
3151 Make_Case_Statement (Var_Loc,
3153 New_Occurrence_Of (Discriminal (
3154 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3155 Alternatives => Variant_Alts));
3159 -- If no initializations when generated for component declarations
3160 -- corresponding to this Stmts, append a null statement to Stmts to
3161 -- to make it a valid Ada tree.
3163 if Is_Empty_List (Stmts) then
3164 Append (Make_Null_Statement (Loc), Stmts);
3170 when RE_Not_Available =>
3172 end Build_Init_Statements;
3174 -------------------------
3175 -- Build_Record_Checks --
3176 -------------------------
3178 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3179 Subtype_Mark_Id : Entity_Id;
3181 procedure Constrain_Array
3183 Check_List : List_Id);
3184 -- Apply a list of index constraints to an unconstrained array type.
3185 -- The first parameter is the entity for the resulting subtype.
3186 -- Check_List is a list to which the check actions are appended.
3188 ---------------------
3189 -- Constrain_Array --
3190 ---------------------
3192 procedure Constrain_Array
3194 Check_List : List_Id)
3196 C : constant Node_Id := Constraint (SI);
3197 Number_Of_Constraints : Nat := 0;
3201 procedure Constrain_Index
3204 Check_List : List_Id);
3205 -- Process an index constraint in a constrained array declaration.
3206 -- The constraint can be either a subtype name or a range with or
3207 -- without an explicit subtype mark. Index is the corresponding
3208 -- index of the unconstrained array. S is the range expression.
3209 -- Check_List is a list to which the check actions are appended.
3211 ---------------------
3212 -- Constrain_Index --
3213 ---------------------
3215 procedure Constrain_Index
3218 Check_List : List_Id)
3220 T : constant Entity_Id := Etype (Index);
3223 if Nkind (S) = N_Range then
3224 Process_Range_Expr_In_Decl (S, T, Check_List);
3226 end Constrain_Index;
3228 -- Start of processing for Constrain_Array
3231 T := Entity (Subtype_Mark (SI));
3233 if Ekind (T) in Access_Kind then
3234 T := Designated_Type (T);
3237 S := First (Constraints (C));
3239 while Present (S) loop
3240 Number_Of_Constraints := Number_Of_Constraints + 1;
3244 -- In either case, the index constraint must provide a discrete
3245 -- range for each index of the array type and the type of each
3246 -- discrete range must be the same as that of the corresponding
3247 -- index. (RM 3.6.1)
3249 S := First (Constraints (C));
3250 Index := First_Index (T);
3253 -- Apply constraints to each index type
3255 for J in 1 .. Number_Of_Constraints loop
3256 Constrain_Index (Index, S, Check_List);
3260 end Constrain_Array;
3262 -- Start of processing for Build_Record_Checks
3265 if Nkind (S) = N_Subtype_Indication then
3266 Find_Type (Subtype_Mark (S));
3267 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3269 -- Remaining processing depends on type
3271 case Ekind (Subtype_Mark_Id) is
3274 Constrain_Array (S, Check_List);
3280 end Build_Record_Checks;
3282 -------------------------------------------
3283 -- Component_Needs_Simple_Initialization --
3284 -------------------------------------------
3286 function Component_Needs_Simple_Initialization
3287 (T : Entity_Id) return Boolean
3291 Needs_Simple_Initialization (T)
3292 and then not Is_RTE (T, RE_Tag)
3294 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3296 and then not Is_RTE (T, RE_Interface_Tag);
3297 end Component_Needs_Simple_Initialization;
3299 --------------------------------------
3300 -- Parent_Subtype_Renaming_Discrims --
3301 --------------------------------------
3303 function Parent_Subtype_Renaming_Discrims return Boolean is
3308 if Base_Type (Rec_Ent) /= Rec_Ent then
3312 if Etype (Rec_Ent) = Rec_Ent
3313 or else not Has_Discriminants (Rec_Ent)
3314 or else Is_Constrained (Rec_Ent)
3315 or else Is_Tagged_Type (Rec_Ent)
3320 -- If there are no explicit stored discriminants we have inherited
3321 -- the root type discriminants so far, so no renamings occurred.
3323 if First_Discriminant (Rec_Ent) =
3324 First_Stored_Discriminant (Rec_Ent)
3329 -- Check if we have done some trivial renaming of the parent
3330 -- discriminants, i.e. something like
3332 -- type DT (X1, X2: int) is new PT (X1, X2);
3334 De := First_Discriminant (Rec_Ent);
3335 Dp := First_Discriminant (Etype (Rec_Ent));
3336 while Present (De) loop
3337 pragma Assert (Present (Dp));
3339 if Corresponding_Discriminant (De) /= Dp then
3343 Next_Discriminant (De);
3344 Next_Discriminant (Dp);
3347 return Present (Dp);
3348 end Parent_Subtype_Renaming_Discrims;
3350 ------------------------
3351 -- Requires_Init_Proc --
3352 ------------------------
3354 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3355 Comp_Decl : Node_Id;
3360 -- Definitely do not need one if specifically suppressed
3362 if Initialization_Suppressed (Rec_Id) then
3366 -- If it is a type derived from a type with unknown discriminants,
3367 -- we cannot build an initialization procedure for it.
3369 if Has_Unknown_Discriminants (Rec_Id)
3370 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3375 -- Otherwise we need to generate an initialization procedure if
3376 -- Is_CPP_Class is False and at least one of the following applies:
3378 -- 1. Discriminants are present, since they need to be initialized
3379 -- with the appropriate discriminant constraint expressions.
3380 -- However, the discriminant of an unchecked union does not
3381 -- count, since the discriminant is not present.
3383 -- 2. The type is a tagged type, since the implicit Tag component
3384 -- needs to be initialized with a pointer to the dispatch table.
3386 -- 3. The type contains tasks
3388 -- 4. One or more components has an initial value
3390 -- 5. One or more components is for a type which itself requires
3391 -- an initialization procedure.
3393 -- 6. One or more components is a type that requires simple
3394 -- initialization (see Needs_Simple_Initialization), except
3395 -- that types Tag and Interface_Tag are excluded, since fields
3396 -- of these types are initialized by other means.
3398 -- 7. The type is the record type built for a task type (since at
3399 -- the very least, Create_Task must be called)
3401 -- 8. The type is the record type built for a protected type (since
3402 -- at least Initialize_Protection must be called)
3404 -- 9. The type is marked as a public entity. The reason we add this
3405 -- case (even if none of the above apply) is to properly handle
3406 -- Initialize_Scalars. If a package is compiled without an IS
3407 -- pragma, and the client is compiled with an IS pragma, then
3408 -- the client will think an initialization procedure is present
3409 -- and call it, when in fact no such procedure is required, but
3410 -- since the call is generated, there had better be a routine
3411 -- at the other end of the call, even if it does nothing).
3413 -- Note: the reason we exclude the CPP_Class case is because in this
3414 -- case the initialization is performed by the C++ constructors, and
3415 -- the IP is built by Set_CPP_Constructors.
3417 if Is_CPP_Class (Rec_Id) then
3420 elsif Is_Interface (Rec_Id) then
3423 elsif (Has_Discriminants (Rec_Id)
3424 and then not Is_Unchecked_Union (Rec_Id))
3425 or else Is_Tagged_Type (Rec_Id)
3426 or else Is_Concurrent_Record_Type (Rec_Id)
3427 or else Has_Task (Rec_Id)
3432 Id := First_Component (Rec_Id);
3433 while Present (Id) loop
3434 Comp_Decl := Parent (Id);
3437 if Present (Expression (Comp_Decl))
3438 or else Has_Non_Null_Base_Init_Proc (Typ)
3439 or else Component_Needs_Simple_Initialization (Typ)
3444 Next_Component (Id);
3447 -- As explained above, a record initialization procedure is needed
3448 -- for public types in case Initialize_Scalars applies to a client.
3449 -- However, such a procedure is not needed in the case where either
3450 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3451 -- applies. No_Initialize_Scalars excludes the possibility of using
3452 -- Initialize_Scalars in any partition, and No_Default_Initialization
3453 -- implies that no initialization should ever be done for objects of
3454 -- the type, so is incompatible with Initialize_Scalars.
3456 if not Restriction_Active (No_Initialize_Scalars)
3457 and then not Restriction_Active (No_Default_Initialization)
3458 and then Is_Public (Rec_Id)
3464 end Requires_Init_Proc;
3466 -- Start of processing for Build_Record_Init_Proc
3469 -- Check for value type, which means no initialization required
3471 Rec_Type := Defining_Identifier (N);
3473 if Is_Value_Type (Rec_Type) then
3477 -- This may be full declaration of a private type, in which case
3478 -- the visible entity is a record, and the private entity has been
3479 -- exchanged with it in the private part of the current package.
3480 -- The initialization procedure is built for the record type, which
3481 -- is retrievable from the private entity.
3483 if Is_Incomplete_Or_Private_Type (Rec_Type) then
3484 Rec_Type := Underlying_Type (Rec_Type);
3487 -- If there are discriminants, build the discriminant map to replace
3488 -- discriminants by their discriminals in complex bound expressions.
3489 -- These only arise for the corresponding records of synchronized types.
3491 if Is_Concurrent_Record_Type (Rec_Type)
3492 and then Has_Discriminants (Rec_Type)
3497 Disc := First_Discriminant (Rec_Type);
3498 while Present (Disc) loop
3499 Append_Elmt (Disc, Discr_Map);
3500 Append_Elmt (Discriminal (Disc), Discr_Map);
3501 Next_Discriminant (Disc);
3506 -- Derived types that have no type extension can use the initialization
3507 -- procedure of their parent and do not need a procedure of their own.
3508 -- This is only correct if there are no representation clauses for the
3509 -- type or its parent, and if the parent has in fact been frozen so
3510 -- that its initialization procedure exists.
3512 if Is_Derived_Type (Rec_Type)
3513 and then not Is_Tagged_Type (Rec_Type)
3514 and then not Is_Unchecked_Union (Rec_Type)
3515 and then not Has_New_Non_Standard_Rep (Rec_Type)
3516 and then not Parent_Subtype_Renaming_Discrims
3517 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
3519 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3521 -- Otherwise if we need an initialization procedure, then build one,
3522 -- mark it as public and inlinable and as having a completion.
3524 elsif Requires_Init_Proc (Rec_Type)
3525 or else Is_Unchecked_Union (Rec_Type)
3528 Make_Defining_Identifier (Loc,
3529 Chars => Make_Init_Proc_Name (Rec_Type));
3531 -- If No_Default_Initialization restriction is active, then we don't
3532 -- want to build an init_proc, but we need to mark that an init_proc
3533 -- would be needed if this restriction was not active (so that we can
3534 -- detect attempts to call it), so set a dummy init_proc in place.
3536 if Restriction_Active (No_Default_Initialization) then
3537 Set_Init_Proc (Rec_Type, Proc_Id);
3541 Build_Offset_To_Top_Functions;
3542 Build_CPP_Init_Procedure;
3543 Build_Init_Procedure;
3544 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
3546 -- The initialization of protected records is not worth inlining.
3547 -- In addition, when compiled for another unit for inlining purposes,
3548 -- it may make reference to entities that have not been elaborated
3549 -- yet. The initialization of controlled records contains a nested
3550 -- clean-up procedure that makes it impractical to inline as well,
3551 -- and leads to undefined symbols if inlined in a different unit.
3552 -- Similar considerations apply to task types.
3554 if not Is_Concurrent_Type (Rec_Type)
3555 and then not Has_Task (Rec_Type)
3556 and then not Needs_Finalization (Rec_Type)
3558 Set_Is_Inlined (Proc_Id);
3561 Set_Is_Internal (Proc_Id);
3562 Set_Has_Completion (Proc_Id);
3564 if not Debug_Generated_Code then
3565 Set_Debug_Info_Off (Proc_Id);
3569 Agg : constant Node_Id :=
3570 Build_Equivalent_Record_Aggregate (Rec_Type);
3572 procedure Collect_Itypes (Comp : Node_Id);
3573 -- Generate references to itypes in the aggregate, because
3574 -- the first use of the aggregate may be in a nested scope.
3576 --------------------
3577 -- Collect_Itypes --
3578 --------------------
3580 procedure Collect_Itypes (Comp : Node_Id) is
3583 Typ : constant Entity_Id := Etype (Comp);
3586 if Is_Array_Type (Typ)
3587 and then Is_Itype (Typ)
3589 Ref := Make_Itype_Reference (Loc);
3590 Set_Itype (Ref, Typ);
3591 Append_Freeze_Action (Rec_Type, Ref);
3593 Ref := Make_Itype_Reference (Loc);
3594 Set_Itype (Ref, Etype (First_Index (Typ)));
3595 Append_Freeze_Action (Rec_Type, Ref);
3597 Sub_Aggr := First (Expressions (Comp));
3599 -- Recurse on nested arrays
3601 while Present (Sub_Aggr) loop
3602 Collect_Itypes (Sub_Aggr);
3609 -- If there is a static initialization aggregate for the type,
3610 -- generate itype references for the types of its (sub)components,
3611 -- to prevent out-of-scope errors in the resulting tree.
3612 -- The aggregate may have been rewritten as a Raise node, in which
3613 -- case there are no relevant itypes.
3616 and then Nkind (Agg) = N_Aggregate
3618 Set_Static_Initialization (Proc_Id, Agg);
3623 Comp := First (Component_Associations (Agg));
3624 while Present (Comp) loop
3625 Collect_Itypes (Expression (Comp));
3632 end Build_Record_Init_Proc;
3634 --------------------------------
3635 -- Build_Record_Invariant_Proc --
3636 --------------------------------
3638 function Build_Record_Invariant_Proc
3639 (R_Type : Entity_Id;
3640 Nod : Node_Id) return Node_Id
3642 Loc : constant Source_Ptr := Sloc (Nod);
3644 Object_Name : constant Name_Id := New_Internal_Name ('I');
3645 -- Name for argument of invariant procedure
3647 Object_Entity : constant Node_Id :=
3648 Make_Defining_Identifier (Loc, Object_Name);
3649 -- The procedure declaration entity for the argument
3651 Invariant_Found : Boolean;
3652 -- Set if any component needs an invariant check.
3654 Proc_Id : Entity_Id;
3655 Proc_Body : Node_Id;
3659 function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id;
3660 -- Recursive procedure that generates a list of checks for components
3661 -- that need it, and recurses through variant parts when present.
3663 function Build_Component_Invariant_Call (Comp : Entity_Id)
3665 -- Build call to invariant procedure for a record component.
3667 ------------------------------------
3668 -- Build_Component_Invariant_Call --
3669 ------------------------------------
3671 function Build_Component_Invariant_Call (Comp : Entity_Id)
3679 Invariant_Found := True;
3680 Typ := Etype (Comp);
3683 Make_Selected_Component (Loc,
3684 Prefix => New_Occurrence_Of (Object_Entity, Loc),
3685 Selector_Name => New_Occurrence_Of (Comp, Loc));
3687 if Is_Access_Type (Typ) then
3688 Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
3689 Typ := Designated_Type (Typ);
3693 Make_Procedure_Call_Statement (Loc,
3695 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
3696 Parameter_Associations => New_List (Sel_Comp));
3698 if Is_Access_Type (Etype (Comp)) then
3700 Make_If_Statement (Loc,
3703 Left_Opnd => Make_Null (Loc),
3705 Make_Selected_Component (Loc,
3706 Prefix => New_Occurrence_Of (Object_Entity, Loc),
3707 Selector_Name => New_Occurrence_Of (Comp, Loc))),
3708 Then_Statements => New_List (Call));
3712 end Build_Component_Invariant_Call;
3714 ----------------------------
3715 -- Build_Invariant_Checks --
3716 ----------------------------
3718 function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is
3725 Decl := First_Non_Pragma (Component_Items (Comp_List));
3726 while Present (Decl) loop
3727 if Nkind (Decl) = N_Component_Declaration then
3728 Id := Defining_Identifier (Decl);
3730 if Has_Invariants (Etype (Id))
3731 and then In_Open_Scopes (Scope (R_Type))
3733 Append_To (Stmts, Build_Component_Invariant_Call (Id));
3735 elsif Is_Access_Type (Etype (Id))
3736 and then not Is_Access_Constant (Etype (Id))
3737 and then Has_Invariants (Designated_Type (Etype (Id)))
3738 and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
3740 Append_To (Stmts, Build_Component_Invariant_Call (Id));
3747 if Present (Variant_Part (Comp_List)) then
3749 Variant_Alts : constant List_Id := New_List;
3750 Var_Loc : Source_Ptr;
3752 Variant_Stmts : List_Id;
3756 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3757 while Present (Variant) loop
3759 Build_Invariant_Checks (Component_List (Variant));
3760 Var_Loc := Sloc (Variant);
3761 Append_To (Variant_Alts,
3762 Make_Case_Statement_Alternative (Var_Loc,
3764 New_Copy_List (Discrete_Choices (Variant)),
3765 Statements => Variant_Stmts));
3767 Next_Non_Pragma (Variant);
3770 -- The expression in the case statement is the reference to
3771 -- the discriminant of the target object.
3774 Make_Case_Statement (Var_Loc,
3776 Make_Selected_Component (Var_Loc,
3777 Prefix => New_Occurrence_Of (Object_Entity, Var_Loc),
3778 Selector_Name => New_Occurrence_Of
3780 (Name (Variant_Part (Comp_List))), Var_Loc)),
3781 Alternatives => Variant_Alts));
3786 end Build_Invariant_Checks;
3788 -- Start of processing for Build_Record_Invariant_Proc
3791 Invariant_Found := False;
3792 Type_Def := Type_Definition (Parent (R_Type));
3794 if Nkind (Type_Def) = N_Record_Definition
3795 and then not Null_Present (Type_Def)
3797 Stmts := Build_Invariant_Checks (Component_List (Type_Def));
3802 if not Invariant_Found then
3807 Make_Defining_Identifier (Loc,
3808 Chars => New_External_Name (Chars (R_Type), "Invariant"));
3811 Make_Subprogram_Body (Loc,
3813 Make_Procedure_Specification (Loc,
3814 Defining_Unit_Name => Proc_Id,
3815 Parameter_Specifications => New_List (
3816 Make_Parameter_Specification (Loc,
3817 Defining_Identifier => Object_Entity,
3818 Parameter_Type => New_Occurrence_Of (R_Type, Loc)))),
3820 Declarations => Empty_List,
3821 Handled_Statement_Sequence =>
3822 Make_Handled_Sequence_Of_Statements (Loc,
3823 Statements => Stmts));
3825 Set_Ekind (Proc_Id, E_Procedure);
3826 Set_Is_Public (Proc_Id, Is_Public (R_Type));
3827 Set_Is_Internal (Proc_Id);
3828 Set_Has_Completion (Proc_Id);
3831 -- Insert_After (Nod, Proc_Body);
3832 -- Analyze (Proc_Body);
3833 end Build_Record_Invariant_Proc;
3835 ----------------------------
3836 -- Build_Slice_Assignment --
3837 ----------------------------
3839 -- Generates the following subprogram:
3842 -- (Source, Target : Array_Type,
3843 -- Left_Lo, Left_Hi : Index;
3844 -- Right_Lo, Right_Hi : Index;
3852 -- if Left_Hi < Left_Lo then
3865 -- Target (Li1) := Source (Ri1);
3868 -- exit when Li1 = Left_Lo;
3869 -- Li1 := Index'pred (Li1);
3870 -- Ri1 := Index'pred (Ri1);
3872 -- exit when Li1 = Left_Hi;
3873 -- Li1 := Index'succ (Li1);
3874 -- Ri1 := Index'succ (Ri1);
3879 procedure Build_Slice_Assignment (Typ : Entity_Id) is
3880 Loc : constant Source_Ptr := Sloc (Typ);
3881 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
3883 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
3884 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
3885 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
3886 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
3887 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
3888 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
3889 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
3890 -- Formal parameters of procedure
3892 Proc_Name : constant Entity_Id :=
3893 Make_Defining_Identifier (Loc,
3894 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
3896 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
3897 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
3898 -- Subscripts for left and right sides
3905 -- Build declarations for indexes
3910 Make_Object_Declaration (Loc,
3911 Defining_Identifier => Lnn,
3912 Object_Definition =>
3913 New_Occurrence_Of (Index, Loc)));
3916 Make_Object_Declaration (Loc,
3917 Defining_Identifier => Rnn,
3918 Object_Definition =>
3919 New_Occurrence_Of (Index, Loc)));
3923 -- Build test for empty slice case
3926 Make_If_Statement (Loc,
3929 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
3930 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
3931 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
3933 -- Build initializations for indexes
3936 F_Init : constant List_Id := New_List;
3937 B_Init : constant List_Id := New_List;
3941 Make_Assignment_Statement (Loc,
3942 Name => New_Occurrence_Of (Lnn, Loc),
3943 Expression => New_Occurrence_Of (Left_Lo, Loc)));
3946 Make_Assignment_Statement (Loc,
3947 Name => New_Occurrence_Of (Rnn, Loc),
3948 Expression => New_Occurrence_Of (Right_Lo, Loc)));
3951 Make_Assignment_Statement (Loc,
3952 Name => New_Occurrence_Of (Lnn, Loc),
3953 Expression => New_Occurrence_Of (Left_Hi, Loc)));
3956 Make_Assignment_Statement (Loc,
3957 Name => New_Occurrence_Of (Rnn, Loc),
3958 Expression => New_Occurrence_Of (Right_Hi, Loc)));
3961 Make_If_Statement (Loc,
3962 Condition => New_Occurrence_Of (Rev, Loc),
3963 Then_Statements => B_Init,
3964 Else_Statements => F_Init));
3967 -- Now construct the assignment statement
3970 Make_Loop_Statement (Loc,
3971 Statements => New_List (
3972 Make_Assignment_Statement (Loc,
3974 Make_Indexed_Component (Loc,
3975 Prefix => New_Occurrence_Of (Larray, Loc),
3976 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
3978 Make_Indexed_Component (Loc,
3979 Prefix => New_Occurrence_Of (Rarray, Loc),
3980 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
3981 End_Label => Empty);
3983 -- Build the exit condition and increment/decrement statements
3986 F_Ass : constant List_Id := New_List;
3987 B_Ass : constant List_Id := New_List;
3991 Make_Exit_Statement (Loc,
3994 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3995 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
3998 Make_Assignment_Statement (Loc,
3999 Name => New_Occurrence_Of (Lnn, Loc),
4001 Make_Attribute_Reference (Loc,
4003 New_Occurrence_Of (Index, Loc),
4004 Attribute_Name => Name_Succ,
4005 Expressions => New_List (
4006 New_Occurrence_Of (Lnn, Loc)))));
4009 Make_Assignment_Statement (Loc,
4010 Name => New_Occurrence_Of (Rnn, Loc),
4012 Make_Attribute_Reference (Loc,
4014 New_Occurrence_Of (Index, Loc),
4015 Attribute_Name => Name_Succ,
4016 Expressions => New_List (
4017 New_Occurrence_Of (Rnn, Loc)))));
4020 Make_Exit_Statement (Loc,
4023 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4024 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
4027 Make_Assignment_Statement (Loc,
4028 Name => New_Occurrence_Of (Lnn, Loc),
4030 Make_Attribute_Reference (Loc,
4032 New_Occurrence_Of (Index, Loc),
4033 Attribute_Name => Name_Pred,
4034 Expressions => New_List (
4035 New_Occurrence_Of (Lnn, Loc)))));
4038 Make_Assignment_Statement (Loc,
4039 Name => New_Occurrence_Of (Rnn, Loc),
4041 Make_Attribute_Reference (Loc,
4043 New_Occurrence_Of (Index, Loc),
4044 Attribute_Name => Name_Pred,
4045 Expressions => New_List (
4046 New_Occurrence_Of (Rnn, Loc)))));
4048 Append_To (Statements (Loops),
4049 Make_If_Statement (Loc,
4050 Condition => New_Occurrence_Of (Rev, Loc),
4051 Then_Statements => B_Ass,
4052 Else_Statements => F_Ass));
4055 Append_To (Stats, Loops);
4059 Formals : List_Id := New_List;
4062 Formals := New_List (
4063 Make_Parameter_Specification (Loc,
4064 Defining_Identifier => Larray,
4065 Out_Present => True,
4067 New_Occurrence_Of (Base_Type (Typ), Loc)),
4069 Make_Parameter_Specification (Loc,
4070 Defining_Identifier => Rarray,
4072 New_Occurrence_Of (Base_Type (Typ), Loc)),
4074 Make_Parameter_Specification (Loc,
4075 Defining_Identifier => Left_Lo,
4077 New_Occurrence_Of (Index, Loc)),
4079 Make_Parameter_Specification (Loc,
4080 Defining_Identifier => Left_Hi,
4082 New_Occurrence_Of (Index, Loc)),
4084 Make_Parameter_Specification (Loc,
4085 Defining_Identifier => Right_Lo,
4087 New_Occurrence_Of (Index, Loc)),
4089 Make_Parameter_Specification (Loc,
4090 Defining_Identifier => Right_Hi,
4092 New_Occurrence_Of (Index, Loc)));
4095 Make_Parameter_Specification (Loc,
4096 Defining_Identifier => Rev,
4098 New_Occurrence_Of (Standard_Boolean, Loc)));
4101 Make_Procedure_Specification (Loc,
4102 Defining_Unit_Name => Proc_Name,
4103 Parameter_Specifications => Formals);
4106 Make_Subprogram_Body (Loc,
4107 Specification => Spec,
4108 Declarations => Decls,
4109 Handled_Statement_Sequence =>
4110 Make_Handled_Sequence_Of_Statements (Loc,
4111 Statements => Stats)));
4114 Set_TSS (Typ, Proc_Name);
4115 Set_Is_Pure (Proc_Name);
4116 end Build_Slice_Assignment;
4118 -----------------------------
4119 -- Build_Untagged_Equality --
4120 -----------------------------
4122 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4130 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4131 -- Check whether the type T has a user-defined primitive equality. If so
4132 -- return it, else return Empty. If true for a component of Typ, we have
4133 -- to build the primitive equality for it.
4135 ---------------------
4136 -- User_Defined_Eq --
4137 ---------------------
4139 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4144 Op := TSS (T, TSS_Composite_Equality);
4146 if Present (Op) then
4150 Prim := First_Elmt (Collect_Primitive_Operations (T));
4151 while Present (Prim) loop
4154 if Chars (Op) = Name_Op_Eq
4155 and then Etype (Op) = Standard_Boolean
4156 and then Etype (First_Formal (Op)) = T
4157 and then Etype (Next_Formal (First_Formal (Op))) = T
4166 end User_Defined_Eq;
4168 -- Start of processing for Build_Untagged_Equality
4171 -- If a record component has a primitive equality operation, we must
4172 -- build the corresponding one for the current type.
4175 Comp := First_Component (Typ);
4176 while Present (Comp) loop
4177 if Is_Record_Type (Etype (Comp))
4178 and then Present (User_Defined_Eq (Etype (Comp)))
4183 Next_Component (Comp);
4186 -- If there is a user-defined equality for the type, we do not create
4187 -- the implicit one.
4189 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
4191 while Present (Prim) loop
4192 if Chars (Node (Prim)) = Name_Op_Eq
4193 and then Comes_From_Source (Node (Prim))
4195 -- Don't we also need to check formal types and return type as in
4196 -- User_Defined_Eq above???
4199 Eq_Op := Node (Prim);
4207 -- If the type is derived, inherit the operation, if present, from the
4208 -- parent type. It may have been declared after the type derivation. If
4209 -- the parent type itself is derived, it may have inherited an operation
4210 -- that has itself been overridden, so update its alias and related
4211 -- flags. Ditto for inequality.
4213 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4214 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
4215 while Present (Prim) loop
4216 if Chars (Node (Prim)) = Name_Op_Eq then
4217 Copy_TSS (Node (Prim), Typ);
4221 Op : constant Entity_Id := User_Defined_Eq (Typ);
4222 Eq_Op : constant Entity_Id := Node (Prim);
4223 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4226 if Present (Op) then
4227 Set_Alias (Op, Eq_Op);
4228 Set_Is_Abstract_Subprogram
4229 (Op, Is_Abstract_Subprogram (Eq_Op));
4231 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4232 Set_Is_Abstract_Subprogram
4233 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4245 -- If not inherited and not user-defined, build body as for a type with
4246 -- tagged components.
4250 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4251 Op := Defining_Entity (Decl);
4255 if Is_Library_Level_Entity (Typ) then
4259 end Build_Untagged_Equality;
4261 ------------------------------------
4262 -- Build_Variant_Record_Equality --
4263 ------------------------------------
4267 -- function _Equality (X, Y : T) return Boolean is
4269 -- -- Compare discriminants
4271 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
4275 -- -- Compare components
4277 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
4281 -- -- Compare variant part
4285 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
4290 -- if False or else X.Cn /= Y.Cn then
4298 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
4299 Loc : constant Source_Ptr := Sloc (Typ);
4301 F : constant Entity_Id :=
4302 Make_Defining_Identifier (Loc,
4303 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
4305 X : constant Entity_Id :=
4306 Make_Defining_Identifier (Loc,
4309 Y : constant Entity_Id :=
4310 Make_Defining_Identifier (Loc,
4313 Def : constant Node_Id := Parent (Typ);
4314 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4315 Stmts : constant List_Id := New_List;
4316 Pspecs : constant List_Id := New_List;
4319 -- Derived Unchecked_Union types no longer inherit the equality function
4322 if Is_Derived_Type (Typ)
4323 and then not Is_Unchecked_Union (Typ)
4324 and then not Has_New_Non_Standard_Rep (Typ)
4327 Parent_Eq : constant Entity_Id :=
4328 TSS (Root_Type (Typ), TSS_Composite_Equality);
4331 if Present (Parent_Eq) then
4332 Copy_TSS (Parent_Eq, Typ);
4339 Make_Subprogram_Body (Loc,
4341 Make_Function_Specification (Loc,
4342 Defining_Unit_Name => F,
4343 Parameter_Specifications => Pspecs,
4344 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
4345 Declarations => New_List,
4346 Handled_Statement_Sequence =>
4347 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
4350 Make_Parameter_Specification (Loc,
4351 Defining_Identifier => X,
4352 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4355 Make_Parameter_Specification (Loc,
4356 Defining_Identifier => Y,
4357 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4359 -- Unchecked_Unions require additional machinery to support equality.
4360 -- Two extra parameters (A and B) are added to the equality function
4361 -- parameter list for each discriminant of the type, in order to
4362 -- capture the inferred values of the discriminants in equality calls.
4363 -- The names of the parameters match the names of the corresponding
4364 -- discriminant, with an added suffix.
4366 if Is_Unchecked_Union (Typ) then
4369 Discr_Type : Entity_Id;
4371 New_Discrs : Elist_Id;
4374 New_Discrs := New_Elmt_List;
4376 Discr := First_Discriminant (Typ);
4377 while Present (Discr) loop
4378 Discr_Type := Etype (Discr);
4379 A := Make_Defining_Identifier (Loc,
4380 Chars => New_External_Name (Chars (Discr), 'A'));
4382 B := Make_Defining_Identifier (Loc,
4383 Chars => New_External_Name (Chars (Discr), 'B'));
4385 -- Add new parameters to the parameter list
4388 Make_Parameter_Specification (Loc,
4389 Defining_Identifier => A,
4391 New_Occurrence_Of (Discr_Type, Loc)));
4394 Make_Parameter_Specification (Loc,
4395 Defining_Identifier => B,
4397 New_Occurrence_Of (Discr_Type, Loc)));
4399 Append_Elmt (A, New_Discrs);
4401 -- Generate the following code to compare each of the inferred
4409 Make_If_Statement (Loc,
4412 Left_Opnd => New_Occurrence_Of (A, Loc),
4413 Right_Opnd => New_Occurrence_Of (B, Loc)),
4414 Then_Statements => New_List (
4415 Make_Simple_Return_Statement (Loc,
4417 New_Occurrence_Of (Standard_False, Loc)))));
4418 Next_Discriminant (Discr);
4421 -- Generate component-by-component comparison. Note that we must
4422 -- propagate the inferred discriminants formals to act as
4423 -- the case statement switch. Their value is added when an
4424 -- equality call on unchecked unions is expanded.
4426 Append_List_To (Stmts,
4427 Make_Eq_Case (Typ, Comps, New_Discrs));
4430 -- Normal case (not unchecked union)
4435 Discriminant_Specifications (Def)));
4437 Append_List_To (Stmts,
4438 Make_Eq_Case (Typ, Comps));
4442 Make_Simple_Return_Statement (Loc,
4443 Expression => New_Occurrence_Of (Standard_True, Loc)));
4448 if not Debug_Generated_Code then
4449 Set_Debug_Info_Off (F);
4451 end Build_Variant_Record_Equality;
4453 -----------------------------
4454 -- Check_Stream_Attributes --
4455 -----------------------------
4457 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4459 Par_Read : constant Boolean :=
4460 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4461 and then not Has_Specified_Stream_Read (Typ);
4462 Par_Write : constant Boolean :=
4463 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4464 and then not Has_Specified_Stream_Write (Typ);
4466 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4467 -- Check that Comp has a user-specified Nam stream attribute
4473 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4475 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4476 Error_Msg_Name_1 := Nam;
4478 ("|component& in limited extension must have% attribute", Comp);
4482 -- Start of processing for Check_Stream_Attributes
4485 if Par_Read or else Par_Write then
4486 Comp := First_Component (Typ);
4487 while Present (Comp) loop
4488 if Comes_From_Source (Comp)
4489 and then Original_Record_Component (Comp) = Comp
4490 and then Is_Limited_Type (Etype (Comp))
4493 Check_Attr (Name_Read, TSS_Stream_Read);
4497 Check_Attr (Name_Write, TSS_Stream_Write);
4501 Next_Component (Comp);
4504 end Check_Stream_Attributes;
4506 -----------------------------
4507 -- Expand_Record_Extension --
4508 -----------------------------
4510 -- Add a field _parent at the beginning of the record extension. This is
4511 -- used to implement inheritance. Here are some examples of expansion:
4513 -- 1. no discriminants
4514 -- type T2 is new T1 with null record;
4516 -- type T2 is new T1 with record
4520 -- 2. renamed discriminants
4521 -- type T2 (B, C : Int) is new T1 (A => B) with record
4522 -- _Parent : T1 (A => B);
4526 -- 3. inherited discriminants
4527 -- type T2 is new T1 with record -- discriminant A inherited
4528 -- _Parent : T1 (A);
4532 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
4533 Indic : constant Node_Id := Subtype_Indication (Def);
4534 Loc : constant Source_Ptr := Sloc (Def);
4535 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
4536 Par_Subtype : Entity_Id;
4537 Comp_List : Node_Id;
4538 Comp_Decl : Node_Id;
4541 List_Constr : constant List_Id := New_List;
4544 -- Expand_Record_Extension is called directly from the semantics, so
4545 -- we must check to see whether expansion is active before proceeding
4547 if not Expander_Active then
4551 -- This may be a derivation of an untagged private type whose full
4552 -- view is tagged, in which case the Derived_Type_Definition has no
4553 -- extension part. Build an empty one now.
4555 if No (Rec_Ext_Part) then
4557 Make_Record_Definition (Loc,
4559 Component_List => Empty,
4560 Null_Present => True);
4562 Set_Record_Extension_Part (Def, Rec_Ext_Part);
4563 Mark_Rewrite_Insertion (Rec_Ext_Part);
4566 Comp_List := Component_List (Rec_Ext_Part);
4568 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
4570 -- If the derived type inherits its discriminants the type of the
4571 -- _parent field must be constrained by the inherited discriminants
4573 if Has_Discriminants (T)
4574 and then Nkind (Indic) /= N_Subtype_Indication
4575 and then not Is_Constrained (Entity (Indic))
4577 D := First_Discriminant (T);
4578 while Present (D) loop
4579 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
4580 Next_Discriminant (D);
4585 Make_Subtype_Indication (Loc,
4586 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
4588 Make_Index_Or_Discriminant_Constraint (Loc,
4589 Constraints => List_Constr)),
4592 -- Otherwise the original subtype_indication is just what is needed
4595 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
4598 Set_Parent_Subtype (T, Par_Subtype);
4601 Make_Component_Declaration (Loc,
4602 Defining_Identifier => Parent_N,
4603 Component_Definition =>
4604 Make_Component_Definition (Loc,
4605 Aliased_Present => False,
4606 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
4608 if Null_Present (Rec_Ext_Part) then
4609 Set_Component_List (Rec_Ext_Part,
4610 Make_Component_List (Loc,
4611 Component_Items => New_List (Comp_Decl),
4612 Variant_Part => Empty,
4613 Null_Present => False));
4614 Set_Null_Present (Rec_Ext_Part, False);
4616 elsif Null_Present (Comp_List)
4617 or else Is_Empty_List (Component_Items (Comp_List))
4619 Set_Component_Items (Comp_List, New_List (Comp_Decl));
4620 Set_Null_Present (Comp_List, False);
4623 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
4626 Analyze (Comp_Decl);
4627 end Expand_Record_Extension;
4629 ------------------------------------
4630 -- Expand_N_Full_Type_Declaration --
4631 ------------------------------------
4633 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
4635 procedure Build_Master (Ptr_Typ : Entity_Id);
4636 -- Create the master associated with Ptr_Typ
4642 procedure Build_Master (Ptr_Typ : Entity_Id) is
4643 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
4646 -- If the designated type is an incomplete view coming from a
4647 -- limited-with'ed package, we need to use the nonlimited view in
4648 -- case it has tasks.
4650 if Ekind (Desig_Typ) in Incomplete_Kind
4651 and then Present (Non_Limited_View (Desig_Typ))
4653 Desig_Typ := Non_Limited_View (Desig_Typ);
4656 -- Anonymous access types are created for the components of the
4657 -- record parameter for an entry declaration. No master is created
4660 if Comes_From_Source (N)
4661 and then Has_Task (Desig_Typ)
4663 Build_Master_Entity (Ptr_Typ);
4664 Build_Master_Renaming (Ptr_Typ);
4666 -- Create a class-wide master because a Master_Id must be generated
4667 -- for access-to-limited-class-wide types whose root may be extended
4668 -- with task components.
4670 -- Note: This code covers access-to-limited-interfaces because they
4671 -- can be used to reference tasks implementing them.
4673 elsif Is_Limited_Class_Wide_Type (Desig_Typ)
4674 and then Tasking_Allowed
4676 -- Do not create a class-wide master for types whose convention is
4677 -- Java since these types cannot embed Ada tasks anyway. Note that
4678 -- the following test cannot catch the following case:
4680 -- package java.lang.Object is
4681 -- type Typ is tagged limited private;
4682 -- type Ref is access all Typ'Class;
4684 -- type Typ is tagged limited ...;
4685 -- pragma Convention (Typ, Java)
4688 -- Because the convention appears after we have done the
4689 -- processing for type Ref.
4691 and then Convention (Desig_Typ) /= Convention_Java
4692 and then Convention (Desig_Typ) /= Convention_CIL
4694 Build_Class_Wide_Master (Ptr_Typ);
4698 -- Local declarations
4700 Def_Id : constant Entity_Id := Defining_Identifier (N);
4701 B_Id : constant Entity_Id := Base_Type (Def_Id);
4705 -- Start of processing for Expand_N_Full_Type_Declaration
4708 if Is_Access_Type (Def_Id) then
4709 Build_Master (Def_Id);
4711 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
4712 Expand_Access_Protected_Subprogram_Type (N);
4715 -- Array of anonymous access-to-task pointers
4717 elsif Ada_Version >= Ada_2005
4718 and then Is_Array_Type (Def_Id)
4719 and then Is_Access_Type (Component_Type (Def_Id))
4720 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
4722 Build_Master (Component_Type (Def_Id));
4724 elsif Has_Task (Def_Id) then
4725 Expand_Previous_Access_Type (Def_Id);
4727 -- Check the components of a record type or array of records for
4728 -- anonymous access-to-task pointers.
4730 elsif Ada_Version >= Ada_2005
4731 and then (Is_Record_Type (Def_Id)
4733 (Is_Array_Type (Def_Id)
4734 and then Is_Record_Type (Component_Type (Def_Id))))
4743 if Is_Array_Type (Def_Id) then
4744 Comp := First_Entity (Component_Type (Def_Id));
4746 Comp := First_Entity (Def_Id);
4749 -- Examine all components looking for anonymous access-to-task
4753 while Present (Comp) loop
4754 Typ := Etype (Comp);
4756 if Ekind (Typ) = E_Anonymous_Access_Type
4757 and then Has_Task (Available_View (Designated_Type (Typ)))
4758 and then No (Master_Id (Typ))
4760 -- Ensure that the record or array type have a _master
4763 Build_Master_Entity (Def_Id);
4764 Build_Master_Renaming (Typ);
4765 M_Id := Master_Id (Typ);
4769 -- Reuse the same master to service any additional types
4772 Set_Master_Id (Typ, M_Id);
4781 Par_Id := Etype (B_Id);
4783 -- The parent type is private then we need to inherit any TSS operations
4784 -- from the full view.
4786 if Ekind (Par_Id) in Private_Kind
4787 and then Present (Full_View (Par_Id))
4789 Par_Id := Base_Type (Full_View (Par_Id));
4792 if Nkind (Type_Definition (Original_Node (N))) =
4793 N_Derived_Type_Definition
4794 and then not Is_Tagged_Type (Def_Id)
4795 and then Present (Freeze_Node (Par_Id))
4796 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
4798 Ensure_Freeze_Node (B_Id);
4799 FN := Freeze_Node (B_Id);
4801 if No (TSS_Elist (FN)) then
4802 Set_TSS_Elist (FN, New_Elmt_List);
4806 T_E : constant Elist_Id := TSS_Elist (FN);
4810 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
4811 while Present (Elmt) loop
4812 if Chars (Node (Elmt)) /= Name_uInit then
4813 Append_Elmt (Node (Elmt), T_E);
4819 -- If the derived type itself is private with a full view, then
4820 -- associate the full view with the inherited TSS_Elist as well.
4822 if Ekind (B_Id) in Private_Kind
4823 and then Present (Full_View (B_Id))
4825 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
4827 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
4831 end Expand_N_Full_Type_Declaration;
4833 ---------------------------------
4834 -- Expand_N_Object_Declaration --
4835 ---------------------------------
4837 procedure Expand_N_Object_Declaration (N : Node_Id) is
4838 Def_Id : constant Entity_Id := Defining_Identifier (N);
4839 Expr : constant Node_Id := Expression (N);
4840 Loc : constant Source_Ptr := Sloc (N);
4841 Typ : constant Entity_Id := Etype (Def_Id);
4842 Base_Typ : constant Entity_Id := Base_Type (Typ);
4847 Init_After : Node_Id := N;
4848 -- Node after which the init proc call is to be inserted. This is
4849 -- normally N, except for the case of a shared passive variable, in
4850 -- which case the init proc call must be inserted only after the bodies
4851 -- of the shared variable procedures have been seen.
4853 function Build_Equivalent_Aggregate return Boolean;
4854 -- If the object has a constrained discriminated type and no initial
4855 -- value, it may be possible to build an equivalent aggregate instead,
4856 -- and prevent an actual call to the initialization procedure.
4858 function Rewrite_As_Renaming return Boolean;
4859 -- Indicate whether to rewrite a declaration with initialization into an
4860 -- object renaming declaration (see below).
4862 --------------------------------
4863 -- Build_Equivalent_Aggregate --
4864 --------------------------------
4866 function Build_Equivalent_Aggregate return Boolean is
4870 Full_Type : Entity_Id;
4875 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
4876 Full_Type := Full_View (Typ);
4879 -- Only perform this transformation if Elaboration_Code is forbidden
4880 -- or undesirable, and if this is a global entity of a constrained
4883 -- If Initialize_Scalars might be active this transformation cannot
4884 -- be performed either, because it will lead to different semantics
4885 -- or because elaboration code will in fact be created.
4887 if Ekind (Full_Type) /= E_Record_Subtype
4888 or else not Has_Discriminants (Full_Type)
4889 or else not Is_Constrained (Full_Type)
4890 or else Is_Controlled (Full_Type)
4891 or else Is_Limited_Type (Full_Type)
4892 or else not Restriction_Active (No_Initialize_Scalars)
4897 if Ekind (Current_Scope) = E_Package
4899 (Restriction_Active (No_Elaboration_Code)
4900 or else Is_Preelaborated (Current_Scope))
4903 -- Building a static aggregate is possible if the discriminants
4904 -- have static values and the other components have static
4905 -- defaults or none.
4907 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
4908 while Present (Discr) loop
4909 if not Is_OK_Static_Expression (Node (Discr)) then
4916 -- Check that initialized components are OK, and that non-
4917 -- initialized components do not require a call to their own
4918 -- initialization procedure.
4920 Comp := First_Component (Full_Type);
4921 while Present (Comp) loop
4922 if Ekind (Comp) = E_Component
4923 and then Present (Expression (Parent (Comp)))
4925 not Is_OK_Static_Expression (Expression (Parent (Comp)))
4929 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
4934 Next_Component (Comp);
4937 -- Everything is static, assemble the aggregate, discriminant
4941 Make_Aggregate (Loc,
4942 Expressions => New_List,
4943 Component_Associations => New_List);
4945 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
4946 while Present (Discr) loop
4947 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
4951 -- Now collect values of initialized components
4953 Comp := First_Component (Full_Type);
4954 while Present (Comp) loop
4955 if Ekind (Comp) = E_Component
4956 and then Present (Expression (Parent (Comp)))
4958 Append_To (Component_Associations (Aggr),
4959 Make_Component_Association (Loc,
4960 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
4961 Expression => New_Copy_Tree
4962 (Expression (Parent (Comp)))));
4965 Next_Component (Comp);
4968 -- Finally, box-initialize remaining components
4970 Append_To (Component_Associations (Aggr),
4971 Make_Component_Association (Loc,
4972 Choices => New_List (Make_Others_Choice (Loc)),
4973 Expression => Empty));
4974 Set_Box_Present (Last (Component_Associations (Aggr)));
4975 Set_Expression (N, Aggr);
4977 if Typ /= Full_Type then
4978 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
4979 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
4980 Analyze_And_Resolve (Aggr, Typ);
4982 Analyze_And_Resolve (Aggr, Full_Type);
4990 end Build_Equivalent_Aggregate;
4992 -------------------------
4993 -- Rewrite_As_Renaming --
4994 -------------------------
4996 function Rewrite_As_Renaming return Boolean is
4998 return not Aliased_Present (N)
4999 and then Is_Entity_Name (Expr_Q)
5000 and then Ekind (Entity (Expr_Q)) = E_Variable
5001 and then OK_To_Rename (Entity (Expr_Q))
5002 and then Is_Entity_Name (Object_Definition (N));
5003 end Rewrite_As_Renaming;
5005 -- Start of processing for Expand_N_Object_Declaration
5008 -- Don't do anything for deferred constants. All proper actions will be
5009 -- expanded during the full declaration.
5011 if No (Expr) and Constant_Present (N) then
5015 -- First we do special processing for objects of a tagged type where
5016 -- this is the point at which the type is frozen. The creation of the
5017 -- dispatch table and the initialization procedure have to be deferred
5018 -- to this point, since we reference previously declared primitive
5021 -- Force construction of dispatch tables of library level tagged types
5023 if Tagged_Type_Expansion
5024 and then Static_Dispatch_Tables
5025 and then Is_Library_Level_Entity (Def_Id)
5026 and then Is_Library_Level_Tagged_Type (Base_Typ)
5027 and then (Ekind (Base_Typ) = E_Record_Type
5028 or else Ekind (Base_Typ) = E_Protected_Type
5029 or else Ekind (Base_Typ) = E_Task_Type)
5030 and then not Has_Dispatch_Table (Base_Typ)
5033 New_Nodes : List_Id := No_List;
5036 if Is_Concurrent_Type (Base_Typ) then
5037 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
5039 New_Nodes := Make_DT (Base_Typ, N);
5042 if not Is_Empty_List (New_Nodes) then
5043 Insert_List_Before (N, New_Nodes);
5048 -- Make shared memory routines for shared passive variable
5050 if Is_Shared_Passive (Def_Id) then
5051 Init_After := Make_Shared_Var_Procs (N);
5054 -- If tasks being declared, make sure we have an activation chain
5055 -- defined for the tasks (has no effect if we already have one), and
5056 -- also that a Master variable is established and that the appropriate
5057 -- enclosing construct is established as a task master.
5059 if Has_Task (Typ) then
5060 Build_Activation_Chain_Entity (N);
5061 Build_Master_Entity (Def_Id);
5064 -- Default initialization required, and no expression present
5068 -- For the default initialization case, if we have a private type
5069 -- with invariants, and invariant checks are enabled, then insert an
5070 -- invariant check after the object declaration. Note that it is OK
5071 -- to clobber the object with an invalid value since if the exception
5072 -- is raised, then the object will go out of scope. In the case where
5073 -- an array object is initialized with an aggregate, the expression
5074 -- is removed. Check flag Has_Init_Expression to avoid generating a
5075 -- junk invariant check.
5077 if Has_Invariants (Base_Typ)
5078 and then Present (Invariant_Procedure (Base_Typ))
5079 and then not Has_Init_Expression (N)
5082 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
5085 -- Expand Initialize call for controlled objects. One may wonder why
5086 -- the Initialize Call is not done in the regular Init procedure
5087 -- attached to the record type. That's because the init procedure is
5088 -- recursively called on each component, including _Parent, thus the
5089 -- Init call for a controlled object would generate not only one
5090 -- Initialize call as it is required but one for each ancestor of
5091 -- its type. This processing is suppressed if No_Initialization set.
5093 if not Needs_Finalization (Typ) or else No_Initialization (N) then
5096 elsif not Abort_Allowed or else not Comes_From_Source (N) then
5097 Insert_Action_After (Init_After,
5099 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5105 -- We need to protect the initialize call
5109 -- Initialize (...);
5111 -- Undefer_Abort.all;
5114 -- ??? this won't protect the initialize call for controlled
5115 -- components which are part of the init proc, so this block
5116 -- should probably also contain the call to _init_proc but this
5117 -- requires some code reorganization...
5120 L : constant List_Id := New_List (
5122 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5125 Blk : constant Node_Id :=
5126 Make_Block_Statement (Loc,
5127 Handled_Statement_Sequence =>
5128 Make_Handled_Sequence_Of_Statements (Loc, L));
5131 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
5132 Set_At_End_Proc (Handled_Statement_Sequence (Blk),
5133 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
5134 Insert_Actions_After (Init_After, New_List (Blk));
5135 Expand_At_End_Handler
5136 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
5140 -- Call type initialization procedure if there is one. We build the
5141 -- call and put it immediately after the object declaration, so that
5142 -- it will be expanded in the usual manner. Note that this will
5143 -- result in proper handling of defaulted discriminants.
5145 -- Need call if there is a base init proc
5147 if Has_Non_Null_Base_Init_Proc (Typ)
5149 -- Suppress call if No_Initialization set on declaration
5151 and then not No_Initialization (N)
5153 -- Suppress call for special case of value type for VM
5155 and then not Is_Value_Type (Typ)
5157 -- Suppress call if initialization suppressed for the type
5159 and then not Initialization_Suppressed (Typ)
5161 -- Return without initializing when No_Default_Initialization
5162 -- applies. Note that the actual restriction check occurs later,
5163 -- when the object is frozen, because we don't know yet whether
5164 -- the object is imported, which is a case where the check does
5167 if Restriction_Active (No_Default_Initialization) then
5171 -- The call to the initialization procedure does NOT freeze the
5172 -- object being initialized. This is because the call is not a
5173 -- source level call. This works fine, because the only possible
5174 -- statements depending on freeze status that can appear after the
5175 -- Init_Proc call are rep clauses which can safely appear after
5176 -- actual references to the object. Note that this call may
5177 -- subsequently be removed (if a pragma Import is encountered),
5178 -- or moved to the freeze actions for the object (e.g. if an
5179 -- address clause is applied to the object, causing it to get
5180 -- delayed freezing).
5182 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
5183 Set_Must_Not_Freeze (Id_Ref);
5184 Set_Assignment_OK (Id_Ref);
5187 Init_Expr : constant Node_Id :=
5188 Static_Initialization (Base_Init_Proc (Typ));
5191 if Present (Init_Expr) then
5193 (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
5196 -- If type has discriminants, try to build equivalent aggregate
5197 -- using discriminant values from the declaration. This
5198 -- is a useful optimization, in particular if restriction
5199 -- No_Elaboration_Code is active.
5201 elsif Build_Equivalent_Aggregate then
5205 Initialization_Warning (Id_Ref);
5207 Insert_Actions_After (Init_After,
5208 Build_Initialization_Call (Loc, Id_Ref, Typ));
5212 -- If simple initialization is required, then set an appropriate
5213 -- simple initialization expression in place. This special
5214 -- initialization is required even though No_Init_Flag is present,
5215 -- but is not needed if there was an explicit initialization.
5217 -- An internally generated temporary needs no initialization because
5218 -- it will be assigned subsequently. In particular, there is no point
5219 -- in applying Initialize_Scalars to such a temporary.
5221 elsif Needs_Simple_Initialization
5224 and then not Has_Following_Address_Clause (N))
5225 and then not Is_Internal (Def_Id)
5226 and then not Has_Init_Expression (N)
5228 Set_No_Initialization (N, False);
5229 Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
5230 Analyze_And_Resolve (Expression (N), Typ);
5233 -- Generate attribute for Persistent_BSS if needed
5235 if Persistent_BSS_Mode
5236 and then Comes_From_Source (N)
5237 and then Is_Potentially_Persistent_Type (Typ)
5238 and then not Has_Init_Expression (N)
5239 and then Is_Library_Level_Entity (Def_Id)
5245 Make_Linker_Section_Pragma
5246 (Def_Id, Sloc (N), ".persistent.bss");
5247 Insert_After (N, Prag);
5252 -- If access type, then we know it is null if not initialized
5254 if Is_Access_Type (Typ) then
5255 Set_Is_Known_Null (Def_Id);
5258 -- Explicit initialization present
5261 -- Obtain actual expression from qualified expression
5263 if Nkind (Expr) = N_Qualified_Expression then
5264 Expr_Q := Expression (Expr);
5269 -- When we have the appropriate type of aggregate in the expression
5270 -- (it has been determined during analysis of the aggregate by
5271 -- setting the delay flag), let's perform in place assignment and
5272 -- thus avoid creating a temporary.
5274 if Is_Delayed_Aggregate (Expr_Q) then
5275 Convert_Aggr_In_Object_Decl (N);
5277 -- Ada 2005 (AI-318-02): If the initialization expression is a call
5278 -- to a build-in-place function, then access to the declared object
5279 -- must be passed to the function. Currently we limit such functions
5280 -- to those with constrained limited result subtypes, but eventually
5281 -- plan to expand the allowed forms of functions that are treated as
5284 elsif Ada_Version >= Ada_2005
5285 and then Is_Build_In_Place_Function_Call (Expr_Q)
5287 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
5289 -- The previous call expands the expression initializing the
5290 -- built-in-place object into further code that will be analyzed
5291 -- later. No further expansion needed here.
5295 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
5296 -- class-wide interface object to ensure that we copy the full
5297 -- object, unless we are targetting a VM where interfaces are handled
5298 -- by VM itself. Note that if the root type of Typ is an ancestor of
5299 -- Expr's type, both types share the same dispatch table and there is
5300 -- no need to displace the pointer.
5302 elsif Is_Interface (Typ)
5304 -- Avoid never-ending recursion because if Equivalent_Type is set
5305 -- then we've done it already and must not do it again.
5308 (Nkind (Object_Definition (N)) = N_Identifier
5310 Present (Equivalent_Type (Entity (Object_Definition (N)))))
5312 pragma Assert (Is_Class_Wide_Type (Typ));
5314 -- If the object is a return object of an inherently limited type,
5315 -- which implies build-in-place treatment, bypass the special
5316 -- treatment of class-wide interface initialization below. In this
5317 -- case, the expansion of the return statement will take care of
5318 -- creating the object (via allocator) and initializing it.
5320 if Is_Return_Object (Def_Id)
5321 and then Is_Limited_View (Typ)
5325 elsif Tagged_Type_Expansion then
5327 Iface : constant Entity_Id := Root_Type (Typ);
5328 Expr_N : Node_Id := Expr;
5329 Expr_Typ : Entity_Id;
5335 -- If the original node of the expression was a conversion
5336 -- to this specific class-wide interface type then restore
5337 -- the original node because we must copy the object before
5338 -- displacing the pointer to reference the secondary tag
5339 -- component. This code must be kept synchronized with the
5340 -- expansion done by routine Expand_Interface_Conversion
5342 if not Comes_From_Source (Expr_N)
5343 and then Nkind (Expr_N) = N_Explicit_Dereference
5344 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
5345 and then Etype (Original_Node (Expr_N)) = Typ
5347 Rewrite (Expr_N, Original_Node (Expression (N)));
5350 -- Avoid expansion of redundant interface conversion
5352 if Is_Interface (Etype (Expr_N))
5353 and then Nkind (Expr_N) = N_Type_Conversion
5354 and then Etype (Expr_N) = Typ
5356 Expr_N := Expression (Expr_N);
5357 Set_Expression (N, Expr_N);
5360 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
5361 Expr_Typ := Base_Type (Etype (Expr_N));
5363 if Is_Class_Wide_Type (Expr_Typ) then
5364 Expr_Typ := Root_Type (Expr_Typ);
5368 -- CW : I'Class := Obj;
5371 -- type Ityp is not null access I'Class;
5372 -- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all;
5374 if Comes_From_Source (Expr_N)
5375 and then Nkind (Expr_N) = N_Identifier
5376 and then not Is_Interface (Expr_Typ)
5377 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
5378 and then (Expr_Typ = Etype (Expr_Typ)
5380 Is_Variable_Size_Record (Etype (Expr_Typ)))
5385 Make_Object_Declaration (Loc,
5386 Defining_Identifier => Obj_Id,
5387 Object_Definition =>
5388 New_Occurrence_Of (Expr_Typ, Loc),
5390 Relocate_Node (Expr_N)));
5392 -- Statically reference the tag associated with the
5396 Make_Selected_Component (Loc,
5397 Prefix => New_Occurrence_Of (Obj_Id, Loc),
5400 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
5403 -- IW : I'Class := Obj;
5405 -- type Equiv_Record is record ... end record;
5406 -- implicit subtype CW is <Class_Wide_Subtype>;
5407 -- Tmp : CW := CW!(Obj);
5408 -- type Ityp is not null access I'Class;
5409 -- IW : I'Class renames
5410 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
5413 -- Generate the equivalent record type and update the
5414 -- subtype indication to reference it.
5416 Expand_Subtype_From_Expr
5419 Subtype_Indic => Object_Definition (N),
5422 if not Is_Interface (Etype (Expr_N)) then
5423 New_Expr := Relocate_Node (Expr_N);
5425 -- For interface types we use 'Address which displaces
5426 -- the pointer to the base of the object (if required)
5430 Unchecked_Convert_To (Etype (Object_Definition (N)),
5431 Make_Explicit_Dereference (Loc,
5432 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5433 Make_Attribute_Reference (Loc,
5434 Prefix => Relocate_Node (Expr_N),
5435 Attribute_Name => Name_Address))));
5440 if not Is_Limited_Record (Expr_Typ) then
5442 Make_Object_Declaration (Loc,
5443 Defining_Identifier => Obj_Id,
5444 Object_Definition =>
5446 (Etype (Object_Definition (N)), Loc),
5447 Expression => New_Expr));
5449 -- Rename limited type object since they cannot be copied
5450 -- This case occurs when the initialization expression
5451 -- has been previously expanded into a temporary object.
5453 else pragma Assert (not Comes_From_Source (Expr_Q));
5455 Make_Object_Renaming_Declaration (Loc,
5456 Defining_Identifier => Obj_Id,
5459 (Etype (Object_Definition (N)), Loc),
5461 Unchecked_Convert_To
5462 (Etype (Object_Definition (N)), New_Expr)));
5465 -- Dynamically reference the tag associated with the
5469 Make_Function_Call (Loc,
5470 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
5471 Parameter_Associations => New_List (
5472 Make_Attribute_Reference (Loc,
5473 Prefix => New_Occurrence_Of (Obj_Id, Loc),
5474 Attribute_Name => Name_Address),
5476 (Node (First_Elmt (Access_Disp_Table (Iface))),
5481 Make_Object_Renaming_Declaration (Loc,
5482 Defining_Identifier => Make_Temporary (Loc, 'D'),
5483 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
5484 Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
5486 -- If the original entity comes from source, then mark the
5487 -- new entity as needing debug information, even though it's
5488 -- defined by a generated renaming that does not come from
5489 -- source, so that Materialize_Entity will be set on the
5490 -- entity when Debug_Renaming_Declaration is called during
5493 if Comes_From_Source (Def_Id) then
5494 Set_Debug_Info_Needed (Defining_Identifier (N));
5497 Analyze (N, Suppress => All_Checks);
5499 -- Replace internal identifier of rewritten node by the
5500 -- identifier found in the sources. We also have to exchange
5501 -- entities containing their defining identifiers to ensure
5502 -- the correct replacement of the object declaration by this
5503 -- object renaming declaration because these identifiers
5504 -- were previously added by Enter_Name to the current scope.
5505 -- We must preserve the homonym chain of the source entity
5506 -- as well. We must also preserve the kind of the entity,
5507 -- which may be a constant. Preserve entity chain because
5508 -- itypes may have been generated already, and the full
5509 -- chain must be preserved for final freezing. Finally,
5510 -- preserve Comes_From_Source setting, so that debugging
5511 -- and cross-referencing information is properly kept, and
5512 -- preserve source location, to prevent spurious errors when
5513 -- entities are declared (they must have their own Sloc).
5516 New_Id : constant Entity_Id := Defining_Identifier (N);
5517 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
5518 S_Flag : constant Boolean :=
5519 Comes_From_Source (Def_Id);
5522 Set_Next_Entity (New_Id, Next_Entity (Def_Id));
5523 Set_Next_Entity (Def_Id, Next_Temp);
5525 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
5526 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
5527 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
5528 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
5530 Set_Comes_From_Source (Def_Id, False);
5531 Exchange_Entities (Defining_Identifier (N), Def_Id);
5532 Set_Comes_From_Source (Def_Id, S_Flag);
5539 -- Common case of explicit object initialization
5542 -- In most cases, we must check that the initial value meets any
5543 -- constraint imposed by the declared type. However, there is one
5544 -- very important exception to this rule. If the entity has an
5545 -- unconstrained nominal subtype, then it acquired its constraints
5546 -- from the expression in the first place, and not only does this
5547 -- mean that the constraint check is not needed, but an attempt to
5548 -- perform the constraint check can cause order of elaboration
5551 if not Is_Constr_Subt_For_U_Nominal (Typ) then
5553 -- If this is an allocator for an aggregate that has been
5554 -- allocated in place, delay checks until assignments are
5555 -- made, because the discriminants are not initialized.
5557 if Nkind (Expr) = N_Allocator
5558 and then No_Initialization (Expr)
5562 -- Otherwise apply a constraint check now if no prev error
5564 elsif Nkind (Expr) /= N_Error then
5565 Apply_Constraint_Check (Expr, Typ);
5567 -- If the expression has been marked as requiring a range
5568 -- check, generate it now and reset the flag.
5570 if Do_Range_Check (Expr) then
5571 Set_Do_Range_Check (Expr, False);
5573 if not Suppress_Assignment_Checks (N) then
5574 Generate_Range_Check
5575 (Expr, Typ, CE_Range_Check_Failed);
5581 -- If the type is controlled and not inherently limited, then
5582 -- the target is adjusted after the copy and attached to the
5583 -- finalization list. However, no adjustment is done in the case
5584 -- where the object was initialized by a call to a function whose
5585 -- result is built in place, since no copy occurred. (Eventually
5586 -- we plan to support in-place function results for some cases
5587 -- of nonlimited types. ???) Similarly, no adjustment is required
5588 -- if we are going to rewrite the object declaration into a
5589 -- renaming declaration.
5591 if Needs_Finalization (Typ)
5592 and then not Is_Limited_View (Typ)
5593 and then not Rewrite_As_Renaming
5595 Insert_Action_After (Init_After,
5597 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5601 -- For tagged types, when an init value is given, the tag has to
5602 -- be re-initialized separately in order to avoid the propagation
5603 -- of a wrong tag coming from a view conversion unless the type
5604 -- is class wide (in this case the tag comes from the init value).
5605 -- Suppress the tag assignment when VM_Target because VM tags are
5606 -- represented implicitly in objects. Ditto for types that are
5607 -- CPP_CLASS, and for initializations that are aggregates, because
5608 -- they have to have the right tag.
5610 if Is_Tagged_Type (Typ)
5611 and then not Is_Class_Wide_Type (Typ)
5612 and then not Is_CPP_Class (Typ)
5613 and then Tagged_Type_Expansion
5614 and then Nkind (Expr) /= N_Aggregate
5615 and then (Nkind (Expr) /= N_Qualified_Expression
5616 or else Nkind (Expression (Expr)) /= N_Aggregate)
5619 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
5622 -- The re-assignment of the tag has to be done even if the
5623 -- object is a constant. The assignment must be analyzed
5624 -- after the declaration.
5627 Make_Selected_Component (Loc,
5628 Prefix => New_Occurrence_Of (Def_Id, Loc),
5630 New_Occurrence_Of (First_Tag_Component (Full_Typ),
5632 Set_Assignment_OK (New_Ref);
5634 Insert_Action_After (Init_After,
5635 Make_Assignment_Statement (Loc,
5638 Unchecked_Convert_To (RTE (RE_Tag),
5640 (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
5644 -- Handle C++ constructor calls. Note that we do not check that
5645 -- Typ is a tagged type since the equivalent Ada type of a C++
5646 -- class that has no virtual methods is a non-tagged limited
5649 elsif Is_CPP_Constructor_Call (Expr) then
5651 -- The call to the initialization procedure does NOT freeze the
5652 -- object being initialized.
5654 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
5655 Set_Must_Not_Freeze (Id_Ref);
5656 Set_Assignment_OK (Id_Ref);
5658 Insert_Actions_After (Init_After,
5659 Build_Initialization_Call (Loc, Id_Ref, Typ,
5660 Constructor_Ref => Expr));
5662 -- We remove here the original call to the constructor
5663 -- to avoid its management in the backend
5665 Set_Expression (N, Empty);
5668 -- For discrete types, set the Is_Known_Valid flag if the
5669 -- initializing value is known to be valid.
5671 elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then
5672 Set_Is_Known_Valid (Def_Id);
5674 elsif Is_Access_Type (Typ) then
5676 -- For access types set the Is_Known_Non_Null flag if the
5677 -- initializing value is known to be non-null. We can also set
5678 -- Can_Never_Be_Null if this is a constant.
5680 if Known_Non_Null (Expr) then
5681 Set_Is_Known_Non_Null (Def_Id, True);
5683 if Constant_Present (N) then
5684 Set_Can_Never_Be_Null (Def_Id);
5689 -- If validity checking on copies, validate initial expression.
5690 -- But skip this if declaration is for a generic type, since it
5691 -- makes no sense to validate generic types. Not clear if this
5692 -- can happen for legal programs, but it definitely can arise
5693 -- from previous instantiation errors.
5695 if Validity_Checks_On
5696 and then Validity_Check_Copies
5697 and then not Is_Generic_Type (Etype (Def_Id))
5699 Ensure_Valid (Expr);
5700 Set_Is_Known_Valid (Def_Id);
5704 -- Cases where the back end cannot handle the initialization directly
5705 -- In such cases, we expand an assignment that will be appropriately
5706 -- handled by Expand_N_Assignment_Statement.
5708 -- The exclusion of the unconstrained case is wrong, but for now it
5709 -- is too much trouble ???
5711 if (Is_Possibly_Unaligned_Slice (Expr)
5712 or else (Is_Possibly_Unaligned_Object (Expr)
5713 and then not Represented_As_Scalar (Etype (Expr))))
5714 and then not (Is_Array_Type (Etype (Expr))
5715 and then not Is_Constrained (Etype (Expr)))
5718 Stat : constant Node_Id :=
5719 Make_Assignment_Statement (Loc,
5720 Name => New_Occurrence_Of (Def_Id, Loc),
5721 Expression => Relocate_Node (Expr));
5723 Set_Expression (N, Empty);
5724 Set_No_Initialization (N);
5725 Set_Assignment_OK (Name (Stat));
5726 Set_No_Ctrl_Actions (Stat);
5727 Insert_After_And_Analyze (Init_After, Stat);
5731 -- Final transformation, if the initializing expression is an entity
5732 -- for a variable with OK_To_Rename set, then we transform:
5738 -- X : typ renames expr
5740 -- provided that X is not aliased. The aliased case has to be
5741 -- excluded in general because Expr will not be aliased in general.
5743 if Rewrite_As_Renaming then
5745 Make_Object_Renaming_Declaration (Loc,
5746 Defining_Identifier => Defining_Identifier (N),
5747 Subtype_Mark => Object_Definition (N),
5750 -- We do not analyze this renaming declaration, because all its
5751 -- components have already been analyzed, and if we were to go
5752 -- ahead and analyze it, we would in effect be trying to generate
5753 -- another declaration of X, which won't do.
5755 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
5758 -- We do need to deal with debug issues for this renaming
5760 -- First, if entity comes from source, then mark it as needing
5761 -- debug information, even though it is defined by a generated
5762 -- renaming that does not come from source.
5764 if Comes_From_Source (Defining_Identifier (N)) then
5765 Set_Debug_Info_Needed (Defining_Identifier (N));
5768 -- Now call the routine to generate debug info for the renaming
5771 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
5773 if Present (Decl) then
5774 Insert_Action (N, Decl);
5780 if Nkind (N) = N_Object_Declaration
5781 and then Nkind (Object_Definition (N)) = N_Access_Definition
5782 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
5784 -- An Ada 2012 stand-alone object of an anonymous access type
5787 Loc : constant Source_Ptr := Sloc (N);
5789 Level : constant Entity_Id :=
5790 Make_Defining_Identifier (Sloc (N),
5792 New_External_Name (Chars (Def_Id), Suffix => "L"));
5794 Level_Expr : Node_Id;
5795 Level_Decl : Node_Id;
5798 Set_Ekind (Level, Ekind (Def_Id));
5799 Set_Etype (Level, Standard_Natural);
5800 Set_Scope (Level, Scope (Def_Id));
5804 -- Set accessibility level of null
5807 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
5810 Level_Expr := Dynamic_Accessibility_Level (Expr);
5813 Level_Decl := Make_Object_Declaration (Loc,
5814 Defining_Identifier => Level,
5815 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
5816 Expression => Level_Expr,
5817 Constant_Present => Constant_Present (N),
5818 Has_Init_Expression => True);
5820 Insert_Action_After (Init_After, Level_Decl);
5822 Set_Extra_Accessibility (Def_Id, Level);
5826 -- Exception on library entity not available
5829 when RE_Not_Available =>
5831 end Expand_N_Object_Declaration;
5833 ---------------------------------
5834 -- Expand_N_Subtype_Indication --
5835 ---------------------------------
5837 -- Add a check on the range of the subtype. The static case is partially
5838 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
5839 -- to check here for the static case in order to avoid generating
5840 -- extraneous expanded code. Also deal with validity checking.
5842 procedure Expand_N_Subtype_Indication (N : Node_Id) is
5843 Ran : constant Node_Id := Range_Expression (Constraint (N));
5844 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
5847 if Nkind (Constraint (N)) = N_Range_Constraint then
5848 Validity_Check_Range (Range_Expression (Constraint (N)));
5851 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
5852 Apply_Range_Check (Ran, Typ);
5854 end Expand_N_Subtype_Indication;
5856 ---------------------------
5857 -- Expand_N_Variant_Part --
5858 ---------------------------
5860 -- Note: this procedure no longer has any effect. It used to be that we
5861 -- would replace the choices in the last variant by a when others, and
5862 -- also expanded static predicates in variant choices here, but both of
5863 -- those activities were being done too early, since we can't check the
5864 -- choices until the statically predicated subtypes are frozen, which can
5865 -- happen as late as the free point of the record, and we can't change the
5866 -- last choice to an others before checking the choices, which is now done
5867 -- at the freeze point of the record.
5869 procedure Expand_N_Variant_Part (N : Node_Id) is
5872 end Expand_N_Variant_Part;
5874 ---------------------------------
5875 -- Expand_Previous_Access_Type --
5876 ---------------------------------
5878 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
5879 Ptr_Typ : Entity_Id;
5882 -- Find all access types in the current scope whose designated type is
5883 -- Def_Id and build master renamings for them.
5885 Ptr_Typ := First_Entity (Current_Scope);
5886 while Present (Ptr_Typ) loop
5887 if Is_Access_Type (Ptr_Typ)
5888 and then Designated_Type (Ptr_Typ) = Def_Id
5889 and then No (Master_Id (Ptr_Typ))
5891 -- Ensure that the designated type has a master
5893 Build_Master_Entity (Def_Id);
5895 -- Private and incomplete types complicate the insertion of master
5896 -- renamings because the access type may precede the full view of
5897 -- the designated type. For this reason, the master renamings are
5898 -- inserted relative to the designated type.
5900 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
5903 Next_Entity (Ptr_Typ);
5905 end Expand_Previous_Access_Type;
5907 ------------------------
5908 -- Expand_Tagged_Root --
5909 ------------------------
5911 procedure Expand_Tagged_Root (T : Entity_Id) is
5912 Def : constant Node_Id := Type_Definition (Parent (T));
5913 Comp_List : Node_Id;
5914 Comp_Decl : Node_Id;
5915 Sloc_N : Source_Ptr;
5918 if Null_Present (Def) then
5919 Set_Component_List (Def,
5920 Make_Component_List (Sloc (Def),
5921 Component_Items => Empty_List,
5922 Variant_Part => Empty,
5923 Null_Present => True));
5926 Comp_List := Component_List (Def);
5928 if Null_Present (Comp_List)
5929 or else Is_Empty_List (Component_Items (Comp_List))
5931 Sloc_N := Sloc (Comp_List);
5933 Sloc_N := Sloc (First (Component_Items (Comp_List)));
5937 Make_Component_Declaration (Sloc_N,
5938 Defining_Identifier => First_Tag_Component (T),
5939 Component_Definition =>
5940 Make_Component_Definition (Sloc_N,
5941 Aliased_Present => False,
5942 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
5944 if Null_Present (Comp_List)
5945 or else Is_Empty_List (Component_Items (Comp_List))
5947 Set_Component_Items (Comp_List, New_List (Comp_Decl));
5948 Set_Null_Present (Comp_List, False);
5951 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
5954 -- We don't Analyze the whole expansion because the tag component has
5955 -- already been analyzed previously. Here we just insure that the tree
5956 -- is coherent with the semantic decoration
5958 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
5961 when RE_Not_Available =>
5963 end Expand_Tagged_Root;
5965 ----------------------
5966 -- Clean_Task_Names --
5967 ----------------------
5969 procedure Clean_Task_Names
5971 Proc_Id : Entity_Id)
5975 and then not Restriction_Active (No_Implicit_Heap_Allocations)
5976 and then not Global_Discard_Names
5977 and then Tagged_Type_Expansion
5979 Set_Uses_Sec_Stack (Proc_Id);
5981 end Clean_Task_Names;
5983 ------------------------------
5984 -- Expand_Freeze_Array_Type --
5985 ------------------------------
5987 procedure Expand_Freeze_Array_Type (N : Node_Id) is
5988 Typ : constant Entity_Id := Entity (N);
5989 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5990 Base : constant Entity_Id := Base_Type (Typ);
5993 if not Is_Bit_Packed_Array (Typ) then
5995 -- If the component contains tasks, so does the array type. This may
5996 -- not be indicated in the array type because the component may have
5997 -- been a private type at the point of definition. Same if component
5998 -- type is controlled.
6000 Set_Has_Task (Base, Has_Task (Comp_Typ));
6001 Set_Has_Controlled_Component (Base,
6002 Has_Controlled_Component (Comp_Typ)
6003 or else Is_Controlled (Comp_Typ));
6005 if No (Init_Proc (Base)) then
6007 -- If this is an anonymous array created for a declaration with
6008 -- an initial value, its init_proc will never be called. The
6009 -- initial value itself may have been expanded into assignments,
6010 -- in which case the object declaration is carries the
6011 -- No_Initialization flag.
6014 and then Nkind (Associated_Node_For_Itype (Base)) =
6015 N_Object_Declaration
6016 and then (Present (Expression (Associated_Node_For_Itype (Base)))
6018 No_Initialization (Associated_Node_For_Itype (Base)))
6022 -- We do not need an init proc for string or wide [wide] string,
6023 -- since the only time these need initialization in normalize or
6024 -- initialize scalars mode, and these types are treated specially
6025 -- and do not need initialization procedures.
6027 elsif Root_Type (Base) = Standard_String
6028 or else Root_Type (Base) = Standard_Wide_String
6029 or else Root_Type (Base) = Standard_Wide_Wide_String
6033 -- Otherwise we have to build an init proc for the subtype
6036 Build_Array_Init_Proc (Base, N);
6041 if Has_Controlled_Component (Base) then
6042 Build_Controlling_Procs (Base);
6044 if not Is_Limited_Type (Comp_Typ)
6045 and then Number_Dimensions (Typ) = 1
6047 Build_Slice_Assignment (Typ);
6051 -- Create a finalization master to service the anonymous access
6052 -- components of the array.
6054 if Ekind (Comp_Typ) = E_Anonymous_Access_Type
6055 and then Needs_Finalization (Designated_Type (Comp_Typ))
6057 Build_Finalization_Master
6059 Ins_Node => Parent (Typ),
6060 Encl_Scope => Scope (Typ));
6064 -- For packed case, default initialization, except if the component type
6065 -- is itself a packed structure with an initialization procedure, or
6066 -- initialize/normalize scalars active, and we have a base type, or the
6067 -- type is public, because in that case a client might specify
6068 -- Normalize_Scalars and there better be a public Init_Proc for it.
6070 elsif (Present (Init_Proc (Component_Type (Base)))
6071 and then No (Base_Init_Proc (Base)))
6072 or else (Init_Or_Norm_Scalars and then Base = Typ)
6073 or else Is_Public (Typ)
6075 Build_Array_Init_Proc (Base, N);
6078 if Has_Invariants (Component_Type (Base))
6080 and then In_Open_Scopes (Scope (Component_Type (Base)))
6082 -- Generate component invariant checking procedure. This is only
6083 -- relevant if the array type is within the scope of the component
6084 -- type. Otherwise an array object can only be built using the public
6085 -- subprograms for the component type, and calls to those will have
6086 -- invariant checks. The invariant procedure is only generated for
6087 -- a base type, not a subtype.
6089 Insert_Component_Invariant_Checks
6090 (N, Base, Build_Array_Invariant_Proc (Base, N));
6092 end Expand_Freeze_Array_Type;
6094 -----------------------------------
6095 -- Expand_Freeze_Class_Wide_Type --
6096 -----------------------------------
6098 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
6099 Typ : constant Entity_Id := Entity (N);
6100 Root : constant Entity_Id := Root_Type (Typ);
6102 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
6103 -- Given a type, determine whether it is derived from a C or C++ root
6105 ---------------------
6106 -- Is_C_Derivation --
6107 ---------------------
6109 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
6110 T : Entity_Id := Typ;
6115 or else Convention (T) = Convention_C
6116 or else Convention (T) = Convention_CPP
6121 exit when T = Etype (T);
6127 end Is_C_Derivation;
6129 -- Start of processing for Expand_Freeze_Class_Wide_Type
6132 -- Certain run-time configurations and targets do not provide support
6133 -- for controlled types.
6135 if Restriction_Active (No_Finalization) then
6138 -- Do not create TSS routine Finalize_Address when dispatching calls are
6139 -- disabled since the core of the routine is a dispatching call.
6141 elsif Restriction_Active (No_Dispatching_Calls) then
6144 -- Do not create TSS routine Finalize_Address for concurrent class-wide
6145 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
6146 -- non-Ada side will handle their destruction.
6148 elsif Is_Concurrent_Type (Root)
6149 or else Is_C_Derivation (Root)
6150 or else Convention (Typ) = Convention_CIL
6151 or else Convention (Typ) = Convention_CPP
6152 or else Convention (Typ) = Convention_Java
6156 -- Do not create TSS routine Finalize_Address for .NET/JVM because these
6157 -- targets do not support address arithmetic and unchecked conversions.
6159 elsif VM_Target /= No_VM then
6162 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
6163 -- mode since the routine contains an Unchecked_Conversion.
6165 elsif CodePeer_Mode then
6169 -- Create the body of TSS primitive Finalize_Address. This automatically
6170 -- sets the TSS entry for the class-wide type.
6172 Make_Finalize_Address_Body (Typ);
6173 end Expand_Freeze_Class_Wide_Type;
6175 ------------------------------------
6176 -- Expand_Freeze_Enumeration_Type --
6177 ------------------------------------
6179 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
6180 Typ : constant Entity_Id := Entity (N);
6181 Loc : constant Source_Ptr := Sloc (Typ);
6188 Is_Contiguous : Boolean;
6193 pragma Warnings (Off, Func);
6196 -- Various optimizations possible if given representation is contiguous
6198 Is_Contiguous := True;
6200 Ent := First_Literal (Typ);
6201 Last_Repval := Enumeration_Rep (Ent);
6204 while Present (Ent) loop
6205 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
6206 Is_Contiguous := False;
6209 Last_Repval := Enumeration_Rep (Ent);
6215 if Is_Contiguous then
6216 Set_Has_Contiguous_Rep (Typ);
6217 Ent := First_Literal (Typ);
6219 Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
6222 -- Build list of literal references
6227 Ent := First_Literal (Typ);
6228 while Present (Ent) loop
6229 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
6235 -- Now build an array declaration
6237 -- typA : array (Natural range 0 .. num - 1) of ctype :=
6238 -- (v, v, v, v, v, ....)
6240 -- where ctype is the corresponding integer type. If the representation
6241 -- is contiguous, we only keep the first literal, which provides the
6242 -- offset for Pos_To_Rep computations.
6245 Make_Defining_Identifier (Loc,
6246 Chars => New_External_Name (Chars (Typ), 'A'));
6248 Append_Freeze_Action (Typ,
6249 Make_Object_Declaration (Loc,
6250 Defining_Identifier => Arr,
6251 Constant_Present => True,
6253 Object_Definition =>
6254 Make_Constrained_Array_Definition (Loc,
6255 Discrete_Subtype_Definitions => New_List (
6256 Make_Subtype_Indication (Loc,
6257 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
6259 Make_Range_Constraint (Loc,
6263 Make_Integer_Literal (Loc, 0),
6265 Make_Integer_Literal (Loc, Num - 1))))),
6267 Component_Definition =>
6268 Make_Component_Definition (Loc,
6269 Aliased_Present => False,
6270 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
6273 Make_Aggregate (Loc,
6274 Expressions => Lst)));
6276 Set_Enum_Pos_To_Rep (Typ, Arr);
6278 -- Now we build the function that converts representation values to
6279 -- position values. This function has the form:
6281 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
6284 -- when enum-lit'Enum_Rep => return posval;
6285 -- when enum-lit'Enum_Rep => return posval;
6288 -- [raise Constraint_Error when F "invalid data"]
6293 -- Note: the F parameter determines whether the others case (no valid
6294 -- representation) raises Constraint_Error or returns a unique value
6295 -- of minus one. The latter case is used, e.g. in 'Valid code.
6297 -- Note: the reason we use Enum_Rep values in the case here is to avoid
6298 -- the code generator making inappropriate assumptions about the range
6299 -- of the values in the case where the value is invalid. ityp is a
6300 -- signed or unsigned integer type of appropriate width.
6302 -- Note: if exceptions are not supported, then we suppress the raise
6303 -- and return -1 unconditionally (this is an erroneous program in any
6304 -- case and there is no obligation to raise Constraint_Error here). We
6305 -- also do this if pragma Restrictions (No_Exceptions) is active.
6307 -- Is this right??? What about No_Exception_Propagation???
6309 -- Representations are signed
6311 if Enumeration_Rep (First_Literal (Typ)) < 0 then
6313 -- The underlying type is signed. Reset the Is_Unsigned_Type
6314 -- explicitly, because it might have been inherited from
6317 Set_Is_Unsigned_Type (Typ, False);
6319 if Esize (Typ) <= Standard_Integer_Size then
6320 Ityp := Standard_Integer;
6322 Ityp := Universal_Integer;
6325 -- Representations are unsigned
6328 if Esize (Typ) <= Standard_Integer_Size then
6329 Ityp := RTE (RE_Unsigned);
6331 Ityp := RTE (RE_Long_Long_Unsigned);
6335 -- The body of the function is a case statement. First collect case
6336 -- alternatives, or optimize the contiguous case.
6340 -- If representation is contiguous, Pos is computed by subtracting
6341 -- the representation of the first literal.
6343 if Is_Contiguous then
6344 Ent := First_Literal (Typ);
6346 if Enumeration_Rep (Ent) = Last_Repval then
6348 -- Another special case: for a single literal, Pos is zero
6350 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
6354 Convert_To (Standard_Integer,
6355 Make_Op_Subtract (Loc,
6357 Unchecked_Convert_To
6358 (Ityp, Make_Identifier (Loc, Name_uA)),
6360 Make_Integer_Literal (Loc,
6361 Intval => Enumeration_Rep (First_Literal (Typ)))));
6365 Make_Case_Statement_Alternative (Loc,
6366 Discrete_Choices => New_List (
6367 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
6369 Make_Integer_Literal (Loc,
6370 Intval => Enumeration_Rep (Ent)),
6372 Make_Integer_Literal (Loc, Intval => Last_Repval))),
6374 Statements => New_List (
6375 Make_Simple_Return_Statement (Loc,
6376 Expression => Pos_Expr))));
6379 Ent := First_Literal (Typ);
6380 while Present (Ent) loop
6382 Make_Case_Statement_Alternative (Loc,
6383 Discrete_Choices => New_List (
6384 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
6385 Intval => Enumeration_Rep (Ent))),
6387 Statements => New_List (
6388 Make_Simple_Return_Statement (Loc,
6390 Make_Integer_Literal (Loc,
6391 Intval => Enumeration_Pos (Ent))))));
6397 -- In normal mode, add the others clause with the test
6399 if not No_Exception_Handlers_Set then
6401 Make_Case_Statement_Alternative (Loc,
6402 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
6403 Statements => New_List (
6404 Make_Raise_Constraint_Error (Loc,
6405 Condition => Make_Identifier (Loc, Name_uF),
6406 Reason => CE_Invalid_Data),
6407 Make_Simple_Return_Statement (Loc,
6409 Make_Integer_Literal (Loc, -1)))));
6411 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
6412 -- active then return -1 (we cannot usefully raise Constraint_Error in
6413 -- this case). See description above for further details.
6417 Make_Case_Statement_Alternative (Loc,
6418 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
6419 Statements => New_List (
6420 Make_Simple_Return_Statement (Loc,
6422 Make_Integer_Literal (Loc, -1)))));
6425 -- Now we can build the function body
6428 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
6431 Make_Subprogram_Body (Loc,
6433 Make_Function_Specification (Loc,
6434 Defining_Unit_Name => Fent,
6435 Parameter_Specifications => New_List (
6436 Make_Parameter_Specification (Loc,
6437 Defining_Identifier =>
6438 Make_Defining_Identifier (Loc, Name_uA),
6439 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
6440 Make_Parameter_Specification (Loc,
6441 Defining_Identifier =>
6442 Make_Defining_Identifier (Loc, Name_uF),
6444 New_Occurrence_Of (Standard_Boolean, Loc))),
6446 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
6448 Declarations => Empty_List,
6450 Handled_Statement_Sequence =>
6451 Make_Handled_Sequence_Of_Statements (Loc,
6452 Statements => New_List (
6453 Make_Case_Statement (Loc,
6455 Unchecked_Convert_To
6456 (Ityp, Make_Identifier (Loc, Name_uA)),
6457 Alternatives => Lst))));
6459 Set_TSS (Typ, Fent);
6461 -- Set Pure flag (it will be reset if the current context is not Pure).
6462 -- We also pretend there was a pragma Pure_Function so that for purposes
6463 -- of optimization and constant-folding, we will consider the function
6464 -- Pure even if we are not in a Pure context).
6467 Set_Has_Pragma_Pure_Function (Fent);
6469 -- Unless we are in -gnatD mode, where we are debugging generated code,
6470 -- this is an internal entity for which we don't need debug info.
6472 if not Debug_Generated_Code then
6473 Set_Debug_Info_Off (Fent);
6477 when RE_Not_Available =>
6479 end Expand_Freeze_Enumeration_Type;
6481 -------------------------------
6482 -- Expand_Freeze_Record_Type --
6483 -------------------------------
6485 procedure Expand_Freeze_Record_Type (N : Node_Id) is
6486 Def_Id : constant Node_Id := Entity (N);
6487 Type_Decl : constant Node_Id := Parent (Def_Id);
6489 Comp_Typ : Entity_Id;
6491 Predef_List : List_Id;
6493 Renamed_Eq : Node_Id := Empty;
6494 -- Defining unit name for the predefined equality function in the case
6495 -- where the type has a primitive operation that is a renaming of
6496 -- predefined equality (but only if there is also an overriding
6497 -- user-defined equality function). Used to pass this entity from
6498 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
6500 Wrapper_Decl_List : List_Id := No_List;
6501 Wrapper_Body_List : List_Id := No_List;
6503 -- Start of processing for Expand_Freeze_Record_Type
6506 -- Build discriminant checking functions if not a derived type (for
6507 -- derived types that are not tagged types, always use the discriminant
6508 -- checking functions of the parent type). However, for untagged types
6509 -- the derivation may have taken place before the parent was frozen, so
6510 -- we copy explicitly the discriminant checking functions from the
6511 -- parent into the components of the derived type.
6513 if not Is_Derived_Type (Def_Id)
6514 or else Has_New_Non_Standard_Rep (Def_Id)
6515 or else Is_Tagged_Type (Def_Id)
6517 Build_Discr_Checking_Funcs (Type_Decl);
6519 elsif Is_Derived_Type (Def_Id)
6520 and then not Is_Tagged_Type (Def_Id)
6522 -- If we have a derived Unchecked_Union, we do not inherit the
6523 -- discriminant checking functions from the parent type since the
6524 -- discriminants are non existent.
6526 and then not Is_Unchecked_Union (Def_Id)
6527 and then Has_Discriminants (Def_Id)
6530 Old_Comp : Entity_Id;
6534 First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
6535 Comp := First_Component (Def_Id);
6536 while Present (Comp) loop
6537 if Ekind (Comp) = E_Component
6538 and then Chars (Comp) = Chars (Old_Comp)
6540 Set_Discriminant_Checking_Func (Comp,
6541 Discriminant_Checking_Func (Old_Comp));
6544 Next_Component (Old_Comp);
6545 Next_Component (Comp);
6550 if Is_Derived_Type (Def_Id)
6551 and then Is_Limited_Type (Def_Id)
6552 and then Is_Tagged_Type (Def_Id)
6554 Check_Stream_Attributes (Def_Id);
6557 -- Update task and controlled component flags, because some of the
6558 -- component types may have been private at the point of the record
6559 -- declaration. Detect anonymous access-to-controlled components.
6563 Comp := First_Component (Def_Id);
6564 while Present (Comp) loop
6565 Comp_Typ := Etype (Comp);
6567 if Has_Task (Comp_Typ) then
6568 Set_Has_Task (Def_Id);
6570 -- Do not set Has_Controlled_Component on a class-wide equivalent
6571 -- type. See Make_CW_Equivalent_Type.
6573 elsif not Is_Class_Wide_Equivalent_Type (Def_Id)
6574 and then (Has_Controlled_Component (Comp_Typ)
6575 or else (Chars (Comp) /= Name_uParent
6576 and then Is_Controlled (Comp_Typ)))
6578 Set_Has_Controlled_Component (Def_Id);
6580 -- Non-self-referential anonymous access-to-controlled component
6582 elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
6583 and then Needs_Finalization (Designated_Type (Comp_Typ))
6584 and then Designated_Type (Comp_Typ) /= Def_Id
6589 Next_Component (Comp);
6592 -- Handle constructors of non-tagged CPP_Class types
6594 if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then
6595 Set_CPP_Constructors (Def_Id);
6598 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
6599 -- for regular tagged types as well as for Ada types deriving from a C++
6600 -- Class, but not for tagged types directly corresponding to C++ classes
6601 -- In the later case we assume that it is created in the C++ side and we
6604 if Is_Tagged_Type (Def_Id) then
6606 -- Add the _Tag component
6608 if Underlying_Type (Etype (Def_Id)) = Def_Id then
6609 Expand_Tagged_Root (Def_Id);
6612 if Is_CPP_Class (Def_Id) then
6613 Set_All_DT_Position (Def_Id);
6615 -- Create the tag entities with a minimum decoration
6617 if Tagged_Type_Expansion then
6618 Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
6621 Set_CPP_Constructors (Def_Id);
6624 if not Building_Static_DT (Def_Id) then
6626 -- Usually inherited primitives are not delayed but the first
6627 -- Ada extension of a CPP_Class is an exception since the
6628 -- address of the inherited subprogram has to be inserted in
6629 -- the new Ada Dispatch Table and this is a freezing action.
6631 -- Similarly, if this is an inherited operation whose parent is
6632 -- not frozen yet, it is not in the DT of the parent, and we
6633 -- generate an explicit freeze node for the inherited operation
6634 -- so it is properly inserted in the DT of the current type.
6641 Elmt := First_Elmt (Primitive_Operations (Def_Id));
6642 while Present (Elmt) loop
6643 Subp := Node (Elmt);
6645 if Present (Alias (Subp)) then
6646 if Is_CPP_Class (Etype (Def_Id)) then
6647 Set_Has_Delayed_Freeze (Subp);
6649 elsif Has_Delayed_Freeze (Alias (Subp))
6650 and then not Is_Frozen (Alias (Subp))
6652 Set_Is_Frozen (Subp, False);
6653 Set_Has_Delayed_Freeze (Subp);
6662 -- Unfreeze momentarily the type to add the predefined primitives
6663 -- operations. The reason we unfreeze is so that these predefined
6664 -- operations will indeed end up as primitive operations (which
6665 -- must be before the freeze point).
6667 Set_Is_Frozen (Def_Id, False);
6669 -- Do not add the spec of predefined primitives in case of
6670 -- CPP tagged type derivations that have convention CPP.
6672 if Is_CPP_Class (Root_Type (Def_Id))
6673 and then Convention (Def_Id) = Convention_CPP
6677 -- Do not add the spec of predefined primitives in case of
6678 -- CIL and Java tagged types
6680 elsif Convention (Def_Id) = Convention_CIL
6681 or else Convention (Def_Id) = Convention_Java
6685 -- Do not add the spec of the predefined primitives if we are
6686 -- compiling under restriction No_Dispatching_Calls.
6688 elsif not Restriction_Active (No_Dispatching_Calls) then
6689 Make_Predefined_Primitive_Specs
6690 (Def_Id, Predef_List, Renamed_Eq);
6691 Insert_List_Before_And_Analyze (N, Predef_List);
6694 -- Ada 2005 (AI-391): For a nonabstract null extension, create
6695 -- wrapper functions for each nonoverridden inherited function
6696 -- with a controlling result of the type. The wrapper for such
6697 -- a function returns an extension aggregate that invokes the
6700 if Ada_Version >= Ada_2005
6701 and then not Is_Abstract_Type (Def_Id)
6702 and then Is_Null_Extension (Def_Id)
6704 Make_Controlling_Function_Wrappers
6705 (Def_Id, Wrapper_Decl_List, Wrapper_Body_List);
6706 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
6709 -- Ada 2005 (AI-251): For a nonabstract type extension, build
6710 -- null procedure declarations for each set of homographic null
6711 -- procedures that are inherited from interface types but not
6712 -- overridden. This is done to ensure that the dispatch table
6713 -- entry associated with such null primitives are properly filled.
6715 if Ada_Version >= Ada_2005
6716 and then Etype (Def_Id) /= Def_Id
6717 and then not Is_Abstract_Type (Def_Id)
6718 and then Has_Interfaces (Def_Id)
6720 Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id));
6723 Set_Is_Frozen (Def_Id);
6724 if not Is_Derived_Type (Def_Id)
6725 or else Is_Tagged_Type (Etype (Def_Id))
6727 Set_All_DT_Position (Def_Id);
6730 -- Create and decorate the tags. Suppress their creation when
6731 -- VM_Target because the dispatching mechanism is handled
6732 -- internally by the VMs.
6734 if Tagged_Type_Expansion then
6735 Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
6737 -- Generate dispatch table of locally defined tagged type.
6738 -- Dispatch tables of library level tagged types are built
6739 -- later (see Analyze_Declarations).
6741 if not Building_Static_DT (Def_Id) then
6742 Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
6745 elsif VM_Target /= No_VM then
6746 Append_Freeze_Actions (Def_Id, Make_VM_TSD (Def_Id));
6749 -- If the type has unknown discriminants, propagate dispatching
6750 -- information to its underlying record view, which does not get
6751 -- its own dispatch table.
6753 if Is_Derived_Type (Def_Id)
6754 and then Has_Unknown_Discriminants (Def_Id)
6755 and then Present (Underlying_Record_View (Def_Id))
6758 Rep : constant Entity_Id := Underlying_Record_View (Def_Id);
6760 Set_Access_Disp_Table
6761 (Rep, Access_Disp_Table (Def_Id));
6762 Set_Dispatch_Table_Wrappers
6763 (Rep, Dispatch_Table_Wrappers (Def_Id));
6764 Set_Direct_Primitive_Operations
6765 (Rep, Direct_Primitive_Operations (Def_Id));
6769 -- Make sure that the primitives Initialize, Adjust and Finalize
6770 -- are Frozen before other TSS subprograms. We don't want them
6773 if Is_Controlled (Def_Id) then
6774 if not Is_Limited_Type (Def_Id) then
6775 Append_Freeze_Actions (Def_Id,
6777 (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id));
6780 Append_Freeze_Actions (Def_Id,
6782 (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id));
6784 Append_Freeze_Actions (Def_Id,
6786 (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id));
6789 -- Freeze rest of primitive operations. There is no need to handle
6790 -- the predefined primitives if we are compiling under restriction
6791 -- No_Dispatching_Calls.
6793 if not Restriction_Active (No_Dispatching_Calls) then
6794 Append_Freeze_Actions
6795 (Def_Id, Predefined_Primitive_Freeze (Def_Id));
6799 -- In the non-tagged case, ever since Ada 83 an equality function must
6800 -- be provided for variant records that are not unchecked unions.
6801 -- In Ada 2012 the equality function composes, and thus must be built
6802 -- explicitly just as for tagged records.
6804 elsif Has_Discriminants (Def_Id)
6805 and then not Is_Limited_Type (Def_Id)
6808 Comps : constant Node_Id :=
6809 Component_List (Type_Definition (Type_Decl));
6812 and then Present (Variant_Part (Comps))
6814 Build_Variant_Record_Equality (Def_Id);
6818 -- Otherwise create primitive equality operation (AI05-0123)
6820 -- This is done unconditionally to ensure that tools can be linked
6821 -- properly with user programs compiled with older language versions.
6822 -- In addition, this is needed because "=" composes for bounded strings
6823 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
6825 elsif Comes_From_Source (Def_Id)
6826 and then Convention (Def_Id) = Convention_Ada
6827 and then not Is_Limited_Type (Def_Id)
6829 Build_Untagged_Equality (Def_Id);
6832 -- Before building the record initialization procedure, if we are
6833 -- dealing with a concurrent record value type, then we must go through
6834 -- the discriminants, exchanging discriminals between the concurrent
6835 -- type and the concurrent record value type. See the section "Handling
6836 -- of Discriminants" in the Einfo spec for details.
6838 if Is_Concurrent_Record_Type (Def_Id)
6839 and then Has_Discriminants (Def_Id)
6842 Ctyp : constant Entity_Id :=
6843 Corresponding_Concurrent_Type (Def_Id);
6844 Conc_Discr : Entity_Id;
6845 Rec_Discr : Entity_Id;
6849 Conc_Discr := First_Discriminant (Ctyp);
6850 Rec_Discr := First_Discriminant (Def_Id);
6851 while Present (Conc_Discr) loop
6852 Temp := Discriminal (Conc_Discr);
6853 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
6854 Set_Discriminal (Rec_Discr, Temp);
6856 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
6857 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
6859 Next_Discriminant (Conc_Discr);
6860 Next_Discriminant (Rec_Discr);
6865 if Has_Controlled_Component (Def_Id) then
6866 Build_Controlling_Procs (Def_Id);
6869 Adjust_Discriminants (Def_Id);
6871 if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then
6873 -- Do not need init for interfaces on e.g. CIL since they're
6874 -- abstract. Helps operation of peverify (the PE Verify tool).
6876 Build_Record_Init_Proc (Type_Decl, Def_Id);
6879 -- For tagged type that are not interfaces, build bodies of primitive
6880 -- operations. Note: do this after building the record initialization
6881 -- procedure, since the primitive operations may need the initialization
6882 -- routine. There is no need to add predefined primitives of interfaces
6883 -- because all their predefined primitives are abstract.
6885 if Is_Tagged_Type (Def_Id)
6886 and then not Is_Interface (Def_Id)
6888 -- Do not add the body of predefined primitives in case of
6889 -- CPP tagged type derivations that have convention CPP.
6891 if Is_CPP_Class (Root_Type (Def_Id))
6892 and then Convention (Def_Id) = Convention_CPP
6896 -- Do not add the body of predefined primitives in case of
6897 -- CIL and Java tagged types.
6899 elsif Convention (Def_Id) = Convention_CIL
6900 or else Convention (Def_Id) = Convention_Java
6904 -- Do not add the body of the predefined primitives if we are
6905 -- compiling under restriction No_Dispatching_Calls or if we are
6906 -- compiling a CPP tagged type.
6908 elsif not Restriction_Active (No_Dispatching_Calls) then
6910 -- Create the body of TSS primitive Finalize_Address. This must
6911 -- be done before the bodies of all predefined primitives are
6912 -- created. If Def_Id is limited, Stream_Input and Stream_Read
6913 -- may produce build-in-place allocations and for those the
6914 -- expander needs Finalize_Address.
6916 Make_Finalize_Address_Body (Def_Id);
6917 Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
6918 Append_Freeze_Actions (Def_Id, Predef_List);
6921 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
6922 -- inherited functions, then add their bodies to the freeze actions.
6924 if Present (Wrapper_Body_List) then
6925 Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
6928 -- Create extra formals for the primitive operations of the type.
6929 -- This must be done before analyzing the body of the initialization
6930 -- procedure, because a self-referential type might call one of these
6931 -- primitives in the body of the init_proc itself.
6938 Elmt := First_Elmt (Primitive_Operations (Def_Id));
6939 while Present (Elmt) loop
6940 Subp := Node (Elmt);
6941 if not Has_Foreign_Convention (Subp)
6942 and then not Is_Predefined_Dispatching_Operation (Subp)
6944 Create_Extra_Formals (Subp);
6952 -- Create a heterogeneous finalization master to service the anonymous
6953 -- access-to-controlled components of the record type.
6957 Encl_Scope : constant Entity_Id := Scope (Def_Id);
6958 Ins_Node : constant Node_Id := Parent (Def_Id);
6959 Loc : constant Source_Ptr := Sloc (Def_Id);
6960 Fin_Mas_Id : Entity_Id;
6962 Attributes_Set : Boolean := False;
6963 Master_Built : Boolean := False;
6964 -- Two flags which control the creation and initialization of a
6965 -- common heterogeneous master.
6968 Comp := First_Component (Def_Id);
6969 while Present (Comp) loop
6970 Comp_Typ := Etype (Comp);
6972 -- A non-self-referential anonymous access-to-controlled
6975 if Ekind (Comp_Typ) = E_Anonymous_Access_Type
6976 and then Needs_Finalization (Designated_Type (Comp_Typ))
6977 and then Designated_Type (Comp_Typ) /= Def_Id
6979 if VM_Target = No_VM then
6981 -- Build a homogeneous master for the first anonymous
6982 -- access-to-controlled component. This master may be
6983 -- converted into a heterogeneous collection if more
6984 -- components are to follow.
6986 if not Master_Built then
6987 Master_Built := True;
6989 -- All anonymous access-to-controlled types allocate
6990 -- on the global pool.
6992 Set_Associated_Storage_Pool (Comp_Typ,
6993 Get_Global_Pool_For_Access_Type (Comp_Typ));
6995 Build_Finalization_Master
6997 Ins_Node => Ins_Node,
6998 Encl_Scope => Encl_Scope);
7000 Fin_Mas_Id := Finalization_Master (Comp_Typ);
7002 -- Subsequent anonymous access-to-controlled components
7003 -- reuse the already available master.
7006 -- All anonymous access-to-controlled types allocate
7007 -- on the global pool.
7009 Set_Associated_Storage_Pool (Comp_Typ,
7010 Get_Global_Pool_For_Access_Type (Comp_Typ));
7012 -- Shared the master among multiple components
7014 Set_Finalization_Master (Comp_Typ, Fin_Mas_Id);
7016 -- Convert the master into a heterogeneous collection.
7019 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
7021 if not Attributes_Set then
7022 Attributes_Set := True;
7024 Insert_Action (Ins_Node,
7025 Make_Procedure_Call_Statement (Loc,
7028 (RTE (RE_Set_Is_Heterogeneous), Loc),
7029 Parameter_Associations => New_List (
7030 New_Occurrence_Of (Fin_Mas_Id, Loc))));
7034 -- Since .NET/JVM targets do not support heterogeneous
7035 -- masters, each component must have its own master.
7038 Build_Finalization_Master
7040 Ins_Node => Ins_Node,
7041 Encl_Scope => Encl_Scope);
7045 Next_Component (Comp);
7050 -- Check whether individual components have a defined invariant,
7051 -- and add the corresponding component invariant checks.
7053 Insert_Component_Invariant_Checks
7054 (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N));
7055 end Expand_Freeze_Record_Type;
7057 ------------------------------
7058 -- Freeze_Stream_Operations --
7059 ------------------------------
7061 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
7062 Names : constant array (1 .. 4) of TSS_Name_Type :=
7067 Stream_Op : Entity_Id;
7070 -- Primitive operations of tagged types are frozen when the dispatch
7071 -- table is constructed.
7073 if not Comes_From_Source (Typ)
7074 or else Is_Tagged_Type (Typ)
7079 for J in Names'Range loop
7080 Stream_Op := TSS (Typ, Names (J));
7082 if Present (Stream_Op)
7083 and then Is_Subprogram (Stream_Op)
7084 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
7085 N_Subprogram_Declaration
7086 and then not Is_Frozen (Stream_Op)
7088 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
7091 end Freeze_Stream_Operations;
7097 -- Full type declarations are expanded at the point at which the type is
7098 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
7099 -- declarations generated by the freezing (e.g. the procedure generated
7100 -- for initialization) are chained in the Actions field list of the freeze
7101 -- node using Append_Freeze_Actions.
7103 function Freeze_Type (N : Node_Id) return Boolean is
7104 Def_Id : constant Entity_Id := Entity (N);
7105 RACW_Seen : Boolean := False;
7106 Result : Boolean := False;
7109 -- Process associated access types needing special processing
7111 if Present (Access_Types_To_Process (N)) then
7113 E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
7115 while Present (E) loop
7117 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
7118 Validate_RACW_Primitives (Node (E));
7128 -- If there are RACWs designating this type, make stubs now
7130 Remote_Types_Tagged_Full_View_Encountered (Def_Id);
7134 -- Freeze processing for record types
7136 if Is_Record_Type (Def_Id) then
7137 if Ekind (Def_Id) = E_Record_Type then
7138 Expand_Freeze_Record_Type (N);
7140 elsif Is_Class_Wide_Type (Def_Id) then
7141 Expand_Freeze_Class_Wide_Type (N);
7144 -- Freeze processing for array types
7146 elsif Is_Array_Type (Def_Id) then
7147 Expand_Freeze_Array_Type (N);
7149 -- Freeze processing for access types
7151 -- For pool-specific access types, find out the pool object used for
7152 -- this type, needs actual expansion of it in some cases. Here are the
7153 -- different cases :
7155 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
7156 -- ---> don't use any storage pool
7158 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
7160 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
7162 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7163 -- ---> Storage Pool is the specified one
7165 -- See GNAT Pool packages in the Run-Time for more details
7167 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
7169 Loc : constant Source_Ptr := Sloc (N);
7170 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
7171 Pool_Object : Entity_Id;
7173 Freeze_Action_Typ : Entity_Id;
7178 -- Rep Clause "for Def_Id'Storage_Size use 0;"
7179 -- ---> don't use any storage pool
7181 if No_Pool_Assigned (Def_Id) then
7186 -- Rep Clause : for Def_Id'Storage_Size use Expr.
7188 -- Def_Id__Pool : Stack_Bounded_Pool
7189 -- (Expr, DT'Size, DT'Alignment);
7191 elsif Has_Storage_Size_Clause (Def_Id) then
7197 -- For unconstrained composite types we give a size of zero
7198 -- so that the pool knows that it needs a special algorithm
7199 -- for variable size object allocation.
7201 if Is_Composite_Type (Desig_Type)
7202 and then not Is_Constrained (Desig_Type)
7205 Make_Integer_Literal (Loc, 0);
7208 Make_Integer_Literal (Loc, Maximum_Alignment);
7212 Make_Attribute_Reference (Loc,
7213 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7214 Attribute_Name => Name_Max_Size_In_Storage_Elements);
7217 Make_Attribute_Reference (Loc,
7218 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7219 Attribute_Name => Name_Alignment);
7223 Make_Defining_Identifier (Loc,
7224 Chars => New_External_Name (Chars (Def_Id), 'P'));
7226 -- We put the code associated with the pools in the entity
7227 -- that has the later freeze node, usually the access type
7228 -- but it can also be the designated_type; because the pool
7229 -- code requires both those types to be frozen
7231 if Is_Frozen (Desig_Type)
7232 and then (No (Freeze_Node (Desig_Type))
7233 or else Analyzed (Freeze_Node (Desig_Type)))
7235 Freeze_Action_Typ := Def_Id;
7237 -- A Taft amendment type cannot get the freeze actions
7238 -- since the full view is not there.
7240 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
7241 and then No (Full_View (Desig_Type))
7243 Freeze_Action_Typ := Def_Id;
7246 Freeze_Action_Typ := Desig_Type;
7249 Append_Freeze_Action (Freeze_Action_Typ,
7250 Make_Object_Declaration (Loc,
7251 Defining_Identifier => Pool_Object,
7252 Object_Definition =>
7253 Make_Subtype_Indication (Loc,
7256 (RTE (RE_Stack_Bounded_Pool), Loc),
7259 Make_Index_Or_Discriminant_Constraint (Loc,
7260 Constraints => New_List (
7262 -- First discriminant is the Pool Size
7265 Storage_Size_Variable (Def_Id), Loc),
7267 -- Second discriminant is the element size
7271 -- Third discriminant is the alignment
7276 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
7280 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7281 -- ---> Storage Pool is the specified one
7283 -- When compiling in Ada 2012 mode, ensure that the accessibility
7284 -- level of the subpool access type is not deeper than that of the
7285 -- pool_with_subpools.
7287 elsif Ada_Version >= Ada_2012
7288 and then Present (Associated_Storage_Pool (Def_Id))
7290 -- Omit this check on .NET/JVM where pools are not supported
7292 and then VM_Target = No_VM
7294 -- Omit this check for the case of a configurable run-time that
7295 -- does not provide package System.Storage_Pools.Subpools.
7297 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
7300 Loc : constant Source_Ptr := Sloc (Def_Id);
7301 Pool : constant Entity_Id :=
7302 Associated_Storage_Pool (Def_Id);
7303 RSPWS : constant Entity_Id :=
7304 RTE (RE_Root_Storage_Pool_With_Subpools);
7307 -- It is known that the accessibility level of the access
7308 -- type is deeper than that of the pool.
7310 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
7311 and then not Accessibility_Checks_Suppressed (Def_Id)
7312 and then not Accessibility_Checks_Suppressed (Pool)
7314 -- Static case: the pool is known to be a descendant of
7315 -- Root_Storage_Pool_With_Subpools.
7317 if Is_Ancestor (RSPWS, Etype (Pool)) then
7319 ("??subpool access type has deeper accessibility " &
7320 "level than pool", Def_Id);
7322 Append_Freeze_Action (Def_Id,
7323 Make_Raise_Program_Error (Loc,
7324 Reason => PE_Accessibility_Check_Failed));
7326 -- Dynamic case: when the pool is of a class-wide type,
7327 -- it may or may not support subpools depending on the
7328 -- path of derivation. Generate:
7330 -- if Def_Id in RSPWS'Class then
7331 -- raise Program_Error;
7334 elsif Is_Class_Wide_Type (Etype (Pool)) then
7335 Append_Freeze_Action (Def_Id,
7336 Make_If_Statement (Loc,
7340 New_Occurrence_Of (Pool, Loc),
7343 (Class_Wide_Type (RSPWS), Loc)),
7345 Then_Statements => New_List (
7346 Make_Raise_Program_Error (Loc,
7347 Reason => PE_Accessibility_Check_Failed))));
7353 -- For access-to-controlled types (including class-wide types and
7354 -- Taft-amendment types, which potentially have controlled
7355 -- components), expand the list controller object that will store
7356 -- the dynamically allocated objects. Don't do this transformation
7357 -- for expander-generated access types, but do it for types that
7358 -- are the full view of types derived from other private types.
7359 -- Also suppress the list controller in the case of a designated
7360 -- type with convention Java, since this is used when binding to
7361 -- Java API specs, where there's no equivalent of a finalization
7362 -- list and we don't want to pull in the finalization support if
7365 if not Comes_From_Source (Def_Id)
7366 and then not Has_Private_Declaration (Def_Id)
7370 -- An exception is made for types defined in the run-time because
7371 -- Ada.Tags.Tag itself is such a type and cannot afford this
7372 -- unnecessary overhead that would generates a loop in the
7373 -- expansion scheme. Another exception is if Restrictions
7374 -- (No_Finalization) is active, since then we know nothing is
7377 elsif Restriction_Active (No_Finalization)
7378 or else In_Runtime (Def_Id)
7382 -- Assume that incomplete and private types are always completed
7383 -- by a controlled full view.
7385 elsif Needs_Finalization (Desig_Type)
7387 (Is_Incomplete_Or_Private_Type (Desig_Type)
7388 and then No (Full_View (Desig_Type)))
7390 (Is_Array_Type (Desig_Type)
7391 and then Needs_Finalization (Component_Type (Desig_Type)))
7393 Build_Finalization_Master (Def_Id);
7397 -- Freeze processing for enumeration types
7399 elsif Ekind (Def_Id) = E_Enumeration_Type then
7401 -- We only have something to do if we have a non-standard
7402 -- representation (i.e. at least one literal whose pos value
7403 -- is not the same as its representation)
7405 if Has_Non_Standard_Rep (Def_Id) then
7406 Expand_Freeze_Enumeration_Type (N);
7409 -- Private types that are completed by a derivation from a private
7410 -- type have an internally generated full view, that needs to be
7411 -- frozen. This must be done explicitly because the two views share
7412 -- the freeze node, and the underlying full view is not visible when
7413 -- the freeze node is analyzed.
7415 elsif Is_Private_Type (Def_Id)
7416 and then Is_Derived_Type (Def_Id)
7417 and then Present (Full_View (Def_Id))
7418 and then Is_Itype (Full_View (Def_Id))
7419 and then Has_Private_Declaration (Full_View (Def_Id))
7420 and then Freeze_Node (Full_View (Def_Id)) = N
7422 Set_Entity (N, Full_View (Def_Id));
7423 Result := Freeze_Type (N);
7424 Set_Entity (N, Def_Id);
7426 -- All other types require no expander action. There are such cases
7427 -- (e.g. task types and protected types). In such cases, the freeze
7428 -- nodes are there for use by Gigi.
7432 Freeze_Stream_Operations (N, Def_Id);
7436 when RE_Not_Available =>
7440 -------------------------
7441 -- Get_Simple_Init_Val --
7442 -------------------------
7444 function Get_Simple_Init_Val
7447 Size : Uint := No_Uint) return Node_Id
7449 Loc : constant Source_Ptr := Sloc (N);
7455 -- This is the size to be used for computation of the appropriate
7456 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
7458 IV_Attribute : constant Boolean :=
7459 Nkind (N) = N_Attribute_Reference
7460 and then Attribute_Name (N) = Name_Invalid_Value;
7464 -- These are the values computed by the procedure Check_Subtype_Bounds
7466 procedure Check_Subtype_Bounds;
7467 -- This procedure examines the subtype T, and its ancestor subtypes and
7468 -- derived types to determine the best known information about the
7469 -- bounds of the subtype. After the call Lo_Bound is set either to
7470 -- No_Uint if no information can be determined, or to a value which
7471 -- represents a known low bound, i.e. a valid value of the subtype can
7472 -- not be less than this value. Hi_Bound is similarly set to a known
7473 -- high bound (valid value cannot be greater than this).
7475 --------------------------
7476 -- Check_Subtype_Bounds --
7477 --------------------------
7479 procedure Check_Subtype_Bounds is
7488 Lo_Bound := No_Uint;
7489 Hi_Bound := No_Uint;
7491 -- Loop to climb ancestor subtypes and derived types
7495 if not Is_Discrete_Type (ST1) then
7499 Lo := Type_Low_Bound (ST1);
7500 Hi := Type_High_Bound (ST1);
7502 if Compile_Time_Known_Value (Lo) then
7503 Loval := Expr_Value (Lo);
7505 if Lo_Bound = No_Uint or else Lo_Bound < Loval then
7510 if Compile_Time_Known_Value (Hi) then
7511 Hival := Expr_Value (Hi);
7513 if Hi_Bound = No_Uint or else Hi_Bound > Hival then
7518 ST2 := Ancestor_Subtype (ST1);
7524 exit when ST1 = ST2;
7527 end Check_Subtype_Bounds;
7529 -- Start of processing for Get_Simple_Init_Val
7532 -- For a private type, we should always have an underlying type
7533 -- (because this was already checked in Needs_Simple_Initialization).
7534 -- What we do is to get the value for the underlying type and then do
7535 -- an Unchecked_Convert to the private type.
7537 if Is_Private_Type (T) then
7538 Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
7540 -- A special case, if the underlying value is null, then qualify it
7541 -- with the underlying type, so that the null is properly typed
7542 -- Similarly, if it is an aggregate it must be qualified, because an
7543 -- unchecked conversion does not provide a context for it.
7545 if Nkind_In (Val, N_Null, N_Aggregate) then
7547 Make_Qualified_Expression (Loc,
7549 New_Occurrence_Of (Underlying_Type (T), Loc),
7553 Result := Unchecked_Convert_To (T, Val);
7555 -- Don't truncate result (important for Initialize/Normalize_Scalars)
7557 if Nkind (Result) = N_Unchecked_Type_Conversion
7558 and then Is_Scalar_Type (Underlying_Type (T))
7560 Set_No_Truncation (Result);
7565 -- Scalars with Default_Value aspect. The first subtype may now be
7566 -- private, so retrieve value from underlying type.
7568 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
7569 if Is_Private_Type (First_Subtype (T)) then
7570 return Unchecked_Convert_To (T,
7571 Default_Aspect_Value (Full_View (First_Subtype (T))));
7574 Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
7577 -- Otherwise, for scalars, we must have normalize/initialize scalars
7578 -- case, or if the node N is an 'Invalid_Value attribute node.
7580 elsif Is_Scalar_Type (T) then
7581 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
7583 -- Compute size of object. If it is given by the caller, we can use
7584 -- it directly, otherwise we use Esize (T) as an estimate. As far as
7585 -- we know this covers all cases correctly.
7587 if Size = No_Uint or else Size <= Uint_0 then
7588 Size_To_Use := UI_Max (Uint_1, Esize (T));
7590 Size_To_Use := Size;
7593 -- Maximum size to use is 64 bits, since we will create values of
7594 -- type Unsigned_64 and the range must fit this type.
7596 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
7597 Size_To_Use := Uint_64;
7600 -- Check known bounds of subtype
7602 Check_Subtype_Bounds;
7604 -- Processing for Normalize_Scalars case
7606 if Normalize_Scalars and then not IV_Attribute then
7608 -- If zero is invalid, it is a convenient value to use that is
7609 -- for sure an appropriate invalid value in all situations.
7611 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7612 Val := Make_Integer_Literal (Loc, 0);
7614 -- Cases where all one bits is the appropriate invalid value
7616 -- For modular types, all 1 bits is either invalid or valid. If
7617 -- it is valid, then there is nothing that can be done since there
7618 -- are no invalid values (we ruled out zero already).
7620 -- For signed integer types that have no negative values, either
7621 -- there is room for negative values, or there is not. If there
7622 -- is, then all 1-bits may be interpreted as minus one, which is
7623 -- certainly invalid. Alternatively it is treated as the largest
7624 -- positive value, in which case the observation for modular types
7627 -- For float types, all 1-bits is a NaN (not a number), which is
7628 -- certainly an appropriately invalid value.
7630 elsif Is_Unsigned_Type (T)
7631 or else Is_Floating_Point_Type (T)
7632 or else Is_Enumeration_Type (T)
7634 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
7636 -- Resolve as Unsigned_64, because the largest number we can
7637 -- generate is out of range of universal integer.
7639 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
7641 -- Case of signed types
7645 Signed_Size : constant Uint :=
7646 UI_Min (Uint_63, Size_To_Use - 1);
7649 -- Normally we like to use the most negative number. The one
7650 -- exception is when this number is in the known subtype
7651 -- range and the largest positive number is not in the known
7654 -- For this exceptional case, use largest positive value
7656 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
7657 and then Lo_Bound <= (-(2 ** Signed_Size))
7658 and then Hi_Bound < 2 ** Signed_Size
7660 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
7662 -- Normal case of largest negative value
7665 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
7670 -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
7673 -- For float types, use float values from System.Scalar_Values
7675 if Is_Floating_Point_Type (T) then
7676 if Root_Type (T) = Standard_Short_Float then
7677 Val_RE := RE_IS_Isf;
7678 elsif Root_Type (T) = Standard_Float then
7679 Val_RE := RE_IS_Ifl;
7680 elsif Root_Type (T) = Standard_Long_Float then
7681 Val_RE := RE_IS_Ilf;
7682 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
7683 Val_RE := RE_IS_Ill;
7686 -- If zero is invalid, use zero values from System.Scalar_Values
7688 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7689 if Size_To_Use <= 8 then
7690 Val_RE := RE_IS_Iz1;
7691 elsif Size_To_Use <= 16 then
7692 Val_RE := RE_IS_Iz2;
7693 elsif Size_To_Use <= 32 then
7694 Val_RE := RE_IS_Iz4;
7696 Val_RE := RE_IS_Iz8;
7699 -- For unsigned, use unsigned values from System.Scalar_Values
7701 elsif Is_Unsigned_Type (T) then
7702 if Size_To_Use <= 8 then
7703 Val_RE := RE_IS_Iu1;
7704 elsif Size_To_Use <= 16 then
7705 Val_RE := RE_IS_Iu2;
7706 elsif Size_To_Use <= 32 then
7707 Val_RE := RE_IS_Iu4;
7709 Val_RE := RE_IS_Iu8;
7712 -- For signed, use signed values from System.Scalar_Values
7715 if Size_To_Use <= 8 then
7716 Val_RE := RE_IS_Is1;
7717 elsif Size_To_Use <= 16 then
7718 Val_RE := RE_IS_Is2;
7719 elsif Size_To_Use <= 32 then
7720 Val_RE := RE_IS_Is4;
7722 Val_RE := RE_IS_Is8;
7726 Val := New_Occurrence_Of (RTE (Val_RE), Loc);
7729 -- The final expression is obtained by doing an unchecked conversion
7730 -- of this result to the base type of the required subtype. We use
7731 -- the base type to prevent the unchecked conversion from chopping
7732 -- bits, and then we set Kill_Range_Check to preserve the "bad"
7735 Result := Unchecked_Convert_To (Base_Type (T), Val);
7737 -- Ensure result is not truncated, since we want the "bad" bits, and
7738 -- also kill range check on result.
7740 if Nkind (Result) = N_Unchecked_Type_Conversion then
7741 Set_No_Truncation (Result);
7742 Set_Kill_Range_Check (Result, True);
7747 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
7749 elsif Root_Type (T) = Standard_String
7751 Root_Type (T) = Standard_Wide_String
7753 Root_Type (T) = Standard_Wide_Wide_String
7755 pragma Assert (Init_Or_Norm_Scalars);
7758 Make_Aggregate (Loc,
7759 Component_Associations => New_List (
7760 Make_Component_Association (Loc,
7761 Choices => New_List (
7762 Make_Others_Choice (Loc)),
7765 (Component_Type (T), N, Esize (Root_Type (T))))));
7767 -- Access type is initialized to null
7769 elsif Is_Access_Type (T) then
7770 return Make_Null (Loc);
7772 -- No other possibilities should arise, since we should only be calling
7773 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
7774 -- indicating one of the above cases held.
7777 raise Program_Error;
7781 when RE_Not_Available =>
7783 end Get_Simple_Init_Val;
7785 ------------------------------
7786 -- Has_New_Non_Standard_Rep --
7787 ------------------------------
7789 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
7791 if not Is_Derived_Type (T) then
7792 return Has_Non_Standard_Rep (T)
7793 or else Has_Non_Standard_Rep (Root_Type (T));
7795 -- If Has_Non_Standard_Rep is not set on the derived type, the
7796 -- representation is fully inherited.
7798 elsif not Has_Non_Standard_Rep (T) then
7802 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
7804 -- May need a more precise check here: the First_Rep_Item may
7805 -- be a stream attribute, which does not affect the representation
7808 end Has_New_Non_Standard_Rep;
7814 function In_Runtime (E : Entity_Id) return Boolean is
7819 while Scope (S1) /= Standard_Standard loop
7823 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
7826 ---------------------------------------
7827 -- Insert_Component_Invariant_Checks --
7828 ---------------------------------------
7830 procedure Insert_Component_Invariant_Checks
7835 Loc : constant Source_Ptr := Sloc (Typ);
7836 Proc_Id : Entity_Id;
7839 if Present (Proc) then
7840 Proc_Id := Defining_Entity (Proc);
7842 if not Has_Invariants (Typ) then
7843 Set_Has_Invariants (Typ);
7844 Set_Is_Invariant_Procedure (Proc_Id);
7845 Set_Invariant_Procedure (Typ, Proc_Id);
7846 Insert_After (N, Proc);
7851 -- Find already created invariant body, insert body of component
7852 -- invariant proc in it, and add call after other checks.
7856 Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
7857 Call : constant Node_Id :=
7858 Make_Procedure_Call_Statement (Loc,
7859 Name => New_Occurrence_Of (Proc_Id, Loc),
7860 Parameter_Associations =>
7862 (New_Occurrence_Of (First_Formal (Inv_Id), Loc)));
7866 -- The invariant body has not been analyzed yet, so we do a
7867 -- sequential search forward, and retrieve it by name.
7870 while Present (Bod) loop
7871 exit when Nkind (Bod) = N_Subprogram_Body
7872 and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id);
7876 Append_To (Declarations (Bod), Proc);
7877 Append_To (Statements (Handled_Statement_Sequence (Bod)), Call);
7881 end Insert_Component_Invariant_Checks;
7883 ----------------------------
7884 -- Initialization_Warning --
7885 ----------------------------
7887 procedure Initialization_Warning (E : Entity_Id) is
7888 Warning_Needed : Boolean;
7891 Warning_Needed := False;
7893 if Ekind (Current_Scope) = E_Package
7894 and then Static_Elaboration_Desired (Current_Scope)
7897 if Is_Record_Type (E) then
7898 if Has_Discriminants (E)
7899 or else Is_Limited_Type (E)
7900 or else Has_Non_Standard_Rep (E)
7902 Warning_Needed := True;
7905 -- Verify that at least one component has an initialization
7906 -- expression. No need for a warning on a type if all its
7907 -- components have no initialization.
7913 Comp := First_Component (E);
7914 while Present (Comp) loop
7915 if Ekind (Comp) = E_Discriminant
7917 (Nkind (Parent (Comp)) = N_Component_Declaration
7918 and then Present (Expression (Parent (Comp))))
7920 Warning_Needed := True;
7924 Next_Component (Comp);
7929 if Warning_Needed then
7931 ("Objects of the type cannot be initialized "
7932 & "statically by default??", Parent (E));
7937 Error_Msg_N ("Object cannot be initialized statically??", E);
7940 end Initialization_Warning;
7946 function Init_Formals (Typ : Entity_Id) return List_Id is
7947 Loc : constant Source_Ptr := Sloc (Typ);
7951 -- First parameter is always _Init : in out typ. Note that we need
7952 -- this to be in/out because in the case of the task record value,
7953 -- there are default record fields (_Priority, _Size, -Task_Info)
7954 -- that may be referenced in the generated initialization routine.
7956 Formals := New_List (
7957 Make_Parameter_Specification (Loc,
7958 Defining_Identifier =>
7959 Make_Defining_Identifier (Loc, Name_uInit),
7961 Out_Present => True,
7962 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
7964 -- For task record value, or type that contains tasks, add two more
7965 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
7966 -- We also add these parameters for the task record type case.
7969 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
7972 Make_Parameter_Specification (Loc,
7973 Defining_Identifier =>
7974 Make_Defining_Identifier (Loc, Name_uMaster),
7976 New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
7978 -- Add _Chain (not done for sequential elaboration policy, see
7979 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
7981 if Partition_Elaboration_Policy /= 'S' then
7983 Make_Parameter_Specification (Loc,
7984 Defining_Identifier =>
7985 Make_Defining_Identifier (Loc, Name_uChain),
7987 Out_Present => True,
7989 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
7993 Make_Parameter_Specification (Loc,
7994 Defining_Identifier =>
7995 Make_Defining_Identifier (Loc, Name_uTask_Name),
7997 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
8003 when RE_Not_Available =>
8007 -------------------------
8008 -- Init_Secondary_Tags --
8009 -------------------------
8011 procedure Init_Secondary_Tags
8014 Stmts_List : List_Id;
8015 Fixed_Comps : Boolean := True;
8016 Variable_Comps : Boolean := True)
8018 Loc : constant Source_Ptr := Sloc (Target);
8020 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
8021 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8023 procedure Initialize_Tag
8026 Tag_Comp : Entity_Id;
8027 Iface_Tag : Node_Id);
8028 -- Initialize the tag of the secondary dispatch table of Typ associated
8029 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
8030 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
8031 -- of Typ CPP tagged type we generate code to inherit the contents of
8032 -- the dispatch table directly from the ancestor.
8034 --------------------
8035 -- Initialize_Tag --
8036 --------------------
8038 procedure Initialize_Tag
8041 Tag_Comp : Entity_Id;
8042 Iface_Tag : Node_Id)
8044 Comp_Typ : Entity_Id;
8045 Offset_To_Top_Comp : Entity_Id := Empty;
8048 -- Initialize the pointer to the secondary DT associated with the
8051 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8052 Append_To (Stmts_List,
8053 Make_Assignment_Statement (Loc,
8055 Make_Selected_Component (Loc,
8056 Prefix => New_Copy_Tree (Target),
8057 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8059 New_Occurrence_Of (Iface_Tag, Loc)));
8062 Comp_Typ := Scope (Tag_Comp);
8064 -- Initialize the entries of the table of interfaces. We generate a
8065 -- different call when the parent of the type has variable size
8068 if Comp_Typ /= Etype (Comp_Typ)
8069 and then Is_Variable_Size_Record (Etype (Comp_Typ))
8070 and then Chars (Tag_Comp) /= Name_uTag
8072 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
8074 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
8075 -- configurable run-time environment.
8077 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
8079 ("variable size record with interface types", Typ);
8084 -- Set_Dynamic_Offset_To_Top
8086 -- Interface_T => Iface'Tag,
8087 -- Offset_Value => n,
8088 -- Offset_Func => Fn'Address)
8090 Append_To (Stmts_List,
8091 Make_Procedure_Call_Statement (Loc,
8092 Name => New_Occurrence_Of
8093 (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
8094 Parameter_Associations => New_List (
8095 Make_Attribute_Reference (Loc,
8096 Prefix => New_Copy_Tree (Target),
8097 Attribute_Name => Name_Address),
8099 Unchecked_Convert_To (RTE (RE_Tag),
8101 (Node (First_Elmt (Access_Disp_Table (Iface))),
8104 Unchecked_Convert_To
8105 (RTE (RE_Storage_Offset),
8106 Make_Attribute_Reference (Loc,
8108 Make_Selected_Component (Loc,
8109 Prefix => New_Copy_Tree (Target),
8111 New_Occurrence_Of (Tag_Comp, Loc)),
8112 Attribute_Name => Name_Position)),
8114 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
8115 Make_Attribute_Reference (Loc,
8116 Prefix => New_Occurrence_Of
8117 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
8118 Attribute_Name => Name_Address)))));
8120 -- In this case the next component stores the value of the
8121 -- offset to the top.
8123 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
8124 pragma Assert (Present (Offset_To_Top_Comp));
8126 Append_To (Stmts_List,
8127 Make_Assignment_Statement (Loc,
8129 Make_Selected_Component (Loc,
8130 Prefix => New_Copy_Tree (Target),
8131 Selector_Name => New_Occurrence_Of
8132 (Offset_To_Top_Comp, Loc)),
8134 Make_Attribute_Reference (Loc,
8136 Make_Selected_Component (Loc,
8137 Prefix => New_Copy_Tree (Target),
8138 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8139 Attribute_Name => Name_Position)));
8141 -- Normal case: No discriminants in the parent type
8144 -- Don't need to set any value if this interface shares the
8145 -- primary dispatch table.
8147 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8148 Append_To (Stmts_List,
8149 Build_Set_Static_Offset_To_Top (Loc,
8150 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
8152 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8153 Make_Attribute_Reference (Loc,
8155 Make_Selected_Component (Loc,
8156 Prefix => New_Copy_Tree (Target),
8158 New_Occurrence_Of (Tag_Comp, Loc)),
8159 Attribute_Name => Name_Position))));
8163 -- Register_Interface_Offset
8165 -- Interface_T => Iface'Tag,
8166 -- Is_Constant => True,
8167 -- Offset_Value => n,
8168 -- Offset_Func => null);
8170 if RTE_Available (RE_Register_Interface_Offset) then
8171 Append_To (Stmts_List,
8172 Make_Procedure_Call_Statement (Loc,
8173 Name => New_Occurrence_Of
8174 (RTE (RE_Register_Interface_Offset), Loc),
8175 Parameter_Associations => New_List (
8176 Make_Attribute_Reference (Loc,
8177 Prefix => New_Copy_Tree (Target),
8178 Attribute_Name => Name_Address),
8180 Unchecked_Convert_To (RTE (RE_Tag),
8182 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
8184 New_Occurrence_Of (Standard_True, Loc),
8186 Unchecked_Convert_To
8187 (RTE (RE_Storage_Offset),
8188 Make_Attribute_Reference (Loc,
8190 Make_Selected_Component (Loc,
8191 Prefix => New_Copy_Tree (Target),
8193 New_Occurrence_Of (Tag_Comp, Loc)),
8194 Attribute_Name => Name_Position)),
8203 Full_Typ : Entity_Id;
8204 Ifaces_List : Elist_Id;
8205 Ifaces_Comp_List : Elist_Id;
8206 Ifaces_Tag_List : Elist_Id;
8207 Iface_Elmt : Elmt_Id;
8208 Iface_Comp_Elmt : Elmt_Id;
8209 Iface_Tag_Elmt : Elmt_Id;
8211 In_Variable_Pos : Boolean;
8213 -- Start of processing for Init_Secondary_Tags
8216 -- Handle private types
8218 if Present (Full_View (Typ)) then
8219 Full_Typ := Full_View (Typ);
8224 Collect_Interfaces_Info
8225 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
8227 Iface_Elmt := First_Elmt (Ifaces_List);
8228 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
8229 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
8230 while Present (Iface_Elmt) loop
8231 Tag_Comp := Node (Iface_Comp_Elmt);
8233 -- Check if parent of record type has variable size components
8235 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
8236 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
8238 -- If we are compiling under the CPP full ABI compatibility mode and
8239 -- the ancestor is a CPP_Pragma tagged type then we generate code to
8240 -- initialize the secondary tag components from tags that reference
8241 -- secondary tables filled with copy of parent slots.
8243 if Is_CPP_Class (Root_Type (Full_Typ)) then
8245 -- Reject interface components located at variable offset in
8246 -- C++ derivations. This is currently unsupported.
8248 if not Fixed_Comps and then In_Variable_Pos then
8250 -- Locate the first dynamic component of the record. Done to
8251 -- improve the text of the warning.
8255 Comp_Typ : Entity_Id;
8258 Comp := First_Entity (Typ);
8259 while Present (Comp) loop
8260 Comp_Typ := Etype (Comp);
8262 if Ekind (Comp) /= E_Discriminant
8263 and then not Is_Tag (Comp)
8266 (Is_Record_Type (Comp_Typ)
8267 and then Is_Variable_Size_Record
8268 (Base_Type (Comp_Typ)))
8270 (Is_Array_Type (Comp_Typ)
8271 and then Is_Variable_Size_Array (Comp_Typ));
8277 pragma Assert (Present (Comp));
8278 Error_Msg_Node_2 := Comp;
8280 ("parent type & with dynamic component & cannot be parent"
8281 & " of 'C'P'P derivation if new interfaces are present",
8282 Typ, Scope (Original_Record_Component (Comp)));
8285 Sloc (Scope (Original_Record_Component (Comp)));
8287 ("type derived from 'C'P'P type & defined #",
8288 Typ, Scope (Original_Record_Component (Comp)));
8290 -- Avoid duplicated warnings
8295 -- Initialize secondary tags
8298 Append_To (Stmts_List,
8299 Make_Assignment_Statement (Loc,
8301 Make_Selected_Component (Loc,
8302 Prefix => New_Copy_Tree (Target),
8304 New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
8306 New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
8309 -- Otherwise generate code to initialize the tag
8312 if (In_Variable_Pos and then Variable_Comps)
8313 or else (not In_Variable_Pos and then Fixed_Comps)
8315 Initialize_Tag (Full_Typ,
8316 Iface => Node (Iface_Elmt),
8317 Tag_Comp => Tag_Comp,
8318 Iface_Tag => Node (Iface_Tag_Elmt));
8322 Next_Elmt (Iface_Elmt);
8323 Next_Elmt (Iface_Comp_Elmt);
8324 Next_Elmt (Iface_Tag_Elmt);
8326 end Init_Secondary_Tags;
8328 ------------------------
8329 -- Is_User_Defined_Eq --
8330 ------------------------
8332 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
8334 return Chars (Prim) = Name_Op_Eq
8335 and then Etype (First_Formal (Prim)) =
8336 Etype (Next_Formal (First_Formal (Prim)))
8337 and then Base_Type (Etype (Prim)) = Standard_Boolean;
8338 end Is_User_Defined_Equality;
8340 ----------------------------------------
8341 -- Make_Controlling_Function_Wrappers --
8342 ----------------------------------------
8344 procedure Make_Controlling_Function_Wrappers
8345 (Tag_Typ : Entity_Id;
8346 Decl_List : out List_Id;
8347 Body_List : out List_Id)
8349 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8350 Prim_Elmt : Elmt_Id;
8352 Actual_List : List_Id;
8353 Formal_List : List_Id;
8355 Par_Formal : Entity_Id;
8356 Formal_Node : Node_Id;
8357 Func_Body : Node_Id;
8358 Func_Decl : Node_Id;
8359 Func_Spec : Node_Id;
8360 Return_Stmt : Node_Id;
8363 Decl_List := New_List;
8364 Body_List := New_List;
8366 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8368 while Present (Prim_Elmt) loop
8369 Subp := Node (Prim_Elmt);
8371 -- If a primitive function with a controlling result of the type has
8372 -- not been overridden by the user, then we must create a wrapper
8373 -- function here that effectively overrides it and invokes the
8374 -- (non-abstract) parent function. This can only occur for a null
8375 -- extension. Note that functions with anonymous controlling access
8376 -- results don't qualify and must be overridden. We also exclude
8377 -- Input attributes, since each type will have its own version of
8378 -- Input constructed by the expander. The test for Comes_From_Source
8379 -- is needed to distinguish inherited operations from renamings
8380 -- (which also have Alias set). We exclude internal entities with
8381 -- Interface_Alias to avoid generating duplicated wrappers since
8382 -- the primitive which covers the interface is also available in
8383 -- the list of primitive operations.
8385 -- The function may be abstract, or require_Overriding may be set
8386 -- for it, because tests for null extensions may already have reset
8387 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
8388 -- set, functions that need wrappers are recognized by having an
8389 -- alias that returns the parent type.
8391 if Comes_From_Source (Subp)
8392 or else No (Alias (Subp))
8393 or else Present (Interface_Alias (Subp))
8394 or else Ekind (Subp) /= E_Function
8395 or else not Has_Controlling_Result (Subp)
8396 or else Is_Access_Type (Etype (Subp))
8397 or else Is_Abstract_Subprogram (Alias (Subp))
8398 or else Is_TSS (Subp, TSS_Stream_Input)
8402 elsif Is_Abstract_Subprogram (Subp)
8403 or else Requires_Overriding (Subp)
8405 (Is_Null_Extension (Etype (Subp))
8406 and then Etype (Alias (Subp)) /= Etype (Subp))
8408 Formal_List := No_List;
8409 Formal := First_Formal (Subp);
8411 if Present (Formal) then
8412 Formal_List := New_List;
8414 while Present (Formal) loop
8416 (Make_Parameter_Specification
8418 Defining_Identifier =>
8419 Make_Defining_Identifier (Sloc (Formal),
8420 Chars => Chars (Formal)),
8421 In_Present => In_Present (Parent (Formal)),
8422 Out_Present => Out_Present (Parent (Formal)),
8423 Null_Exclusion_Present =>
8424 Null_Exclusion_Present (Parent (Formal)),
8426 New_Occurrence_Of (Etype (Formal), Loc),
8428 New_Copy_Tree (Expression (Parent (Formal)))),
8431 Next_Formal (Formal);
8436 Make_Function_Specification (Loc,
8437 Defining_Unit_Name =>
8438 Make_Defining_Identifier (Loc,
8439 Chars => Chars (Subp)),
8440 Parameter_Specifications => Formal_List,
8441 Result_Definition =>
8442 New_Occurrence_Of (Etype (Subp), Loc));
8444 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
8445 Append_To (Decl_List, Func_Decl);
8447 -- Build a wrapper body that calls the parent function. The body
8448 -- contains a single return statement that returns an extension
8449 -- aggregate whose ancestor part is a call to the parent function,
8450 -- passing the formals as actuals (with any controlling arguments
8451 -- converted to the types of the corresponding formals of the
8452 -- parent function, which might be anonymous access types), and
8453 -- having a null extension.
8455 Formal := First_Formal (Subp);
8456 Par_Formal := First_Formal (Alias (Subp));
8457 Formal_Node := First (Formal_List);
8459 if Present (Formal) then
8460 Actual_List := New_List;
8462 Actual_List := No_List;
8465 while Present (Formal) loop
8466 if Is_Controlling_Formal (Formal) then
8467 Append_To (Actual_List,
8468 Make_Type_Conversion (Loc,
8470 New_Occurrence_Of (Etype (Par_Formal), Loc),
8473 (Defining_Identifier (Formal_Node), Loc)));
8478 (Defining_Identifier (Formal_Node), Loc));
8481 Next_Formal (Formal);
8482 Next_Formal (Par_Formal);
8487 Make_Simple_Return_Statement (Loc,
8489 Make_Extension_Aggregate (Loc,
8491 Make_Function_Call (Loc,
8492 Name => New_Occurrence_Of (Alias (Subp), Loc),
8493 Parameter_Associations => Actual_List),
8494 Null_Record_Present => True));
8497 Make_Subprogram_Body (Loc,
8498 Specification => New_Copy_Tree (Func_Spec),
8499 Declarations => Empty_List,
8500 Handled_Statement_Sequence =>
8501 Make_Handled_Sequence_Of_Statements (Loc,
8502 Statements => New_List (Return_Stmt)));
8504 Set_Defining_Unit_Name
8505 (Specification (Func_Body),
8506 Make_Defining_Identifier (Loc, Chars (Subp)));
8508 Append_To (Body_List, Func_Body);
8510 -- Replace the inherited function with the wrapper function in the
8511 -- primitive operations list. We add the minimum decoration needed
8512 -- to override interface primitives.
8514 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
8516 Override_Dispatching_Operation
8517 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
8518 Is_Wrapper => True);
8522 Next_Elmt (Prim_Elmt);
8524 end Make_Controlling_Function_Wrappers;
8530 function Make_Eq_Body
8532 Eq_Name : Name_Id) return Node_Id
8534 Loc : constant Source_Ptr := Sloc (Parent (Typ));
8536 Def : constant Node_Id := Parent (Typ);
8537 Stmts : constant List_Id := New_List;
8538 Variant_Case : Boolean := Has_Discriminants (Typ);
8539 Comps : Node_Id := Empty;
8540 Typ_Def : Node_Id := Type_Definition (Def);
8544 Predef_Spec_Or_Body (Loc,
8547 Profile => New_List (
8548 Make_Parameter_Specification (Loc,
8549 Defining_Identifier =>
8550 Make_Defining_Identifier (Loc, Name_X),
8551 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8553 Make_Parameter_Specification (Loc,
8554 Defining_Identifier =>
8555 Make_Defining_Identifier (Loc, Name_Y),
8556 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8558 Ret_Type => Standard_Boolean,
8561 if Variant_Case then
8562 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8563 Typ_Def := Record_Extension_Part (Typ_Def);
8566 if Present (Typ_Def) then
8567 Comps := Component_List (Typ_Def);
8571 Present (Comps) and then Present (Variant_Part (Comps));
8574 if Variant_Case then
8576 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
8577 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
8579 Make_Simple_Return_Statement (Loc,
8580 Expression => New_Occurrence_Of (Standard_True, Loc)));
8584 Make_Simple_Return_Statement (Loc,
8586 Expand_Record_Equality
8589 Lhs => Make_Identifier (Loc, Name_X),
8590 Rhs => Make_Identifier (Loc, Name_Y),
8591 Bodies => Declarations (Decl))));
8594 Set_Handled_Statement_Sequence
8595 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8603 -- <Make_Eq_If shared components>
8605 -- when V1 => <Make_Eq_Case> on subcomponents
8607 -- when Vn => <Make_Eq_Case> on subcomponents
8610 function Make_Eq_Case
8613 Discrs : Elist_Id := New_Elmt_List) return List_Id
8615 Loc : constant Source_Ptr := Sloc (E);
8616 Result : constant List_Id := New_List;
8620 function Corresponding_Formal (C : Node_Id) return Entity_Id;
8621 -- Given the discriminant that controls a given variant of an unchecked
8622 -- union, find the formal of the equality function that carries the
8623 -- inferred value of the discriminant.
8625 function External_Name (E : Entity_Id) return Name_Id;
8626 -- The value of a given discriminant is conveyed in the corresponding
8627 -- formal parameter of the equality routine. The name of this formal
8628 -- parameter carries a one-character suffix which is removed here.
8630 --------------------------
8631 -- Corresponding_Formal --
8632 --------------------------
8634 function Corresponding_Formal (C : Node_Id) return Entity_Id is
8635 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
8639 Elm := First_Elmt (Discrs);
8640 while Present (Elm) loop
8641 if Chars (Discr) = External_Name (Node (Elm)) then
8647 -- A formal of the proper name must be found
8649 raise Program_Error;
8650 end Corresponding_Formal;
8656 function External_Name (E : Entity_Id) return Name_Id is
8658 Get_Name_String (Chars (E));
8659 Name_Len := Name_Len - 1;
8663 -- Start of processing for Make_Eq_Case
8666 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
8668 if No (Variant_Part (CL)) then
8672 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
8674 if No (Variant) then
8678 Alt_List := New_List;
8680 while Present (Variant) loop
8681 Append_To (Alt_List,
8682 Make_Case_Statement_Alternative (Loc,
8683 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
8685 Make_Eq_Case (E, Component_List (Variant), Discrs)));
8687 Next_Non_Pragma (Variant);
8690 -- If we have an Unchecked_Union, use one of the parameters of the
8691 -- enclosing equality routine that captures the discriminant, to use
8692 -- as the expression in the generated case statement.
8694 if Is_Unchecked_Union (E) then
8696 Make_Case_Statement (Loc,
8698 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
8699 Alternatives => Alt_List));
8703 Make_Case_Statement (Loc,
8705 Make_Selected_Component (Loc,
8706 Prefix => Make_Identifier (Loc, Name_X),
8707 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
8708 Alternatives => Alt_List));
8729 -- or a null statement if the list L is empty
8733 L : List_Id) return Node_Id
8735 Loc : constant Source_Ptr := Sloc (E);
8737 Field_Name : Name_Id;
8742 return Make_Null_Statement (Loc);
8747 C := First_Non_Pragma (L);
8748 while Present (C) loop
8749 Field_Name := Chars (Defining_Identifier (C));
8751 -- The tags must not be compared: they are not part of the value.
8752 -- Ditto for parent interfaces because their equality operator is
8755 -- Note also that in the following, we use Make_Identifier for
8756 -- the component names. Use of New_Occurrence_Of to identify the
8757 -- components would be incorrect because the wrong entities for
8758 -- discriminants could be picked up in the private type case.
8760 if Field_Name = Name_uParent
8761 and then Is_Interface (Etype (Defining_Identifier (C)))
8765 elsif Field_Name /= Name_uTag then
8766 Evolve_Or_Else (Cond,
8769 Make_Selected_Component (Loc,
8770 Prefix => Make_Identifier (Loc, Name_X),
8771 Selector_Name => Make_Identifier (Loc, Field_Name)),
8774 Make_Selected_Component (Loc,
8775 Prefix => Make_Identifier (Loc, Name_Y),
8776 Selector_Name => Make_Identifier (Loc, Field_Name))));
8779 Next_Non_Pragma (C);
8783 return Make_Null_Statement (Loc);
8787 Make_Implicit_If_Statement (E,
8789 Then_Statements => New_List (
8790 Make_Simple_Return_Statement (Loc,
8791 Expression => New_Occurrence_Of (Standard_False, Loc))));
8796 --------------------
8798 --------------------
8800 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
8802 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
8803 -- Returns true if Prim is a renaming of an unresolved predefined
8804 -- inequality operation.
8806 --------------------------------
8807 -- Is_Predefined_Neq_Renaming --
8808 --------------------------------
8810 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
8812 return Chars (Prim) /= Name_Op_Ne
8813 and then Present (Alias (Prim))
8814 and then Comes_From_Source (Prim)
8815 and then Is_Intrinsic_Subprogram (Alias (Prim))
8816 and then Chars (Alias (Prim)) = Name_Op_Ne;
8817 end Is_Predefined_Neq_Renaming;
8821 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
8822 Stmts : constant List_Id := New_List;
8824 Eq_Prim : Entity_Id;
8825 Left_Op : Entity_Id;
8826 Renaming_Prim : Entity_Id;
8827 Right_Op : Entity_Id;
8830 -- Start of processing for Make_Neq_Body
8833 -- For a call on a renaming of a dispatching subprogram that is
8834 -- overridden, if the overriding occurred before the renaming, then
8835 -- the body executed is that of the overriding declaration, even if the
8836 -- overriding declaration is not visible at the place of the renaming;
8837 -- otherwise, the inherited or predefined subprogram is called, see
8840 -- Stage 1: Search for a renaming of the inequality primitive and also
8841 -- search for an overriding of the equality primitive located before the
8842 -- renaming declaration.
8850 Renaming_Prim := Empty;
8852 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8853 while Present (Elmt) loop
8854 Prim := Node (Elmt);
8856 if Is_User_Defined_Equality (Prim)
8857 and then No (Alias (Prim))
8859 if No (Renaming_Prim) then
8860 pragma Assert (No (Eq_Prim));
8864 elsif Is_Predefined_Neq_Renaming (Prim) then
8865 Renaming_Prim := Prim;
8872 -- No further action needed if no renaming was found
8874 if No (Renaming_Prim) then
8878 -- Stage 2: Replace the renaming declaration by a subprogram declaration
8879 -- (required to add its body)
8881 Decl := Parent (Parent (Renaming_Prim));
8883 Make_Subprogram_Declaration (Loc,
8884 Specification => Specification (Decl)));
8885 Set_Analyzed (Decl);
8887 -- Remove the decoration of intrinsic renaming subprogram
8889 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
8890 Set_Convention (Renaming_Prim, Convention_Ada);
8891 Set_Alias (Renaming_Prim, Empty);
8892 Set_Has_Completion (Renaming_Prim, False);
8894 -- Stage 3: Build the corresponding body
8896 Left_Op := First_Formal (Renaming_Prim);
8897 Right_Op := Next_Formal (Left_Op);
8900 Predef_Spec_Or_Body (Loc,
8902 Name => Chars (Renaming_Prim),
8903 Profile => New_List (
8904 Make_Parameter_Specification (Loc,
8905 Defining_Identifier =>
8906 Make_Defining_Identifier (Loc, Chars (Left_Op)),
8907 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
8909 Make_Parameter_Specification (Loc,
8910 Defining_Identifier =>
8911 Make_Defining_Identifier (Loc, Chars (Right_Op)),
8912 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
8914 Ret_Type => Standard_Boolean,
8917 -- If the overriding of the equality primitive occurred before the
8918 -- renaming, then generate:
8920 -- function <Neq_Name> (X : Y : Typ) return Boolean is
8922 -- return not Oeq (X, Y);
8925 if Present (Eq_Prim) then
8928 -- Otherwise build a nested subprogram which performs the predefined
8929 -- evaluation of the equality operator. That is, generate:
8931 -- function <Neq_Name> (X : Y : Typ) return Boolean is
8932 -- function Oeq (X : Y) return Boolean is
8934 -- <<body of default implementation>>
8937 -- return not Oeq (X, Y);
8942 Local_Subp : Node_Id;
8944 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
8945 Set_Declarations (Decl, New_List (Local_Subp));
8946 Target := Defining_Entity (Local_Subp);
8951 Make_Simple_Return_Statement (Loc,
8954 Make_Function_Call (Loc,
8955 Name => New_Occurrence_Of (Target, Loc),
8956 Parameter_Associations => New_List (
8957 Make_Identifier (Loc, Chars (Left_Op)),
8958 Make_Identifier (Loc, Chars (Right_Op)))))));
8960 Set_Handled_Statement_Sequence
8961 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8965 -------------------------------
8966 -- Make_Null_Procedure_Specs --
8967 -------------------------------
8969 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
8970 Decl_List : constant List_Id := New_List;
8971 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8973 Formal_List : List_Id;
8974 New_Param_Spec : Node_Id;
8975 Parent_Subp : Entity_Id;
8976 Prim_Elmt : Elmt_Id;
8980 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8981 while Present (Prim_Elmt) loop
8982 Subp := Node (Prim_Elmt);
8984 -- If a null procedure inherited from an interface has not been
8985 -- overridden, then we build a null procedure declaration to
8986 -- override the inherited procedure.
8988 Parent_Subp := Alias (Subp);
8990 if Present (Parent_Subp)
8991 and then Is_Null_Interface_Primitive (Parent_Subp)
8993 Formal_List := No_List;
8994 Formal := First_Formal (Subp);
8996 if Present (Formal) then
8997 Formal_List := New_List;
8999 while Present (Formal) loop
9001 -- Copy the parameter spec including default expressions
9004 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
9006 -- Generate a new defining identifier for the new formal.
9007 -- required because New_Copy_Tree does not duplicate
9008 -- semantic fields (except itypes).
9010 Set_Defining_Identifier (New_Param_Spec,
9011 Make_Defining_Identifier (Sloc (Formal),
9012 Chars => Chars (Formal)));
9014 -- For controlling arguments we must change their
9015 -- parameter type to reference the tagged type (instead
9016 -- of the interface type)
9018 if Is_Controlling_Formal (Formal) then
9019 if Nkind (Parameter_Type (Parent (Formal)))
9022 Set_Parameter_Type (New_Param_Spec,
9023 New_Occurrence_Of (Tag_Typ, Loc));
9026 (Nkind (Parameter_Type (Parent (Formal)))
9027 = N_Access_Definition);
9028 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
9029 New_Occurrence_Of (Tag_Typ, Loc));
9033 Append (New_Param_Spec, Formal_List);
9035 Next_Formal (Formal);
9039 Append_To (Decl_List,
9040 Make_Subprogram_Declaration (Loc,
9041 Make_Procedure_Specification (Loc,
9042 Defining_Unit_Name =>
9043 Make_Defining_Identifier (Loc, Chars (Subp)),
9044 Parameter_Specifications => Formal_List,
9045 Null_Present => True)));
9048 Next_Elmt (Prim_Elmt);
9052 end Make_Null_Procedure_Specs;
9054 -------------------------------------
9055 -- Make_Predefined_Primitive_Specs --
9056 -------------------------------------
9058 procedure Make_Predefined_Primitive_Specs
9059 (Tag_Typ : Entity_Id;
9060 Predef_List : out List_Id;
9061 Renamed_Eq : out Entity_Id)
9063 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
9064 -- Returns true if Prim is a renaming of an unresolved predefined
9065 -- equality operation.
9067 -------------------------------
9068 -- Is_Predefined_Eq_Renaming --
9069 -------------------------------
9071 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
9073 return Chars (Prim) /= Name_Op_Eq
9074 and then Present (Alias (Prim))
9075 and then Comes_From_Source (Prim)
9076 and then Is_Intrinsic_Subprogram (Alias (Prim))
9077 and then Chars (Alias (Prim)) = Name_Op_Eq;
9078 end Is_Predefined_Eq_Renaming;
9082 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9083 Res : constant List_Id := New_List;
9084 Eq_Name : Name_Id := Name_Op_Eq;
9085 Eq_Needed : Boolean;
9089 Has_Predef_Eq_Renaming : Boolean := False;
9090 -- Set to True if Tag_Typ has a primitive that renames the predefined
9091 -- equality operator. Used to implement (RM 8-5-4(8)).
9093 -- Start of processing for Make_Predefined_Primitive_Specs
9096 Renamed_Eq := Empty;
9100 Append_To (Res, Predef_Spec_Or_Body (Loc,
9103 Profile => New_List (
9104 Make_Parameter_Specification (Loc,
9105 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9106 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9108 Ret_Type => Standard_Long_Long_Integer));
9110 -- Specs for dispatching stream attributes
9113 Stream_Op_TSS_Names :
9114 constant array (Integer range <>) of TSS_Name_Type :=
9121 for Op in Stream_Op_TSS_Names'Range loop
9122 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
9124 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
9125 Stream_Op_TSS_Names (Op)));
9130 -- Spec of "=" is expanded if the type is not limited and if a user
9131 -- defined "=" was not already declared for the non-full view of a
9132 -- private extension
9134 if not Is_Limited_Type (Tag_Typ) then
9136 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9137 while Present (Prim) loop
9139 -- If a primitive is encountered that renames the predefined
9140 -- equality operator before reaching any explicit equality
9141 -- primitive, then we still need to create a predefined equality
9142 -- function, because calls to it can occur via the renaming. A
9143 -- new name is created for the equality to avoid conflicting with
9144 -- any user-defined equality. (Note that this doesn't account for
9145 -- renamings of equality nested within subpackages???)
9147 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9148 Has_Predef_Eq_Renaming := True;
9149 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
9151 -- User-defined equality
9153 elsif Is_User_Defined_Equality (Node (Prim)) then
9154 if No (Alias (Node (Prim)))
9155 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
9156 N_Subprogram_Renaming_Declaration
9161 -- If the parent is not an interface type and has an abstract
9162 -- equality function, the inherited equality is abstract as
9163 -- well, and no body can be created for it.
9165 elsif not Is_Interface (Etype (Tag_Typ))
9166 and then Present (Alias (Node (Prim)))
9167 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
9172 -- If the type has an equality function corresponding with
9173 -- a primitive defined in an interface type, the inherited
9174 -- equality is abstract as well, and no body can be created
9177 elsif Present (Alias (Node (Prim)))
9178 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
9181 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
9191 -- If a renaming of predefined equality was found but there was no
9192 -- user-defined equality (so Eq_Needed is still true), then set the
9193 -- name back to Name_Op_Eq. But in the case where a user-defined
9194 -- equality was located after such a renaming, then the predefined
9195 -- equality function is still needed, so Eq_Needed must be set back
9198 if Eq_Name /= Name_Op_Eq then
9200 Eq_Name := Name_Op_Eq;
9207 Eq_Spec := Predef_Spec_Or_Body (Loc,
9210 Profile => New_List (
9211 Make_Parameter_Specification (Loc,
9212 Defining_Identifier =>
9213 Make_Defining_Identifier (Loc, Name_X),
9214 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9215 Make_Parameter_Specification (Loc,
9216 Defining_Identifier =>
9217 Make_Defining_Identifier (Loc, Name_Y),
9218 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9219 Ret_Type => Standard_Boolean);
9220 Append_To (Res, Eq_Spec);
9222 if Has_Predef_Eq_Renaming then
9223 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
9225 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9226 while Present (Prim) loop
9228 -- Any renamings of equality that appeared before an
9229 -- overriding equality must be updated to refer to the
9230 -- entity for the predefined equality, otherwise calls via
9231 -- the renaming would get incorrectly resolved to call the
9232 -- user-defined equality function.
9234 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9235 Set_Alias (Node (Prim), Renamed_Eq);
9237 -- Exit upon encountering a user-defined equality
9239 elsif Chars (Node (Prim)) = Name_Op_Eq
9240 and then No (Alias (Node (Prim)))
9250 -- Spec for dispatching assignment
9252 Append_To (Res, Predef_Spec_Or_Body (Loc,
9254 Name => Name_uAssign,
9255 Profile => New_List (
9256 Make_Parameter_Specification (Loc,
9257 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9258 Out_Present => True,
9259 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9261 Make_Parameter_Specification (Loc,
9262 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9263 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
9266 -- Ada 2005: Generate declarations for the following primitive
9267 -- operations for limited interfaces and synchronized types that
9268 -- implement a limited interface.
9270 -- Disp_Asynchronous_Select
9271 -- Disp_Conditional_Select
9272 -- Disp_Get_Prim_Op_Kind
9275 -- Disp_Timed_Select
9277 -- Disable the generation of these bodies if No_Dispatching_Calls,
9278 -- Ravenscar or ZFP is active.
9280 if Ada_Version >= Ada_2005
9281 and then not Restriction_Active (No_Dispatching_Calls)
9282 and then not Restriction_Active (No_Select_Statements)
9283 and then RTE_Available (RE_Select_Specific_Data)
9285 -- These primitives are defined abstract in interface types
9287 if Is_Interface (Tag_Typ)
9288 and then Is_Limited_Record (Tag_Typ)
9291 Make_Abstract_Subprogram_Declaration (Loc,
9293 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9296 Make_Abstract_Subprogram_Declaration (Loc,
9298 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9301 Make_Abstract_Subprogram_Declaration (Loc,
9303 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9306 Make_Abstract_Subprogram_Declaration (Loc,
9308 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9311 Make_Abstract_Subprogram_Declaration (Loc,
9313 Make_Disp_Requeue_Spec (Tag_Typ)));
9316 Make_Abstract_Subprogram_Declaration (Loc,
9318 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9320 -- If the ancestor is an interface type we declare non-abstract
9321 -- primitives to override the abstract primitives of the interface
9324 -- In VM targets we define these primitives in all root tagged types
9325 -- that are not interface types. Done because in VM targets we don't
9326 -- have secondary dispatch tables and any derivation of Tag_Typ may
9327 -- cover limited interfaces (which always have these primitives since
9328 -- they may be ancestors of synchronized interface types).
9330 elsif (not Is_Interface (Tag_Typ)
9331 and then Is_Interface (Etype (Tag_Typ))
9332 and then Is_Limited_Record (Etype (Tag_Typ)))
9334 (Is_Concurrent_Record_Type (Tag_Typ)
9335 and then Has_Interfaces (Tag_Typ))
9337 (not Tagged_Type_Expansion
9338 and then not Is_Interface (Tag_Typ)
9339 and then Tag_Typ = Root_Type (Tag_Typ))
9342 Make_Subprogram_Declaration (Loc,
9344 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9347 Make_Subprogram_Declaration (Loc,
9349 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9352 Make_Subprogram_Declaration (Loc,
9354 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9357 Make_Subprogram_Declaration (Loc,
9359 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9362 Make_Subprogram_Declaration (Loc,
9364 Make_Disp_Requeue_Spec (Tag_Typ)));
9367 Make_Subprogram_Declaration (Loc,
9369 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9373 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
9374 -- regardless of whether they are controlled or may contain controlled
9377 -- Do not generate the routines if finalization is disabled
9379 if Restriction_Active (No_Finalization) then
9382 -- Finalization is not available for CIL value types
9384 elsif Is_Value_Type (Tag_Typ) then
9388 if not Is_Limited_Type (Tag_Typ) then
9389 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
9392 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
9396 end Make_Predefined_Primitive_Specs;
9398 ---------------------------------
9399 -- Needs_Simple_Initialization --
9400 ---------------------------------
9402 function Needs_Simple_Initialization
9404 Consider_IS : Boolean := True) return Boolean
9406 Consider_IS_NS : constant Boolean :=
9408 or (Initialize_Scalars and Consider_IS);
9411 -- Never need initialization if it is suppressed
9413 if Initialization_Suppressed (T) then
9417 -- Check for private type, in which case test applies to the underlying
9418 -- type of the private type.
9420 if Is_Private_Type (T) then
9422 RT : constant Entity_Id := Underlying_Type (T);
9425 if Present (RT) then
9426 return Needs_Simple_Initialization (RT);
9432 -- Scalar type with Default_Value aspect requires initialization
9434 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
9437 -- Cases needing simple initialization are access types, and, if pragma
9438 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
9441 elsif Is_Access_Type (T)
9442 or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
9446 -- If Initialize/Normalize_Scalars is in effect, string objects also
9447 -- need initialization, unless they are created in the course of
9448 -- expanding an aggregate (since in the latter case they will be
9449 -- filled with appropriate initializing values before they are used).
9451 elsif Consider_IS_NS
9453 (Root_Type (T) = Standard_String
9454 or else Root_Type (T) = Standard_Wide_String
9455 or else Root_Type (T) = Standard_Wide_Wide_String)
9458 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
9465 end Needs_Simple_Initialization;
9467 ----------------------
9468 -- Predef_Deep_Spec --
9469 ----------------------
9471 function Predef_Deep_Spec
9473 Tag_Typ : Entity_Id;
9474 Name : TSS_Name_Type;
9475 For_Body : Boolean := False) return Node_Id
9480 -- V : in out Tag_Typ
9482 Formals := New_List (
9483 Make_Parameter_Specification (Loc,
9484 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9486 Out_Present => True,
9487 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
9489 -- F : Boolean := True
9491 if Name = TSS_Deep_Adjust
9492 or else Name = TSS_Deep_Finalize
9495 Make_Parameter_Specification (Loc,
9496 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9497 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9498 Expression => New_Occurrence_Of (Standard_True, Loc)));
9502 Predef_Spec_Or_Body (Loc,
9503 Name => Make_TSS_Name (Tag_Typ, Name),
9506 For_Body => For_Body);
9509 when RE_Not_Available =>
9511 end Predef_Deep_Spec;
9513 -------------------------
9514 -- Predef_Spec_Or_Body --
9515 -------------------------
9517 function Predef_Spec_Or_Body
9519 Tag_Typ : Entity_Id;
9522 Ret_Type : Entity_Id := Empty;
9523 For_Body : Boolean := False) return Node_Id
9525 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
9529 Set_Is_Public (Id, Is_Public (Tag_Typ));
9531 -- The internal flag is set to mark these declarations because they have
9532 -- specific properties. First, they are primitives even if they are not
9533 -- defined in the type scope (the freezing point is not necessarily in
9534 -- the same scope). Second, the predefined equality can be overridden by
9535 -- a user-defined equality, no body will be generated in this case.
9537 Set_Is_Internal (Id);
9539 if not Debug_Generated_Code then
9540 Set_Debug_Info_Off (Id);
9543 if No (Ret_Type) then
9545 Make_Procedure_Specification (Loc,
9546 Defining_Unit_Name => Id,
9547 Parameter_Specifications => Profile);
9550 Make_Function_Specification (Loc,
9551 Defining_Unit_Name => Id,
9552 Parameter_Specifications => Profile,
9553 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
9556 if Is_Interface (Tag_Typ) then
9557 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9559 -- If body case, return empty subprogram body. Note that this is ill-
9560 -- formed, because there is not even a null statement, and certainly not
9561 -- a return in the function case. The caller is expected to do surgery
9562 -- on the body to add the appropriate stuff.
9565 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
9567 -- For the case of an Input attribute predefined for an abstract type,
9568 -- generate an abstract specification. This will never be called, but we
9569 -- need the slot allocated in the dispatching table so that attributes
9570 -- typ'Class'Input and typ'Class'Output will work properly.
9572 elsif Is_TSS (Name, TSS_Stream_Input)
9573 and then Is_Abstract_Type (Tag_Typ)
9575 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9577 -- Normal spec case, where we return a subprogram declaration
9580 return Make_Subprogram_Declaration (Loc, Spec);
9582 end Predef_Spec_Or_Body;
9584 -----------------------------
9585 -- Predef_Stream_Attr_Spec --
9586 -----------------------------
9588 function Predef_Stream_Attr_Spec
9590 Tag_Typ : Entity_Id;
9591 Name : TSS_Name_Type;
9592 For_Body : Boolean := False) return Node_Id
9594 Ret_Type : Entity_Id;
9597 if Name = TSS_Stream_Input then
9598 Ret_Type := Tag_Typ;
9606 Name => Make_TSS_Name (Tag_Typ, Name),
9608 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
9609 Ret_Type => Ret_Type,
9610 For_Body => For_Body);
9611 end Predef_Stream_Attr_Spec;
9613 ---------------------------------
9614 -- Predefined_Primitive_Bodies --
9615 ---------------------------------
9617 function Predefined_Primitive_Bodies
9618 (Tag_Typ : Entity_Id;
9619 Renamed_Eq : Entity_Id) return List_Id
9621 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9622 Res : constant List_Id := New_List;
9625 Eq_Needed : Boolean;
9629 pragma Warnings (Off, Ent);
9632 pragma Assert (not Is_Interface (Tag_Typ));
9634 -- See if we have a predefined "=" operator
9636 if Present (Renamed_Eq) then
9638 Eq_Name := Chars (Renamed_Eq);
9640 -- If the parent is an interface type then it has defined all the
9641 -- predefined primitives abstract and we need to check if the type
9642 -- has some user defined "=" function which matches the profile of
9643 -- the Ada predefined equality operator to avoid generating it.
9645 elsif Is_Interface (Etype (Tag_Typ)) then
9647 Eq_Name := Name_Op_Eq;
9649 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9650 while Present (Prim) loop
9651 if Chars (Node (Prim)) = Name_Op_Eq
9652 and then not Is_Internal (Node (Prim))
9653 and then Present (First_Entity (Node (Prim)))
9655 -- The predefined equality primitive must have exactly two
9656 -- formals whose type is this tagged type
9658 and then Present (Last_Entity (Node (Prim)))
9659 and then Next_Entity (First_Entity (Node (Prim)))
9660 = Last_Entity (Node (Prim))
9661 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
9662 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
9676 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9677 while Present (Prim) loop
9678 if Chars (Node (Prim)) = Name_Op_Eq
9679 and then Is_Internal (Node (Prim))
9682 Eq_Name := Name_Op_Eq;
9692 Decl := Predef_Spec_Or_Body (Loc,
9695 Profile => New_List (
9696 Make_Parameter_Specification (Loc,
9697 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9698 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9700 Ret_Type => Standard_Long_Long_Integer,
9703 Set_Handled_Statement_Sequence (Decl,
9704 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9705 Make_Simple_Return_Statement (Loc,
9707 Make_Attribute_Reference (Loc,
9708 Prefix => Make_Identifier (Loc, Name_X),
9709 Attribute_Name => Name_Size)))));
9711 Append_To (Res, Decl);
9713 -- Bodies for Dispatching stream IO routines. We need these only for
9714 -- non-limited types (in the limited case there is no dispatching).
9715 -- We also skip them if dispatching or finalization are not available.
9717 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
9718 and then No (TSS (Tag_Typ, TSS_Stream_Read))
9720 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
9721 Append_To (Res, Decl);
9724 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
9725 and then No (TSS (Tag_Typ, TSS_Stream_Write))
9727 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
9728 Append_To (Res, Decl);
9731 -- Skip body of _Input for the abstract case, since the corresponding
9732 -- spec is abstract (see Predef_Spec_Or_Body).
9734 if not Is_Abstract_Type (Tag_Typ)
9735 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
9736 and then No (TSS (Tag_Typ, TSS_Stream_Input))
9738 Build_Record_Or_Elementary_Input_Function
9739 (Loc, Tag_Typ, Decl, Ent);
9740 Append_To (Res, Decl);
9743 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
9744 and then No (TSS (Tag_Typ, TSS_Stream_Output))
9746 Build_Record_Or_Elementary_Output_Procedure
9747 (Loc, Tag_Typ, Decl, Ent);
9748 Append_To (Res, Decl);
9751 -- Ada 2005: Generate bodies for the following primitive operations for
9752 -- limited interfaces and synchronized types that implement a limited
9755 -- disp_asynchronous_select
9756 -- disp_conditional_select
9757 -- disp_get_prim_op_kind
9759 -- disp_timed_select
9761 -- The interface versions will have null bodies
9763 -- Disable the generation of these bodies if No_Dispatching_Calls,
9764 -- Ravenscar or ZFP is active.
9766 -- In VM targets we define these primitives in all root tagged types
9767 -- that are not interface types. Done because in VM targets we don't
9768 -- have secondary dispatch tables and any derivation of Tag_Typ may
9769 -- cover limited interfaces (which always have these primitives since
9770 -- they may be ancestors of synchronized interface types).
9772 if Ada_Version >= Ada_2005
9773 and then not Is_Interface (Tag_Typ)
9775 ((Is_Interface (Etype (Tag_Typ))
9776 and then Is_Limited_Record (Etype (Tag_Typ)))
9778 (Is_Concurrent_Record_Type (Tag_Typ)
9779 and then Has_Interfaces (Tag_Typ))
9781 (not Tagged_Type_Expansion
9782 and then Tag_Typ = Root_Type (Tag_Typ)))
9783 and then not Restriction_Active (No_Dispatching_Calls)
9784 and then not Restriction_Active (No_Select_Statements)
9785 and then RTE_Available (RE_Select_Specific_Data)
9787 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
9788 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
9789 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
9790 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
9791 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
9792 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
9795 if not Is_Limited_Type (Tag_Typ)
9796 and then not Is_Interface (Tag_Typ)
9798 -- Body for equality
9801 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
9802 Append_To (Res, Decl);
9805 -- Body for inequality (if required)
9807 Decl := Make_Neq_Body (Tag_Typ);
9809 if Present (Decl) then
9810 Append_To (Res, Decl);
9813 -- Body for dispatching assignment
9816 Predef_Spec_Or_Body (Loc,
9818 Name => Name_uAssign,
9819 Profile => New_List (
9820 Make_Parameter_Specification (Loc,
9821 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9822 Out_Present => True,
9823 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9825 Make_Parameter_Specification (Loc,
9826 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9827 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9830 Set_Handled_Statement_Sequence (Decl,
9831 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9832 Make_Assignment_Statement (Loc,
9833 Name => Make_Identifier (Loc, Name_X),
9834 Expression => Make_Identifier (Loc, Name_Y)))));
9836 Append_To (Res, Decl);
9839 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
9840 -- tagged types which do not contain controlled components.
9842 -- Do not generate the routines if finalization is disabled
9844 if Restriction_Active (No_Finalization) then
9847 elsif not Has_Controlled_Component (Tag_Typ) then
9848 if not Is_Limited_Type (Tag_Typ) then
9849 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
9851 if Is_Controlled (Tag_Typ) then
9852 Set_Handled_Statement_Sequence (Decl,
9853 Make_Handled_Sequence_Of_Statements (Loc,
9854 Statements => New_List (
9856 Obj_Ref => Make_Identifier (Loc, Name_V),
9859 Set_Handled_Statement_Sequence (Decl,
9860 Make_Handled_Sequence_Of_Statements (Loc,
9861 Statements => New_List (
9862 Make_Null_Statement (Loc))));
9865 Append_To (Res, Decl);
9868 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
9870 if Is_Controlled (Tag_Typ) then
9871 Set_Handled_Statement_Sequence (Decl,
9872 Make_Handled_Sequence_Of_Statements (Loc,
9873 Statements => New_List (
9875 (Obj_Ref => Make_Identifier (Loc, Name_V),
9878 Set_Handled_Statement_Sequence (Decl,
9879 Make_Handled_Sequence_Of_Statements (Loc,
9880 Statements => New_List (Make_Null_Statement (Loc))));
9883 Append_To (Res, Decl);
9887 end Predefined_Primitive_Bodies;
9889 ---------------------------------
9890 -- Predefined_Primitive_Freeze --
9891 ---------------------------------
9893 function Predefined_Primitive_Freeze
9894 (Tag_Typ : Entity_Id) return List_Id
9896 Res : constant List_Id := New_List;
9901 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9902 while Present (Prim) loop
9903 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
9904 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
9906 if Present (Frnodes) then
9907 Append_List_To (Res, Frnodes);
9915 end Predefined_Primitive_Freeze;
9917 -------------------------
9918 -- Stream_Operation_OK --
9919 -------------------------
9921 function Stream_Operation_OK
9923 Operation : TSS_Name_Type) return Boolean
9925 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
9928 -- Special case of a limited type extension: a default implementation
9929 -- of the stream attributes Read or Write exists if that attribute
9930 -- has been specified or is available for an ancestor type; a default
9931 -- implementation of the attribute Output (resp. Input) exists if the
9932 -- attribute has been specified or Write (resp. Read) is available for
9933 -- an ancestor type. The last condition only applies under Ada 2005.
9935 if Is_Limited_Type (Typ)
9936 and then Is_Tagged_Type (Typ)
9938 if Operation = TSS_Stream_Read then
9939 Has_Predefined_Or_Specified_Stream_Attribute :=
9940 Has_Specified_Stream_Read (Typ);
9942 elsif Operation = TSS_Stream_Write then
9943 Has_Predefined_Or_Specified_Stream_Attribute :=
9944 Has_Specified_Stream_Write (Typ);
9946 elsif Operation = TSS_Stream_Input then
9947 Has_Predefined_Or_Specified_Stream_Attribute :=
9948 Has_Specified_Stream_Input (Typ)
9950 (Ada_Version >= Ada_2005
9951 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
9953 elsif Operation = TSS_Stream_Output then
9954 Has_Predefined_Or_Specified_Stream_Attribute :=
9955 Has_Specified_Stream_Output (Typ)
9957 (Ada_Version >= Ada_2005
9958 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
9961 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
9963 if not Has_Predefined_Or_Specified_Stream_Attribute
9964 and then Is_Derived_Type (Typ)
9965 and then (Operation = TSS_Stream_Read
9966 or else Operation = TSS_Stream_Write)
9968 Has_Predefined_Or_Specified_Stream_Attribute :=
9970 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
9974 -- If the type is not limited, or else is limited but the attribute is
9975 -- explicitly specified or is predefined for the type, then return True,
9976 -- unless other conditions prevail, such as restrictions prohibiting
9977 -- streams or dispatching operations. We also return True for limited
9978 -- interfaces, because they may be extended by nonlimited types and
9979 -- permit inheritance in this case (addresses cases where an abstract
9980 -- extension doesn't get 'Input declared, as per comments below, but
9981 -- 'Class'Input must still be allowed). Note that attempts to apply
9982 -- stream attributes to a limited interface or its class-wide type
9983 -- (or limited extensions thereof) will still get properly rejected
9984 -- by Check_Stream_Attribute.
9986 -- We exclude the Input operation from being a predefined subprogram in
9987 -- the case where the associated type is an abstract extension, because
9988 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
9989 -- we don't want an abstract version created because types derived from
9990 -- the abstract type may not even have Input available (for example if
9991 -- derived from a private view of the abstract type that doesn't have
9992 -- a visible Input), but a VM such as .NET or the Java VM can treat the
9993 -- operation as inherited anyway, and we don't want an abstract function
9994 -- to be (implicitly) inherited in that case because it can lead to a VM
9997 -- Do not generate stream routines for type Finalization_Master because
9998 -- a master may never appear in types and therefore cannot be read or
10002 (not Is_Limited_Type (Typ)
10003 or else Is_Interface (Typ)
10004 or else Has_Predefined_Or_Specified_Stream_Attribute)
10006 (Operation /= TSS_Stream_Input
10007 or else not Is_Abstract_Type (Typ)
10008 or else not Is_Derived_Type (Typ))
10009 and then not Has_Unknown_Discriminants (Typ)
10011 (Is_Interface (Typ)
10013 (Is_Task_Interface (Typ)
10014 or else Is_Protected_Interface (Typ)
10015 or else Is_Synchronized_Interface (Typ)))
10016 and then not Restriction_Active (No_Streams)
10017 and then not Restriction_Active (No_Dispatch)
10018 and then not No_Run_Time_Mode
10019 and then RTE_Available (RE_Tag)
10020 and then No (Type_Without_Stream_Operation (Typ))
10021 and then RTE_Available (RE_Root_Stream_Type)
10022 and then not Is_RTE (Typ, RE_Finalization_Master);
10023 end Stream_Operation_OK;