Add assember CFI directives to millicode division and remainder routines.
[official-gcc.git] / gcc / ada / exp_ch3.adb
blobabe71b252e7761a8da1cb8d7a42a2705c6a6694f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 3 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Accessibility; use Accessibility;
27 with Aspects; use Aspects;
28 with Atree; use Atree;
29 with Checks; use Checks;
30 with Contracts; use Contracts;
31 with Einfo; use Einfo;
32 with Einfo.Entities; use Einfo.Entities;
33 with Einfo.Utils; use Einfo.Utils;
34 with Errout; use Errout;
35 with Expander; use Expander;
36 with Exp_Aggr; use Exp_Aggr;
37 with Exp_Atag; use Exp_Atag;
38 with Exp_Ch4; use Exp_Ch4;
39 with Exp_Ch6; use Exp_Ch6;
40 with Exp_Ch7; use Exp_Ch7;
41 with Exp_Ch9; use Exp_Ch9;
42 with Exp_Dbug; use Exp_Dbug;
43 with Exp_Disp; use Exp_Disp;
44 with Exp_Dist; use Exp_Dist;
45 with Exp_Put_Image;
46 with Exp_Smem; use Exp_Smem;
47 with Exp_Strm; use Exp_Strm;
48 with Exp_Util; use Exp_Util;
49 with Freeze; use Freeze;
50 with Ghost; use Ghost;
51 with Lib; use Lib;
52 with Namet; use Namet;
53 with Nlists; use Nlists;
54 with Nmake; use Nmake;
55 with Opt; use Opt;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
59 with Sem; use Sem;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Attr; use Sem_Attr;
62 with Sem_Cat; use Sem_Cat;
63 with Sem_Ch3; use Sem_Ch3;
64 with Sem_Ch6; use Sem_Ch6;
65 with Sem_Ch8; use Sem_Ch8;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Eval; use Sem_Eval;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res; use Sem_Res;
70 with Sem_SCIL; use Sem_SCIL;
71 with Sem_Type; use Sem_Type;
72 with Sem_Util; use Sem_Util;
73 with Sinfo; use Sinfo;
74 with Sinfo.Nodes; use Sinfo.Nodes;
75 with Sinfo.Utils; use Sinfo.Utils;
76 with Stand; use Stand;
77 with Snames; use Snames;
78 with Tbuild; use Tbuild;
79 with Ttypes; use Ttypes;
80 with Validsw; use Validsw;
82 package body Exp_Ch3 is
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
88 procedure Adjust_Discriminants (Rtype : Entity_Id);
89 -- This is used when freezing a record type. It attempts to construct
90 -- more restrictive subtypes for discriminants so that the max size of
91 -- the record can be calculated more accurately. See the body of this
92 -- procedure for details.
94 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
95 -- Build initialization procedure for given array type. Nod is a node
96 -- used for attachment of any actions required in its construction.
97 -- It also supplies the source location used for the procedure.
99 function Build_Discriminant_Formals
100 (Rec_Id : Entity_Id;
101 Use_Dl : Boolean) return List_Id;
102 -- This function uses the discriminants of a type to build a list of
103 -- formal parameters, used in Build_Init_Procedure among other places.
104 -- If the flag Use_Dl is set, the list is built using the already
105 -- defined discriminals of the type, as is the case for concurrent
106 -- types with discriminants. Otherwise new identifiers are created,
107 -- with the source names of the discriminants.
109 procedure Build_Discr_Checking_Funcs (N : Node_Id);
110 -- For each variant component, builds a function which checks whether
111 -- the component name is consistent with the current discriminants
112 -- and sets the component's Dcheck_Function attribute to refer to it.
113 -- N is the full type declaration node; the discriminant checking
114 -- functions are inserted after this node.
116 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
117 -- This function builds a static aggregate that can serve as the initial
118 -- value for an array type whose bounds are static, and whose component
119 -- type is a composite type that has a static equivalent aggregate.
120 -- The equivalent array aggregate is used both for object initialization
121 -- and for component initialization, when used in the following function.
123 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
124 -- This function builds a static aggregate that can serve as the initial
125 -- value for a record type whose components are scalar and initialized
126 -- with compile-time values, or arrays with similar initialization or
127 -- defaults. When possible, initialization of an object of the type can
128 -- be achieved by using a copy of the aggregate as an initial value, thus
129 -- removing the implicit call that would otherwise constitute elaboration
130 -- code.
132 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
133 -- Build record initialization procedure. N is the type declaration
134 -- node, and Rec_Ent is the corresponding entity for the record type.
136 procedure Build_Slice_Assignment (Typ : Entity_Id);
137 -- Build assignment procedure for one-dimensional arrays of controlled
138 -- types. Other array and slice assignments are expanded in-line, but
139 -- the code expansion for controlled components (when control actions
140 -- are active) can lead to very large blocks that GCC handles poorly.
142 procedure Build_Untagged_Equality (Typ : Entity_Id);
143 -- AI05-0123: Equality on untagged records composes. This procedure
144 -- builds the equality routine for an untagged record that has components
145 -- of a record type that has user-defined primitive equality operations.
146 -- The resulting operation is a TSS subprogram.
148 procedure Check_Stream_Attributes (Typ : Entity_Id);
149 -- Check that if a limited extension has a parent with user-defined stream
150 -- attributes, and does not itself have user-defined stream-attributes,
151 -- then any limited component of the extension also has the corresponding
152 -- user-defined stream attributes.
154 procedure Clean_Task_Names
155 (Typ : Entity_Id;
156 Proc_Id : Entity_Id);
157 -- If an initialization procedure includes calls to generate names
158 -- for task subcomponents, indicate that secondary stack cleanup is
159 -- needed after an initialization. Typ is the component type, and Proc_Id
160 -- the initialization procedure for the enclosing composite type.
162 procedure Copy_Discr_Checking_Funcs (N : Node_Id);
163 -- For a derived untagged type, copy the attributes that were set
164 -- for the components of the parent type onto the components of the
165 -- derived type. No new subprograms are constructed.
166 -- N is the full type declaration node, as for Build_Discr_Checking_Funcs.
168 procedure Expand_Freeze_Array_Type (N : Node_Id);
169 -- Freeze an array type. Deals with building the initialization procedure,
170 -- creating the packed array type for a packed array and also with the
171 -- creation of the controlling procedures for the controlled case. The
172 -- argument N is the N_Freeze_Entity node for the type.
174 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
175 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
176 -- of finalizing controlled derivations from the class-wide's root type.
178 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
179 -- Freeze enumeration type with non-standard representation. Builds the
180 -- array and function needed to convert between enumeration pos and
181 -- enumeration representation values. N is the N_Freeze_Entity node
182 -- for the type.
184 procedure Expand_Freeze_Record_Type (N : Node_Id);
185 -- Freeze record type. Builds all necessary discriminant checking
186 -- and other ancillary functions, and builds dispatch tables where
187 -- needed. The argument N is the N_Freeze_Entity node. This processing
188 -- applies only to E_Record_Type entities, not to class wide types,
189 -- record subtypes, or private types.
191 procedure Expand_Tagged_Root (T : Entity_Id);
192 -- Add a field _Tag at the beginning of the record. This field carries
193 -- the value of the access to the Dispatch table. This procedure is only
194 -- called on root type, the _Tag field being inherited by the descendants.
196 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
197 -- Treat user-defined stream operations as renaming_as_body if the
198 -- subprogram they rename is not frozen when the type is frozen.
200 package Initialization_Control is
202 function Requires_Late_Init
203 (Decl : Node_Id; Rec_Type : Entity_Id) return Boolean;
204 -- Return True iff the given component declaration requires late
205 -- initialization, as defined by 3.3.1 (8.1/5).
207 function Has_Late_Init_Component
208 (Tagged_Rec_Type : Entity_Id) return Boolean;
209 -- Return True iff the given tagged record type has at least one
210 -- component that requires late initialization; this includes
211 -- components of ancestor types.
213 type Initialization_Mode is
214 (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
215 -- The initialization routine for a tagged type is passed in a
216 -- formal parameter of this type, indicating what initialization
217 -- is to be performed. This parameter defaults to Full_Init in all
218 -- cases except when the init proc of a type extension (let's call
219 -- that type T2) calls the init proc of its parent (let's call that
220 -- type T1). In that case, one of the other 3 values will
221 -- be passed in. In all three of those cases, the Tag component has
222 -- already been initialized before the call and is therefore not to be
223 -- modified. T2's init proc will either call T1's init proc
224 -- once (with Full_Init_Except_Tag as the parameter value) or twice
225 -- (first with Early_Init_Only, then later with Late_Init_Only),
226 -- depending on the result returned by Has_Late_Init_Component (T1).
227 -- In the latter case, the first call does not initialize any
228 -- components that require late initialization and the second call
229 -- then performs that deferred initialization.
230 -- Strictly speaking, the formal parameter subtype is actually Natural
231 -- but calls will only pass in values corresponding to literals
232 -- of this enumeration type.
234 function Make_Mode_Literal
235 (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
236 is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
237 -- Generate an integer literal for a given mode value.
239 function Tag_Init_Condition
240 (Loc : Source_Ptr;
241 Init_Control_Formal : Entity_Id) return Node_Id;
242 function Early_Init_Condition
243 (Loc : Source_Ptr;
244 Init_Control_Formal : Entity_Id) return Node_Id;
245 function Late_Init_Condition
246 (Loc : Source_Ptr;
247 Init_Control_Formal : Entity_Id) return Node_Id;
248 -- These three functions each return a Boolean expression that
249 -- can be used to determine whether a given call to the initialization
250 -- expression for a tagged type should initialize (respectively)
251 -- the Tag component, the non-Tag components that do not require late
252 -- initialization, and the components that do require late
253 -- initialization.
255 end Initialization_Control;
257 procedure Initialization_Warning (E : Entity_Id);
258 -- If static elaboration of the package is requested, indicate
259 -- when a type does meet the conditions for static initialization. If
260 -- E is a type, it has components that have no static initialization.
261 -- if E is an entity, its initial expression is not compile-time known.
263 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id;
264 -- This function builds the list of formals for an initialization routine.
265 -- The first formal is always _Init with the given type. For task value
266 -- record types and types containing tasks, three additional formals are
267 -- added and Proc_Id is decorated with attribute Has_Master_Entity:
269 -- _Master : Master_Id
270 -- _Chain : in out Activation_Chain
271 -- _Task_Name : String
273 -- The caller must append additional entries for discriminants if required.
275 function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
276 -- Returns true if the initialization procedure of Typ should be inlined
278 function In_Runtime (E : Entity_Id) return Boolean;
279 -- Check if E is defined in the RTL (in a child of Ada or System). Used
280 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
282 function Is_Null_Statement_List (Stmts : List_Id) return Boolean;
283 -- Returns true if Stmts is made of null statements only, possibly wrapped
284 -- in a case statement, recursively. This latter pattern may occur for the
285 -- initialization procedure of an unchecked union.
287 function Make_Eq_Body
288 (Typ : Entity_Id;
289 Eq_Name : Name_Id) return Node_Id;
290 -- Build the body of a primitive equality operation for a tagged record
291 -- type, or in Ada 2012 for any record type that has components with a
292 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
294 function Make_Eq_Case
295 (E : Entity_Id;
296 CL : Node_Id;
297 Discrs : Elist_Id := New_Elmt_List) return List_Id;
298 -- Building block for variant record equality. Defined to share the code
299 -- between the tagged and untagged case. Given a Component_List node CL,
300 -- it generates an 'if' followed by a 'case' statement that compares all
301 -- components of local temporaries named X and Y (that are declared as
302 -- formals at some upper level). E provides the Sloc to be used for the
303 -- generated code.
305 -- IF E is an unchecked_union, Discrs is the list of formals created for
306 -- the inferred discriminants of one operand. These formals are used in
307 -- the generated case statements for each variant of the unchecked union.
309 function Make_Eq_If
310 (E : Entity_Id;
311 L : List_Id) return Node_Id;
312 -- Building block for variant record equality. Defined to share the code
313 -- between the tagged and untagged case. Given the list of components
314 -- (or discriminants) L, it generates a return statement that compares all
315 -- components of local temporaries named X and Y (that are declared as
316 -- formals at some upper level). E provides the Sloc to be used for the
317 -- generated code.
319 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
320 -- Search for a renaming of the inequality dispatching primitive of
321 -- this tagged type. If found then build and return the corresponding
322 -- rename-as-body inequality subprogram; otherwise return Empty.
324 procedure Make_Predefined_Primitive_Specs
325 (Tag_Typ : Entity_Id;
326 Predef_List : out List_Id;
327 Renamed_Eq : out Entity_Id);
328 -- Create a list with the specs of the predefined primitive operations.
329 -- For tagged types that are interfaces all these primitives are defined
330 -- abstract.
332 -- The following entries are present for all tagged types, and provide
333 -- the results of the corresponding attribute applied to the object.
334 -- Dispatching is required in general, since the result of the attribute
335 -- will vary with the actual object subtype.
337 -- _size provides result of 'Size attribute
338 -- typSR provides result of 'Read attribute
339 -- typSW provides result of 'Write attribute
340 -- typSI provides result of 'Input attribute
341 -- typSO provides result of 'Output attribute
342 -- typPI provides result of 'Put_Image attribute
344 -- The following entries are additionally present for non-limited tagged
345 -- types, and implement additional dispatching operations for predefined
346 -- operations:
348 -- _equality implements "=" operator
349 -- _assign implements assignment operation
350 -- typDF implements deep finalization
351 -- typDA implements deep adjust
353 -- The latter two are empty procedures unless the type contains some
354 -- controlled components that require finalization actions (the deep
355 -- in the name refers to the fact that the action applies to components).
357 -- The list of specs is returned in Predef_List
359 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
360 -- Returns True if there are representation clauses for type T that are not
361 -- inherited. If the result is false, the init_proc and the discriminant
362 -- checking functions of the parent can be reused by a derived type.
364 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
365 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
366 -- null procedures inherited from an interface type that have not been
367 -- overridden. Only one null procedure will be created for a given set of
368 -- inherited null procedures with homographic profiles.
370 function Predef_Spec_Or_Body
371 (Loc : Source_Ptr;
372 Tag_Typ : Entity_Id;
373 Name : Name_Id;
374 Profile : List_Id;
375 Ret_Type : Entity_Id := Empty;
376 For_Body : Boolean := False) return Node_Id;
377 -- This function generates the appropriate expansion for a predefined
378 -- primitive operation specified by its name, parameter profile and
379 -- return type (Empty means this is a procedure). If For_Body is false,
380 -- then the returned node is a subprogram declaration. If For_Body is
381 -- true, then the returned node is a empty subprogram body containing
382 -- no declarations and no statements.
384 function Predef_Stream_Attr_Spec
385 (Loc : Source_Ptr;
386 Tag_Typ : Entity_Id;
387 Name : TSS_Name_Type) return Node_Id;
388 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
389 -- input and output attribute whose specs are constructed in Exp_Strm.
391 function Predef_Deep_Spec
392 (Loc : Source_Ptr;
393 Tag_Typ : Entity_Id;
394 Name : TSS_Name_Type;
395 For_Body : Boolean := False) return Node_Id;
396 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
397 -- and _deep_finalize
399 function Predefined_Primitive_Bodies
400 (Tag_Typ : Entity_Id;
401 Renamed_Eq : Entity_Id) return List_Id;
402 -- Create the bodies of the predefined primitives that are described in
403 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
404 -- the defining unit name of the type's predefined equality as returned
405 -- by Make_Predefined_Primitive_Specs.
407 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
408 -- Freeze entities of all predefined primitive operations. This is needed
409 -- because the bodies of these operations do not normally do any freezing.
411 --------------------------
412 -- Adjust_Discriminants --
413 --------------------------
415 -- This procedure attempts to define subtypes for discriminants that are
416 -- more restrictive than those declared. Such a replacement is possible if
417 -- we can demonstrate that values outside the restricted range would cause
418 -- constraint errors in any case. The advantage of restricting the
419 -- discriminant types in this way is that the maximum size of the variant
420 -- record can be calculated more conservatively.
422 -- An example of a situation in which we can perform this type of
423 -- restriction is the following:
425 -- subtype B is range 1 .. 10;
426 -- type Q is array (B range <>) of Integer;
428 -- type V (N : Natural) is record
429 -- C : Q (1 .. N);
430 -- end record;
432 -- In this situation, we can restrict the upper bound of N to 10, since
433 -- any larger value would cause a constraint error in any case.
435 -- There are many situations in which such restriction is possible, but
436 -- for now, we just look for cases like the above, where the component
437 -- in question is a one dimensional array whose upper bound is one of
438 -- the record discriminants. Also the component must not be part of
439 -- any variant part, since then the component does not always exist.
441 procedure Adjust_Discriminants (Rtype : Entity_Id) is
442 Loc : constant Source_Ptr := Sloc (Rtype);
443 Comp : Entity_Id;
444 Ctyp : Entity_Id;
445 Ityp : Entity_Id;
446 Lo : Node_Id;
447 Hi : Node_Id;
448 P : Node_Id;
449 Loval : Uint;
450 Discr : Entity_Id;
451 Dtyp : Entity_Id;
452 Dhi : Node_Id;
453 Dhiv : Uint;
454 Ahi : Node_Id;
455 Ahiv : Uint;
456 Tnn : Entity_Id;
458 begin
459 Comp := First_Component (Rtype);
460 while Present (Comp) loop
462 -- If our parent is a variant, quit, we do not look at components
463 -- that are in variant parts, because they may not always exist.
465 P := Parent (Comp); -- component declaration
466 P := Parent (P); -- component list
468 exit when Nkind (Parent (P)) = N_Variant;
470 -- We are looking for a one dimensional array type
472 Ctyp := Etype (Comp);
474 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
475 goto Continue;
476 end if;
478 -- The lower bound must be constant, and the upper bound is a
479 -- discriminant (which is a discriminant of the current record).
481 Ityp := Etype (First_Index (Ctyp));
482 Lo := Type_Low_Bound (Ityp);
483 Hi := Type_High_Bound (Ityp);
485 if not Compile_Time_Known_Value (Lo)
486 or else Nkind (Hi) /= N_Identifier
487 or else No (Entity (Hi))
488 or else Ekind (Entity (Hi)) /= E_Discriminant
489 then
490 goto Continue;
491 end if;
493 -- We have an array with appropriate bounds
495 Loval := Expr_Value (Lo);
496 Discr := Entity (Hi);
497 Dtyp := Etype (Discr);
499 -- See if the discriminant has a known upper bound
501 Dhi := Type_High_Bound (Dtyp);
503 if not Compile_Time_Known_Value (Dhi) then
504 goto Continue;
505 end if;
507 Dhiv := Expr_Value (Dhi);
509 -- See if base type of component array has known upper bound
511 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
513 if not Compile_Time_Known_Value (Ahi) then
514 goto Continue;
515 end if;
517 Ahiv := Expr_Value (Ahi);
519 -- The condition for doing the restriction is that the high bound
520 -- of the discriminant is greater than the low bound of the array,
521 -- and is also greater than the high bound of the base type index.
523 if Dhiv > Loval and then Dhiv > Ahiv then
525 -- We can reset the upper bound of the discriminant type to
526 -- whichever is larger, the low bound of the component, or
527 -- the high bound of the base type array index.
529 -- We build a subtype that is declared as
531 -- subtype Tnn is discr_type range discr_type'First .. max;
533 -- And insert this declaration into the tree. The type of the
534 -- discriminant is then reset to this more restricted subtype.
536 Tnn := Make_Temporary (Loc, 'T');
538 Insert_Action (Declaration_Node (Rtype),
539 Make_Subtype_Declaration (Loc,
540 Defining_Identifier => Tnn,
541 Subtype_Indication =>
542 Make_Subtype_Indication (Loc,
543 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
544 Constraint =>
545 Make_Range_Constraint (Loc,
546 Range_Expression =>
547 Make_Range (Loc,
548 Low_Bound =>
549 Make_Attribute_Reference (Loc,
550 Attribute_Name => Name_First,
551 Prefix => New_Occurrence_Of (Dtyp, Loc)),
552 High_Bound =>
553 Make_Integer_Literal (Loc,
554 Intval => UI_Max (Loval, Ahiv)))))));
556 Set_Etype (Discr, Tnn);
557 end if;
559 <<Continue>>
560 Next_Component (Comp);
561 end loop;
562 end Adjust_Discriminants;
564 ------------------------------------------
565 -- Build_Access_Subprogram_Wrapper_Body --
566 ------------------------------------------
568 procedure Build_Access_Subprogram_Wrapper_Body
569 (Decl : Node_Id;
570 New_Decl : Node_Id)
572 Loc : constant Source_Ptr := Sloc (Decl);
573 Actuals : constant List_Id := New_List;
574 Type_Def : constant Node_Id := Type_Definition (Decl);
575 Type_Id : constant Entity_Id := Defining_Identifier (Decl);
576 Spec_Node : constant Node_Id :=
577 Copy_Subprogram_Spec (Specification (New_Decl));
578 -- This copy creates new identifiers for formals and subprogram.
580 Act : Node_Id;
581 Body_Node : Node_Id;
582 Call_Stmt : Node_Id;
583 Ptr : Entity_Id;
585 begin
586 if not Expander_Active then
587 return;
588 end if;
590 -- Create List of actuals for indirect call. The last parameter of the
591 -- subprogram declaration is the access value for the indirect call.
593 Act := First (Parameter_Specifications (Spec_Node));
595 while Present (Act) loop
596 exit when Act = Last (Parameter_Specifications (Spec_Node));
597 Append_To (Actuals,
598 Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
599 Next (Act);
600 end loop;
602 Ptr :=
603 Defining_Identifier
604 (Last (Parameter_Specifications (Specification (New_Decl))));
606 if Nkind (Type_Def) = N_Access_Procedure_Definition then
607 Call_Stmt := Make_Procedure_Call_Statement (Loc,
608 Name =>
609 Make_Explicit_Dereference
610 (Loc, New_Occurrence_Of (Ptr, Loc)),
611 Parameter_Associations => Actuals);
612 else
613 Call_Stmt := Make_Simple_Return_Statement (Loc,
614 Expression =>
615 Make_Function_Call (Loc,
616 Name => Make_Explicit_Dereference
617 (Loc, New_Occurrence_Of (Ptr, Loc)),
618 Parameter_Associations => Actuals));
619 end if;
621 Body_Node := Make_Subprogram_Body (Loc,
622 Specification => Spec_Node,
623 Declarations => New_List,
624 Handled_Statement_Sequence =>
625 Make_Handled_Sequence_Of_Statements (Loc,
626 Statements => New_List (Call_Stmt)));
628 -- Place body in list of freeze actions for the type.
630 Append_Freeze_Action (Type_Id, Body_Node);
631 end Build_Access_Subprogram_Wrapper_Body;
633 ---------------------------
634 -- Build_Array_Init_Proc --
635 ---------------------------
637 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
638 Comp_Type : constant Entity_Id := Component_Type (A_Type);
639 Comp_Simple_Init : constant Boolean :=
640 Needs_Simple_Initialization
641 (Typ => Comp_Type,
642 Consider_IS =>
643 not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
644 -- True if the component needs simple initialization, based on its type,
645 -- plus the fact that we do not do simple initialization for components
646 -- of bit-packed arrays when validity checks are enabled, because the
647 -- initialization with deliberately out-of-range values would raise
648 -- Constraint_Error.
650 Body_Stmts : List_Id;
651 Has_Default_Init : Boolean;
652 Index_List : List_Id;
653 Loc : Source_Ptr;
654 Parameters : List_Id;
655 Proc_Id : Entity_Id;
657 function Init_Component return List_Id;
658 -- Create one statement to initialize one array component, designated
659 -- by a full set of indexes.
661 function Init_One_Dimension (N : Int) return List_Id;
662 -- Create loop to initialize one dimension of the array. The single
663 -- statement in the loop body initializes the inner dimensions if any,
664 -- or else the single component. Note that this procedure is called
665 -- recursively, with N being the dimension to be initialized. A call
666 -- with N greater than the number of dimensions simply generates the
667 -- component initialization, terminating the recursion.
669 --------------------
670 -- Init_Component --
671 --------------------
673 function Init_Component return List_Id is
674 Comp : Node_Id;
676 begin
677 Comp :=
678 Make_Indexed_Component (Loc,
679 Prefix => Make_Identifier (Loc, Name_uInit),
680 Expressions => Index_List);
682 if Has_Default_Aspect (A_Type) then
683 Set_Assignment_OK (Comp);
684 return New_List (
685 Make_Assignment_Statement (Loc,
686 Name => Comp,
687 Expression =>
688 Convert_To (Comp_Type,
689 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
691 elsif Comp_Simple_Init then
692 Set_Assignment_OK (Comp);
693 return New_List (
694 Make_Assignment_Statement (Loc,
695 Name => Comp,
696 Expression =>
697 Get_Simple_Init_Val
698 (Typ => Comp_Type,
699 N => Nod,
700 Size => Component_Size (A_Type))));
702 else
703 Clean_Task_Names (Comp_Type, Proc_Id);
704 return
705 Build_Initialization_Call
706 (Loc => Loc,
707 Id_Ref => Comp,
708 Typ => Comp_Type,
709 In_Init_Proc => True,
710 Enclos_Type => A_Type);
711 end if;
712 end Init_Component;
714 ------------------------
715 -- Init_One_Dimension --
716 ------------------------
718 function Init_One_Dimension (N : Int) return List_Id is
719 Index : Entity_Id;
720 DIC_Call : Node_Id;
721 Result_List : List_Id;
723 function Possible_DIC_Call return Node_Id;
724 -- If the component type has Default_Initial_Conditions and a DIC
725 -- procedure that is not an empty body, then builds a call to the
726 -- DIC procedure and returns it.
728 -----------------------
729 -- Possible_DIC_Call --
730 -----------------------
732 function Possible_DIC_Call return Node_Id is
733 begin
734 -- When the component's type has a Default_Initial_Condition, then
735 -- create a call for the DIC check.
737 if Has_DIC (Comp_Type)
738 -- In GNATprove mode, the component DICs are checked by other
739 -- means. They should not be added to the record type DIC
740 -- procedure, so that the procedure can be used to check the
741 -- record type invariants or DICs if any.
743 and then not GNATprove_Mode
745 -- DIC checks for components of controlled types are done later
746 -- (see Exp_Ch7.Make_Deep_Array_Body).
748 and then not Is_Controlled (Comp_Type)
750 and then Present (DIC_Procedure (Comp_Type))
752 and then not Has_Null_Body (DIC_Procedure (Comp_Type))
753 then
754 return
755 Build_DIC_Call (Loc,
756 Make_Indexed_Component (Loc,
757 Prefix => Make_Identifier (Loc, Name_uInit),
758 Expressions => Index_List),
759 Comp_Type);
760 else
761 return Empty;
762 end if;
763 end Possible_DIC_Call;
765 -- Start of processing for Init_One_Dimension
767 begin
768 -- If the component does not need initializing, then there is nothing
769 -- to do here, so we return a null body. This occurs when generating
770 -- the dummy Init_Proc needed for Initialize_Scalars processing.
771 -- An exception is if component type has a Default_Initial_Condition,
772 -- in which case we generate a call to the type's DIC procedure.
774 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
775 and then not Comp_Simple_Init
776 and then not Has_Task (Comp_Type)
777 and then not Has_Default_Aspect (A_Type)
778 and then (not Has_DIC (Comp_Type)
779 or else N > Number_Dimensions (A_Type))
780 then
781 DIC_Call := Possible_DIC_Call;
783 if Present (DIC_Call) then
784 return New_List (DIC_Call);
785 else
786 return New_List (Make_Null_Statement (Loc));
787 end if;
789 -- If all dimensions dealt with, we simply initialize the component
790 -- and append a call to component type's DIC procedure when needed.
792 elsif N > Number_Dimensions (A_Type) then
793 DIC_Call := Possible_DIC_Call;
795 if Present (DIC_Call) then
796 Result_List := Init_Component;
797 Append (DIC_Call, Result_List);
798 return Result_List;
800 else
801 return Init_Component;
802 end if;
804 -- Here we generate the required loop
806 else
807 Index :=
808 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
810 Append (New_Occurrence_Of (Index, Loc), Index_List);
812 return New_List (
813 Make_Implicit_Loop_Statement (Nod,
814 Identifier => Empty,
815 Iteration_Scheme =>
816 Make_Iteration_Scheme (Loc,
817 Loop_Parameter_Specification =>
818 Make_Loop_Parameter_Specification (Loc,
819 Defining_Identifier => Index,
820 Discrete_Subtype_Definition =>
821 Make_Attribute_Reference (Loc,
822 Prefix =>
823 Make_Identifier (Loc, Name_uInit),
824 Attribute_Name => Name_Range,
825 Expressions => New_List (
826 Make_Integer_Literal (Loc, N))))),
827 Statements => Init_One_Dimension (N + 1)));
828 end if;
829 end Init_One_Dimension;
831 -- Start of processing for Build_Array_Init_Proc
833 begin
834 -- The init proc is created when analyzing the freeze node for the type,
835 -- but it properly belongs with the array type declaration. However, if
836 -- the freeze node is for a subtype of a type declared in another unit
837 -- it seems preferable to use the freeze node as the source location of
838 -- the init proc. In any case this is preferable for gcov usage, and
839 -- the Sloc is not otherwise used by the compiler.
841 if In_Open_Scopes (Scope (A_Type)) then
842 Loc := Sloc (A_Type);
843 else
844 Loc := Sloc (Nod);
845 end if;
847 -- Nothing to generate in the following cases:
849 -- 1. Initialization is suppressed for the type
850 -- 2. An initialization already exists for the base type
852 if Initialization_Suppressed (A_Type)
853 or else Present (Base_Init_Proc (A_Type))
854 then
855 return;
856 end if;
858 Index_List := New_List;
860 -- We need an initialization procedure if any of the following is true:
862 -- 1. The component type has an initialization procedure
863 -- 2. The component type needs simple initialization
864 -- 3. Tasks are present
865 -- 4. The type is marked as a public entity
866 -- 5. The array type has a Default_Component_Value aspect
867 -- 6. The array component type has a Default_Initialization_Condition
869 -- The reason for the public entity test is to deal properly with the
870 -- Initialize_Scalars pragma. This pragma can be set in the client and
871 -- not in the declaring package, this means the client will make a call
872 -- to the initialization procedure (because one of conditions 1-3 must
873 -- apply in this case), and we must generate a procedure (even if it is
874 -- null) to satisfy the call in this case.
876 -- Exception: do not build an array init_proc for a type whose root
877 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
878 -- is no place to put the code, and in any case we handle initialization
879 -- of such types (in the Initialize_Scalars case, that's the only time
880 -- the issue arises) in a special manner anyway which does not need an
881 -- init_proc.
883 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
884 or else Comp_Simple_Init
885 or else Has_Task (Comp_Type)
886 or else Has_Default_Aspect (A_Type)
887 or else Has_DIC (Comp_Type);
889 if Has_Default_Init
890 or else (not Restriction_Active (No_Initialize_Scalars)
891 and then Is_Public (A_Type)
892 and then not Is_Standard_String_Type (A_Type))
893 then
894 Proc_Id :=
895 Make_Defining_Identifier (Loc,
896 Chars => Make_Init_Proc_Name (A_Type));
898 -- If No_Default_Initialization restriction is active, then we don't
899 -- want to build an init_proc, but we need to mark that an init_proc
900 -- would be needed if this restriction was not active (so that we can
901 -- detect attempts to call it), so set a dummy init_proc in place.
902 -- This is only done though when actual default initialization is
903 -- needed (and not done when only Is_Public is True), since otherwise
904 -- objects such as arrays of scalars could be wrongly flagged as
905 -- violating the restriction.
907 if Restriction_Active (No_Default_Initialization) then
908 if Has_Default_Init then
909 Set_Init_Proc (A_Type, Proc_Id);
910 end if;
912 return;
913 end if;
915 Body_Stmts := Init_One_Dimension (1);
916 Parameters := Init_Formals (A_Type, Proc_Id);
918 Discard_Node (
919 Make_Subprogram_Body (Loc,
920 Specification =>
921 Make_Procedure_Specification (Loc,
922 Defining_Unit_Name => Proc_Id,
923 Parameter_Specifications => Parameters),
924 Declarations => New_List,
925 Handled_Statement_Sequence =>
926 Make_Handled_Sequence_Of_Statements (Loc,
927 Statements => Body_Stmts)));
929 Mutate_Ekind (Proc_Id, E_Procedure);
930 Set_Is_Public (Proc_Id, Is_Public (A_Type));
931 Set_Is_Internal (Proc_Id);
932 Set_Has_Completion (Proc_Id);
934 if not Debug_Generated_Code then
935 Set_Debug_Info_Off (Proc_Id);
936 end if;
938 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
939 -- component type itself (see also Build_Record_Init_Proc).
941 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
943 -- Associate Init_Proc with type, and determine if the procedure
944 -- is null (happens because of the Initialize_Scalars pragma case,
945 -- where we have to generate a null procedure in case it is called
946 -- by a client with Initialize_Scalars set). Such procedures have
947 -- to be generated, but do not have to be called, so we mark them
948 -- as null to suppress the call. Kill also warnings for the _Init
949 -- out parameter, which is left entirely uninitialized.
951 Set_Init_Proc (A_Type, Proc_Id);
953 if Is_Null_Statement_List (Body_Stmts) then
954 Set_Is_Null_Init_Proc (Proc_Id);
955 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
957 else
958 -- Try to build a static aggregate to statically initialize
959 -- objects of the type. This can only be done for constrained
960 -- one-dimensional arrays with static bounds.
962 Set_Static_Initialization
963 (Proc_Id,
964 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
965 end if;
966 end if;
967 end Build_Array_Init_Proc;
969 --------------------------------
970 -- Build_Discr_Checking_Funcs --
971 --------------------------------
973 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
974 Rec_Id : Entity_Id;
975 Loc : Source_Ptr;
976 Enclosing_Func_Id : Entity_Id;
977 Sequence : Nat := 1;
978 Type_Def : Node_Id;
979 V : Node_Id;
981 function Build_Case_Statement
982 (Case_Id : Entity_Id;
983 Variant : Node_Id) return Node_Id;
984 -- Build a case statement containing only two alternatives. The first
985 -- alternative corresponds to the discrete choices given on the variant
986 -- that contains the components that we are generating the checks
987 -- for. If the discriminant is one of these return False. The second
988 -- alternative is an OTHERS choice that returns True indicating the
989 -- discriminant did not match.
991 function Build_Dcheck_Function
992 (Case_Id : Entity_Id;
993 Variant : Node_Id) return Entity_Id;
994 -- Build the discriminant checking function for a given variant
996 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
997 -- Builds the discriminant checking function for each variant of the
998 -- given variant part of the record type.
1000 --------------------------
1001 -- Build_Case_Statement --
1002 --------------------------
1004 function Build_Case_Statement
1005 (Case_Id : Entity_Id;
1006 Variant : Node_Id) return Node_Id
1008 Alt_List : constant List_Id := New_List;
1009 Actuals_List : List_Id;
1010 Case_Node : Node_Id;
1011 Case_Alt_Node : Node_Id;
1012 Choice : Node_Id;
1013 Choice_List : List_Id;
1014 D : Entity_Id;
1015 Return_Node : Node_Id;
1017 begin
1018 Case_Node := New_Node (N_Case_Statement, Loc);
1019 Set_End_Span (Case_Node, Uint_0);
1021 -- Replace the discriminant which controls the variant with the name
1022 -- of the formal of the checking function.
1024 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
1026 Choice := First (Discrete_Choices (Variant));
1028 if Nkind (Choice) = N_Others_Choice then
1029 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
1030 else
1031 Choice_List := New_Copy_List (Discrete_Choices (Variant));
1032 end if;
1034 if not Is_Empty_List (Choice_List) then
1035 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
1036 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
1038 -- In case this is a nested variant, we need to return the result
1039 -- of the discriminant checking function for the immediately
1040 -- enclosing variant.
1042 if Present (Enclosing_Func_Id) then
1043 Actuals_List := New_List;
1045 D := First_Discriminant (Rec_Id);
1046 while Present (D) loop
1047 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
1048 Next_Discriminant (D);
1049 end loop;
1051 Return_Node :=
1052 Make_Simple_Return_Statement (Loc,
1053 Expression =>
1054 Make_Function_Call (Loc,
1055 Name =>
1056 New_Occurrence_Of (Enclosing_Func_Id, Loc),
1057 Parameter_Associations =>
1058 Actuals_List));
1060 else
1061 Return_Node :=
1062 Make_Simple_Return_Statement (Loc,
1063 Expression =>
1064 New_Occurrence_Of (Standard_False, Loc));
1065 end if;
1067 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1068 Append (Case_Alt_Node, Alt_List);
1069 end if;
1071 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
1072 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
1073 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
1075 Return_Node :=
1076 Make_Simple_Return_Statement (Loc,
1077 Expression =>
1078 New_Occurrence_Of (Standard_True, Loc));
1080 Set_Statements (Case_Alt_Node, New_List (Return_Node));
1081 Append (Case_Alt_Node, Alt_List);
1083 Set_Alternatives (Case_Node, Alt_List);
1084 return Case_Node;
1085 end Build_Case_Statement;
1087 ---------------------------
1088 -- Build_Dcheck_Function --
1089 ---------------------------
1091 function Build_Dcheck_Function
1092 (Case_Id : Entity_Id;
1093 Variant : Node_Id) return Entity_Id
1095 Body_Node : Node_Id;
1096 Func_Id : Entity_Id;
1097 Parameter_List : List_Id;
1098 Spec_Node : Node_Id;
1100 begin
1101 Body_Node := New_Node (N_Subprogram_Body, Loc);
1102 Sequence := Sequence + 1;
1104 Func_Id :=
1105 Make_Defining_Identifier (Loc,
1106 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
1107 Set_Is_Discriminant_Check_Function (Func_Id);
1109 Spec_Node := New_Node (N_Function_Specification, Loc);
1110 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1112 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
1114 Set_Parameter_Specifications (Spec_Node, Parameter_List);
1115 Set_Result_Definition (Spec_Node,
1116 New_Occurrence_Of (Standard_Boolean, Loc));
1117 Set_Specification (Body_Node, Spec_Node);
1118 Set_Declarations (Body_Node, New_List);
1120 Set_Handled_Statement_Sequence (Body_Node,
1121 Make_Handled_Sequence_Of_Statements (Loc,
1122 Statements => New_List (
1123 Build_Case_Statement (Case_Id, Variant))));
1125 Mutate_Ekind (Func_Id, E_Function);
1126 Set_Mechanism (Func_Id, Default_Mechanism);
1127 Set_Is_Inlined (Func_Id, True);
1128 Set_Is_Pure (Func_Id, True);
1129 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
1130 Set_Is_Internal (Func_Id, True);
1132 if not Debug_Generated_Code then
1133 Set_Debug_Info_Off (Func_Id);
1134 end if;
1136 Analyze (Body_Node);
1138 Append_Freeze_Action (Rec_Id, Body_Node);
1139 Set_Dcheck_Function (Variant, Func_Id);
1140 return Func_Id;
1141 end Build_Dcheck_Function;
1143 ----------------------------
1144 -- Build_Dcheck_Functions --
1145 ----------------------------
1147 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
1148 Component_List_Node : Node_Id;
1149 Decl : Entity_Id;
1150 Discr_Name : Entity_Id;
1151 Func_Id : Entity_Id;
1152 Variant : Node_Id;
1153 Saved_Enclosing_Func_Id : Entity_Id;
1155 begin
1156 -- Build the discriminant-checking function for each variant, and
1157 -- label all components of that variant with the function's name.
1158 -- We only Generate a discriminant-checking function when the
1159 -- variant is not empty, to prevent the creation of dead code.
1161 Discr_Name := Entity (Name (Variant_Part_Node));
1162 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
1164 while Present (Variant) loop
1165 Component_List_Node := Component_List (Variant);
1167 if not Null_Present (Component_List_Node) then
1168 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
1170 Decl :=
1171 First_Non_Pragma (Component_Items (Component_List_Node));
1172 while Present (Decl) loop
1173 Set_Discriminant_Checking_Func
1174 (Defining_Identifier (Decl), Func_Id);
1175 Next_Non_Pragma (Decl);
1176 end loop;
1178 if Present (Variant_Part (Component_List_Node)) then
1179 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
1180 Enclosing_Func_Id := Func_Id;
1181 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
1182 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
1183 end if;
1184 end if;
1186 Next_Non_Pragma (Variant);
1187 end loop;
1188 end Build_Dcheck_Functions;
1190 -- Start of processing for Build_Discr_Checking_Funcs
1192 begin
1193 -- Only build if not done already
1195 if not Discr_Check_Funcs_Built (N) then
1196 Type_Def := Type_Definition (N);
1198 if Nkind (Type_Def) = N_Record_Definition then
1199 if No (Component_List (Type_Def)) then -- null record.
1200 return;
1201 else
1202 V := Variant_Part (Component_List (Type_Def));
1203 end if;
1205 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1206 if No (Component_List (Record_Extension_Part (Type_Def))) then
1207 return;
1208 else
1209 V := Variant_Part
1210 (Component_List (Record_Extension_Part (Type_Def)));
1211 end if;
1212 end if;
1214 Rec_Id := Defining_Identifier (N);
1216 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1217 Loc := Sloc (N);
1218 Enclosing_Func_Id := Empty;
1219 Build_Dcheck_Functions (V);
1220 end if;
1222 Set_Discr_Check_Funcs_Built (N);
1223 end if;
1224 end Build_Discr_Checking_Funcs;
1226 ----------------------------------------
1227 -- Build_Or_Copy_Discr_Checking_Funcs --
1228 ----------------------------------------
1230 procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is
1231 Typ : constant Entity_Id := Defining_Identifier (N);
1232 begin
1233 if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then
1234 null;
1235 elsif not Is_Derived_Type (Typ)
1236 or else Has_New_Non_Standard_Rep (Typ)
1237 or else Is_Tagged_Type (Typ)
1238 then
1239 Build_Discr_Checking_Funcs (N);
1240 else
1241 Copy_Discr_Checking_Funcs (N);
1242 end if;
1243 end Build_Or_Copy_Discr_Checking_Funcs;
1245 --------------------------------
1246 -- Build_Discriminant_Formals --
1247 --------------------------------
1249 function Build_Discriminant_Formals
1250 (Rec_Id : Entity_Id;
1251 Use_Dl : Boolean) return List_Id
1253 Loc : Source_Ptr := Sloc (Rec_Id);
1254 Parameter_List : constant List_Id := New_List;
1255 D : Entity_Id;
1256 Formal : Entity_Id;
1257 Formal_Type : Entity_Id;
1258 Param_Spec_Node : Node_Id;
1260 begin
1261 if Has_Discriminants (Rec_Id) then
1262 D := First_Discriminant (Rec_Id);
1263 while Present (D) loop
1264 Loc := Sloc (D);
1266 if Use_Dl then
1267 Formal := Discriminal (D);
1268 Formal_Type := Etype (Formal);
1269 else
1270 Formal := Make_Defining_Identifier (Loc, Chars (D));
1271 Formal_Type := Etype (D);
1272 end if;
1274 Param_Spec_Node :=
1275 Make_Parameter_Specification (Loc,
1276 Defining_Identifier => Formal,
1277 Parameter_Type =>
1278 New_Occurrence_Of (Formal_Type, Loc));
1279 Append (Param_Spec_Node, Parameter_List);
1280 Next_Discriminant (D);
1281 end loop;
1282 end if;
1284 return Parameter_List;
1285 end Build_Discriminant_Formals;
1287 --------------------------------------
1288 -- Build_Equivalent_Array_Aggregate --
1289 --------------------------------------
1291 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1292 Loc : constant Source_Ptr := Sloc (T);
1293 Comp_Type : constant Entity_Id := Component_Type (T);
1294 Index_Type : constant Entity_Id := Etype (First_Index (T));
1295 Proc : constant Entity_Id := Base_Init_Proc (T);
1296 Lo, Hi : Node_Id;
1297 Aggr : Node_Id;
1298 Expr : Node_Id;
1300 begin
1301 if not Is_Constrained (T)
1302 or else Number_Dimensions (T) > 1
1303 or else No (Proc)
1304 then
1305 Initialization_Warning (T);
1306 return Empty;
1307 end if;
1309 Lo := Type_Low_Bound (Index_Type);
1310 Hi := Type_High_Bound (Index_Type);
1312 if not Compile_Time_Known_Value (Lo)
1313 or else not Compile_Time_Known_Value (Hi)
1314 then
1315 Initialization_Warning (T);
1316 return Empty;
1317 end if;
1319 if Is_Record_Type (Comp_Type)
1320 and then Present (Base_Init_Proc (Comp_Type))
1321 then
1322 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1324 if No (Expr) then
1325 Initialization_Warning (T);
1326 return Empty;
1327 end if;
1329 else
1330 Initialization_Warning (T);
1331 return Empty;
1332 end if;
1334 Aggr := Make_Aggregate (Loc, No_List, New_List);
1335 Set_Etype (Aggr, T);
1336 Set_Aggregate_Bounds (Aggr,
1337 Make_Range (Loc,
1338 Low_Bound => New_Copy (Lo),
1339 High_Bound => New_Copy (Hi)));
1340 Set_Parent (Aggr, Parent (Proc));
1342 Append_To (Component_Associations (Aggr),
1343 Make_Component_Association (Loc,
1344 Choices =>
1345 New_List (
1346 Make_Range (Loc,
1347 Low_Bound => New_Copy (Lo),
1348 High_Bound => New_Copy (Hi))),
1349 Expression => Expr));
1351 if Static_Array_Aggregate (Aggr) then
1352 return Aggr;
1353 else
1354 Initialization_Warning (T);
1355 return Empty;
1356 end if;
1357 end Build_Equivalent_Array_Aggregate;
1359 ---------------------------------------
1360 -- Build_Equivalent_Record_Aggregate --
1361 ---------------------------------------
1363 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1364 Agg : Node_Id;
1365 Comp : Entity_Id;
1366 Comp_Type : Entity_Id;
1368 begin
1369 if not Is_Record_Type (T)
1370 or else Has_Discriminants (T)
1371 or else Is_Limited_Type (T)
1372 or else Has_Non_Standard_Rep (T)
1373 then
1374 Initialization_Warning (T);
1375 return Empty;
1376 end if;
1378 Comp := First_Component (T);
1380 -- A null record needs no warning
1382 if No (Comp) then
1383 return Empty;
1384 end if;
1386 while Present (Comp) loop
1388 -- Array components are acceptable if initialized by a positional
1389 -- aggregate with static components.
1391 if Is_Array_Type (Etype (Comp)) then
1392 Comp_Type := Component_Type (Etype (Comp));
1394 if Nkind (Parent (Comp)) /= N_Component_Declaration
1395 or else No (Expression (Parent (Comp)))
1396 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1397 then
1398 Initialization_Warning (T);
1399 return Empty;
1401 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1402 and then
1403 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1404 or else
1405 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1406 then
1407 Initialization_Warning (T);
1408 return Empty;
1410 elsif
1411 not Static_Array_Aggregate (Expression (Parent (Comp)))
1412 then
1413 Initialization_Warning (T);
1414 return Empty;
1416 -- We need to return empty if the type has predicates because
1417 -- this would otherwise duplicate calls to the predicate
1418 -- function. If the type hasn't been frozen before being
1419 -- referenced in the current record, the extraneous call to
1420 -- the predicate function would be inserted somewhere before
1421 -- the predicate function is elaborated, which would result in
1422 -- an invalid tree.
1424 elsif Has_Predicates (Etype (Comp)) then
1425 return Empty;
1426 end if;
1428 elsif Is_Scalar_Type (Etype (Comp)) then
1429 Comp_Type := Etype (Comp);
1431 if Nkind (Parent (Comp)) /= N_Component_Declaration
1432 or else No (Expression (Parent (Comp)))
1433 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1434 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1435 or else not
1436 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1437 then
1438 Initialization_Warning (T);
1439 return Empty;
1440 end if;
1442 -- For now, other types are excluded
1444 else
1445 Initialization_Warning (T);
1446 return Empty;
1447 end if;
1449 Next_Component (Comp);
1450 end loop;
1452 -- All components have static initialization. Build positional aggregate
1453 -- from the given expressions or defaults.
1455 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1456 Set_Parent (Agg, Parent (T));
1458 Comp := First_Component (T);
1459 while Present (Comp) loop
1460 Append
1461 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1462 Next_Component (Comp);
1463 end loop;
1465 Analyze_And_Resolve (Agg, T);
1466 return Agg;
1467 end Build_Equivalent_Record_Aggregate;
1469 ----------------------------
1470 -- Init_Proc_Level_Formal --
1471 ----------------------------
1473 function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is
1474 Form : Entity_Id;
1475 begin
1476 -- Move through the formals of the initialization procedure Proc to find
1477 -- the extra accessibility level parameter associated with the object
1478 -- being initialized.
1480 Form := First_Formal (Proc);
1481 while Present (Form) loop
1482 if Chars (Form) = Name_uInit_Level then
1483 return Form;
1484 end if;
1486 Next_Formal (Form);
1487 end loop;
1489 -- No formal was found, return Empty
1491 return Empty;
1492 end Init_Proc_Level_Formal;
1494 -------------------------------
1495 -- Build_Initialization_Call --
1496 -------------------------------
1498 -- References to a discriminant inside the record type declaration can
1499 -- appear either in the subtype_indication to constrain a record or an
1500 -- array, or as part of a larger expression given for the initial value
1501 -- of a component. In both of these cases N appears in the record
1502 -- initialization procedure and needs to be replaced by the formal
1503 -- parameter of the initialization procedure which corresponds to that
1504 -- discriminant.
1506 -- In the example below, references to discriminants D1 and D2 in proc_1
1507 -- are replaced by references to formals with the same name
1508 -- (discriminals)
1510 -- A similar replacement is done for calls to any record initialization
1511 -- procedure for any components that are themselves of a record type.
1513 -- type R (D1, D2 : Integer) is record
1514 -- X : Integer := F * D1;
1515 -- Y : Integer := F * D2;
1516 -- end record;
1518 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1519 -- begin
1520 -- Out_2.D1 := D1;
1521 -- Out_2.D2 := D2;
1522 -- Out_2.X := F * D1;
1523 -- Out_2.Y := F * D2;
1524 -- end;
1526 function Build_Initialization_Call
1527 (Loc : Source_Ptr;
1528 Id_Ref : Node_Id;
1529 Typ : Entity_Id;
1530 In_Init_Proc : Boolean := False;
1531 Enclos_Type : Entity_Id := Empty;
1532 Discr_Map : Elist_Id := New_Elmt_List;
1533 With_Default_Init : Boolean := False;
1534 Constructor_Ref : Node_Id := Empty;
1535 Init_Control_Actual : Entity_Id := Empty) return List_Id
1537 Res : constant List_Id := New_List;
1539 Full_Type : Entity_Id;
1541 procedure Check_Predicated_Discriminant
1542 (Val : Node_Id;
1543 Discr : Entity_Id);
1544 -- Discriminants whose subtypes have predicates are checked in two
1545 -- cases:
1546 -- a) When an object is default-initialized and assertions are enabled
1547 -- we check that the value of the discriminant obeys the predicate.
1549 -- b) In all cases, if the discriminant controls a variant and the
1550 -- variant has no others_choice, Constraint_Error must be raised if
1551 -- the predicate is violated, because there is no variant covered
1552 -- by the illegal discriminant value.
1554 -----------------------------------
1555 -- Check_Predicated_Discriminant --
1556 -----------------------------------
1558 procedure Check_Predicated_Discriminant
1559 (Val : Node_Id;
1560 Discr : Entity_Id)
1562 Typ : constant Entity_Id := Etype (Discr);
1564 procedure Check_Missing_Others (V : Node_Id);
1565 -- Check that a given variant and its nested variants have an others
1566 -- choice, and generate a constraint error raise when it does not.
1568 --------------------------
1569 -- Check_Missing_Others --
1570 --------------------------
1572 procedure Check_Missing_Others (V : Node_Id) is
1573 Alt : Node_Id;
1574 Choice : Node_Id;
1575 Last_Var : Node_Id;
1577 begin
1578 Last_Var := Last_Non_Pragma (Variants (V));
1579 Choice := First (Discrete_Choices (Last_Var));
1581 -- An others_choice is added during expansion for gcc use, but
1582 -- does not cover the illegality.
1584 if Entity (Name (V)) = Discr then
1585 if Present (Choice)
1586 and then (Nkind (Choice) /= N_Others_Choice
1587 or else not Comes_From_Source (Choice))
1588 then
1589 Check_Expression_Against_Static_Predicate (Val, Typ);
1591 if not Is_Static_Expression (Val) then
1592 Prepend_To (Res,
1593 Make_Raise_Constraint_Error (Loc,
1594 Condition =>
1595 Make_Op_Not (Loc,
1596 Right_Opnd => Make_Predicate_Call (Typ, Val)),
1597 Reason => CE_Invalid_Data));
1598 end if;
1599 end if;
1600 end if;
1602 -- Check whether some nested variant is ruled by the predicated
1603 -- discriminant.
1605 Alt := First (Variants (V));
1606 while Present (Alt) loop
1607 if Nkind (Alt) = N_Variant
1608 and then Present (Variant_Part (Component_List (Alt)))
1609 then
1610 Check_Missing_Others
1611 (Variant_Part (Component_List (Alt)));
1612 end if;
1614 Next (Alt);
1615 end loop;
1616 end Check_Missing_Others;
1618 -- Local variables
1620 Def : Node_Id;
1622 -- Start of processing for Check_Predicated_Discriminant
1624 begin
1625 if Ekind (Base_Type (Full_Type)) = E_Record_Type then
1626 Def := Type_Definition (Parent (Base_Type (Full_Type)));
1627 else
1628 return;
1629 end if;
1631 if Policy_In_Effect (Name_Assert) = Name_Check
1632 and then not Predicates_Ignored (Etype (Discr))
1633 then
1634 Prepend_To (Res, Make_Predicate_Check (Typ, Val));
1635 end if;
1637 -- If discriminant controls a variant, verify that predicate is
1638 -- obeyed or else an Others_Choice is present.
1640 if Nkind (Def) = N_Record_Definition
1641 and then Present (Variant_Part (Component_List (Def)))
1642 and then Policy_In_Effect (Name_Assert) = Name_Ignore
1643 then
1644 Check_Missing_Others (Variant_Part (Component_List (Def)));
1645 end if;
1646 end Check_Predicated_Discriminant;
1648 -- Local variables
1650 Arg : Node_Id;
1651 Args : List_Id;
1652 Decls : List_Id;
1653 Decl : Node_Id;
1654 Discr : Entity_Id;
1655 First_Arg : Node_Id;
1656 Full_Init_Type : Entity_Id;
1657 Init_Call : Node_Id;
1658 Init_Type : Entity_Id;
1659 Proc : Entity_Id;
1661 -- Start of processing for Build_Initialization_Call
1663 begin
1664 pragma Assert (Constructor_Ref = Empty
1665 or else Is_CPP_Constructor_Call (Constructor_Ref));
1667 if No (Constructor_Ref) then
1668 Proc := Base_Init_Proc (Typ);
1669 else
1670 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1671 end if;
1673 pragma Assert (Present (Proc));
1674 Init_Type := Etype (First_Formal (Proc));
1675 Full_Init_Type := Underlying_Type (Init_Type);
1677 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1678 -- is active (in which case we make the call anyway, since in the
1679 -- actual compiled client it may be non null).
1681 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1682 return Empty_List;
1684 -- Nothing to do for an array of controlled components that have only
1685 -- the inherited Initialize primitive. This is a useful optimization
1686 -- for CodePeer.
1688 elsif Is_Trivial_Subprogram (Proc)
1689 and then Is_Array_Type (Full_Init_Type)
1690 then
1691 return New_List (Make_Null_Statement (Loc));
1692 end if;
1694 -- Use the [underlying] full view when dealing with a private type. This
1695 -- may require several steps depending on derivations.
1697 Full_Type := Typ;
1698 loop
1699 if Is_Private_Type (Full_Type) then
1700 if Present (Full_View (Full_Type)) then
1701 Full_Type := Full_View (Full_Type);
1703 elsif Present (Underlying_Full_View (Full_Type)) then
1704 Full_Type := Underlying_Full_View (Full_Type);
1706 -- When a private type acts as a generic actual and lacks a full
1707 -- view, use the base type.
1709 elsif Is_Generic_Actual_Type (Full_Type) then
1710 Full_Type := Base_Type (Full_Type);
1712 elsif Ekind (Full_Type) = E_Private_Subtype
1713 and then (not Has_Discriminants (Full_Type)
1714 or else No (Discriminant_Constraint (Full_Type)))
1715 then
1716 Full_Type := Etype (Full_Type);
1718 -- The loop has recovered the [underlying] full view, stop the
1719 -- traversal.
1721 else
1722 exit;
1723 end if;
1725 -- The type is not private, nothing to do
1727 else
1728 exit;
1729 end if;
1730 end loop;
1732 -- If Typ is derived, the procedure is the initialization procedure for
1733 -- the root type. Wrap the argument in an conversion to make it type
1734 -- honest. Actually it isn't quite type honest, because there can be
1735 -- conflicts of views in the private type case. That is why we set
1736 -- Conversion_OK in the conversion node.
1738 if (Is_Record_Type (Typ)
1739 or else Is_Array_Type (Typ)
1740 or else Is_Private_Type (Typ))
1741 and then Init_Type /= Base_Type (Typ)
1742 then
1743 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1744 Set_Etype (First_Arg, Init_Type);
1746 else
1747 First_Arg := Id_Ref;
1748 end if;
1750 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1752 -- In the tasks case, add _Master as the value of the _Master parameter
1753 -- and _Chain as the value of the _Chain parameter. At the outer level,
1754 -- these will be variables holding the corresponding values obtained
1755 -- from GNARL. At inner levels, they will be the parameters passed down
1756 -- through the outer routines.
1758 if Has_Task (Full_Type) then
1759 if Restriction_Active (No_Task_Hierarchy) then
1760 Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level));
1761 else
1762 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1763 end if;
1765 -- Add _Chain (not done for sequential elaboration policy, see
1766 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1768 if Partition_Elaboration_Policy /= 'S' then
1769 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1770 end if;
1772 -- Ada 2005 (AI-287): In case of default initialized components
1773 -- with tasks, we generate a null string actual parameter.
1774 -- This is just a workaround that must be improved later???
1776 if With_Default_Init then
1777 Append_To (Args,
1778 Make_String_Literal (Loc,
1779 Strval => ""));
1781 else
1782 Decls :=
1783 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1784 Decl := Last (Decls);
1786 Append_To (Args,
1787 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1788 Append_List (Decls, Res);
1789 end if;
1791 else
1792 Decls := No_List;
1793 Decl := Empty;
1794 end if;
1796 -- Handle the optionally generated formal *_skip_null_excluding_checks
1798 -- Look at the associated node for the object we are referencing and
1799 -- verify that we are expanding a call to an Init_Proc for an internally
1800 -- generated object declaration before passing True and skipping the
1801 -- relevant checks.
1803 if Needs_Conditional_Null_Excluding_Check (Full_Init_Type)
1804 and then Nkind (Id_Ref) in N_Has_Entity
1805 and then (Comes_From_Source (Id_Ref)
1806 or else (Present (Associated_Node (Id_Ref))
1807 and then Comes_From_Source
1808 (Associated_Node (Id_Ref))))
1809 then
1810 Append_To (Args, New_Occurrence_Of (Standard_True, Loc));
1811 end if;
1813 -- Add discriminant values if discriminants are present
1815 if Has_Discriminants (Full_Init_Type) then
1816 Discr := First_Discriminant (Full_Init_Type);
1817 while Present (Discr) loop
1819 -- If this is a discriminated concurrent type, the init_proc
1820 -- for the corresponding record is being called. Use that type
1821 -- directly to find the discriminant value, to handle properly
1822 -- intervening renamed discriminants.
1824 declare
1825 T : Entity_Id := Full_Type;
1827 begin
1828 if Is_Protected_Type (T) then
1829 T := Corresponding_Record_Type (T);
1830 end if;
1832 Arg :=
1833 Get_Discriminant_Value (
1834 Discr,
1836 Discriminant_Constraint (Full_Type));
1837 end;
1839 -- If the target has access discriminants, and is constrained by
1840 -- an access to the enclosing construct, i.e. a current instance,
1841 -- replace the reference to the type by a reference to the object.
1843 if Nkind (Arg) = N_Attribute_Reference
1844 and then Is_Access_Type (Etype (Arg))
1845 and then Is_Entity_Name (Prefix (Arg))
1846 and then Is_Type (Entity (Prefix (Arg)))
1847 then
1848 Arg :=
1849 Make_Attribute_Reference (Loc,
1850 Prefix => New_Copy (Prefix (Id_Ref)),
1851 Attribute_Name => Name_Unrestricted_Access);
1853 elsif In_Init_Proc then
1855 -- Replace any possible references to the discriminant in the
1856 -- call to the record initialization procedure with references
1857 -- to the appropriate formal parameter.
1859 if Nkind (Arg) = N_Identifier
1860 and then Ekind (Entity (Arg)) = E_Discriminant
1861 then
1862 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1864 -- Otherwise make a copy of the default expression. Note that
1865 -- we use the current Sloc for this, because we do not want the
1866 -- call to appear to be at the declaration point. Within the
1867 -- expression, replace discriminants with their discriminals.
1869 else
1870 Arg :=
1871 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1872 end if;
1874 else
1875 if Is_Constrained (Full_Type) then
1876 Arg := Duplicate_Subexpr_No_Checks (Arg);
1877 else
1878 -- The constraints come from the discriminant default exps,
1879 -- they must be reevaluated, so we use New_Copy_Tree but we
1880 -- ensure the proper Sloc (for any embedded calls).
1881 -- In addition, if a predicate check is needed on the value
1882 -- of the discriminant, insert it ahead of the call.
1884 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1885 end if;
1887 if Has_Predicates (Etype (Discr)) then
1888 Check_Predicated_Discriminant (Arg, Discr);
1889 end if;
1890 end if;
1892 -- Ada 2005 (AI-287): In case of default initialized components,
1893 -- if the component is constrained with a discriminant of the
1894 -- enclosing type, we need to generate the corresponding selected
1895 -- component node to access the discriminant value. In other cases
1896 -- this is not required, either because we are inside the init
1897 -- proc and we use the corresponding formal, or else because the
1898 -- component is constrained by an expression.
1900 if With_Default_Init
1901 and then Nkind (Id_Ref) = N_Selected_Component
1902 and then Nkind (Arg) = N_Identifier
1903 and then Ekind (Entity (Arg)) = E_Discriminant
1904 then
1905 Append_To (Args,
1906 Make_Selected_Component (Loc,
1907 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1908 Selector_Name => Arg));
1909 else
1910 Append_To (Args, Arg);
1911 end if;
1913 Next_Discriminant (Discr);
1914 end loop;
1915 end if;
1917 -- If this is a call to initialize the parent component of a derived
1918 -- tagged type, indicate that the tag should not be set in the parent.
1919 -- This is done via the actual parameter value for the Init_Control
1920 -- formal parameter, which is also used to deal with late initialization
1921 -- requirements.
1923 -- We pass in Full_Init_Except_Tag unless the caller tells us to do
1924 -- otherwise (by passing in a nonempty Init_Control_Actual parameter).
1926 if Is_Tagged_Type (Full_Init_Type)
1927 and then not Is_CPP_Class (Full_Init_Type)
1928 and then Nkind (Id_Ref) = N_Selected_Component
1929 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1930 then
1931 declare
1932 use Initialization_Control;
1933 begin
1934 Append_To (Args,
1935 (if Present (Init_Control_Actual)
1936 then Init_Control_Actual
1937 else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
1938 end;
1939 elsif Present (Constructor_Ref) then
1940 Append_List_To (Args,
1941 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1942 end if;
1944 -- Pass the extra accessibility level parameter associated with the
1945 -- level of the object being initialized when required.
1947 if Is_Entity_Name (Id_Ref)
1948 and then Present (Init_Proc_Level_Formal (Proc))
1949 then
1950 Append_To (Args,
1951 Make_Parameter_Association (Loc,
1952 Selector_Name =>
1953 Make_Identifier (Loc, Name_uInit_Level),
1954 Explicit_Actual_Parameter =>
1955 Accessibility_Level (Id_Ref, Dynamic_Level)));
1956 end if;
1958 Append_To (Res,
1959 Make_Procedure_Call_Statement (Loc,
1960 Name => New_Occurrence_Of (Proc, Loc),
1961 Parameter_Associations => Args));
1963 if Needs_Finalization (Typ)
1964 and then Nkind (Id_Ref) = N_Selected_Component
1965 then
1966 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1967 Init_Call :=
1968 Make_Init_Call
1969 (Obj_Ref => New_Copy_Tree (First_Arg),
1970 Typ => Typ);
1972 -- Guard against a missing [Deep_]Initialize when the type was not
1973 -- properly frozen.
1975 if Present (Init_Call) then
1976 Append_To (Res, Init_Call);
1977 end if;
1978 end if;
1979 end if;
1981 return Res;
1983 exception
1984 when RE_Not_Available =>
1985 return Empty_List;
1986 end Build_Initialization_Call;
1988 ----------------------------
1989 -- Build_Record_Init_Proc --
1990 ----------------------------
1992 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1993 Decls : constant List_Id := New_List;
1994 Discr_Map : constant Elist_Id := New_Elmt_List;
1995 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1996 Counter : Nat := 0;
1997 Proc_Id : Entity_Id;
1998 Rec_Type : Entity_Id;
2000 Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements
2001 Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
2003 function Build_Assignment
2004 (Id : Entity_Id;
2005 Default : Node_Id) return List_Id;
2006 -- Build an assignment statement that assigns the default expression to
2007 -- its corresponding record component if defined. The left-hand side of
2008 -- the assignment is marked Assignment_OK so that initialization of
2009 -- limited private records works correctly. This routine may also build
2010 -- an adjustment call if the component is controlled.
2012 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
2013 -- If the record has discriminants, add assignment statements to
2014 -- Statement_List to initialize the discriminant values from the
2015 -- arguments of the initialization procedure.
2017 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
2018 -- Build a list representing a sequence of statements which initialize
2019 -- components of the given component list. This may involve building
2020 -- case statements for the variant parts. Append any locally declared
2021 -- objects on list Decls.
2023 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
2024 -- Given an untagged type-derivation that declares discriminants, e.g.
2026 -- type R (R1, R2 : Integer) is record ... end record;
2027 -- type D (D1 : Integer) is new R (1, D1);
2029 -- we make the _init_proc of D be
2031 -- procedure _init_proc (X : D; D1 : Integer) is
2032 -- begin
2033 -- _init_proc (R (X), 1, D1);
2034 -- end _init_proc;
2036 -- This function builds the call statement in this _init_proc.
2038 procedure Build_CPP_Init_Procedure;
2039 -- Build the tree corresponding to the procedure specification and body
2040 -- of the IC procedure that initializes the C++ part of the dispatch
2041 -- table of an Ada tagged type that is a derivation of a CPP type.
2042 -- Install it as the CPP_Init TSS.
2044 procedure Build_Init_Procedure;
2045 -- Build the tree corresponding to the procedure specification and body
2046 -- of the initialization procedure and install it as the _init TSS.
2048 procedure Build_Offset_To_Top_Functions;
2049 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
2050 -- and body of Offset_To_Top, a function used in conjuction with types
2051 -- having secondary dispatch tables.
2053 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
2054 -- Add range checks to components of discriminated records. S is a
2055 -- subtype indication of a record component. Check_List is a list
2056 -- to which the check actions are appended.
2058 function Component_Needs_Simple_Initialization
2059 (T : Entity_Id) return Boolean;
2060 -- Determine if a component needs simple initialization, given its type
2061 -- T. This routine is the same as Needs_Simple_Initialization except for
2062 -- components of type Tag and Interface_Tag. These two access types do
2063 -- not require initialization since they are explicitly initialized by
2064 -- other means.
2066 function Parent_Subtype_Renaming_Discrims return Boolean;
2067 -- Returns True for base types N that rename discriminants, else False
2069 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
2070 -- Determine whether a record initialization procedure needs to be
2071 -- generated for the given record type.
2073 ----------------------
2074 -- Build_Assignment --
2075 ----------------------
2077 function Build_Assignment
2078 (Id : Entity_Id;
2079 Default : Node_Id) return List_Id
2081 Default_Loc : constant Source_Ptr := Sloc (Default);
2082 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
2084 Adj_Call : Node_Id;
2085 Exp : Node_Id := Default;
2086 Kind : Node_Kind := Nkind (Default);
2087 Lhs : Node_Id;
2088 Res : List_Id;
2090 begin
2091 Lhs :=
2092 Make_Selected_Component (Default_Loc,
2093 Prefix => Make_Identifier (Loc, Name_uInit),
2094 Selector_Name => New_Occurrence_Of (Id, Default_Loc));
2095 Set_Assignment_OK (Lhs);
2097 -- Take a copy of Exp to ensure that later copies of this component
2098 -- declaration in derived types see the original tree, not a node
2099 -- rewritten during expansion of the init_proc. If the copy contains
2100 -- itypes, the scope of the new itypes is the init_proc being built.
2102 declare
2103 Map : Elist_Id := No_Elist;
2104 begin
2105 if Has_Late_Init_Comp then
2106 -- Map the type to the _Init parameter in order to
2107 -- handle "current instance" references.
2109 Map := New_Elmt_List
2110 (Elmt1 => Rec_Type,
2111 Elmt2 => Defining_Identifier (First
2112 (Parameter_Specifications
2113 (Parent (Proc_Id)))));
2115 -- If the type has an incomplete view, a current instance
2116 -- may have an incomplete type. In that case, it must also be
2117 -- replaced by the formal of the Init_Proc.
2119 if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration
2120 and then Present (Incomplete_View (Parent (Rec_Type)))
2121 then
2122 Append_Elmt (
2123 N => Incomplete_View (Parent (Rec_Type)),
2124 To => Map);
2125 Append_Elmt (
2126 N => Defining_Identifier
2127 (First
2128 (Parameter_Specifications
2129 (Parent (Proc_Id)))),
2130 To => Map);
2131 end if;
2132 end if;
2134 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map);
2135 end;
2137 Res := New_List (
2138 Make_Assignment_Statement (Loc,
2139 Name => Lhs,
2140 Expression => Exp));
2142 Set_No_Ctrl_Actions (First (Res));
2144 -- Adjust the tag if tagged (because of possible view conversions).
2145 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
2146 -- tags are represented implicitly in objects, and when the record is
2147 -- initialized with a raise expression.
2149 if Is_Tagged_Type (Typ)
2150 and then Tagged_Type_Expansion
2151 and then Nkind (Exp) /= N_Raise_Expression
2152 and then (Nkind (Exp) /= N_Qualified_Expression
2153 or else Nkind (Expression (Exp)) /= N_Raise_Expression)
2154 then
2155 Append_To (Res,
2156 Make_Assignment_Statement (Default_Loc,
2157 Name =>
2158 Make_Selected_Component (Default_Loc,
2159 Prefix =>
2160 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
2161 Selector_Name =>
2162 New_Occurrence_Of
2163 (First_Tag_Component (Typ), Default_Loc)),
2165 Expression =>
2166 Unchecked_Convert_To (RTE (RE_Tag),
2167 New_Occurrence_Of
2168 (Node (First_Elmt (Access_Disp_Table (Underlying_Type
2169 (Typ)))),
2170 Default_Loc))));
2171 end if;
2173 -- Adjust the component if controlled except if it is an aggregate
2174 -- that will be expanded inline.
2176 if Kind = N_Qualified_Expression then
2177 Kind := Nkind (Expression (Default));
2178 end if;
2180 if Needs_Finalization (Typ)
2181 and then Kind not in N_Aggregate | N_Extension_Aggregate
2182 and then not Is_Build_In_Place_Function_Call (Exp)
2183 then
2184 Adj_Call :=
2185 Make_Adjust_Call
2186 (Obj_Ref => New_Copy_Tree (Lhs),
2187 Typ => Etype (Id));
2189 -- Guard against a missing [Deep_]Adjust when the component type
2190 -- was not properly frozen.
2192 if Present (Adj_Call) then
2193 Append_To (Res, Adj_Call);
2194 end if;
2195 end if;
2197 -- If a component type has a predicate, add check to the component
2198 -- assignment. Discriminants are handled at the point of the call,
2199 -- which provides for a better error message.
2201 if Comes_From_Source (Exp)
2202 and then Predicate_Enabled (Typ)
2203 then
2204 Append (Make_Predicate_Check (Typ, Exp), Res);
2205 end if;
2207 return Res;
2209 exception
2210 when RE_Not_Available =>
2211 return Empty_List;
2212 end Build_Assignment;
2214 ------------------------------------
2215 -- Build_Discriminant_Assignments --
2216 ------------------------------------
2218 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
2219 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
2220 D : Entity_Id;
2221 D_Loc : Source_Ptr;
2223 begin
2224 if Has_Discriminants (Rec_Type)
2225 and then not Is_Unchecked_Union (Rec_Type)
2226 then
2227 D := First_Discriminant (Rec_Type);
2228 while Present (D) loop
2230 -- Don't generate the assignment for discriminants in derived
2231 -- tagged types if the discriminant is a renaming of some
2232 -- ancestor discriminant. This initialization will be done
2233 -- when initializing the _parent field of the derived record.
2235 if Is_Tagged
2236 and then Present (Corresponding_Discriminant (D))
2237 then
2238 null;
2240 else
2241 D_Loc := Sloc (D);
2242 Append_List_To (Statement_List,
2243 Build_Assignment (D,
2244 New_Occurrence_Of (Discriminal (D), D_Loc)));
2245 end if;
2247 Next_Discriminant (D);
2248 end loop;
2249 end if;
2250 end Build_Discriminant_Assignments;
2252 --------------------------
2253 -- Build_Init_Call_Thru --
2254 --------------------------
2256 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
2257 Parent_Proc : constant Entity_Id :=
2258 Base_Init_Proc (Etype (Rec_Type));
2260 Parent_Type : constant Entity_Id :=
2261 Etype (First_Formal (Parent_Proc));
2263 Uparent_Type : constant Entity_Id :=
2264 Underlying_Type (Parent_Type);
2266 First_Discr_Param : Node_Id;
2268 Arg : Node_Id;
2269 Args : List_Id;
2270 First_Arg : Node_Id;
2271 Parent_Discr : Entity_Id;
2272 Res : List_Id;
2274 begin
2275 -- First argument (_Init) is the object to be initialized.
2276 -- ??? not sure where to get a reasonable Loc for First_Arg
2278 First_Arg :=
2279 OK_Convert_To (Parent_Type,
2280 New_Occurrence_Of
2281 (Defining_Identifier (First (Parameters)), Loc));
2283 Set_Etype (First_Arg, Parent_Type);
2285 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
2287 -- In the tasks case,
2288 -- add _Master as the value of the _Master parameter
2289 -- add _Chain as the value of the _Chain parameter.
2290 -- add _Task_Name as the value of the _Task_Name parameter.
2291 -- At the outer level, these will be variables holding the
2292 -- corresponding values obtained from GNARL or the expander.
2294 -- At inner levels, they will be the parameters passed down through
2295 -- the outer routines.
2297 First_Discr_Param := Next (First (Parameters));
2299 if Has_Task (Rec_Type) then
2300 if Restriction_Active (No_Task_Hierarchy) then
2301 Append_To
2302 (Args, Make_Integer_Literal (Loc, Library_Task_Level));
2303 else
2304 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
2305 end if;
2307 -- Add _Chain (not done for sequential elaboration policy, see
2308 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
2310 if Partition_Elaboration_Policy /= 'S' then
2311 Append_To (Args, Make_Identifier (Loc, Name_uChain));
2312 end if;
2314 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
2315 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
2316 end if;
2318 -- Append discriminant values
2320 if Has_Discriminants (Uparent_Type) then
2321 pragma Assert (not Is_Tagged_Type (Uparent_Type));
2323 Parent_Discr := First_Discriminant (Uparent_Type);
2324 while Present (Parent_Discr) loop
2326 -- Get the initial value for this discriminant
2327 -- ??? needs to be cleaned up to use parent_Discr_Constr
2328 -- directly.
2330 declare
2331 Discr : Entity_Id :=
2332 First_Stored_Discriminant (Uparent_Type);
2334 Discr_Value : Elmt_Id :=
2335 First_Elmt (Stored_Constraint (Rec_Type));
2337 begin
2338 while Original_Record_Component (Parent_Discr) /= Discr loop
2339 Next_Stored_Discriminant (Discr);
2340 Next_Elmt (Discr_Value);
2341 end loop;
2343 Arg := Node (Discr_Value);
2344 end;
2346 -- Append it to the list
2348 if Nkind (Arg) = N_Identifier
2349 and then Ekind (Entity (Arg)) = E_Discriminant
2350 then
2351 Append_To (Args,
2352 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
2354 -- Case of access discriminants. We replace the reference
2355 -- to the type by a reference to the actual object.
2357 -- Is above comment right??? Use of New_Copy below seems mighty
2358 -- suspicious ???
2360 else
2361 Append_To (Args, New_Copy (Arg));
2362 end if;
2364 Next_Discriminant (Parent_Discr);
2365 end loop;
2366 end if;
2368 Res :=
2369 New_List (
2370 Make_Procedure_Call_Statement (Loc,
2371 Name =>
2372 New_Occurrence_Of (Parent_Proc, Loc),
2373 Parameter_Associations => Args));
2375 return Res;
2376 end Build_Init_Call_Thru;
2378 -----------------------------------
2379 -- Build_Offset_To_Top_Functions --
2380 -----------------------------------
2382 procedure Build_Offset_To_Top_Functions is
2384 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
2385 -- Generate:
2386 -- function Fxx (O : Address) return Storage_Offset is
2387 -- type Acc is access all <Typ>;
2388 -- begin
2389 -- return Acc!(O).Iface_Comp'Position;
2390 -- end Fxx;
2392 ----------------------------------
2393 -- Build_Offset_To_Top_Function --
2394 ----------------------------------
2396 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
2397 Body_Node : Node_Id;
2398 Func_Id : Entity_Id;
2399 Spec_Node : Node_Id;
2400 Acc_Type : Entity_Id;
2402 begin
2403 Func_Id := Make_Temporary (Loc, 'F');
2404 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
2406 -- Generate
2407 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
2409 Spec_Node := New_Node (N_Function_Specification, Loc);
2410 Set_Defining_Unit_Name (Spec_Node, Func_Id);
2411 Set_Parameter_Specifications (Spec_Node, New_List (
2412 Make_Parameter_Specification (Loc,
2413 Defining_Identifier =>
2414 Make_Defining_Identifier (Loc, Name_uO),
2415 In_Present => True,
2416 Parameter_Type =>
2417 New_Occurrence_Of (RTE (RE_Address), Loc))));
2418 Set_Result_Definition (Spec_Node,
2419 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
2421 -- Generate
2422 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
2423 -- begin
2424 -- return -O.Iface_Comp'Position;
2425 -- end Fxx;
2427 Body_Node := New_Node (N_Subprogram_Body, Loc);
2428 Set_Specification (Body_Node, Spec_Node);
2430 Acc_Type := Make_Temporary (Loc, 'T');
2431 Set_Declarations (Body_Node, New_List (
2432 Make_Full_Type_Declaration (Loc,
2433 Defining_Identifier => Acc_Type,
2434 Type_Definition =>
2435 Make_Access_To_Object_Definition (Loc,
2436 All_Present => True,
2437 Null_Exclusion_Present => False,
2438 Constant_Present => False,
2439 Subtype_Indication =>
2440 New_Occurrence_Of (Rec_Type, Loc)))));
2442 Set_Handled_Statement_Sequence (Body_Node,
2443 Make_Handled_Sequence_Of_Statements (Loc,
2444 Statements => New_List (
2445 Make_Simple_Return_Statement (Loc,
2446 Expression =>
2447 Make_Op_Minus (Loc,
2448 Make_Attribute_Reference (Loc,
2449 Prefix =>
2450 Make_Selected_Component (Loc,
2451 Prefix =>
2452 Make_Explicit_Dereference (Loc,
2453 Unchecked_Convert_To (Acc_Type,
2454 Make_Identifier (Loc, Name_uO))),
2455 Selector_Name =>
2456 New_Occurrence_Of (Iface_Comp, Loc)),
2457 Attribute_Name => Name_Position))))));
2459 Mutate_Ekind (Func_Id, E_Function);
2460 Set_Mechanism (Func_Id, Default_Mechanism);
2461 Set_Is_Internal (Func_Id, True);
2463 if not Debug_Generated_Code then
2464 Set_Debug_Info_Off (Func_Id);
2465 end if;
2467 Analyze (Body_Node);
2469 Append_Freeze_Action (Rec_Type, Body_Node);
2470 end Build_Offset_To_Top_Function;
2472 -- Local variables
2474 Iface_Comp : Node_Id;
2475 Iface_Comp_Elmt : Elmt_Id;
2476 Ifaces_Comp_List : Elist_Id;
2478 -- Start of processing for Build_Offset_To_Top_Functions
2480 begin
2481 -- Offset_To_Top_Functions are built only for derivations of types
2482 -- with discriminants that cover interface types.
2483 -- Nothing is needed either in case of virtual targets, since
2484 -- interfaces are handled directly by the target.
2486 if not Is_Tagged_Type (Rec_Type)
2487 or else Etype (Rec_Type) = Rec_Type
2488 or else not Has_Discriminants (Etype (Rec_Type))
2489 or else not Tagged_Type_Expansion
2490 then
2491 return;
2492 end if;
2494 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2496 -- For each interface type with secondary dispatch table we generate
2497 -- the Offset_To_Top_Functions (required to displace the pointer in
2498 -- interface conversions)
2500 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2501 while Present (Iface_Comp_Elmt) loop
2502 Iface_Comp := Node (Iface_Comp_Elmt);
2503 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2505 -- If the interface is a parent of Rec_Type it shares the primary
2506 -- dispatch table and hence there is no need to build the function
2508 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2509 Use_Full_View => True)
2510 then
2511 Build_Offset_To_Top_Function (Iface_Comp);
2512 end if;
2514 Next_Elmt (Iface_Comp_Elmt);
2515 end loop;
2516 end Build_Offset_To_Top_Functions;
2518 ------------------------------
2519 -- Build_CPP_Init_Procedure --
2520 ------------------------------
2522 procedure Build_CPP_Init_Procedure is
2523 Body_Node : Node_Id;
2524 Body_Stmts : List_Id;
2525 Flag_Id : Entity_Id;
2526 Handled_Stmt_Node : Node_Id;
2527 Init_Tags_List : List_Id;
2528 Proc_Id : Entity_Id;
2529 Proc_Spec_Node : Node_Id;
2531 begin
2532 -- Check cases requiring no IC routine
2534 if not Is_CPP_Class (Root_Type (Rec_Type))
2535 or else Is_CPP_Class (Rec_Type)
2536 or else CPP_Num_Prims (Rec_Type) = 0
2537 or else not Tagged_Type_Expansion
2538 or else No_Run_Time_Mode
2539 then
2540 return;
2541 end if;
2543 -- Generate:
2545 -- Flag : Boolean := False;
2547 -- procedure Typ_IC is
2548 -- begin
2549 -- if not Flag then
2550 -- Copy C++ dispatch table slots from parent
2551 -- Update C++ slots of overridden primitives
2552 -- end if;
2553 -- end;
2555 Flag_Id := Make_Temporary (Loc, 'F');
2557 Append_Freeze_Action (Rec_Type,
2558 Make_Object_Declaration (Loc,
2559 Defining_Identifier => Flag_Id,
2560 Object_Definition =>
2561 New_Occurrence_Of (Standard_Boolean, Loc),
2562 Expression =>
2563 New_Occurrence_Of (Standard_True, Loc)));
2565 Body_Stmts := New_List;
2566 Body_Node := New_Node (N_Subprogram_Body, Loc);
2568 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2570 Proc_Id :=
2571 Make_Defining_Identifier (Loc,
2572 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2574 Mutate_Ekind (Proc_Id, E_Procedure);
2575 Set_Is_Internal (Proc_Id);
2577 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2579 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2580 Set_Specification (Body_Node, Proc_Spec_Node);
2581 Set_Declarations (Body_Node, New_List);
2583 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2585 Append_To (Init_Tags_List,
2586 Make_Assignment_Statement (Loc,
2587 Name =>
2588 New_Occurrence_Of (Flag_Id, Loc),
2589 Expression =>
2590 New_Occurrence_Of (Standard_False, Loc)));
2592 Append_To (Body_Stmts,
2593 Make_If_Statement (Loc,
2594 Condition => New_Occurrence_Of (Flag_Id, Loc),
2595 Then_Statements => Init_Tags_List));
2597 Handled_Stmt_Node :=
2598 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2599 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2600 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2601 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2603 if not Debug_Generated_Code then
2604 Set_Debug_Info_Off (Proc_Id);
2605 end if;
2607 -- Associate CPP_Init_Proc with type
2609 Set_Init_Proc (Rec_Type, Proc_Id);
2610 end Build_CPP_Init_Procedure;
2612 --------------------------
2613 -- Build_Init_Procedure --
2614 --------------------------
2616 procedure Build_Init_Procedure is
2617 Body_Stmts : List_Id;
2618 Body_Node : Node_Id;
2619 Handled_Stmt_Node : Node_Id;
2620 Init_Tags_List : List_Id;
2621 Parameters : List_Id;
2622 Proc_Spec_Node : Node_Id;
2623 Record_Extension_Node : Node_Id;
2625 use Initialization_Control;
2626 begin
2627 Body_Stmts := New_List;
2628 Body_Node := New_Node (N_Subprogram_Body, Loc);
2629 Mutate_Ekind (Proc_Id, E_Procedure);
2631 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2632 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2634 Parameters := Init_Formals (Rec_Type, Proc_Id);
2635 Append_List_To (Parameters,
2636 Build_Discriminant_Formals (Rec_Type, True));
2638 -- For tagged types, we add a parameter to indicate what
2639 -- portion of the object's initialization is to be performed.
2640 -- This is used for two purposes:
2641 -- 1) When a type extension's initialization procedure calls
2642 -- the initialization procedure of the parent type, we do
2643 -- not want the parent to initialize the Tag component;
2644 -- it has been set already.
2645 -- 2) If an ancestor type has at least one component that requires
2646 -- late initialization, then we need to be able to initialize
2647 -- those components separately after initializing any other
2648 -- components.
2650 if Is_Tagged_Type (Rec_Type) then
2651 Init_Control_Formal := Make_Temporary (Loc, 'P');
2653 Append_To (Parameters,
2654 Make_Parameter_Specification (Loc,
2655 Defining_Identifier => Init_Control_Formal,
2656 Parameter_Type =>
2657 New_Occurrence_Of (Standard_Natural, Loc),
2658 Expression => Make_Mode_Literal (Loc, Full_Init)));
2659 end if;
2661 -- Create an extra accessibility parameter to capture the level of
2662 -- the object being initialized when its type is a limited record.
2664 if Is_Limited_Record (Rec_Type) then
2665 Append_To (Parameters,
2666 Make_Parameter_Specification (Loc,
2667 Defining_Identifier => Make_Defining_Identifier
2668 (Loc, Name_uInit_Level),
2669 Parameter_Type =>
2670 New_Occurrence_Of (Standard_Natural, Loc),
2671 Expression =>
2672 Make_Integer_Literal
2673 (Loc, Scope_Depth (Standard_Standard))));
2674 end if;
2676 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2677 Set_Specification (Body_Node, Proc_Spec_Node);
2678 Set_Declarations (Body_Node, Decls);
2680 -- N is a Derived_Type_Definition that renames the parameters of the
2681 -- ancestor type. We initialize it by expanding our discriminants and
2682 -- call the ancestor _init_proc with a type-converted object.
2684 if Parent_Subtype_Renaming_Discrims then
2685 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2687 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2688 Build_Discriminant_Assignments (Body_Stmts);
2690 if not Null_Present (Type_Definition (N)) then
2691 Append_List_To (Body_Stmts,
2692 Build_Init_Statements (Component_List (Type_Definition (N))));
2693 end if;
2695 -- N is a Derived_Type_Definition with a possible non-empty
2696 -- extension. The initialization of a type extension consists in the
2697 -- initialization of the components in the extension.
2699 else
2700 Build_Discriminant_Assignments (Body_Stmts);
2702 Record_Extension_Node :=
2703 Record_Extension_Part (Type_Definition (N));
2705 if not Null_Present (Record_Extension_Node) then
2706 declare
2707 Stmts : constant List_Id :=
2708 Build_Init_Statements (
2709 Component_List (Record_Extension_Node));
2711 begin
2712 -- The parent field must be initialized first because the
2713 -- offset of the new discriminants may depend on it. This is
2714 -- not needed if the parent is an interface type because in
2715 -- such case the initialization of the _parent field was not
2716 -- generated.
2718 if not Is_Interface (Etype (Rec_Ent)) then
2719 declare
2720 Parent_IP : constant Name_Id :=
2721 Make_Init_Proc_Name (Etype (Rec_Ent));
2722 Stmt : Node_Id := First (Stmts);
2723 IP_Call : Node_Id := Empty;
2724 begin
2725 -- Look for a call to the parent IP associated with
2726 -- the record extension.
2727 -- The call will be inside not one but two
2728 -- if-statements (with the same condition). Testing
2729 -- the same Early_Init condition twice might seem
2730 -- redundant. However, as soon as we exit this loop,
2731 -- we are going to hoist the inner if-statement out
2732 -- of the outer one; the "redundant" test was built
2733 -- in anticipation of this hoisting.
2735 while Present (Stmt) loop
2736 if Nkind (Stmt) = N_If_Statement then
2737 declare
2738 Then_Stmt1 : Node_Id :=
2739 First (Then_Statements (Stmt));
2740 Then_Stmt2 : Node_Id;
2741 begin
2742 while Present (Then_Stmt1) loop
2743 if Nkind (Then_Stmt1) = N_If_Statement then
2744 Then_Stmt2 :=
2745 First (Then_Statements (Then_Stmt1));
2747 if Nkind (Then_Stmt2) =
2748 N_Procedure_Call_Statement
2749 and then Chars (Name (Then_Stmt2)) =
2750 Parent_IP
2751 then
2752 -- IP_Call is a call wrapped in an
2753 -- if statement.
2754 IP_Call := Then_Stmt1;
2755 exit;
2756 end if;
2757 end if;
2758 Next (Then_Stmt1);
2759 end loop;
2760 end;
2761 end if;
2763 Next (Stmt);
2764 end loop;
2766 -- If found then move it to the beginning of the
2767 -- statements of this IP routine
2769 if Present (IP_Call) then
2770 Remove (IP_Call);
2771 Prepend_List_To (Body_Stmts, New_List (IP_Call));
2772 end if;
2773 end;
2774 end if;
2776 Append_List_To (Body_Stmts, Stmts);
2777 end;
2778 end if;
2779 end if;
2781 -- Add here the assignment to instantiate the Tag
2783 -- The assignment corresponds to the code:
2785 -- _Init._Tag := Typ'Tag;
2787 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2788 -- tags are represented implicitly in objects. It is also suppressed
2789 -- in case of CPP_Class types because in this case the tag is
2790 -- initialized in the C++ side.
2792 if Is_Tagged_Type (Rec_Type)
2793 and then Tagged_Type_Expansion
2794 and then not No_Run_Time_Mode
2795 then
2796 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2797 -- the actual object and invoke the IP of the parent (in this
2798 -- order). The tag must be initialized before the call to the IP
2799 -- of the parent and the assignments to other components because
2800 -- the initial value of the components may depend on the tag (eg.
2801 -- through a dispatching operation on an access to the current
2802 -- type). The tag assignment is not done when initializing the
2803 -- parent component of a type extension, because in that case the
2804 -- tag is set in the extension.
2806 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2808 -- Initialize the primary tag component
2810 Init_Tags_List := New_List (
2811 Make_Assignment_Statement (Loc,
2812 Name =>
2813 Make_Selected_Component (Loc,
2814 Prefix => Make_Identifier (Loc, Name_uInit),
2815 Selector_Name =>
2816 New_Occurrence_Of
2817 (First_Tag_Component (Rec_Type), Loc)),
2818 Expression =>
2819 New_Occurrence_Of
2820 (Node
2821 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2823 -- Ada 2005 (AI-251): Initialize the secondary tags components
2824 -- located at fixed positions (tags whose position depends on
2825 -- variable size components are initialized later ---see below)
2827 if Ada_Version >= Ada_2005
2828 and then not Is_Interface (Rec_Type)
2829 and then Has_Interfaces (Rec_Type)
2830 then
2831 declare
2832 Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
2833 Elab_List : List_Id := New_List;
2835 begin
2836 Init_Secondary_Tags
2837 (Typ => Rec_Type,
2838 Target => Make_Identifier (Loc, Name_uInit),
2839 Init_Tags_List => Init_Tags_List,
2840 Stmts_List => Elab_Sec_DT_Stmts_List,
2841 Fixed_Comps => True,
2842 Variable_Comps => False);
2844 Elab_List := New_List (
2845 Make_If_Statement (Loc,
2846 Condition =>
2847 Tag_Init_Condition (Loc, Init_Control_Formal),
2848 Then_Statements => Init_Tags_List));
2850 if Elab_Flag_Needed (Rec_Type) then
2851 Append_To (Elab_Sec_DT_Stmts_List,
2852 Make_Assignment_Statement (Loc,
2853 Name =>
2854 New_Occurrence_Of
2855 (Access_Disp_Table_Elab_Flag (Rec_Type),
2856 Loc),
2857 Expression =>
2858 New_Occurrence_Of (Standard_False, Loc)));
2860 Append_To (Elab_List,
2861 Make_If_Statement (Loc,
2862 Condition =>
2863 New_Occurrence_Of
2864 (Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
2865 Then_Statements => Elab_Sec_DT_Stmts_List));
2866 end if;
2868 Prepend_List_To (Body_Stmts, Elab_List);
2869 end;
2870 else
2871 Prepend_To (Body_Stmts,
2872 Make_If_Statement (Loc,
2873 Condition =>
2874 Tag_Init_Condition (Loc, Init_Control_Formal),
2875 Then_Statements => Init_Tags_List));
2876 end if;
2878 -- Case 2: CPP type. The imported C++ constructor takes care of
2879 -- tags initialization. No action needed here because the IP
2880 -- is built by Set_CPP_Constructors; in this case the IP is a
2881 -- wrapper that invokes the C++ constructor and copies the C++
2882 -- tags locally. Done to inherit the C++ slots in Ada derivations
2883 -- (see case 3).
2885 elsif Is_CPP_Class (Rec_Type) then
2886 pragma Assert (False);
2887 null;
2889 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2890 -- type derivations. Derivations of imported C++ classes add a
2891 -- complication, because we cannot inhibit tag setting in the
2892 -- constructor for the parent. Hence we initialize the tag after
2893 -- the call to the parent IP (that is, in reverse order compared
2894 -- with pure Ada hierarchies ---see comment on case 1).
2896 else
2897 -- Initialize the primary tag
2899 Init_Tags_List := New_List (
2900 Make_Assignment_Statement (Loc,
2901 Name =>
2902 Make_Selected_Component (Loc,
2903 Prefix => Make_Identifier (Loc, Name_uInit),
2904 Selector_Name =>
2905 New_Occurrence_Of
2906 (First_Tag_Component (Rec_Type), Loc)),
2907 Expression =>
2908 New_Occurrence_Of
2909 (Node
2910 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2912 -- Ada 2005 (AI-251): Initialize the secondary tags components
2913 -- located at fixed positions (tags whose position depends on
2914 -- variable size components are initialized later ---see below)
2916 if Ada_Version >= Ada_2005
2917 and then not Is_Interface (Rec_Type)
2918 and then Has_Interfaces (Rec_Type)
2919 then
2920 Init_Secondary_Tags
2921 (Typ => Rec_Type,
2922 Target => Make_Identifier (Loc, Name_uInit),
2923 Init_Tags_List => Init_Tags_List,
2924 Stmts_List => Init_Tags_List,
2925 Fixed_Comps => True,
2926 Variable_Comps => False);
2927 end if;
2929 -- Initialize the tag component after invocation of parent IP.
2931 -- Generate:
2932 -- parent_IP(_init.parent); // Invokes the C++ constructor
2933 -- [ typIC; ] // Inherit C++ slots from parent
2934 -- init_tags
2936 declare
2937 Ins_Nod : Node_Id;
2939 begin
2940 -- Search for the call to the IP of the parent. We assume
2941 -- that the first init_proc call is for the parent.
2942 -- It is wrapped in an "if Early_Init_Condition"
2943 -- if-statement.
2945 Ins_Nod := First (Body_Stmts);
2946 while Present (Next (Ins_Nod))
2947 and then
2948 (Nkind (Ins_Nod) /= N_If_Statement
2949 or else (Nkind (First (Then_Statements (Ins_Nod)))
2950 /= N_Procedure_Call_Statement)
2951 or else not Is_Init_Proc
2952 (Name (First (Then_Statements
2953 (Ins_Nod)))))
2954 loop
2955 Next (Ins_Nod);
2956 end loop;
2958 -- The IC routine copies the inherited slots of the C+ part
2959 -- of the dispatch table from the parent and updates the
2960 -- overridden C++ slots.
2962 if CPP_Num_Prims (Rec_Type) > 0 then
2963 declare
2964 Init_DT : Entity_Id;
2965 New_Nod : Node_Id;
2967 begin
2968 Init_DT := CPP_Init_Proc (Rec_Type);
2969 pragma Assert (Present (Init_DT));
2971 New_Nod :=
2972 Make_Procedure_Call_Statement (Loc,
2973 New_Occurrence_Of (Init_DT, Loc));
2974 Insert_After (Ins_Nod, New_Nod);
2976 -- Update location of init tag statements
2978 Ins_Nod := New_Nod;
2979 end;
2980 end if;
2982 Insert_List_After (Ins_Nod, Init_Tags_List);
2983 end;
2984 end if;
2986 -- Ada 2005 (AI-251): Initialize the secondary tag components
2987 -- located at variable positions. We delay the generation of this
2988 -- code until here because the value of the attribute 'Position
2989 -- applied to variable size components of the parent type that
2990 -- depend on discriminants is only safely read at runtime after
2991 -- the parent components have been initialized.
2993 if Ada_Version >= Ada_2005
2994 and then not Is_Interface (Rec_Type)
2995 and then Has_Interfaces (Rec_Type)
2996 and then Has_Discriminants (Etype (Rec_Type))
2997 and then Is_Variable_Size_Record (Etype (Rec_Type))
2998 then
2999 Init_Tags_List := New_List;
3001 Init_Secondary_Tags
3002 (Typ => Rec_Type,
3003 Target => Make_Identifier (Loc, Name_uInit),
3004 Init_Tags_List => Init_Tags_List,
3005 Stmts_List => Init_Tags_List,
3006 Fixed_Comps => False,
3007 Variable_Comps => True);
3009 Append_List_To (Body_Stmts, Init_Tags_List);
3010 end if;
3011 end if;
3013 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
3014 Set_Statements (Handled_Stmt_Node, Body_Stmts);
3016 -- Generate:
3017 -- Deep_Finalize (_init, C1, ..., CN);
3018 -- raise;
3020 if Counter > 0
3021 and then Needs_Finalization (Rec_Type)
3022 and then not Is_Abstract_Type (Rec_Type)
3023 and then not Restriction_Active (No_Exception_Propagation)
3024 then
3025 declare
3026 DF_Call : Node_Id;
3027 DF_Id : Entity_Id;
3029 begin
3030 -- Create a local version of Deep_Finalize which has indication
3031 -- of partial initialization state.
3033 DF_Id :=
3034 Make_Defining_Identifier (Loc,
3035 Chars => New_External_Name (Name_uFinalizer));
3037 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
3039 DF_Call :=
3040 Make_Procedure_Call_Statement (Loc,
3041 Name => New_Occurrence_Of (DF_Id, Loc),
3042 Parameter_Associations => New_List (
3043 Make_Identifier (Loc, Name_uInit),
3044 New_Occurrence_Of (Standard_False, Loc)));
3046 -- Do not emit warnings related to the elaboration order when a
3047 -- controlled object is declared before the body of Finalize is
3048 -- seen.
3050 if Legacy_Elaboration_Checks then
3051 Set_No_Elaboration_Check (DF_Call);
3052 end if;
3054 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
3055 Make_Exception_Handler (Loc,
3056 Exception_Choices => New_List (
3057 Make_Others_Choice (Loc)),
3058 Statements => New_List (
3059 DF_Call,
3060 Make_Raise_Statement (Loc)))));
3061 end;
3062 else
3063 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
3064 end if;
3066 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
3068 if not Debug_Generated_Code then
3069 Set_Debug_Info_Off (Proc_Id);
3070 end if;
3072 -- Associate Init_Proc with type, and determine if the procedure
3073 -- is null (happens because of the Initialize_Scalars pragma case,
3074 -- where we have to generate a null procedure in case it is called
3075 -- by a client with Initialize_Scalars set). Such procedures have
3076 -- to be generated, but do not have to be called, so we mark them
3077 -- as null to suppress the call. Kill also warnings for the _Init
3078 -- out parameter, which is left entirely uninitialized.
3080 Set_Init_Proc (Rec_Type, Proc_Id);
3082 if Is_Null_Statement_List (Body_Stmts) then
3083 Set_Is_Null_Init_Proc (Proc_Id);
3084 Set_Warnings_Off (Defining_Identifier (First (Parameters)));
3085 end if;
3086 end Build_Init_Procedure;
3088 ---------------------------
3089 -- Build_Init_Statements --
3090 ---------------------------
3092 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
3093 Checks : constant List_Id := New_List;
3094 Actions : List_Id := No_List;
3095 Counter_Id : Entity_Id := Empty;
3096 Comp_Loc : Source_Ptr;
3097 Decl : Node_Id;
3098 Id : Entity_Id;
3099 Parent_Stmts : List_Id;
3100 Parent_Id : Entity_Id := Empty;
3101 Stmts, Late_Stmts : List_Id := Empty_List;
3102 Typ : Entity_Id;
3104 procedure Increment_Counter
3105 (Loc : Source_Ptr; Late : Boolean := False);
3106 -- Generate an "increment by one" statement for the current counter
3107 -- and append it to the appropriate statement list.
3109 procedure Make_Counter (Loc : Source_Ptr);
3110 -- Create a new counter for the current component list. The routine
3111 -- creates a new defining Id, adds an object declaration and sets
3112 -- the Id generator for the next variant.
3114 -----------------------
3115 -- Increment_Counter --
3116 -----------------------
3118 procedure Increment_Counter
3119 (Loc : Source_Ptr; Late : Boolean := False) is
3120 begin
3121 -- Generate:
3122 -- Counter := Counter + 1;
3124 Append_To ((if Late then Late_Stmts else Stmts),
3125 Make_Assignment_Statement (Loc,
3126 Name => New_Occurrence_Of (Counter_Id, Loc),
3127 Expression =>
3128 Make_Op_Add (Loc,
3129 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
3130 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3131 end Increment_Counter;
3133 ------------------
3134 -- Make_Counter --
3135 ------------------
3137 procedure Make_Counter (Loc : Source_Ptr) is
3138 begin
3139 -- Increment the Id generator
3141 Counter := Counter + 1;
3143 -- Create the entity and declaration
3145 Counter_Id :=
3146 Make_Defining_Identifier (Loc,
3147 Chars => New_External_Name ('C', Counter));
3149 -- Generate:
3150 -- Cnn : Integer := 0;
3152 Append_To (Decls,
3153 Make_Object_Declaration (Loc,
3154 Defining_Identifier => Counter_Id,
3155 Object_Definition =>
3156 New_Occurrence_Of (Standard_Integer, Loc),
3157 Expression =>
3158 Make_Integer_Literal (Loc, 0)));
3159 end Make_Counter;
3161 -- Start of processing for Build_Init_Statements
3163 begin
3164 if Null_Present (Comp_List) then
3165 return New_List (Make_Null_Statement (Loc));
3166 end if;
3168 Parent_Stmts := New_List;
3169 Stmts := New_List;
3171 -- Loop through visible declarations of task types and protected
3172 -- types moving any expanded code from the spec to the body of the
3173 -- init procedure.
3175 if Is_Concurrent_Record_Type (Rec_Type) then
3176 declare
3177 Decl : constant Node_Id :=
3178 Parent (Corresponding_Concurrent_Type (Rec_Type));
3179 Def : Node_Id;
3180 N1 : Node_Id;
3181 N2 : Node_Id;
3183 begin
3184 if Is_Task_Record_Type (Rec_Type) then
3185 Def := Task_Definition (Decl);
3186 else
3187 Def := Protected_Definition (Decl);
3188 end if;
3190 if Present (Def) then
3191 N1 := First (Visible_Declarations (Def));
3192 while Present (N1) loop
3193 N2 := N1;
3194 N1 := Next (N1);
3196 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
3197 or else Nkind (N2) in N_Raise_xxx_Error
3198 or else Nkind (N2) = N_Procedure_Call_Statement
3199 then
3200 Append_To (Stmts,
3201 New_Copy_Tree (N2, New_Scope => Proc_Id));
3202 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
3203 Analyze (N2);
3204 end if;
3205 end loop;
3206 end if;
3207 end;
3208 end if;
3210 -- Loop through components, skipping pragmas, in 2 steps. The first
3211 -- step deals with regular components. The second step deals with
3212 -- components that require late initialization.
3214 -- First pass : regular components
3216 Decl := First_Non_Pragma (Component_Items (Comp_List));
3217 while Present (Decl) loop
3218 Comp_Loc := Sloc (Decl);
3219 Build_Record_Checks
3220 (Subtype_Indication (Component_Definition (Decl)), Checks);
3222 Id := Defining_Identifier (Decl);
3223 Typ := Etype (Id);
3225 -- Leave any processing of component requiring late initialization
3226 -- for the second pass.
3228 if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then
3229 if not Has_Late_Init_Comp then
3230 Late_Stmts := New_List;
3231 end if;
3232 Has_Late_Init_Comp := True;
3234 -- Regular component cases
3236 else
3237 -- In the context of the init proc, references to discriminants
3238 -- resolve to denote the discriminals: this is where we can
3239 -- freeze discriminant dependent component subtypes.
3241 if not Is_Frozen (Typ) then
3242 Append_List_To (Stmts, Freeze_Entity (Typ, N));
3243 end if;
3245 -- Explicit initialization
3247 if Present (Expression (Decl)) then
3248 if Is_CPP_Constructor_Call (Expression (Decl)) then
3249 Actions :=
3250 Build_Initialization_Call
3251 (Comp_Loc,
3252 Id_Ref =>
3253 Make_Selected_Component (Comp_Loc,
3254 Prefix =>
3255 Make_Identifier (Comp_Loc, Name_uInit),
3256 Selector_Name =>
3257 New_Occurrence_Of (Id, Comp_Loc)),
3258 Typ => Typ,
3259 In_Init_Proc => True,
3260 Enclos_Type => Rec_Type,
3261 Discr_Map => Discr_Map,
3262 Constructor_Ref => Expression (Decl));
3263 else
3264 Actions := Build_Assignment (Id, Expression (Decl));
3265 end if;
3267 -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
3268 -- components are filled in with the corresponding rep-item
3269 -- expression of the concurrent type (if any).
3271 elsif Ekind (Scope (Id)) = E_Record_Type
3272 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
3273 and then Chars (Id) in Name_uCPU
3274 | Name_uDispatching_Domain
3275 | Name_uPriority
3276 | Name_uSecondary_Stack_Size
3277 then
3278 declare
3279 Exp : Node_Id;
3280 Nam : Name_Id;
3281 pragma Warnings (Off, Nam);
3282 Ritem : Node_Id;
3284 begin
3285 if Chars (Id) = Name_uCPU then
3286 Nam := Name_CPU;
3288 elsif Chars (Id) = Name_uDispatching_Domain then
3289 Nam := Name_Dispatching_Domain;
3291 elsif Chars (Id) = Name_uPriority then
3292 Nam := Name_Priority;
3294 elsif Chars (Id) = Name_uSecondary_Stack_Size then
3295 Nam := Name_Secondary_Stack_Size;
3296 end if;
3298 -- Get the Rep Item (aspect specification, attribute
3299 -- definition clause or pragma) of the corresponding
3300 -- concurrent type.
3302 Ritem :=
3303 Get_Rep_Item
3304 (Corresponding_Concurrent_Type (Scope (Id)),
3305 Nam,
3306 Check_Parents => False);
3308 if Present (Ritem) then
3310 -- Pragma case
3312 if Nkind (Ritem) = N_Pragma then
3313 Exp :=
3314 Get_Pragma_Arg
3315 (First (Pragma_Argument_Associations (Ritem)));
3317 -- Conversion for Priority expression
3319 if Nam = Name_Priority then
3320 if Pragma_Name (Ritem) = Name_Priority
3321 and then not GNAT_Mode
3322 then
3323 Exp := Convert_To (RTE (RE_Priority), Exp);
3324 else
3325 Exp :=
3326 Convert_To (RTE (RE_Any_Priority), Exp);
3327 end if;
3328 end if;
3330 -- Aspect/Attribute definition clause case
3332 else
3333 Exp := Expression (Ritem);
3335 -- Conversion for Priority expression
3337 if Nam = Name_Priority then
3338 if Chars (Ritem) = Name_Priority
3339 and then not GNAT_Mode
3340 then
3341 Exp := Convert_To (RTE (RE_Priority), Exp);
3342 else
3343 Exp :=
3344 Convert_To (RTE (RE_Any_Priority), Exp);
3345 end if;
3346 end if;
3347 end if;
3349 -- Conversion for Dispatching_Domain value
3351 if Nam = Name_Dispatching_Domain then
3352 Exp :=
3353 Unchecked_Convert_To
3354 (RTE (RE_Dispatching_Domain_Access), Exp);
3356 -- Conversion for Secondary_Stack_Size value
3358 elsif Nam = Name_Secondary_Stack_Size then
3359 Exp := Convert_To (RTE (RE_Size_Type), Exp);
3360 end if;
3362 Actions := Build_Assignment (Id, Exp);
3364 -- Nothing needed if no Rep Item
3366 else
3367 Actions := No_List;
3368 end if;
3369 end;
3371 -- Composite component with its own Init_Proc
3373 elsif not Is_Interface (Typ)
3374 and then Has_Non_Null_Base_Init_Proc (Typ)
3375 then
3376 declare
3377 use Initialization_Control;
3378 Init_Control_Actual : Node_Id := Empty;
3379 Is_Parent : constant Boolean := Chars (Id) = Name_uParent;
3380 Init_Call_Stmts : List_Id;
3381 begin
3382 if Is_Parent and then Has_Late_Init_Component (Etype (Id))
3383 then
3384 Init_Control_Actual :=
3385 Make_Mode_Literal (Comp_Loc, Early_Init_Only);
3386 -- Parent_Id used later in second call to parent's
3387 -- init proc to initialize late-init components.
3388 Parent_Id := Id;
3389 end if;
3391 Init_Call_Stmts :=
3392 Build_Initialization_Call
3393 (Comp_Loc,
3394 Make_Selected_Component (Comp_Loc,
3395 Prefix =>
3396 Make_Identifier (Comp_Loc, Name_uInit),
3397 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3398 Typ,
3399 In_Init_Proc => True,
3400 Enclos_Type => Rec_Type,
3401 Discr_Map => Discr_Map,
3402 Init_Control_Actual => Init_Control_Actual);
3404 if Is_Parent then
3405 -- This is tricky. At first it looks like
3406 -- we are going to end up with nested
3407 -- if-statements with the same condition:
3408 -- if Early_Init_Condition then
3409 -- if Early_Init_Condition then
3410 -- Parent_TypeIP (...);
3411 -- end if;
3412 -- end if;
3413 -- But later we will hoist the inner if-statement
3414 -- out of the outer one; we do this because the
3415 -- init-proc call for the _Parent component of a type
3416 -- extension has to precede any other initialization.
3417 Actions :=
3418 New_List (Make_If_Statement (Loc,
3419 Condition =>
3420 Early_Init_Condition (Loc, Init_Control_Formal),
3421 Then_Statements => Init_Call_Stmts));
3422 else
3423 Actions := Init_Call_Stmts;
3424 end if;
3425 end;
3427 Clean_Task_Names (Typ, Proc_Id);
3429 -- Simple initialization. If the Esize is not yet set, we pass
3430 -- Uint_0 as expected by Get_Simple_Init_Val.
3432 elsif Component_Needs_Simple_Initialization (Typ) then
3433 Actions :=
3434 Build_Assignment
3435 (Id => Id,
3436 Default =>
3437 Get_Simple_Init_Val
3438 (Typ => Typ,
3439 N => N,
3440 Size =>
3441 (if Known_Esize (Id) then Esize (Id)
3442 else Uint_0)));
3444 -- Nothing needed for this case
3446 else
3447 Actions := No_List;
3448 end if;
3450 -- When the component's type has a Default_Initial_Condition,
3451 -- and the component is default initialized, then check the
3452 -- DIC here.
3454 if Has_DIC (Typ)
3455 and then No (Expression (Decl))
3456 and then Present (DIC_Procedure (Typ))
3457 and then not Has_Null_Body (DIC_Procedure (Typ))
3459 -- The DICs of ancestors are checked as part of the type's
3460 -- DIC procedure.
3462 and then Chars (Id) /= Name_uParent
3464 -- In GNATprove mode, the component DICs are checked by other
3465 -- means. They should not be added to the record type DIC
3466 -- procedure, so that the procedure can be used to check the
3467 -- record type invariants or DICs if any.
3469 and then not GNATprove_Mode
3470 then
3471 Append_New_To (Actions,
3472 Build_DIC_Call
3473 (Comp_Loc,
3474 Make_Selected_Component (Comp_Loc,
3475 Prefix =>
3476 Make_Identifier (Comp_Loc, Name_uInit),
3477 Selector_Name =>
3478 New_Occurrence_Of (Id, Comp_Loc)),
3479 Typ));
3480 end if;
3482 if Present (Checks) then
3483 if Chars (Id) = Name_uParent then
3484 Append_List_To (Parent_Stmts, Checks);
3485 else
3486 Append_List_To (Stmts, Checks);
3487 end if;
3488 end if;
3490 if Present (Actions) then
3491 if Chars (Id) = Name_uParent then
3492 Append_List_To (Parent_Stmts, Actions);
3493 else
3494 Append_List_To (Stmts, Actions);
3496 -- Preserve initialization state in the current counter
3498 if Needs_Finalization (Typ) then
3499 if No (Counter_Id) then
3500 Make_Counter (Comp_Loc);
3501 end if;
3503 Increment_Counter (Comp_Loc);
3504 end if;
3505 end if;
3506 end if;
3507 end if;
3509 Next_Non_Pragma (Decl);
3510 end loop;
3512 -- The parent field must be initialized first because variable
3513 -- size components of the parent affect the location of all the
3514 -- new components.
3516 Prepend_List_To (Stmts, Parent_Stmts);
3518 -- Set up tasks and protected object support. This needs to be done
3519 -- before any component with a per-object access discriminant
3520 -- constraint, or any variant part (which may contain such
3521 -- components) is initialized, because the initialization of these
3522 -- components may reference the enclosing concurrent object.
3524 -- For a task record type, add the task create call and calls to bind
3525 -- any interrupt (signal) entries.
3527 if Is_Task_Record_Type (Rec_Type) then
3529 -- In the case of the restricted run time the ATCB has already
3530 -- been preallocated.
3532 if Restricted_Profile then
3533 Append_To (Stmts,
3534 Make_Assignment_Statement (Loc,
3535 Name =>
3536 Make_Selected_Component (Loc,
3537 Prefix => Make_Identifier (Loc, Name_uInit),
3538 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3539 Expression =>
3540 Make_Attribute_Reference (Loc,
3541 Prefix =>
3542 Make_Selected_Component (Loc,
3543 Prefix => Make_Identifier (Loc, Name_uInit),
3544 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
3545 Attribute_Name => Name_Unchecked_Access)));
3546 end if;
3548 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
3550 declare
3551 Task_Type : constant Entity_Id :=
3552 Corresponding_Concurrent_Type (Rec_Type);
3553 Task_Decl : constant Node_Id := Parent (Task_Type);
3554 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
3555 Decl_Loc : Source_Ptr;
3556 Ent : Entity_Id;
3557 Vis_Decl : Node_Id;
3559 begin
3560 if Present (Task_Def) then
3561 Vis_Decl := First (Visible_Declarations (Task_Def));
3562 while Present (Vis_Decl) loop
3563 Decl_Loc := Sloc (Vis_Decl);
3565 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
3566 if Get_Attribute_Id (Chars (Vis_Decl)) =
3567 Attribute_Address
3568 then
3569 Ent := Entity (Name (Vis_Decl));
3571 if Ekind (Ent) = E_Entry then
3572 Append_To (Stmts,
3573 Make_Procedure_Call_Statement (Decl_Loc,
3574 Name =>
3575 New_Occurrence_Of (RTE (
3576 RE_Bind_Interrupt_To_Entry), Decl_Loc),
3577 Parameter_Associations => New_List (
3578 Make_Selected_Component (Decl_Loc,
3579 Prefix =>
3580 Make_Identifier (Decl_Loc, Name_uInit),
3581 Selector_Name =>
3582 Make_Identifier
3583 (Decl_Loc, Name_uTask_Id)),
3584 Entry_Index_Expression
3585 (Decl_Loc, Ent, Empty, Task_Type),
3586 Expression (Vis_Decl))));
3587 end if;
3588 end if;
3589 end if;
3591 Next (Vis_Decl);
3592 end loop;
3593 end if;
3594 end;
3596 -- For a protected type, add statements generated by
3597 -- Make_Initialize_Protection.
3599 elsif Is_Protected_Record_Type (Rec_Type) then
3600 Append_List_To (Stmts,
3601 Make_Initialize_Protection (Rec_Type));
3602 end if;
3604 -- Second pass: components that require late initialization
3606 if Present (Parent_Id) then
3607 declare
3608 Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id));
3609 use Initialization_Control;
3610 begin
3611 -- We are building the init proc for a type extension.
3612 -- Call the parent type's init proc a second time, this
3613 -- time to initialize the parent's components that require
3614 -- late initialization.
3616 Append_List_To (Late_Stmts,
3617 Build_Initialization_Call
3618 (Loc => Parent_Loc,
3619 Id_Ref =>
3620 Make_Selected_Component (Parent_Loc,
3621 Prefix => Make_Identifier
3622 (Parent_Loc, Name_uInit),
3623 Selector_Name => New_Occurrence_Of (Parent_Id,
3624 Parent_Loc)),
3625 Typ => Etype (Parent_Id),
3626 In_Init_Proc => True,
3627 Enclos_Type => Rec_Type,
3628 Discr_Map => Discr_Map,
3629 Init_Control_Actual => Make_Mode_Literal
3630 (Parent_Loc, Late_Init_Only)));
3631 end;
3632 end if;
3634 if Has_Late_Init_Comp then
3635 Decl := First_Non_Pragma (Component_Items (Comp_List));
3636 while Present (Decl) loop
3637 Comp_Loc := Sloc (Decl);
3638 Id := Defining_Identifier (Decl);
3639 Typ := Etype (Id);
3641 if Initialization_Control.Requires_Late_Init (Decl, Rec_Type)
3642 then
3643 if Present (Expression (Decl)) then
3644 Append_List_To (Late_Stmts,
3645 Build_Assignment (Id, Expression (Decl)));
3647 elsif Has_Non_Null_Base_Init_Proc (Typ) then
3648 Append_List_To (Late_Stmts,
3649 Build_Initialization_Call (Comp_Loc,
3650 Make_Selected_Component (Comp_Loc,
3651 Prefix =>
3652 Make_Identifier (Comp_Loc, Name_uInit),
3653 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
3654 Typ,
3655 In_Init_Proc => True,
3656 Enclos_Type => Rec_Type,
3657 Discr_Map => Discr_Map));
3659 Clean_Task_Names (Typ, Proc_Id);
3661 -- Preserve initialization state in the current counter
3663 if Needs_Finalization (Typ) then
3664 if No (Counter_Id) then
3665 Make_Counter (Comp_Loc);
3666 end if;
3668 Increment_Counter (Comp_Loc, Late => True);
3669 end if;
3670 elsif Component_Needs_Simple_Initialization (Typ) then
3671 Append_List_To (Late_Stmts,
3672 Build_Assignment
3673 (Id => Id,
3674 Default =>
3675 Get_Simple_Init_Val
3676 (Typ => Typ,
3677 N => N,
3678 Size => Esize (Id))));
3679 end if;
3680 end if;
3682 Next_Non_Pragma (Decl);
3683 end loop;
3684 end if;
3686 -- Process the variant part (incorrectly ignoring late
3687 -- initialization requirements for components therein).
3689 if Present (Variant_Part (Comp_List)) then
3690 declare
3691 Variant_Alts : constant List_Id := New_List;
3692 Var_Loc : Source_Ptr := No_Location;
3693 Variant : Node_Id;
3695 begin
3696 Variant :=
3697 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3698 while Present (Variant) loop
3699 Var_Loc := Sloc (Variant);
3700 Append_To (Variant_Alts,
3701 Make_Case_Statement_Alternative (Var_Loc,
3702 Discrete_Choices =>
3703 New_Copy_List (Discrete_Choices (Variant)),
3704 Statements =>
3705 Build_Init_Statements (Component_List (Variant))));
3706 Next_Non_Pragma (Variant);
3707 end loop;
3709 -- The expression of the case statement which is a reference
3710 -- to one of the discriminants is replaced by the appropriate
3711 -- formal parameter of the initialization procedure.
3713 Append_To (Stmts,
3714 Make_Case_Statement (Var_Loc,
3715 Expression =>
3716 New_Occurrence_Of (Discriminal (
3717 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3718 Alternatives => Variant_Alts));
3719 end;
3720 end if;
3722 if No (Init_Control_Formal) then
3723 Append_List_To (Stmts, Late_Stmts);
3725 -- If no initializations were generated for component declarations
3726 -- and included in Stmts, then append a null statement to Stmts
3727 -- to make it a valid Ada tree.
3729 if Is_Empty_List (Stmts) then
3730 Append (Make_Null_Statement (Loc), Stmts);
3731 end if;
3733 return Stmts;
3734 else
3735 declare
3736 use Initialization_Control;
3738 If_Early : constant Node_Id :=
3739 (if Is_Empty_List (Stmts) then
3740 Make_Null_Statement (Loc)
3741 else
3742 Make_If_Statement (Loc,
3743 Condition =>
3744 Early_Init_Condition (Loc, Init_Control_Formal),
3745 Then_Statements => Stmts));
3746 If_Late : constant Node_Id :=
3747 (if Is_Empty_List (Late_Stmts) then
3748 Make_Null_Statement (Loc)
3749 else
3750 Make_If_Statement (Loc,
3751 Condition =>
3752 Late_Init_Condition (Loc, Init_Control_Formal),
3753 Then_Statements => Late_Stmts));
3754 begin
3755 return New_List (If_Early, If_Late);
3756 end;
3757 end if;
3758 exception
3759 when RE_Not_Available =>
3760 return Empty_List;
3761 end Build_Init_Statements;
3763 -------------------------
3764 -- Build_Record_Checks --
3765 -------------------------
3767 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3768 Subtype_Mark_Id : Entity_Id;
3770 procedure Constrain_Array
3771 (SI : Node_Id;
3772 Check_List : List_Id);
3773 -- Apply a list of index constraints to an unconstrained array type.
3774 -- The first parameter is the entity for the resulting subtype.
3775 -- Check_List is a list to which the check actions are appended.
3777 ---------------------
3778 -- Constrain_Array --
3779 ---------------------
3781 procedure Constrain_Array
3782 (SI : Node_Id;
3783 Check_List : List_Id)
3785 C : constant Node_Id := Constraint (SI);
3786 Number_Of_Constraints : Nat := 0;
3787 Index : Node_Id;
3788 S, T : Entity_Id;
3790 procedure Constrain_Index
3791 (Index : Node_Id;
3792 S : Node_Id;
3793 Check_List : List_Id);
3794 -- Process an index constraint in a constrained array declaration.
3795 -- The constraint can be either a subtype name or a range with or
3796 -- without an explicit subtype mark. Index is the corresponding
3797 -- index of the unconstrained array. S is the range expression.
3798 -- Check_List is a list to which the check actions are appended.
3800 ---------------------
3801 -- Constrain_Index --
3802 ---------------------
3804 procedure Constrain_Index
3805 (Index : Node_Id;
3806 S : Node_Id;
3807 Check_List : List_Id)
3809 T : constant Entity_Id := Etype (Index);
3811 begin
3812 if Nkind (S) = N_Range then
3813 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3814 end if;
3815 end Constrain_Index;
3817 -- Start of processing for Constrain_Array
3819 begin
3820 T := Entity (Subtype_Mark (SI));
3822 if Is_Access_Type (T) then
3823 T := Designated_Type (T);
3824 end if;
3826 S := First (Constraints (C));
3827 while Present (S) loop
3828 Number_Of_Constraints := Number_Of_Constraints + 1;
3829 Next (S);
3830 end loop;
3832 -- In either case, the index constraint must provide a discrete
3833 -- range for each index of the array type and the type of each
3834 -- discrete range must be the same as that of the corresponding
3835 -- index. (RM 3.6.1)
3837 S := First (Constraints (C));
3838 Index := First_Index (T);
3839 Analyze (Index);
3841 -- Apply constraints to each index type
3843 for J in 1 .. Number_Of_Constraints loop
3844 Constrain_Index (Index, S, Check_List);
3845 Next (Index);
3846 Next (S);
3847 end loop;
3848 end Constrain_Array;
3850 -- Start of processing for Build_Record_Checks
3852 begin
3853 if Nkind (S) = N_Subtype_Indication then
3854 Find_Type (Subtype_Mark (S));
3855 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3857 -- Remaining processing depends on type
3859 case Ekind (Subtype_Mark_Id) is
3860 when Array_Kind =>
3861 Constrain_Array (S, Check_List);
3863 when others =>
3864 null;
3865 end case;
3866 end if;
3867 end Build_Record_Checks;
3869 -------------------------------------------
3870 -- Component_Needs_Simple_Initialization --
3871 -------------------------------------------
3873 function Component_Needs_Simple_Initialization
3874 (T : Entity_Id) return Boolean
3876 begin
3877 return
3878 Needs_Simple_Initialization (T)
3879 and then not Is_RTE (T, RE_Tag)
3881 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3883 and then not Is_RTE (T, RE_Interface_Tag);
3884 end Component_Needs_Simple_Initialization;
3886 --------------------------------------
3887 -- Parent_Subtype_Renaming_Discrims --
3888 --------------------------------------
3890 function Parent_Subtype_Renaming_Discrims return Boolean is
3891 De : Entity_Id;
3892 Dp : Entity_Id;
3894 begin
3895 if Base_Type (Rec_Ent) /= Rec_Ent then
3896 return False;
3897 end if;
3899 if Etype (Rec_Ent) = Rec_Ent
3900 or else not Has_Discriminants (Rec_Ent)
3901 or else Is_Constrained (Rec_Ent)
3902 or else Is_Tagged_Type (Rec_Ent)
3903 then
3904 return False;
3905 end if;
3907 -- If there are no explicit stored discriminants we have inherited
3908 -- the root type discriminants so far, so no renamings occurred.
3910 if First_Discriminant (Rec_Ent) =
3911 First_Stored_Discriminant (Rec_Ent)
3912 then
3913 return False;
3914 end if;
3916 -- Check if we have done some trivial renaming of the parent
3917 -- discriminants, i.e. something like
3919 -- type DT (X1, X2: int) is new PT (X1, X2);
3921 De := First_Discriminant (Rec_Ent);
3922 Dp := First_Discriminant (Etype (Rec_Ent));
3923 while Present (De) loop
3924 pragma Assert (Present (Dp));
3926 if Corresponding_Discriminant (De) /= Dp then
3927 return True;
3928 end if;
3930 Next_Discriminant (De);
3931 Next_Discriminant (Dp);
3932 end loop;
3934 return Present (Dp);
3935 end Parent_Subtype_Renaming_Discrims;
3937 ------------------------
3938 -- Requires_Init_Proc --
3939 ------------------------
3941 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3942 Comp_Decl : Node_Id;
3943 Id : Entity_Id;
3944 Typ : Entity_Id;
3946 begin
3947 -- Definitely do not need one if specifically suppressed
3949 if Initialization_Suppressed (Rec_Id) then
3950 return False;
3951 end if;
3953 -- If it is a type derived from a type with unknown discriminants,
3954 -- we cannot build an initialization procedure for it.
3956 if Has_Unknown_Discriminants (Rec_Id)
3957 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3958 then
3959 return False;
3960 end if;
3962 -- Otherwise we need to generate an initialization procedure if
3963 -- Is_CPP_Class is False and at least one of the following applies:
3965 -- 1. Discriminants are present, since they need to be initialized
3966 -- with the appropriate discriminant constraint expressions.
3967 -- However, the discriminant of an unchecked union does not
3968 -- count, since the discriminant is not present.
3970 -- 2. The type is a tagged type, since the implicit Tag component
3971 -- needs to be initialized with a pointer to the dispatch table.
3973 -- 3. The type contains tasks
3975 -- 4. One or more components has an initial value
3977 -- 5. One or more components is for a type which itself requires
3978 -- an initialization procedure.
3980 -- 6. One or more components is a type that requires simple
3981 -- initialization (see Needs_Simple_Initialization), except
3982 -- that types Tag and Interface_Tag are excluded, since fields
3983 -- of these types are initialized by other means.
3985 -- 7. The type is the record type built for a task type (since at
3986 -- the very least, Create_Task must be called)
3988 -- 8. The type is the record type built for a protected type (since
3989 -- at least Initialize_Protection must be called)
3991 -- 9. The type is marked as a public entity. The reason we add this
3992 -- case (even if none of the above apply) is to properly handle
3993 -- Initialize_Scalars. If a package is compiled without an IS
3994 -- pragma, and the client is compiled with an IS pragma, then
3995 -- the client will think an initialization procedure is present
3996 -- and call it, when in fact no such procedure is required, but
3997 -- since the call is generated, there had better be a routine
3998 -- at the other end of the call, even if it does nothing).
4000 -- Note: the reason we exclude the CPP_Class case is because in this
4001 -- case the initialization is performed by the C++ constructors, and
4002 -- the IP is built by Set_CPP_Constructors.
4004 if Is_CPP_Class (Rec_Id) then
4005 return False;
4007 elsif Is_Interface (Rec_Id) then
4008 return False;
4010 elsif (Has_Discriminants (Rec_Id)
4011 and then not Is_Unchecked_Union (Rec_Id))
4012 or else Is_Tagged_Type (Rec_Id)
4013 or else Is_Concurrent_Record_Type (Rec_Id)
4014 or else Has_Task (Rec_Id)
4015 then
4016 return True;
4017 end if;
4019 Id := First_Component (Rec_Id);
4020 while Present (Id) loop
4021 Comp_Decl := Parent (Id);
4022 Typ := Etype (Id);
4024 if Present (Expression (Comp_Decl))
4025 or else Has_Non_Null_Base_Init_Proc (Typ)
4026 or else Component_Needs_Simple_Initialization (Typ)
4027 then
4028 return True;
4029 end if;
4031 Next_Component (Id);
4032 end loop;
4034 -- As explained above, a record initialization procedure is needed
4035 -- for public types in case Initialize_Scalars applies to a client.
4036 -- However, such a procedure is not needed in the case where either
4037 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
4038 -- applies. No_Initialize_Scalars excludes the possibility of using
4039 -- Initialize_Scalars in any partition, and No_Default_Initialization
4040 -- implies that no initialization should ever be done for objects of
4041 -- the type, so is incompatible with Initialize_Scalars.
4043 if not Restriction_Active (No_Initialize_Scalars)
4044 and then not Restriction_Active (No_Default_Initialization)
4045 and then Is_Public (Rec_Id)
4046 then
4047 return True;
4048 end if;
4050 return False;
4051 end Requires_Init_Proc;
4053 -- Start of processing for Build_Record_Init_Proc
4055 begin
4056 Rec_Type := Defining_Identifier (N);
4058 -- This may be full declaration of a private type, in which case
4059 -- the visible entity is a record, and the private entity has been
4060 -- exchanged with it in the private part of the current package.
4061 -- The initialization procedure is built for the record type, which
4062 -- is retrievable from the private entity.
4064 if Is_Incomplete_Or_Private_Type (Rec_Type) then
4065 Rec_Type := Underlying_Type (Rec_Type);
4066 end if;
4068 -- If we have a variant record with restriction No_Implicit_Conditionals
4069 -- in effect, then we skip building the procedure. This is safe because
4070 -- if we can see the restriction, so can any caller, calls to initialize
4071 -- such records are not allowed for variant records if this restriction
4072 -- is active.
4074 if Has_Variant_Part (Rec_Type)
4075 and then Restriction_Active (No_Implicit_Conditionals)
4076 then
4077 return;
4078 end if;
4080 -- If there are discriminants, build the discriminant map to replace
4081 -- discriminants by their discriminals in complex bound expressions.
4082 -- These only arise for the corresponding records of synchronized types.
4084 if Is_Concurrent_Record_Type (Rec_Type)
4085 and then Has_Discriminants (Rec_Type)
4086 then
4087 declare
4088 Disc : Entity_Id;
4089 begin
4090 Disc := First_Discriminant (Rec_Type);
4091 while Present (Disc) loop
4092 Append_Elmt (Disc, Discr_Map);
4093 Append_Elmt (Discriminal (Disc), Discr_Map);
4094 Next_Discriminant (Disc);
4095 end loop;
4096 end;
4097 end if;
4099 -- Derived types that have no type extension can use the initialization
4100 -- procedure of their parent and do not need a procedure of their own.
4101 -- This is only correct if there are no representation clauses for the
4102 -- type or its parent, and if the parent has in fact been frozen so
4103 -- that its initialization procedure exists.
4105 if Is_Derived_Type (Rec_Type)
4106 and then not Is_Tagged_Type (Rec_Type)
4107 and then not Is_Unchecked_Union (Rec_Type)
4108 and then not Has_New_Non_Standard_Rep (Rec_Type)
4109 and then not Parent_Subtype_Renaming_Discrims
4110 and then Present (Base_Init_Proc (Etype (Rec_Type)))
4111 then
4112 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
4114 -- Otherwise if we need an initialization procedure, then build one,
4115 -- mark it as public and inlinable and as having a completion.
4117 elsif Requires_Init_Proc (Rec_Type)
4118 or else Is_Unchecked_Union (Rec_Type)
4119 then
4120 Proc_Id :=
4121 Make_Defining_Identifier (Loc,
4122 Chars => Make_Init_Proc_Name (Rec_Type));
4124 -- If No_Default_Initialization restriction is active, then we don't
4125 -- want to build an init_proc, but we need to mark that an init_proc
4126 -- would be needed if this restriction was not active (so that we can
4127 -- detect attempts to call it), so set a dummy init_proc in place.
4129 if Restriction_Active (No_Default_Initialization) then
4130 Set_Init_Proc (Rec_Type, Proc_Id);
4131 return;
4132 end if;
4134 Build_Offset_To_Top_Functions;
4135 Build_CPP_Init_Procedure;
4136 Build_Init_Procedure;
4138 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
4139 Set_Is_Internal (Proc_Id);
4140 Set_Has_Completion (Proc_Id);
4142 if not Debug_Generated_Code then
4143 Set_Debug_Info_Off (Proc_Id);
4144 end if;
4146 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
4148 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
4149 -- needed and may generate early references to non frozen types
4150 -- since we expand aggregate much more systematically.
4152 if Modify_Tree_For_C then
4153 return;
4154 end if;
4156 declare
4157 Agg : constant Node_Id :=
4158 Build_Equivalent_Record_Aggregate (Rec_Type);
4160 procedure Collect_Itypes (Comp : Node_Id);
4161 -- Generate references to itypes in the aggregate, because
4162 -- the first use of the aggregate may be in a nested scope.
4164 --------------------
4165 -- Collect_Itypes --
4166 --------------------
4168 procedure Collect_Itypes (Comp : Node_Id) is
4169 Ref : Node_Id;
4170 Sub_Aggr : Node_Id;
4171 Typ : constant Entity_Id := Etype (Comp);
4173 begin
4174 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
4175 Ref := Make_Itype_Reference (Loc);
4176 Set_Itype (Ref, Typ);
4177 Append_Freeze_Action (Rec_Type, Ref);
4179 Ref := Make_Itype_Reference (Loc);
4180 Set_Itype (Ref, Etype (First_Index (Typ)));
4181 Append_Freeze_Action (Rec_Type, Ref);
4183 -- Recurse on nested arrays
4185 Sub_Aggr := First (Expressions (Comp));
4186 while Present (Sub_Aggr) loop
4187 Collect_Itypes (Sub_Aggr);
4188 Next (Sub_Aggr);
4189 end loop;
4190 end if;
4191 end Collect_Itypes;
4193 begin
4194 -- If there is a static initialization aggregate for the type,
4195 -- generate itype references for the types of its (sub)components,
4196 -- to prevent out-of-scope errors in the resulting tree.
4197 -- The aggregate may have been rewritten as a Raise node, in which
4198 -- case there are no relevant itypes.
4200 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
4201 Set_Static_Initialization (Proc_Id, Agg);
4203 declare
4204 Comp : Node_Id;
4205 begin
4206 Comp := First (Component_Associations (Agg));
4207 while Present (Comp) loop
4208 Collect_Itypes (Expression (Comp));
4209 Next (Comp);
4210 end loop;
4211 end;
4212 end if;
4213 end;
4214 end if;
4215 end Build_Record_Init_Proc;
4217 ----------------------------
4218 -- Build_Slice_Assignment --
4219 ----------------------------
4221 -- Generates the following subprogram:
4223 -- procedure array_typeSA
4224 -- (Source, Target : Array_Type,
4225 -- Left_Lo, Left_Hi : Index;
4226 -- Right_Lo, Right_Hi : Index;
4227 -- Rev : Boolean)
4228 -- is
4229 -- Li1 : Index;
4230 -- Ri1 : Index;
4232 -- begin
4233 -- if Left_Hi < Left_Lo then
4234 -- return;
4235 -- end if;
4237 -- if Rev then
4238 -- Li1 := Left_Hi;
4239 -- Ri1 := Right_Hi;
4240 -- else
4241 -- Li1 := Left_Lo;
4242 -- Ri1 := Right_Lo;
4243 -- end if;
4245 -- loop
4246 -- Target (Li1) := Source (Ri1);
4248 -- if Rev then
4249 -- exit when Li1 = Left_Lo;
4250 -- Li1 := Index'pred (Li1);
4251 -- Ri1 := Index'pred (Ri1);
4252 -- else
4253 -- exit when Li1 = Left_Hi;
4254 -- Li1 := Index'succ (Li1);
4255 -- Ri1 := Index'succ (Ri1);
4256 -- end if;
4257 -- end loop;
4258 -- end array_typeSA;
4260 procedure Build_Slice_Assignment (Typ : Entity_Id) is
4261 Loc : constant Source_Ptr := Sloc (Typ);
4262 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
4264 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
4265 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
4266 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
4267 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
4268 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
4269 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
4270 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
4271 -- Formal parameters of procedure
4273 Proc_Name : constant Entity_Id :=
4274 Make_Defining_Identifier (Loc,
4275 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
4277 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
4278 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
4279 -- Subscripts for left and right sides
4281 Decls : List_Id;
4282 Loops : Node_Id;
4283 Stats : List_Id;
4285 begin
4286 -- Build declarations for indexes
4288 Decls := New_List;
4290 Append_To (Decls,
4291 Make_Object_Declaration (Loc,
4292 Defining_Identifier => Lnn,
4293 Object_Definition =>
4294 New_Occurrence_Of (Index, Loc)));
4296 Append_To (Decls,
4297 Make_Object_Declaration (Loc,
4298 Defining_Identifier => Rnn,
4299 Object_Definition =>
4300 New_Occurrence_Of (Index, Loc)));
4302 Stats := New_List;
4304 -- Build test for empty slice case
4306 Append_To (Stats,
4307 Make_If_Statement (Loc,
4308 Condition =>
4309 Make_Op_Lt (Loc,
4310 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
4311 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
4312 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
4314 -- Build initializations for indexes
4316 declare
4317 F_Init : constant List_Id := New_List;
4318 B_Init : constant List_Id := New_List;
4320 begin
4321 Append_To (F_Init,
4322 Make_Assignment_Statement (Loc,
4323 Name => New_Occurrence_Of (Lnn, Loc),
4324 Expression => New_Occurrence_Of (Left_Lo, Loc)));
4326 Append_To (F_Init,
4327 Make_Assignment_Statement (Loc,
4328 Name => New_Occurrence_Of (Rnn, Loc),
4329 Expression => New_Occurrence_Of (Right_Lo, Loc)));
4331 Append_To (B_Init,
4332 Make_Assignment_Statement (Loc,
4333 Name => New_Occurrence_Of (Lnn, Loc),
4334 Expression => New_Occurrence_Of (Left_Hi, Loc)));
4336 Append_To (B_Init,
4337 Make_Assignment_Statement (Loc,
4338 Name => New_Occurrence_Of (Rnn, Loc),
4339 Expression => New_Occurrence_Of (Right_Hi, Loc)));
4341 Append_To (Stats,
4342 Make_If_Statement (Loc,
4343 Condition => New_Occurrence_Of (Rev, Loc),
4344 Then_Statements => B_Init,
4345 Else_Statements => F_Init));
4346 end;
4348 -- Now construct the assignment statement
4350 Loops :=
4351 Make_Loop_Statement (Loc,
4352 Statements => New_List (
4353 Make_Assignment_Statement (Loc,
4354 Name =>
4355 Make_Indexed_Component (Loc,
4356 Prefix => New_Occurrence_Of (Larray, Loc),
4357 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
4358 Expression =>
4359 Make_Indexed_Component (Loc,
4360 Prefix => New_Occurrence_Of (Rarray, Loc),
4361 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
4362 End_Label => Empty);
4364 -- Build the exit condition and increment/decrement statements
4366 declare
4367 F_Ass : constant List_Id := New_List;
4368 B_Ass : constant List_Id := New_List;
4370 begin
4371 Append_To (F_Ass,
4372 Make_Exit_Statement (Loc,
4373 Condition =>
4374 Make_Op_Eq (Loc,
4375 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4376 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
4378 Append_To (F_Ass,
4379 Make_Assignment_Statement (Loc,
4380 Name => New_Occurrence_Of (Lnn, Loc),
4381 Expression =>
4382 Make_Attribute_Reference (Loc,
4383 Prefix =>
4384 New_Occurrence_Of (Index, Loc),
4385 Attribute_Name => Name_Succ,
4386 Expressions => New_List (
4387 New_Occurrence_Of (Lnn, Loc)))));
4389 Append_To (F_Ass,
4390 Make_Assignment_Statement (Loc,
4391 Name => New_Occurrence_Of (Rnn, Loc),
4392 Expression =>
4393 Make_Attribute_Reference (Loc,
4394 Prefix =>
4395 New_Occurrence_Of (Index, Loc),
4396 Attribute_Name => Name_Succ,
4397 Expressions => New_List (
4398 New_Occurrence_Of (Rnn, Loc)))));
4400 Append_To (B_Ass,
4401 Make_Exit_Statement (Loc,
4402 Condition =>
4403 Make_Op_Eq (Loc,
4404 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4405 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
4407 Append_To (B_Ass,
4408 Make_Assignment_Statement (Loc,
4409 Name => New_Occurrence_Of (Lnn, Loc),
4410 Expression =>
4411 Make_Attribute_Reference (Loc,
4412 Prefix =>
4413 New_Occurrence_Of (Index, Loc),
4414 Attribute_Name => Name_Pred,
4415 Expressions => New_List (
4416 New_Occurrence_Of (Lnn, Loc)))));
4418 Append_To (B_Ass,
4419 Make_Assignment_Statement (Loc,
4420 Name => New_Occurrence_Of (Rnn, Loc),
4421 Expression =>
4422 Make_Attribute_Reference (Loc,
4423 Prefix =>
4424 New_Occurrence_Of (Index, Loc),
4425 Attribute_Name => Name_Pred,
4426 Expressions => New_List (
4427 New_Occurrence_Of (Rnn, Loc)))));
4429 Append_To (Statements (Loops),
4430 Make_If_Statement (Loc,
4431 Condition => New_Occurrence_Of (Rev, Loc),
4432 Then_Statements => B_Ass,
4433 Else_Statements => F_Ass));
4434 end;
4436 Append_To (Stats, Loops);
4438 declare
4439 Spec : Node_Id;
4440 Formals : List_Id;
4442 begin
4443 Formals := New_List (
4444 Make_Parameter_Specification (Loc,
4445 Defining_Identifier => Larray,
4446 Out_Present => True,
4447 Parameter_Type =>
4448 New_Occurrence_Of (Base_Type (Typ), Loc)),
4450 Make_Parameter_Specification (Loc,
4451 Defining_Identifier => Rarray,
4452 Parameter_Type =>
4453 New_Occurrence_Of (Base_Type (Typ), Loc)),
4455 Make_Parameter_Specification (Loc,
4456 Defining_Identifier => Left_Lo,
4457 Parameter_Type =>
4458 New_Occurrence_Of (Index, Loc)),
4460 Make_Parameter_Specification (Loc,
4461 Defining_Identifier => Left_Hi,
4462 Parameter_Type =>
4463 New_Occurrence_Of (Index, Loc)),
4465 Make_Parameter_Specification (Loc,
4466 Defining_Identifier => Right_Lo,
4467 Parameter_Type =>
4468 New_Occurrence_Of (Index, Loc)),
4470 Make_Parameter_Specification (Loc,
4471 Defining_Identifier => Right_Hi,
4472 Parameter_Type =>
4473 New_Occurrence_Of (Index, Loc)));
4475 Append_To (Formals,
4476 Make_Parameter_Specification (Loc,
4477 Defining_Identifier => Rev,
4478 Parameter_Type =>
4479 New_Occurrence_Of (Standard_Boolean, Loc)));
4481 Spec :=
4482 Make_Procedure_Specification (Loc,
4483 Defining_Unit_Name => Proc_Name,
4484 Parameter_Specifications => Formals);
4486 Discard_Node (
4487 Make_Subprogram_Body (Loc,
4488 Specification => Spec,
4489 Declarations => Decls,
4490 Handled_Statement_Sequence =>
4491 Make_Handled_Sequence_Of_Statements (Loc,
4492 Statements => Stats)));
4493 end;
4495 Set_TSS (Typ, Proc_Name);
4496 Set_Is_Pure (Proc_Name);
4497 end Build_Slice_Assignment;
4499 -----------------------------
4500 -- Build_Untagged_Equality --
4501 -----------------------------
4503 procedure Build_Untagged_Equality (Typ : Entity_Id) is
4504 Build_Eq : Boolean;
4505 Comp : Entity_Id;
4506 Decl : Node_Id;
4507 Op : Entity_Id;
4508 Eq_Op : Entity_Id;
4510 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
4511 -- Check whether the type T has a user-defined primitive equality. If so
4512 -- return it, else return Empty. If true for a component of Typ, we have
4513 -- to build the primitive equality for it.
4515 ---------------------
4516 -- User_Defined_Eq --
4517 ---------------------
4519 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
4520 Op : constant Entity_Id := TSS (T, TSS_Composite_Equality);
4522 begin
4523 if Present (Op) then
4524 return Op;
4525 else
4526 return Get_User_Defined_Equality (T);
4527 end if;
4528 end User_Defined_Eq;
4530 -- Start of processing for Build_Untagged_Equality
4532 begin
4533 -- If a record component has a primitive equality operation, we must
4534 -- build the corresponding one for the current type.
4536 Build_Eq := False;
4537 Comp := First_Component (Typ);
4538 while Present (Comp) loop
4539 if Is_Record_Type (Etype (Comp))
4540 and then Present (User_Defined_Eq (Etype (Comp)))
4541 then
4542 Build_Eq := True;
4543 exit;
4544 end if;
4546 Next_Component (Comp);
4547 end loop;
4549 -- If there is a user-defined equality for the type, we do not create
4550 -- the implicit one.
4552 Eq_Op := Get_User_Defined_Equality (Typ);
4553 if Present (Eq_Op) then
4554 if Comes_From_Source (Eq_Op) then
4555 Build_Eq := False;
4556 else
4557 Eq_Op := Empty;
4558 end if;
4559 end if;
4561 -- If the type is derived, inherit the operation, if present, from the
4562 -- parent type. It may have been declared after the type derivation. If
4563 -- the parent type itself is derived, it may have inherited an operation
4564 -- that has itself been overridden, so update its alias and related
4565 -- flags. Ditto for inequality.
4567 if No (Eq_Op) and then Is_Derived_Type (Typ) then
4568 Eq_Op := Get_User_Defined_Equality (Etype (Typ));
4569 if Present (Eq_Op) then
4570 Copy_TSS (Eq_Op, Typ);
4571 Build_Eq := False;
4573 declare
4574 Op : constant Entity_Id := User_Defined_Eq (Typ);
4575 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
4577 begin
4578 if Present (Op) then
4579 Set_Alias (Op, Eq_Op);
4580 Set_Is_Abstract_Subprogram
4581 (Op, Is_Abstract_Subprogram (Eq_Op));
4583 if Chars (Next_Entity (Op)) = Name_Op_Ne then
4584 Set_Is_Abstract_Subprogram
4585 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
4586 end if;
4587 end if;
4588 end;
4589 end if;
4590 end if;
4592 -- If not inherited and not user-defined, build body as for a type with
4593 -- components of record type (i.e. a type for which "=" composes when
4594 -- used as a component in an outer composite type).
4596 if Build_Eq then
4597 Decl :=
4598 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
4599 Op := Defining_Entity (Decl);
4600 Set_TSS (Typ, Op);
4601 Set_Is_Pure (Op);
4603 if Is_Library_Level_Entity (Typ) then
4604 Set_Is_Public (Op);
4605 end if;
4606 end if;
4607 end Build_Untagged_Equality;
4609 -----------------------------------
4610 -- Build_Variant_Record_Equality --
4611 -----------------------------------
4613 -- Generates:
4615 -- function <<Body_Id>> (Left, Right : T) return Boolean is
4616 -- [ X : T renames Left; ]
4617 -- [ Y : T renames Right; ]
4618 -- -- The above renamings are generated only if the parameters of
4619 -- -- this built function (which are passed by the caller) are not
4620 -- -- named 'X' and 'Y'; these names are required to reuse several
4621 -- -- expander routines when generating this body.
4623 -- begin
4624 -- -- Compare discriminants
4626 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
4627 -- return False;
4628 -- end if;
4630 -- -- Compare components
4632 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
4633 -- return False;
4634 -- end if;
4636 -- -- Compare variant part
4638 -- case X.D1 is
4639 -- when V1 =>
4640 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
4641 -- return False;
4642 -- end if;
4643 -- ...
4644 -- when Vn =>
4645 -- if X.Cn /= Y.Cn or else ... then
4646 -- return False;
4647 -- end if;
4648 -- end case;
4650 -- return True;
4651 -- end _Equality;
4653 function Build_Variant_Record_Equality
4654 (Typ : Entity_Id;
4655 Body_Id : Entity_Id;
4656 Param_Specs : List_Id) return Node_Id
4658 Loc : constant Source_Ptr := Sloc (Typ);
4659 Def : constant Node_Id := Parent (Typ);
4660 Comps : constant Node_Id := Component_List (Type_Definition (Def));
4661 Left : constant Entity_Id := Defining_Identifier (First (Param_Specs));
4662 Right : constant Entity_Id :=
4663 Defining_Identifier (Next (First (Param_Specs)));
4664 Decls : constant List_Id := New_List;
4665 Stmts : constant List_Id := New_List;
4667 Subp_Body : Node_Id;
4669 begin
4670 pragma Assert (not Is_Tagged_Type (Typ));
4672 -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
4673 -- the name of the formals must be X and Y; otherwise we generate two
4674 -- renaming declarations for such purpose.
4676 if Chars (Left) /= Name_X then
4677 Append_To (Decls,
4678 Make_Object_Renaming_Declaration (Loc,
4679 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
4680 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4681 Name => Make_Identifier (Loc, Chars (Left))));
4682 end if;
4684 if Chars (Right) /= Name_Y then
4685 Append_To (Decls,
4686 Make_Object_Renaming_Declaration (Loc,
4687 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
4688 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4689 Name => Make_Identifier (Loc, Chars (Right))));
4690 end if;
4692 -- Unchecked_Unions require additional machinery to support equality.
4693 -- Two extra parameters (A and B) are added to the equality function
4694 -- parameter list for each discriminant of the type, in order to
4695 -- capture the inferred values of the discriminants in equality calls.
4696 -- The names of the parameters match the names of the corresponding
4697 -- discriminant, with an added suffix.
4699 if Is_Unchecked_Union (Typ) then
4700 declare
4701 A : Entity_Id;
4702 B : Entity_Id;
4703 Discr : Entity_Id;
4704 Discr_Type : Entity_Id;
4705 New_Discrs : Elist_Id;
4707 begin
4708 New_Discrs := New_Elmt_List;
4710 Discr := First_Discriminant (Typ);
4711 while Present (Discr) loop
4712 Discr_Type := Etype (Discr);
4714 A :=
4715 Make_Defining_Identifier (Loc,
4716 Chars => New_External_Name (Chars (Discr), 'A'));
4718 B :=
4719 Make_Defining_Identifier (Loc,
4720 Chars => New_External_Name (Chars (Discr), 'B'));
4722 -- Add new parameters to the parameter list
4724 Append_To (Param_Specs,
4725 Make_Parameter_Specification (Loc,
4726 Defining_Identifier => A,
4727 Parameter_Type =>
4728 New_Occurrence_Of (Discr_Type, Loc)));
4730 Append_To (Param_Specs,
4731 Make_Parameter_Specification (Loc,
4732 Defining_Identifier => B,
4733 Parameter_Type =>
4734 New_Occurrence_Of (Discr_Type, Loc)));
4736 Append_Elmt (A, New_Discrs);
4738 -- Generate the following code to compare each of the inferred
4739 -- discriminants:
4741 -- if a /= b then
4742 -- return False;
4743 -- end if;
4745 Append_To (Stmts,
4746 Make_If_Statement (Loc,
4747 Condition =>
4748 Make_Op_Ne (Loc,
4749 Left_Opnd => New_Occurrence_Of (A, Loc),
4750 Right_Opnd => New_Occurrence_Of (B, Loc)),
4751 Then_Statements => New_List (
4752 Make_Simple_Return_Statement (Loc,
4753 Expression =>
4754 New_Occurrence_Of (Standard_False, Loc)))));
4755 Next_Discriminant (Discr);
4756 end loop;
4758 -- Generate component-by-component comparison. Note that we must
4759 -- propagate the inferred discriminants formals to act as the case
4760 -- statement switch. Their value is added when an equality call on
4761 -- unchecked unions is expanded.
4763 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4764 end;
4766 -- Normal case (not unchecked union)
4768 else
4769 Append_To (Stmts,
4770 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4771 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4772 end if;
4774 Append_To (Stmts,
4775 Make_Simple_Return_Statement (Loc,
4776 Expression => New_Occurrence_Of (Standard_True, Loc)));
4778 Subp_Body :=
4779 Make_Subprogram_Body (Loc,
4780 Specification =>
4781 Make_Function_Specification (Loc,
4782 Defining_Unit_Name => Body_Id,
4783 Parameter_Specifications => Param_Specs,
4784 Result_Definition =>
4785 New_Occurrence_Of (Standard_Boolean, Loc)),
4786 Declarations => Decls,
4787 Handled_Statement_Sequence =>
4788 Make_Handled_Sequence_Of_Statements (Loc,
4789 Statements => Stmts));
4791 return Subp_Body;
4792 end Build_Variant_Record_Equality;
4794 -----------------------------
4795 -- Check_Stream_Attributes --
4796 -----------------------------
4798 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4799 Comp : Entity_Id;
4800 Par_Read : constant Boolean :=
4801 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4802 and then not Has_Specified_Stream_Read (Typ);
4803 Par_Write : constant Boolean :=
4804 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4805 and then not Has_Specified_Stream_Write (Typ);
4807 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4808 -- Check that Comp has a user-specified Nam stream attribute
4810 ----------------
4811 -- Check_Attr --
4812 ----------------
4814 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4815 begin
4816 -- Move this check to sem???
4818 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4819 Error_Msg_Name_1 := Nam;
4820 Error_Msg_N
4821 ("|component& in limited extension must have% attribute", Comp);
4822 end if;
4823 end Check_Attr;
4825 -- Start of processing for Check_Stream_Attributes
4827 begin
4828 if Par_Read or else Par_Write then
4829 Comp := First_Component (Typ);
4830 while Present (Comp) loop
4831 if Comes_From_Source (Comp)
4832 and then Original_Record_Component (Comp) = Comp
4833 and then Is_Limited_Type (Etype (Comp))
4834 then
4835 if Par_Read then
4836 Check_Attr (Name_Read, TSS_Stream_Read);
4837 end if;
4839 if Par_Write then
4840 Check_Attr (Name_Write, TSS_Stream_Write);
4841 end if;
4842 end if;
4844 Next_Component (Comp);
4845 end loop;
4846 end if;
4847 end Check_Stream_Attributes;
4849 ----------------------
4850 -- Clean_Task_Names --
4851 ----------------------
4853 procedure Clean_Task_Names
4854 (Typ : Entity_Id;
4855 Proc_Id : Entity_Id)
4857 begin
4858 if Has_Task (Typ)
4859 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4860 and then not Global_Discard_Names
4861 and then Tagged_Type_Expansion
4862 then
4863 Set_Uses_Sec_Stack (Proc_Id);
4864 end if;
4865 end Clean_Task_Names;
4867 -------------------------------
4868 -- Copy_Discr_Checking_Funcs --
4869 -------------------------------
4871 procedure Copy_Discr_Checking_Funcs (N : Node_Id) is
4872 Typ : constant Entity_Id := Defining_Identifier (N);
4873 Comp : Entity_Id := First_Component (Typ);
4874 Old_Comp : Entity_Id := First_Component
4875 (Base_Type (Underlying_Type (Etype (Typ))));
4876 begin
4877 while Present (Comp) loop
4878 if Chars (Comp) = Chars (Old_Comp) then
4879 Set_Discriminant_Checking_Func
4880 (Comp, Discriminant_Checking_Func (Old_Comp));
4881 end if;
4883 Next_Component (Old_Comp);
4884 Next_Component (Comp);
4885 end loop;
4886 end Copy_Discr_Checking_Funcs;
4888 ------------------------------
4889 -- Expand_Freeze_Array_Type --
4890 ------------------------------
4892 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4893 Typ : constant Entity_Id := Entity (N);
4894 Base : constant Entity_Id := Base_Type (Typ);
4895 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4897 begin
4898 if not Is_Bit_Packed_Array (Typ) then
4900 -- If the component contains tasks, so does the array type. This may
4901 -- not be indicated in the array type because the component may have
4902 -- been a private type at the point of definition. Same if component
4903 -- type is controlled or contains protected objects.
4905 Propagate_Concurrent_Flags (Base, Comp_Typ);
4906 Set_Has_Controlled_Component
4907 (Base, Has_Controlled_Component (Comp_Typ)
4908 or else Is_Controlled (Comp_Typ));
4910 if No (Init_Proc (Base)) then
4912 -- If this is an anonymous array created for a declaration with
4913 -- an initial value, its init_proc will never be called. The
4914 -- initial value itself may have been expanded into assignments,
4915 -- in which case the object declaration is carries the
4916 -- No_Initialization flag.
4918 if Is_Itype (Base)
4919 and then Nkind (Associated_Node_For_Itype (Base)) =
4920 N_Object_Declaration
4921 and then
4922 (Present (Expression (Associated_Node_For_Itype (Base)))
4923 or else No_Initialization (Associated_Node_For_Itype (Base)))
4924 then
4925 null;
4927 -- We do not need an init proc for string or wide [wide] string,
4928 -- since the only time these need initialization in normalize or
4929 -- initialize scalars mode, and these types are treated specially
4930 -- and do not need initialization procedures.
4932 elsif Is_Standard_String_Type (Base) then
4933 null;
4935 -- Otherwise we have to build an init proc for the subtype
4937 else
4938 Build_Array_Init_Proc (Base, N);
4939 end if;
4940 end if;
4942 if Typ = Base and then Has_Controlled_Component (Base) then
4943 Build_Controlling_Procs (Base);
4945 if not Is_Limited_Type (Comp_Typ)
4946 and then Number_Dimensions (Typ) = 1
4947 then
4948 Build_Slice_Assignment (Typ);
4949 end if;
4950 end if;
4952 -- For packed case, default initialization, except if the component type
4953 -- is itself a packed structure with an initialization procedure, or
4954 -- initialize/normalize scalars active, and we have a base type, or the
4955 -- type is public, because in that case a client might specify
4956 -- Normalize_Scalars and there better be a public Init_Proc for it.
4958 elsif (Present (Init_Proc (Component_Type (Base)))
4959 and then No (Base_Init_Proc (Base)))
4960 or else (Init_Or_Norm_Scalars and then Base = Typ)
4961 or else Is_Public (Typ)
4962 then
4963 Build_Array_Init_Proc (Base, N);
4964 end if;
4965 end Expand_Freeze_Array_Type;
4967 -----------------------------------
4968 -- Expand_Freeze_Class_Wide_Type --
4969 -----------------------------------
4971 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4972 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4973 -- Given a type, determine whether it is derived from a C or C++ root
4975 ---------------------
4976 -- Is_C_Derivation --
4977 ---------------------
4979 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4980 T : Entity_Id;
4982 begin
4983 T := Typ;
4984 loop
4985 if Is_CPP_Class (T)
4986 or else Convention (T) = Convention_C
4987 or else Convention (T) = Convention_CPP
4988 then
4989 return True;
4990 end if;
4992 exit when T = Etype (T);
4994 T := Etype (T);
4995 end loop;
4997 return False;
4998 end Is_C_Derivation;
5000 -- Local variables
5002 Typ : constant Entity_Id := Entity (N);
5003 Root : constant Entity_Id := Root_Type (Typ);
5005 -- Start of processing for Expand_Freeze_Class_Wide_Type
5007 begin
5008 -- Certain run-time configurations and targets do not provide support
5009 -- for controlled types.
5011 if Restriction_Active (No_Finalization) then
5012 return;
5014 -- Do not create TSS routine Finalize_Address when dispatching calls are
5015 -- disabled since the core of the routine is a dispatching call.
5017 elsif Restriction_Active (No_Dispatching_Calls) then
5018 return;
5020 -- Do not create TSS routine Finalize_Address for concurrent class-wide
5021 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
5022 -- non-Ada side will handle their destruction.
5024 elsif Is_Concurrent_Type (Root)
5025 or else Is_C_Derivation (Root)
5026 or else Convention (Typ) = Convention_CPP
5027 then
5028 return;
5030 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
5031 -- mode since the routine contains an Unchecked_Conversion.
5033 elsif CodePeer_Mode then
5034 return;
5035 end if;
5037 -- Create the body of TSS primitive Finalize_Address. This automatically
5038 -- sets the TSS entry for the class-wide type.
5040 Make_Finalize_Address_Body (Typ);
5041 end Expand_Freeze_Class_Wide_Type;
5043 ------------------------------------
5044 -- Expand_Freeze_Enumeration_Type --
5045 ------------------------------------
5047 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
5048 Typ : constant Entity_Id := Entity (N);
5049 Loc : constant Source_Ptr := Sloc (Typ);
5051 Arr : Entity_Id;
5052 Ent : Entity_Id;
5053 Fent : Entity_Id;
5054 Is_Contiguous : Boolean;
5055 Index_Typ : Entity_Id;
5056 Ityp : Entity_Id;
5057 Last_Repval : Uint;
5058 Lst : List_Id;
5059 Num : Nat;
5060 Pos_Expr : Node_Id;
5062 Func : Entity_Id;
5063 pragma Warnings (Off, Func);
5065 begin
5066 -- Various optimizations possible if given representation is contiguous
5068 Is_Contiguous := True;
5070 Ent := First_Literal (Typ);
5071 Last_Repval := Enumeration_Rep (Ent);
5072 Num := 1;
5073 Next_Literal (Ent);
5075 while Present (Ent) loop
5076 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
5077 Is_Contiguous := False;
5078 else
5079 Last_Repval := Enumeration_Rep (Ent);
5080 end if;
5082 Num := Num + 1;
5083 Next_Literal (Ent);
5084 end loop;
5086 if Is_Contiguous then
5087 Set_Has_Contiguous_Rep (Typ);
5089 -- Now build a subtype declaration
5091 -- subtype typI is new Natural range 0 .. num - 1
5093 Index_Typ :=
5094 Make_Defining_Identifier (Loc,
5095 Chars => New_External_Name (Chars (Typ), 'I'));
5097 Append_Freeze_Action (Typ,
5098 Make_Subtype_Declaration (Loc,
5099 Defining_Identifier => Index_Typ,
5100 Subtype_Indication =>
5101 Make_Subtype_Indication (Loc,
5102 Subtype_Mark =>
5103 New_Occurrence_Of (Standard_Natural, Loc),
5104 Constraint =>
5105 Make_Range_Constraint (Loc,
5106 Range_Expression =>
5107 Make_Range (Loc,
5108 Low_Bound =>
5109 Make_Integer_Literal (Loc, 0),
5110 High_Bound =>
5111 Make_Integer_Literal (Loc, Num - 1))))));
5113 Set_Enum_Pos_To_Rep (Typ, Index_Typ);
5115 else
5116 -- Build list of literal references
5118 Lst := New_List;
5119 Ent := First_Literal (Typ);
5120 while Present (Ent) loop
5121 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
5122 Next_Literal (Ent);
5123 end loop;
5125 -- Now build an array declaration
5127 -- typA : constant array (Natural range 0 .. num - 1) of typ :=
5128 -- (v, v, v, v, v, ....)
5130 Arr :=
5131 Make_Defining_Identifier (Loc,
5132 Chars => New_External_Name (Chars (Typ), 'A'));
5134 Append_Freeze_Action (Typ,
5135 Make_Object_Declaration (Loc,
5136 Defining_Identifier => Arr,
5137 Constant_Present => True,
5139 Object_Definition =>
5140 Make_Constrained_Array_Definition (Loc,
5141 Discrete_Subtype_Definitions => New_List (
5142 Make_Subtype_Indication (Loc,
5143 Subtype_Mark =>
5144 New_Occurrence_Of (Standard_Natural, Loc),
5145 Constraint =>
5146 Make_Range_Constraint (Loc,
5147 Range_Expression =>
5148 Make_Range (Loc,
5149 Low_Bound =>
5150 Make_Integer_Literal (Loc, 0),
5151 High_Bound =>
5152 Make_Integer_Literal (Loc, Num - 1))))),
5154 Component_Definition =>
5155 Make_Component_Definition (Loc,
5156 Aliased_Present => False,
5157 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
5159 Expression =>
5160 Make_Aggregate (Loc,
5161 Expressions => Lst)));
5163 Set_Enum_Pos_To_Rep (Typ, Arr);
5164 end if;
5166 -- Now we build the function that converts representation values to
5167 -- position values. This function has the form:
5169 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
5170 -- begin
5171 -- case ityp!(A) is
5172 -- when enum-lit'Enum_Rep => return posval;
5173 -- when enum-lit'Enum_Rep => return posval;
5174 -- ...
5175 -- when others =>
5176 -- [raise Constraint_Error when F "invalid data"]
5177 -- return -1;
5178 -- end case;
5179 -- end;
5181 -- Note: the F parameter determines whether the others case (no valid
5182 -- representation) raises Constraint_Error or returns a unique value
5183 -- of minus one. The latter case is used, e.g. in 'Valid code.
5185 -- Note: the reason we use Enum_Rep values in the case here is to avoid
5186 -- the code generator making inappropriate assumptions about the range
5187 -- of the values in the case where the value is invalid. ityp is a
5188 -- signed or unsigned integer type of appropriate width.
5190 -- Note: if exceptions are not supported, then we suppress the raise
5191 -- and return -1 unconditionally (this is an erroneous program in any
5192 -- case and there is no obligation to raise Constraint_Error here). We
5193 -- also do this if pragma Restrictions (No_Exceptions) is active.
5195 -- Is this right??? What about No_Exception_Propagation???
5197 -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly
5198 -- because it might have been inherited from the parent type.
5200 if Enumeration_Rep (First_Literal (Typ)) < 0 then
5201 Set_Is_Unsigned_Type (Typ, False);
5202 end if;
5204 Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ));
5206 -- The body of the function is a case statement. First collect case
5207 -- alternatives, or optimize the contiguous case.
5209 Lst := New_List;
5211 -- If representation is contiguous, Pos is computed by subtracting
5212 -- the representation of the first literal.
5214 if Is_Contiguous then
5215 Ent := First_Literal (Typ);
5217 if Enumeration_Rep (Ent) = Last_Repval then
5219 -- Another special case: for a single literal, Pos is zero
5221 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
5223 else
5224 Pos_Expr :=
5225 Convert_To (Standard_Integer,
5226 Make_Op_Subtract (Loc,
5227 Left_Opnd =>
5228 Unchecked_Convert_To
5229 (Ityp, Make_Identifier (Loc, Name_uA)),
5230 Right_Opnd =>
5231 Make_Integer_Literal (Loc,
5232 Intval => Enumeration_Rep (First_Literal (Typ)))));
5233 end if;
5235 Append_To (Lst,
5236 Make_Case_Statement_Alternative (Loc,
5237 Discrete_Choices => New_List (
5238 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
5239 Low_Bound =>
5240 Make_Integer_Literal (Loc,
5241 Intval => Enumeration_Rep (Ent)),
5242 High_Bound =>
5243 Make_Integer_Literal (Loc, Intval => Last_Repval))),
5245 Statements => New_List (
5246 Make_Simple_Return_Statement (Loc,
5247 Expression => Pos_Expr))));
5249 else
5250 Ent := First_Literal (Typ);
5251 while Present (Ent) loop
5252 Append_To (Lst,
5253 Make_Case_Statement_Alternative (Loc,
5254 Discrete_Choices => New_List (
5255 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
5256 Intval => Enumeration_Rep (Ent))),
5258 Statements => New_List (
5259 Make_Simple_Return_Statement (Loc,
5260 Expression =>
5261 Make_Integer_Literal (Loc,
5262 Intval => Enumeration_Pos (Ent))))));
5264 Next_Literal (Ent);
5265 end loop;
5266 end if;
5268 -- In normal mode, add the others clause with the test.
5269 -- If Predicates_Ignored is True, validity checks do not apply to
5270 -- the subtype.
5272 if not No_Exception_Handlers_Set
5273 and then not Predicates_Ignored (Typ)
5274 then
5275 Append_To (Lst,
5276 Make_Case_Statement_Alternative (Loc,
5277 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5278 Statements => New_List (
5279 Make_Raise_Constraint_Error (Loc,
5280 Condition => Make_Identifier (Loc, Name_uF),
5281 Reason => CE_Invalid_Data),
5282 Make_Simple_Return_Statement (Loc,
5283 Expression => Make_Integer_Literal (Loc, -1)))));
5285 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
5286 -- active then return -1 (we cannot usefully raise Constraint_Error in
5287 -- this case). See description above for further details.
5289 else
5290 Append_To (Lst,
5291 Make_Case_Statement_Alternative (Loc,
5292 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
5293 Statements => New_List (
5294 Make_Simple_Return_Statement (Loc,
5295 Expression => Make_Integer_Literal (Loc, -1)))));
5296 end if;
5298 -- Now we can build the function body
5300 Fent :=
5301 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
5303 Func :=
5304 Make_Subprogram_Body (Loc,
5305 Specification =>
5306 Make_Function_Specification (Loc,
5307 Defining_Unit_Name => Fent,
5308 Parameter_Specifications => New_List (
5309 Make_Parameter_Specification (Loc,
5310 Defining_Identifier =>
5311 Make_Defining_Identifier (Loc, Name_uA),
5312 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5313 Make_Parameter_Specification (Loc,
5314 Defining_Identifier =>
5315 Make_Defining_Identifier (Loc, Name_uF),
5316 Parameter_Type =>
5317 New_Occurrence_Of (Standard_Boolean, Loc))),
5319 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
5321 Declarations => Empty_List,
5323 Handled_Statement_Sequence =>
5324 Make_Handled_Sequence_Of_Statements (Loc,
5325 Statements => New_List (
5326 Make_Case_Statement (Loc,
5327 Expression =>
5328 Unchecked_Convert_To
5329 (Ityp, Make_Identifier (Loc, Name_uA)),
5330 Alternatives => Lst))));
5332 Set_TSS (Typ, Fent);
5334 -- Set Pure flag (it will be reset if the current context is not Pure).
5335 -- We also pretend there was a pragma Pure_Function so that for purposes
5336 -- of optimization and constant-folding, we will consider the function
5337 -- Pure even if we are not in a Pure context).
5339 Set_Is_Pure (Fent);
5340 Set_Has_Pragma_Pure_Function (Fent);
5342 -- Unless we are in -gnatD mode, where we are debugging generated code,
5343 -- this is an internal entity for which we don't need debug info.
5345 if not Debug_Generated_Code then
5346 Set_Debug_Info_Off (Fent);
5347 end if;
5349 Set_Is_Inlined (Fent);
5351 exception
5352 when RE_Not_Available =>
5353 return;
5354 end Expand_Freeze_Enumeration_Type;
5356 -------------------------------
5357 -- Expand_Freeze_Record_Type --
5358 -------------------------------
5360 procedure Expand_Freeze_Record_Type (N : Node_Id) is
5362 procedure Build_Class_Condition_Subprograms (Typ : Entity_Id);
5363 -- Create internal subprograms of Typ primitives that have class-wide
5364 -- preconditions or postconditions; they are invoked by the caller to
5365 -- evaluate the conditions.
5367 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
5368 -- Create An Equality function for the untagged variant record Typ and
5369 -- attach it to the TSS list.
5371 procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id);
5372 -- Register dispatch-table wrappers in the dispatch table of Typ
5374 procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id);
5375 -- Check extra formals of dispatching primitives of tagged type Typ.
5376 -- Used in pragma Debug.
5378 ---------------------------------------
5379 -- Build_Class_Condition_Subprograms --
5380 ---------------------------------------
5382 procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is
5383 Prim_List : constant Elist_Id := Primitive_Operations (Typ);
5384 Prim_Elmt : Elmt_Id := First_Elmt (Prim_List);
5385 Prim : Entity_Id;
5387 begin
5388 while Present (Prim_Elmt) loop
5389 Prim := Node (Prim_Elmt);
5391 -- Primitive with class-wide preconditions
5393 if Comes_From_Source (Prim)
5394 and then Has_Significant_Contract (Prim)
5395 and then
5396 (Present (Class_Preconditions (Prim))
5397 or else Present (Ignored_Class_Preconditions (Prim)))
5398 then
5399 if Expander_Active then
5400 Make_Class_Precondition_Subps (Prim);
5401 end if;
5403 -- Wrapper of a primitive that has or inherits class-wide
5404 -- preconditions.
5406 elsif Is_Primitive_Wrapper (Prim)
5407 and then
5408 (Present (Nearest_Class_Condition_Subprogram
5409 (Spec_Id => Prim,
5410 Kind => Class_Precondition))
5411 or else
5412 Present (Nearest_Class_Condition_Subprogram
5413 (Spec_Id => Prim,
5414 Kind => Ignored_Class_Precondition)))
5415 then
5416 if Expander_Active then
5417 Make_Class_Precondition_Subps (Prim);
5418 end if;
5419 end if;
5421 Next_Elmt (Prim_Elmt);
5422 end loop;
5423 end Build_Class_Condition_Subprograms;
5425 -----------------------------------
5426 -- Build_Variant_Record_Equality --
5427 -----------------------------------
5429 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
5430 Loc : constant Source_Ptr := Sloc (Typ);
5431 F : constant Entity_Id :=
5432 Make_Defining_Identifier (Loc,
5433 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
5434 begin
5435 -- For a variant record with restriction No_Implicit_Conditionals
5436 -- in effect we skip building the procedure. This is safe because
5437 -- if we can see the restriction, so can any caller, and calls to
5438 -- equality test routines are not allowed for variant records if
5439 -- this restriction is active.
5441 if Restriction_Active (No_Implicit_Conditionals) then
5442 return;
5443 end if;
5445 -- Derived Unchecked_Union types no longer inherit the equality
5446 -- function of their parent.
5448 if Is_Derived_Type (Typ)
5449 and then not Is_Unchecked_Union (Typ)
5450 and then not Has_New_Non_Standard_Rep (Typ)
5451 then
5452 declare
5453 Parent_Eq : constant Entity_Id :=
5454 TSS (Root_Type (Typ), TSS_Composite_Equality);
5455 begin
5456 if Present (Parent_Eq) then
5457 Copy_TSS (Parent_Eq, Typ);
5458 return;
5459 end if;
5460 end;
5461 end if;
5463 Discard_Node (
5464 Build_Variant_Record_Equality
5465 (Typ => Typ,
5466 Body_Id => F,
5467 Param_Specs => New_List (
5468 Make_Parameter_Specification (Loc,
5469 Defining_Identifier =>
5470 Make_Defining_Identifier (Loc, Name_X),
5471 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
5473 Make_Parameter_Specification (Loc,
5474 Defining_Identifier =>
5475 Make_Defining_Identifier (Loc, Name_Y),
5476 Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
5478 Set_TSS (Typ, F);
5479 Set_Is_Pure (F);
5481 if not Debug_Generated_Code then
5482 Set_Debug_Info_Off (F);
5483 end if;
5484 end Build_Variant_Record_Equality;
5486 --------------------------------------
5487 -- Register_Dispatch_Table_Wrappers --
5488 --------------------------------------
5490 procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is
5491 Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ));
5492 Subp : Entity_Id;
5494 begin
5495 while Present (Elmt) loop
5496 Subp := Node (Elmt);
5498 if Is_Dispatch_Table_Wrapper (Subp) then
5499 Append_Freeze_Actions (Typ,
5500 Register_Primitive (Sloc (Subp), Subp));
5501 end if;
5503 Next_Elmt (Elmt);
5504 end loop;
5505 end Register_Dispatch_Table_Wrappers;
5507 ----------------------------------------
5508 -- Validate_Tagged_Type_Extra_Formals --
5509 ----------------------------------------
5511 procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is
5512 Ovr_Subp : Entity_Id;
5513 Elmt : Elmt_Id;
5514 Subp : Entity_Id;
5516 begin
5517 pragma Assert (not Is_Class_Wide_Type (Typ));
5519 -- No check required if expansion is not active since we never
5520 -- generate extra formals in such case.
5522 if not Expander_Active then
5523 return;
5524 end if;
5526 Elmt := First_Elmt (Primitive_Operations (Typ));
5527 while Present (Elmt) loop
5528 Subp := Node (Elmt);
5530 -- Extra formals of a dispatching primitive must match:
5532 -- 1) The extra formals of its covered interface primitive
5534 if Present (Interface_Alias (Subp)) then
5535 pragma Assert
5536 (Extra_Formals_Match_OK
5537 (E => Interface_Alias (Subp),
5538 Ref_E => Alias (Subp)));
5539 end if;
5541 -- 2) The extra formals of its renamed primitive
5543 if Present (Alias (Subp)) then
5544 pragma Assert
5545 (Extra_Formals_Match_OK
5546 (E => Subp,
5547 Ref_E => Ultimate_Alias (Subp)));
5548 end if;
5550 -- 3) The extra formals of its overridden primitive
5552 if Present (Overridden_Operation (Subp)) then
5553 Ovr_Subp := Overridden_Operation (Subp);
5555 -- Handle controlling function wrapper
5557 if Is_Wrapper (Subp)
5558 and then Ultimate_Alias (Ovr_Subp) = Subp
5559 then
5560 if Present (Overridden_Operation (Ovr_Subp)) then
5561 pragma Assert
5562 (Extra_Formals_Match_OK
5563 (E => Subp,
5564 Ref_E => Overridden_Operation (Ovr_Subp)));
5565 end if;
5567 else
5568 pragma Assert
5569 (Extra_Formals_Match_OK
5570 (E => Subp,
5571 Ref_E => Ovr_Subp));
5572 end if;
5573 end if;
5575 Next_Elmt (Elmt);
5576 end loop;
5577 end Validate_Tagged_Type_Extra_Formals;
5579 -- Local variables
5581 Typ : constant Node_Id := Entity (N);
5582 Typ_Decl : constant Node_Id := Parent (Typ);
5584 Comp : Entity_Id;
5585 Comp_Typ : Entity_Id;
5586 Predef_List : List_Id;
5588 Wrapper_Decl_List : List_Id;
5589 Wrapper_Body_List : List_Id := No_List;
5591 Renamed_Eq : Node_Id := Empty;
5592 -- Defining unit name for the predefined equality function in the case
5593 -- where the type has a primitive operation that is a renaming of
5594 -- predefined equality (but only if there is also an overriding
5595 -- user-defined equality function). Used to pass this entity from
5596 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
5598 -- Start of processing for Expand_Freeze_Record_Type
5600 begin
5601 -- Build discriminant checking functions if not a derived type (for
5602 -- derived types that are not tagged types, always use the discriminant
5603 -- checking functions of the parent type). However, for untagged types
5604 -- the derivation may have taken place before the parent was frozen, so
5605 -- we copy explicitly the discriminant checking functions from the
5606 -- parent into the components of the derived type.
5608 Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl);
5610 if Is_Derived_Type (Typ)
5611 and then Is_Limited_Type (Typ)
5612 and then Is_Tagged_Type (Typ)
5613 then
5614 Check_Stream_Attributes (Typ);
5615 end if;
5617 -- Update task, protected, and controlled component flags, because some
5618 -- of the component types may have been private at the point of the
5619 -- record declaration. Detect anonymous access-to-controlled components.
5621 Comp := First_Component (Typ);
5622 while Present (Comp) loop
5623 Comp_Typ := Etype (Comp);
5625 Propagate_Concurrent_Flags (Typ, Comp_Typ);
5627 -- Do not set Has_Controlled_Component on a class-wide equivalent
5628 -- type. See Make_CW_Equivalent_Type.
5630 if not Is_Class_Wide_Equivalent_Type (Typ)
5631 and then
5632 (Has_Controlled_Component (Comp_Typ)
5633 or else (Chars (Comp) /= Name_uParent
5634 and then Is_Controlled (Comp_Typ)))
5635 then
5636 Set_Has_Controlled_Component (Typ);
5637 end if;
5639 Next_Component (Comp);
5640 end loop;
5642 -- Handle constructors of untagged CPP_Class types
5644 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
5645 Set_CPP_Constructors (Typ);
5646 end if;
5648 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
5649 -- for regular tagged types as well as for Ada types deriving from a C++
5650 -- Class, but not for tagged types directly corresponding to C++ classes
5651 -- In the later case we assume that it is created in the C++ side and we
5652 -- just use it.
5654 if Is_Tagged_Type (Typ) then
5656 -- Add the _Tag component
5658 if Underlying_Type (Etype (Typ)) = Typ then
5659 Expand_Tagged_Root (Typ);
5660 end if;
5662 if Is_CPP_Class (Typ) then
5663 Set_All_DT_Position (Typ);
5665 -- Create the tag entities with a minimum decoration
5667 if Tagged_Type_Expansion then
5668 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5669 end if;
5671 Set_CPP_Constructors (Typ);
5673 else
5674 if not Building_Static_DT (Typ) then
5676 -- Usually inherited primitives are not delayed but the first
5677 -- Ada extension of a CPP_Class is an exception since the
5678 -- address of the inherited subprogram has to be inserted in
5679 -- the new Ada Dispatch Table and this is a freezing action.
5681 -- Similarly, if this is an inherited operation whose parent is
5682 -- not frozen yet, it is not in the DT of the parent, and we
5683 -- generate an explicit freeze node for the inherited operation
5684 -- so it is properly inserted in the DT of the current type.
5686 declare
5687 Elmt : Elmt_Id;
5688 Subp : Entity_Id;
5690 begin
5691 Elmt := First_Elmt (Primitive_Operations (Typ));
5692 while Present (Elmt) loop
5693 Subp := Node (Elmt);
5695 if Present (Alias (Subp)) then
5696 if Is_CPP_Class (Etype (Typ)) then
5697 Set_Has_Delayed_Freeze (Subp);
5699 elsif Has_Delayed_Freeze (Alias (Subp))
5700 and then not Is_Frozen (Alias (Subp))
5701 then
5702 Set_Is_Frozen (Subp, False);
5703 Set_Has_Delayed_Freeze (Subp);
5704 end if;
5705 end if;
5707 Next_Elmt (Elmt);
5708 end loop;
5709 end;
5710 end if;
5712 -- Unfreeze momentarily the type to add the predefined primitives
5713 -- operations. The reason we unfreeze is so that these predefined
5714 -- operations will indeed end up as primitive operations (which
5715 -- must be before the freeze point).
5717 Set_Is_Frozen (Typ, False);
5719 -- Do not add the spec of predefined primitives in case of
5720 -- CPP tagged type derivations that have convention CPP.
5722 if Is_CPP_Class (Root_Type (Typ))
5723 and then Convention (Typ) = Convention_CPP
5724 then
5725 null;
5727 -- Do not add the spec of the predefined primitives if we are
5728 -- compiling under restriction No_Dispatching_Calls.
5730 elsif not Restriction_Active (No_Dispatching_Calls) then
5731 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
5732 Insert_List_Before_And_Analyze (N, Predef_List);
5733 end if;
5735 -- Ada 2005 (AI-391): For a nonabstract null extension, create
5736 -- wrapper functions for each nonoverridden inherited function
5737 -- with a controlling result of the type. The wrapper for such
5738 -- a function returns an extension aggregate that invokes the
5739 -- parent function.
5741 if Ada_Version >= Ada_2005
5742 and then not Is_Abstract_Type (Typ)
5743 and then Is_Null_Extension (Typ)
5744 then
5745 Make_Controlling_Function_Wrappers
5746 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
5747 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5748 end if;
5750 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5751 -- null procedure declarations for each set of homographic null
5752 -- procedures that are inherited from interface types but not
5753 -- overridden. This is done to ensure that the dispatch table
5754 -- entry associated with such null primitives are properly filled.
5756 if Ada_Version >= Ada_2005
5757 and then Etype (Typ) /= Typ
5758 and then not Is_Abstract_Type (Typ)
5759 and then Has_Interfaces (Typ)
5760 then
5761 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
5762 end if;
5764 Set_Is_Frozen (Typ);
5766 if not Is_Derived_Type (Typ)
5767 or else Is_Tagged_Type (Etype (Typ))
5768 then
5769 Set_All_DT_Position (Typ);
5771 -- If this is a type derived from an untagged private type whose
5772 -- full view is tagged, the type is marked tagged for layout
5773 -- reasons, but it has no dispatch table.
5775 elsif Is_Derived_Type (Typ)
5776 and then Is_Private_Type (Etype (Typ))
5777 and then not Is_Tagged_Type (Etype (Typ))
5778 then
5779 return;
5780 end if;
5782 -- Create and decorate the tags. Suppress their creation when
5783 -- not Tagged_Type_Expansion because the dispatching mechanism is
5784 -- handled internally by the virtual target.
5786 if Tagged_Type_Expansion then
5787 Append_Freeze_Actions (Typ, Make_Tags (Typ));
5789 -- Generate dispatch table of locally defined tagged type.
5790 -- Dispatch tables of library level tagged types are built
5791 -- later (see Build_Static_Dispatch_Tables).
5793 if not Building_Static_DT (Typ) then
5794 Append_Freeze_Actions (Typ, Make_DT (Typ));
5796 -- Register dispatch table wrappers in the dispatch table.
5797 -- It could not be done when these wrappers were built
5798 -- because, at that stage, the dispatch table was not
5799 -- available.
5801 Register_Dispatch_Table_Wrappers (Typ);
5802 end if;
5803 end if;
5805 -- If the type has unknown discriminants, propagate dispatching
5806 -- information to its underlying record view, which does not get
5807 -- its own dispatch table.
5809 if Is_Derived_Type (Typ)
5810 and then Has_Unknown_Discriminants (Typ)
5811 and then Present (Underlying_Record_View (Typ))
5812 then
5813 declare
5814 Rep : constant Entity_Id := Underlying_Record_View (Typ);
5815 begin
5816 Set_Access_Disp_Table
5817 (Rep, Access_Disp_Table (Typ));
5818 Set_Dispatch_Table_Wrappers
5819 (Rep, Dispatch_Table_Wrappers (Typ));
5820 Set_Direct_Primitive_Operations
5821 (Rep, Direct_Primitive_Operations (Typ));
5822 end;
5823 end if;
5825 -- Make sure that the primitives Initialize, Adjust and Finalize
5826 -- are Frozen before other TSS subprograms. We don't want them
5827 -- Frozen inside.
5829 if Is_Controlled (Typ) then
5830 if not Is_Limited_Type (Typ) then
5831 Append_Freeze_Actions (Typ,
5832 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
5833 end if;
5835 Append_Freeze_Actions (Typ,
5836 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
5838 Append_Freeze_Actions (Typ,
5839 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
5840 end if;
5842 -- Freeze rest of primitive operations. There is no need to handle
5843 -- the predefined primitives if we are compiling under restriction
5844 -- No_Dispatching_Calls.
5846 if not Restriction_Active (No_Dispatching_Calls) then
5847 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5848 end if;
5849 end if;
5851 -- In the untagged case, ever since Ada 83 an equality function must
5852 -- be provided for variant records that are not unchecked unions.
5853 -- In Ada 2012 the equality function composes, and thus must be built
5854 -- explicitly just as for tagged records.
5856 elsif Has_Discriminants (Typ)
5857 and then not Is_Limited_Type (Typ)
5858 then
5859 declare
5860 Comps : constant Node_Id :=
5861 Component_List (Type_Definition (Typ_Decl));
5862 begin
5863 if Present (Comps)
5864 and then Present (Variant_Part (Comps))
5865 then
5866 Build_Variant_Record_Equality (Typ);
5867 end if;
5868 end;
5870 -- Otherwise create primitive equality operation (AI05-0123)
5872 -- This is done unconditionally to ensure that tools can be linked
5873 -- properly with user programs compiled with older language versions.
5874 -- In addition, this is needed because "=" composes for bounded strings
5875 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5877 elsif Comes_From_Source (Typ)
5878 and then Convention (Typ) = Convention_Ada
5879 and then not Is_Limited_Type (Typ)
5880 then
5881 Build_Untagged_Equality (Typ);
5882 end if;
5884 -- Before building the record initialization procedure, if we are
5885 -- dealing with a concurrent record value type, then we must go through
5886 -- the discriminants, exchanging discriminals between the concurrent
5887 -- type and the concurrent record value type. See the section "Handling
5888 -- of Discriminants" in the Einfo spec for details.
5890 if Is_Concurrent_Record_Type (Typ)
5891 and then Has_Discriminants (Typ)
5892 then
5893 declare
5894 Ctyp : constant Entity_Id :=
5895 Corresponding_Concurrent_Type (Typ);
5896 Conc_Discr : Entity_Id;
5897 Rec_Discr : Entity_Id;
5898 Temp : Entity_Id;
5900 begin
5901 Conc_Discr := First_Discriminant (Ctyp);
5902 Rec_Discr := First_Discriminant (Typ);
5903 while Present (Conc_Discr) loop
5904 Temp := Discriminal (Conc_Discr);
5905 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5906 Set_Discriminal (Rec_Discr, Temp);
5908 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5909 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5911 Next_Discriminant (Conc_Discr);
5912 Next_Discriminant (Rec_Discr);
5913 end loop;
5914 end;
5915 end if;
5917 if Has_Controlled_Component (Typ) then
5918 Build_Controlling_Procs (Typ);
5919 end if;
5921 Adjust_Discriminants (Typ);
5923 -- Do not need init for interfaces on virtual targets since they're
5924 -- abstract.
5926 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5927 Build_Record_Init_Proc (Typ_Decl, Typ);
5928 end if;
5930 -- For tagged type that are not interfaces, build bodies of primitive
5931 -- operations. Note: do this after building the record initialization
5932 -- procedure, since the primitive operations may need the initialization
5933 -- routine. There is no need to add predefined primitives of interfaces
5934 -- because all their predefined primitives are abstract.
5936 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5938 -- Do not add the body of predefined primitives in case of CPP tagged
5939 -- type derivations that have convention CPP.
5941 if Is_CPP_Class (Root_Type (Typ))
5942 and then Convention (Typ) = Convention_CPP
5943 then
5944 null;
5946 -- Do not add the body of the predefined primitives if we are
5947 -- compiling under restriction No_Dispatching_Calls or if we are
5948 -- compiling a CPP tagged type.
5950 elsif not Restriction_Active (No_Dispatching_Calls) then
5952 -- Create the body of TSS primitive Finalize_Address. This must
5953 -- be done before the bodies of all predefined primitives are
5954 -- created. If Typ is limited, Stream_Input and Stream_Read may
5955 -- produce build-in-place allocations and for those the expander
5956 -- needs Finalize_Address.
5958 Make_Finalize_Address_Body (Typ);
5959 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5960 Append_Freeze_Actions (Typ, Predef_List);
5961 end if;
5963 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5964 -- inherited functions, then add their bodies to the freeze actions.
5966 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5967 end if;
5969 -- Create extra formals for the primitive operations of the type.
5970 -- This must be done before analyzing the body of the initialization
5971 -- procedure, because a self-referential type might call one of these
5972 -- primitives in the body of the init_proc itself.
5974 -- This is not needed:
5975 -- 1) If expansion is disabled, because extra formals are only added
5976 -- when we are generating code.
5978 -- 2) For types with foreign convention since primitives with foreign
5979 -- convention don't have extra formals and AI95-117 requires that
5980 -- all primitives of a tagged type inherit the convention.
5982 if Expander_Active
5983 and then Is_Tagged_Type (Typ)
5984 and then not Has_Foreign_Convention (Typ)
5985 then
5986 declare
5987 Elmt : Elmt_Id;
5988 E : Entity_Id;
5990 begin
5991 -- Add extra formals to primitive operations
5993 Elmt := First_Elmt (Primitive_Operations (Typ));
5994 while Present (Elmt) loop
5995 Create_Extra_Formals (Node (Elmt));
5996 Next_Elmt (Elmt);
5997 end loop;
5999 -- Add extra formals to renamings of primitive operations. The
6000 -- addition of extra formals is done in two steps to minimize
6001 -- the compile time required for this action; the evaluation of
6002 -- Find_Dispatching_Type() and Contains() is only done here for
6003 -- renamings that are not primitive operations.
6005 E := First_Entity (Scope (Typ));
6006 while Present (E) loop
6007 if Is_Dispatching_Operation (E)
6008 and then Present (Alias (E))
6009 and then Find_Dispatching_Type (E) = Typ
6010 and then not Contains (Primitive_Operations (Typ), E)
6011 then
6012 Create_Extra_Formals (E);
6013 end if;
6015 Next_Entity (E);
6016 end loop;
6018 pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ));
6019 end;
6020 end if;
6022 -- Build internal subprograms of primitives with class-wide
6023 -- pre/postconditions.
6025 if Is_Tagged_Type (Typ) then
6026 Build_Class_Condition_Subprograms (Typ);
6027 end if;
6028 end Expand_Freeze_Record_Type;
6030 ------------------------------------
6031 -- Expand_N_Full_Type_Declaration --
6032 ------------------------------------
6034 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
6035 procedure Build_Master (Ptr_Typ : Entity_Id);
6036 -- Create the master associated with Ptr_Typ
6038 ------------------
6039 -- Build_Master --
6040 ------------------
6042 procedure Build_Master (Ptr_Typ : Entity_Id) is
6043 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
6045 begin
6046 -- If the designated type is an incomplete view coming from a
6047 -- limited-with'ed package, we need to use the nonlimited view in
6048 -- case it has tasks.
6050 if Is_Incomplete_Type (Desig_Typ)
6051 and then Present (Non_Limited_View (Desig_Typ))
6052 then
6053 Desig_Typ := Non_Limited_View (Desig_Typ);
6054 end if;
6056 -- Anonymous access types are created for the components of the
6057 -- record parameter for an entry declaration. No master is created
6058 -- for such a type.
6060 if Has_Task (Desig_Typ) then
6061 Build_Master_Entity (Ptr_Typ);
6062 Build_Master_Renaming (Ptr_Typ);
6064 -- Create a class-wide master because a Master_Id must be generated
6065 -- for access-to-limited-class-wide types whose root may be extended
6066 -- with task components.
6068 -- Note: This code covers access-to-limited-interfaces because they
6069 -- can be used to reference tasks implementing them.
6071 -- Suppress the master creation for access types created for entry
6072 -- formal parameters (parameter block component types). Seems like
6073 -- suppression should be more general for compiler-generated types,
6074 -- but testing Comes_From_Source may be too general in this case
6075 -- (affects some test output)???
6077 elsif not Is_Param_Block_Component_Type (Ptr_Typ)
6078 and then Is_Limited_Class_Wide_Type (Desig_Typ)
6079 then
6080 Build_Class_Wide_Master (Ptr_Typ);
6081 end if;
6082 end Build_Master;
6084 -- Local declarations
6086 Def_Id : constant Entity_Id := Defining_Identifier (N);
6087 B_Id : constant Entity_Id := Base_Type (Def_Id);
6088 FN : Node_Id;
6089 Par_Id : Entity_Id;
6091 -- Start of processing for Expand_N_Full_Type_Declaration
6093 begin
6094 if Is_Access_Type (Def_Id) then
6095 Build_Master (Def_Id);
6097 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
6098 Expand_Access_Protected_Subprogram_Type (N);
6099 end if;
6101 -- Array of anonymous access-to-task pointers
6103 elsif Ada_Version >= Ada_2005
6104 and then Is_Array_Type (Def_Id)
6105 and then Is_Access_Type (Component_Type (Def_Id))
6106 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
6107 then
6108 Build_Master (Component_Type (Def_Id));
6110 elsif Has_Task (Def_Id) then
6111 Expand_Previous_Access_Type (Def_Id);
6113 -- Check the components of a record type or array of records for
6114 -- anonymous access-to-task pointers.
6116 elsif Ada_Version >= Ada_2005
6117 and then (Is_Record_Type (Def_Id)
6118 or else
6119 (Is_Array_Type (Def_Id)
6120 and then Is_Record_Type (Component_Type (Def_Id))))
6121 then
6122 declare
6123 Comp : Entity_Id;
6124 First : Boolean;
6125 M_Id : Entity_Id := Empty;
6126 Typ : Entity_Id;
6128 begin
6129 if Is_Array_Type (Def_Id) then
6130 Comp := First_Entity (Component_Type (Def_Id));
6131 else
6132 Comp := First_Entity (Def_Id);
6133 end if;
6135 -- Examine all components looking for anonymous access-to-task
6136 -- types.
6138 First := True;
6139 while Present (Comp) loop
6140 Typ := Etype (Comp);
6142 if Ekind (Typ) = E_Anonymous_Access_Type
6143 and then Might_Have_Tasks
6144 (Available_View (Designated_Type (Typ)))
6145 and then No (Master_Id (Typ))
6146 then
6147 -- Ensure that the record or array type have a _master
6149 if First then
6150 Build_Master_Entity (Def_Id);
6151 Build_Master_Renaming (Typ);
6152 M_Id := Master_Id (Typ);
6154 First := False;
6156 -- Reuse the same master to service any additional types
6158 else
6159 pragma Assert (Present (M_Id));
6160 Set_Master_Id (Typ, M_Id);
6161 end if;
6162 end if;
6164 Next_Entity (Comp);
6165 end loop;
6166 end;
6167 end if;
6169 Par_Id := Etype (B_Id);
6171 -- The parent type is private then we need to inherit any TSS operations
6172 -- from the full view.
6174 if Is_Private_Type (Par_Id)
6175 and then Present (Full_View (Par_Id))
6176 then
6177 Par_Id := Base_Type (Full_View (Par_Id));
6178 end if;
6180 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
6181 and then not Is_Tagged_Type (Def_Id)
6182 and then Present (Freeze_Node (Par_Id))
6183 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
6184 then
6185 Ensure_Freeze_Node (B_Id);
6186 FN := Freeze_Node (B_Id);
6188 if No (TSS_Elist (FN)) then
6189 Set_TSS_Elist (FN, New_Elmt_List);
6190 end if;
6192 declare
6193 T_E : constant Elist_Id := TSS_Elist (FN);
6194 Elmt : Elmt_Id;
6196 begin
6197 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
6198 while Present (Elmt) loop
6199 if Chars (Node (Elmt)) /= Name_uInit then
6200 Append_Elmt (Node (Elmt), T_E);
6201 end if;
6203 Next_Elmt (Elmt);
6204 end loop;
6206 -- If the derived type itself is private with a full view, then
6207 -- associate the full view with the inherited TSS_Elist as well.
6209 if Is_Private_Type (B_Id)
6210 and then Present (Full_View (B_Id))
6211 then
6212 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
6213 Set_TSS_Elist
6214 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
6215 end if;
6216 end;
6217 end if;
6218 end Expand_N_Full_Type_Declaration;
6220 ---------------------------------
6221 -- Expand_N_Object_Declaration --
6222 ---------------------------------
6224 procedure Expand_N_Object_Declaration (N : Node_Id) is
6225 Loc : constant Source_Ptr := Sloc (N);
6226 Def_Id : constant Entity_Id := Defining_Identifier (N);
6227 Expr : constant Node_Id := Expression (N);
6228 Obj_Def : constant Node_Id := Object_Definition (N);
6229 Typ : constant Entity_Id := Etype (Def_Id);
6230 Base_Typ : constant Entity_Id := Base_Type (Typ);
6231 Next_N : constant Node_Id := Next (N);
6233 Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id);
6234 -- If this is a special return object, it will be allocated differently
6235 -- and ultimately rewritten as a renaming, so initialization activities
6236 -- need to be deferred until after that is done.
6238 Func_Id : constant Entity_Id :=
6239 (if Special_Ret_Obj then Return_Applies_To (Scope (Def_Id)) else Empty);
6240 -- The function if this is a special return object, otherwise Empty
6242 function Build_Equivalent_Aggregate return Boolean;
6243 -- If the object has a constrained discriminated type and no initial
6244 -- value, it may be possible to build an equivalent aggregate instead,
6245 -- and prevent an actual call to the initialization procedure.
6247 function Build_Heap_Or_Pool_Allocator
6248 (Temp_Id : Entity_Id;
6249 Temp_Typ : Entity_Id;
6250 Ret_Typ : Entity_Id;
6251 Alloc_Expr : Node_Id) return Node_Id;
6252 -- Create the statements necessary to allocate a return object on the
6253 -- heap or user-defined storage pool. The object may need finalization
6254 -- actions depending on the return type.
6256 -- * Controlled case
6258 -- if BIPfinalizationmaster = null then
6259 -- Temp_Id := <Alloc_Expr>;
6260 -- else
6261 -- declare
6262 -- type Ptr_Typ is access Ret_Typ;
6263 -- for Ptr_Typ'Storage_Pool use
6264 -- Base_Pool (BIPfinalizationmaster.all).all;
6265 -- Local : Ptr_Typ;
6267 -- begin
6268 -- procedure Allocate (...) is
6269 -- begin
6270 -- System.Storage_Pools.Subpools.Allocate_Any (...);
6271 -- end Allocate;
6273 -- Local := <Alloc_Expr>;
6274 -- Temp_Id := Temp_Typ (Local);
6275 -- end;
6276 -- end if;
6278 -- * Non-controlled case
6280 -- Temp_Id := <Alloc_Expr>;
6282 -- Temp_Id is the temporary which is used to reference the internally
6283 -- created object in all allocation forms. Temp_Typ is the type of the
6284 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
6285 -- type of Func_Id. Alloc_Expr is the actual allocator.
6287 procedure Count_Default_Sized_Task_Stacks
6288 (Typ : Entity_Id;
6289 Pri_Stacks : out Int;
6290 Sec_Stacks : out Int);
6291 -- Count the number of default-sized primary and secondary task stacks
6292 -- required for task objects contained within type Typ. If the number of
6293 -- task objects contained within the type is not known at compile time
6294 -- the procedure will return the stack counts of zero.
6296 procedure Default_Initialize_Object (After : Node_Id);
6297 -- Generate all default initialization actions for object Def_Id. Any
6298 -- new code is inserted after node After.
6300 procedure Initialize_Return_Object
6301 (Tag_Assign : Node_Id;
6302 Adj_Call : Node_Id;
6303 Expr : Node_Id;
6304 Init_Stmt : Node_Id;
6305 After : Node_Id);
6306 -- Generate all initialization actions for return object Def_Id. Any
6307 -- new code is inserted after node After.
6309 function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean;
6310 -- If we are not at library level and the object declaration originally
6311 -- appears in the form:
6313 -- Obj : Typ := Func (...);
6315 -- and has been rewritten as the dereference of a captured reference
6316 -- to the function result built either on the primary or the secondary
6317 -- stack, then the declaration can be rewritten as the renaming of this
6318 -- dereference:
6320 -- type Ann is access all Typ;
6321 -- Rnn : constant Axx := Func (...)'reference;
6322 -- Obj : Typ renames Rnn.all;
6324 -- This will avoid making an extra copy and, in the case where Typ needs
6325 -- finalization, a pair of calls to the Adjust and Finalize primitives,
6326 -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ
6327 -- has components that themselves need finalization.
6329 -- However, in the case of a special return object, we need to make sure
6330 -- that the object Rnn is recognized by the Is_Related_To_Func_Return
6331 -- predicate; otherwise, if it is of a type that needs finalization,
6332 -- then Requires_Cleanup_Actions would return true because of this and
6333 -- Build_Finalizer would finalize it prematurely because of this (see
6334 -- also Expand_Simple_Function_Return for the same test in the case of
6335 -- a simple return).
6337 -- Finally, in the case of a special return object, we also need to make
6338 -- sure that the two functions return on the same stack, otherwise we
6339 -- would create a dangling reference.
6341 function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id;
6342 -- Make an allocator for a return object initialized with Expr
6344 function OK_To_Rename_Ref (N : Node_Id) return Boolean;
6345 -- Return True if N denotes an entity with OK_To_Rename set
6347 --------------------------------
6348 -- Build_Equivalent_Aggregate --
6349 --------------------------------
6351 function Build_Equivalent_Aggregate return Boolean is
6352 Aggr : Node_Id;
6353 Comp : Entity_Id;
6354 Discr : Elmt_Id;
6355 Full_Type : Entity_Id;
6357 begin
6358 Full_Type := Typ;
6360 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
6361 Full_Type := Full_View (Typ);
6362 end if;
6364 -- Only perform this transformation if Elaboration_Code is forbidden
6365 -- or undesirable, and if this is a global entity of a constrained
6366 -- record type.
6368 -- If Initialize_Scalars might be active this transformation cannot
6369 -- be performed either, because it will lead to different semantics
6370 -- or because elaboration code will in fact be created.
6372 if Ekind (Full_Type) /= E_Record_Subtype
6373 or else not Has_Discriminants (Full_Type)
6374 or else not Is_Constrained (Full_Type)
6375 or else Is_Controlled (Full_Type)
6376 or else Is_Limited_Type (Full_Type)
6377 or else not Restriction_Active (No_Initialize_Scalars)
6378 then
6379 return False;
6380 end if;
6382 if Ekind (Current_Scope) = E_Package
6383 and then
6384 (Restriction_Active (No_Elaboration_Code)
6385 or else Is_Preelaborated (Current_Scope))
6386 then
6387 -- Building a static aggregate is possible if the discriminants
6388 -- have static values and the other components have static
6389 -- defaults or none.
6391 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6392 while Present (Discr) loop
6393 if not Is_OK_Static_Expression (Node (Discr)) then
6394 return False;
6395 end if;
6397 Next_Elmt (Discr);
6398 end loop;
6400 -- Check that initialized components are OK, and that non-
6401 -- initialized components do not require a call to their own
6402 -- initialization procedure.
6404 Comp := First_Component (Full_Type);
6405 while Present (Comp) loop
6406 if Present (Expression (Parent (Comp)))
6407 and then
6408 not Is_OK_Static_Expression (Expression (Parent (Comp)))
6409 then
6410 return False;
6412 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
6413 return False;
6415 end if;
6417 Next_Component (Comp);
6418 end loop;
6420 -- Everything is static, assemble the aggregate, discriminant
6421 -- values first.
6423 Aggr :=
6424 Make_Aggregate (Loc,
6425 Expressions => New_List,
6426 Component_Associations => New_List);
6428 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
6429 while Present (Discr) loop
6430 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
6431 Next_Elmt (Discr);
6432 end loop;
6434 -- Now collect values of initialized components
6436 Comp := First_Component (Full_Type);
6437 while Present (Comp) loop
6438 if Present (Expression (Parent (Comp))) then
6439 Append_To (Component_Associations (Aggr),
6440 Make_Component_Association (Loc,
6441 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
6442 Expression => New_Copy_Tree
6443 (Expression (Parent (Comp)))));
6444 end if;
6446 Next_Component (Comp);
6447 end loop;
6449 -- Finally, box-initialize remaining components
6451 Append_To (Component_Associations (Aggr),
6452 Make_Component_Association (Loc,
6453 Choices => New_List (Make_Others_Choice (Loc)),
6454 Expression => Empty));
6455 Set_Box_Present (Last (Component_Associations (Aggr)));
6456 Set_Expression (N, Aggr);
6458 if Typ /= Full_Type then
6459 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
6460 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
6461 Analyze_And_Resolve (Aggr, Typ);
6462 else
6463 Analyze_And_Resolve (Aggr, Full_Type);
6464 end if;
6466 return True;
6468 else
6469 return False;
6470 end if;
6471 end Build_Equivalent_Aggregate;
6473 ----------------------------------
6474 -- Build_Heap_Or_Pool_Allocator --
6475 ----------------------------------
6477 function Build_Heap_Or_Pool_Allocator
6478 (Temp_Id : Entity_Id;
6479 Temp_Typ : Entity_Id;
6480 Ret_Typ : Entity_Id;
6481 Alloc_Expr : Node_Id) return Node_Id
6483 begin
6484 pragma Assert (Is_Build_In_Place_Function (Func_Id));
6486 -- Processing for objects that require finalization actions
6488 if Needs_Finalization (Ret_Typ) then
6489 declare
6490 Decls : constant List_Id := New_List;
6491 Fin_Mas_Id : constant Entity_Id :=
6492 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
6493 Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
6494 Stmts : constant List_Id := New_List;
6495 Local_Id : Entity_Id;
6496 Pool_Id : Entity_Id;
6497 Ptr_Typ : Entity_Id;
6499 begin
6500 -- Generate:
6501 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
6503 Pool_Id := Make_Temporary (Loc, 'P');
6505 Append_To (Decls,
6506 Make_Object_Renaming_Declaration (Loc,
6507 Defining_Identifier => Pool_Id,
6508 Subtype_Mark =>
6509 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
6510 Name =>
6511 Make_Explicit_Dereference (Loc,
6512 Prefix =>
6513 Make_Function_Call (Loc,
6514 Name =>
6515 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
6516 Parameter_Associations => New_List (
6517 Make_Explicit_Dereference (Loc,
6518 Prefix =>
6519 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
6521 -- Create an access type which uses the storage pool of the
6522 -- caller's master. This additional type is necessary because
6523 -- the finalization master cannot be associated with the type
6524 -- of the temporary. Otherwise the secondary stack allocation
6525 -- will fail.
6527 -- Generate:
6528 -- type Ptr_Typ is access Ret_Typ;
6530 Ptr_Typ := Make_Temporary (Loc, 'P');
6532 Append_To (Decls,
6533 Make_Full_Type_Declaration (Loc,
6534 Defining_Identifier => Ptr_Typ,
6535 Type_Definition =>
6536 Make_Access_To_Object_Definition (Loc,
6537 Subtype_Indication =>
6538 New_Occurrence_Of (Ret_Typ, Loc))));
6540 -- Perform minor decoration in order to set the master and the
6541 -- storage pool attributes.
6543 Mutate_Ekind (Ptr_Typ, E_Access_Type);
6544 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
6545 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
6547 -- Create the temporary, generate:
6548 -- Local_Id : Ptr_Typ;
6550 Local_Id := Make_Temporary (Loc, 'T');
6552 Append_To (Decls,
6553 Make_Object_Declaration (Loc,
6554 Defining_Identifier => Local_Id,
6555 Object_Definition =>
6556 New_Occurrence_Of (Ptr_Typ, Loc)));
6558 -- Allocate the object, generate:
6559 -- Local_Id := <Alloc_Expr>;
6561 Append_To (Stmts,
6562 Make_Assignment_Statement (Loc,
6563 Name => New_Occurrence_Of (Local_Id, Loc),
6564 Expression => Alloc_Expr));
6566 -- Generate:
6567 -- Temp_Id := Temp_Typ (Local_Id);
6569 Append_To (Stmts,
6570 Make_Assignment_Statement (Loc,
6571 Name => New_Occurrence_Of (Temp_Id, Loc),
6572 Expression =>
6573 Unchecked_Convert_To (Temp_Typ,
6574 New_Occurrence_Of (Local_Id, Loc))));
6576 -- Wrap the allocation in a block. This is further conditioned
6577 -- by checking the caller finalization master at runtime. A
6578 -- null value indicates a non-existent master, most likely due
6579 -- to a Finalize_Storage_Only allocation.
6581 -- Generate:
6582 -- if BIPfinalizationmaster = null then
6583 -- Temp_Id := <Orig_Expr>;
6584 -- else
6585 -- declare
6586 -- <Decls>
6587 -- begin
6588 -- <Stmts>
6589 -- end;
6590 -- end if;
6592 return
6593 Make_If_Statement (Loc,
6594 Condition =>
6595 Make_Op_Eq (Loc,
6596 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
6597 Right_Opnd => Make_Null (Loc)),
6599 Then_Statements => New_List (
6600 Make_Assignment_Statement (Loc,
6601 Name => New_Occurrence_Of (Temp_Id, Loc),
6602 Expression => Orig_Expr)),
6604 Else_Statements => New_List (
6605 Make_Block_Statement (Loc,
6606 Declarations => Decls,
6607 Handled_Statement_Sequence =>
6608 Make_Handled_Sequence_Of_Statements (Loc,
6609 Statements => Stmts))));
6610 end;
6612 -- For all other cases, generate:
6613 -- Temp_Id := <Alloc_Expr>;
6615 else
6616 return
6617 Make_Assignment_Statement (Loc,
6618 Name => New_Occurrence_Of (Temp_Id, Loc),
6619 Expression => Alloc_Expr);
6620 end if;
6621 end Build_Heap_Or_Pool_Allocator;
6623 -------------------------------------
6624 -- Count_Default_Sized_Task_Stacks --
6625 -------------------------------------
6627 procedure Count_Default_Sized_Task_Stacks
6628 (Typ : Entity_Id;
6629 Pri_Stacks : out Int;
6630 Sec_Stacks : out Int)
6632 Component : Entity_Id;
6634 begin
6635 -- To calculate the number of default-sized task stacks required for
6636 -- an object of Typ, a depth-first recursive traversal of the AST
6637 -- from the Typ entity node is undertaken. Only type nodes containing
6638 -- task objects are visited.
6640 Pri_Stacks := 0;
6641 Sec_Stacks := 0;
6643 if not Has_Task (Typ) then
6644 return;
6645 end if;
6647 case Ekind (Typ) is
6648 when E_Task_Subtype
6649 | E_Task_Type
6651 -- A task type is found marking the bottom of the descent. If
6652 -- the type has no representation aspect for the corresponding
6653 -- stack then that stack is using the default size.
6655 if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then
6656 Pri_Stacks := 0;
6657 else
6658 Pri_Stacks := 1;
6659 end if;
6661 if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then
6662 Sec_Stacks := 0;
6663 else
6664 Sec_Stacks := 1;
6665 end if;
6667 when E_Array_Subtype
6668 | E_Array_Type
6670 -- First find the number of default stacks contained within an
6671 -- array component.
6673 Count_Default_Sized_Task_Stacks
6674 (Component_Type (Typ),
6675 Pri_Stacks,
6676 Sec_Stacks);
6678 -- Then multiply the result by the size of the array
6680 declare
6681 Quantity : constant Int := Number_Of_Elements_In_Array (Typ);
6682 -- Number_Of_Elements_In_Array is non-trival, consequently
6683 -- its result is captured as an optimization.
6685 begin
6686 Pri_Stacks := Pri_Stacks * Quantity;
6687 Sec_Stacks := Sec_Stacks * Quantity;
6688 end;
6690 when E_Protected_Subtype
6691 | E_Protected_Type
6692 | E_Record_Subtype
6693 | E_Record_Type
6695 Component := First_Component_Or_Discriminant (Typ);
6697 -- Recursively descend each component of the composite type
6698 -- looking for tasks, but only if the component is marked as
6699 -- having a task.
6701 while Present (Component) loop
6702 if Has_Task (Etype (Component)) then
6703 declare
6704 P : Int;
6705 S : Int;
6707 begin
6708 Count_Default_Sized_Task_Stacks
6709 (Etype (Component), P, S);
6710 Pri_Stacks := Pri_Stacks + P;
6711 Sec_Stacks := Sec_Stacks + S;
6712 end;
6713 end if;
6715 Next_Component_Or_Discriminant (Component);
6716 end loop;
6718 when E_Limited_Private_Subtype
6719 | E_Limited_Private_Type
6720 | E_Record_Subtype_With_Private
6721 | E_Record_Type_With_Private
6723 -- Switch to the full view of the private type to continue
6724 -- search.
6726 Count_Default_Sized_Task_Stacks
6727 (Full_View (Typ), Pri_Stacks, Sec_Stacks);
6729 -- Other types should not contain tasks
6731 when others =>
6732 raise Program_Error;
6733 end case;
6734 end Count_Default_Sized_Task_Stacks;
6736 -------------------------------
6737 -- Default_Initialize_Object --
6738 -------------------------------
6740 procedure Default_Initialize_Object (After : Node_Id) is
6741 function New_Object_Reference return Node_Id;
6742 -- Return a new reference to Def_Id with attributes Assignment_OK and
6743 -- Must_Not_Freeze already set.
6745 function Simple_Initialization_OK
6746 (Init_Typ : Entity_Id) return Boolean;
6747 -- Determine whether object declaration N with entity Def_Id needs
6748 -- simple initialization, assuming that it is of type Init_Typ.
6750 --------------------------
6751 -- New_Object_Reference --
6752 --------------------------
6754 function New_Object_Reference return Node_Id is
6755 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
6757 begin
6758 -- The call to the type init proc or [Deep_]Finalize must not
6759 -- freeze the related object as the call is internally generated.
6760 -- This way legal rep clauses that apply to the object will not be
6761 -- flagged. Note that the initialization call may be removed if
6762 -- pragma Import is encountered or moved to the freeze actions of
6763 -- the object because of an address clause.
6765 Set_Assignment_OK (Obj_Ref);
6766 Set_Must_Not_Freeze (Obj_Ref);
6768 return Obj_Ref;
6769 end New_Object_Reference;
6771 ------------------------------
6772 -- Simple_Initialization_OK --
6773 ------------------------------
6775 function Simple_Initialization_OK
6776 (Init_Typ : Entity_Id) return Boolean
6778 begin
6779 -- Do not consider the object declaration if it comes with an
6780 -- initialization expression, or is internal in which case it
6781 -- will be assigned later.
6783 return
6784 not Is_Internal (Def_Id)
6785 and then not Has_Init_Expression (N)
6786 and then Needs_Simple_Initialization
6787 (Typ => Init_Typ,
6788 Consider_IS =>
6789 Initialize_Scalars
6790 and then No (Following_Address_Clause (N)));
6791 end Simple_Initialization_OK;
6793 -- Local variables
6795 Exceptions_OK : constant Boolean :=
6796 not Restriction_Active (No_Exception_Propagation);
6798 Aggr_Init : Node_Id;
6799 Comp_Init : List_Id := No_List;
6800 Fin_Block : Node_Id;
6801 Fin_Call : Node_Id;
6802 Init_Stmts : List_Id := No_List;
6803 Obj_Init : Node_Id := Empty;
6804 Obj_Ref : Node_Id;
6806 -- Start of processing for Default_Initialize_Object
6808 begin
6809 -- Default initialization is suppressed for objects that are already
6810 -- known to be imported (i.e. whose declaration specifies the Import
6811 -- aspect). Note that for objects with a pragma Import, we generate
6812 -- initialization here, and then remove it downstream when processing
6813 -- the pragma. It is also suppressed for variables for which a pragma
6814 -- Suppress_Initialization has been explicitly given
6816 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
6817 return;
6819 -- Nothing to do if the object being initialized is of a task type
6820 -- and restriction No_Tasking is in effect, because this is a direct
6821 -- violation of the restriction.
6823 elsif Is_Task_Type (Base_Typ)
6824 and then Restriction_Active (No_Tasking)
6825 then
6826 return;
6827 end if;
6829 -- The expansion performed by this routine is as follows:
6831 -- begin
6832 -- Abort_Defer;
6833 -- Type_Init_Proc (Obj);
6835 -- begin
6836 -- [Deep_]Initialize (Obj);
6838 -- exception
6839 -- when others =>
6840 -- [Deep_]Finalize (Obj, Self => False);
6841 -- raise;
6842 -- end;
6843 -- at end
6844 -- Abort_Undefer_Direct;
6845 -- end;
6847 -- Initialize the components of the object
6849 if Has_Non_Null_Base_Init_Proc (Typ)
6850 and then not No_Initialization (N)
6851 and then not Initialization_Suppressed (Typ)
6852 then
6853 -- Do not initialize the components if No_Default_Initialization
6854 -- applies as the actual restriction check will occur later when
6855 -- the object is frozen as it is not known yet whether the object
6856 -- is imported or not.
6858 if not Restriction_Active (No_Default_Initialization) then
6860 -- If the values of the components are compile-time known, use
6861 -- their prebuilt aggregate form directly.
6863 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
6865 if Present (Aggr_Init) then
6866 Set_Expression (N,
6867 New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
6869 -- If type has discriminants, try to build an equivalent
6870 -- aggregate using discriminant values from the declaration.
6871 -- This is a useful optimization, in particular if restriction
6872 -- No_Elaboration_Code is active.
6874 elsif Build_Equivalent_Aggregate then
6875 null;
6877 -- Optimize the default initialization of an array object when
6878 -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
6879 -- Construct an in-place initialization aggregate which may be
6880 -- convert into a fast memset by the backend.
6882 elsif Init_Or_Norm_Scalars
6883 and then Is_Array_Type (Typ)
6885 -- The array must lack atomic components because they are
6886 -- treated as non-static, and as a result the backend will
6887 -- not initialize the memory in one go.
6889 and then not Has_Atomic_Components (Typ)
6891 -- The array must not be packed because the invalid values
6892 -- in System.Scalar_Values are multiples of Storage_Unit.
6894 and then not Is_Packed (Typ)
6896 -- The array must have static non-empty ranges, otherwise
6897 -- the backend cannot initialize the memory in one go.
6899 and then Has_Static_Non_Empty_Array_Bounds (Typ)
6901 -- The optimization is only relevant for arrays of scalar
6902 -- types.
6904 and then Is_Scalar_Type (Component_Type (Typ))
6906 -- Similar to regular array initialization using a type
6907 -- init proc, predicate checks are not performed because the
6908 -- initialization values are intentionally invalid, and may
6909 -- violate the predicate.
6911 and then not Has_Predicates (Component_Type (Typ))
6913 -- The component type must have a single initialization value
6915 and then Simple_Initialization_OK (Component_Type (Typ))
6916 then
6917 Set_No_Initialization (N, False);
6918 Set_Expression (N,
6919 Get_Simple_Init_Val
6920 (Typ => Typ,
6921 N => Obj_Def,
6922 Size => (if Known_Esize (Def_Id) then Esize (Def_Id)
6923 else Uint_0)));
6925 Analyze_And_Resolve
6926 (Expression (N), Typ, Suppress => All_Checks);
6928 -- Otherwise invoke the type init proc, generate:
6929 -- Type_Init_Proc (Obj);
6931 else
6932 Obj_Ref := New_Object_Reference;
6934 if Comes_From_Source (Def_Id) then
6935 Initialization_Warning (Obj_Ref);
6936 end if;
6938 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
6939 end if;
6940 end if;
6942 -- Provide a default value if the object needs simple initialization
6944 elsif Simple_Initialization_OK (Typ) then
6945 Set_No_Initialization (N, False);
6946 Set_Expression (N,
6947 Get_Simple_Init_Val
6948 (Typ => Typ,
6949 N => Obj_Def,
6950 Size =>
6951 (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0)));
6953 Analyze_And_Resolve (Expression (N), Typ);
6954 end if;
6956 -- Initialize the object, generate:
6957 -- [Deep_]Initialize (Obj);
6959 if Needs_Finalization (Typ) and then not No_Initialization (N) then
6960 Obj_Init :=
6961 Make_Init_Call
6962 (Obj_Ref => New_Object_Reference,
6963 Typ => Typ);
6964 end if;
6966 -- Build a special finalization block when both the object and its
6967 -- controlled components are to be initialized. The block finalizes
6968 -- the components if the object initialization fails. Generate:
6970 -- begin
6971 -- <Obj_Init>
6973 -- exception
6974 -- when others =>
6975 -- <Fin_Call>
6976 -- raise;
6977 -- end;
6979 if Has_Controlled_Component (Typ)
6980 and then Present (Comp_Init)
6981 and then Present (Obj_Init)
6982 and then Exceptions_OK
6983 then
6984 Init_Stmts := Comp_Init;
6986 Fin_Call :=
6987 Make_Final_Call
6988 (Obj_Ref => New_Object_Reference,
6989 Typ => Typ,
6990 Skip_Self => True);
6992 if Present (Fin_Call) then
6994 -- Do not emit warnings related to the elaboration order when a
6995 -- controlled object is declared before the body of Finalize is
6996 -- seen.
6998 if Legacy_Elaboration_Checks then
6999 Set_No_Elaboration_Check (Fin_Call);
7000 end if;
7002 Fin_Block :=
7003 Make_Block_Statement (Loc,
7004 Declarations => No_List,
7006 Handled_Statement_Sequence =>
7007 Make_Handled_Sequence_Of_Statements (Loc,
7008 Statements => New_List (Obj_Init),
7010 Exception_Handlers => New_List (
7011 Make_Exception_Handler (Loc,
7012 Exception_Choices => New_List (
7013 Make_Others_Choice (Loc)),
7015 Statements => New_List (
7016 Fin_Call,
7017 Make_Raise_Statement (Loc))))));
7019 -- Signal the ABE mechanism that the block carries out
7020 -- initialization actions.
7022 Set_Is_Initialization_Block (Fin_Block);
7024 Append_To (Init_Stmts, Fin_Block);
7025 end if;
7027 -- Otherwise finalization is not required, the initialization calls
7028 -- are passed to the abort block building circuitry, generate:
7030 -- Type_Init_Proc (Obj);
7031 -- [Deep_]Initialize (Obj);
7033 else
7034 if Present (Comp_Init) then
7035 Init_Stmts := Comp_Init;
7036 end if;
7038 if Present (Obj_Init) then
7039 if No (Init_Stmts) then
7040 Init_Stmts := New_List;
7041 end if;
7043 Append_To (Init_Stmts, Obj_Init);
7044 end if;
7045 end if;
7047 -- Build an abort block to protect the initialization calls
7049 if Abort_Allowed
7050 and then Present (Comp_Init)
7051 and then Present (Obj_Init)
7052 then
7053 -- Generate:
7054 -- Abort_Defer;
7056 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7058 -- When exceptions are propagated, abort deferral must take place
7059 -- in the presence of initialization or finalization exceptions.
7060 -- Generate:
7062 -- begin
7063 -- Abort_Defer;
7064 -- <Init_Stmts>
7065 -- at end
7066 -- Abort_Undefer_Direct;
7067 -- end;
7069 if Exceptions_OK then
7070 Init_Stmts := New_List (
7071 Build_Abort_Undefer_Block (Loc,
7072 Stmts => Init_Stmts,
7073 Context => N));
7075 -- Otherwise exceptions are not propagated. Generate:
7077 -- Abort_Defer;
7078 -- <Init_Stmts>
7079 -- Abort_Undefer;
7081 else
7082 Append_To (Init_Stmts,
7083 Build_Runtime_Call (Loc, RE_Abort_Undefer));
7084 end if;
7085 end if;
7087 -- Insert the whole initialization sequence into the tree. If the
7088 -- object has a delayed freeze, as will be the case when it has
7089 -- aspect specifications, the initialization sequence is part of
7090 -- the freeze actions.
7092 if Present (Init_Stmts) then
7093 if Has_Delayed_Freeze (Def_Id) then
7094 Append_Freeze_Actions (Def_Id, Init_Stmts);
7095 else
7096 Insert_Actions_After (After, Init_Stmts);
7097 end if;
7098 end if;
7099 end Default_Initialize_Object;
7101 ------------------------------
7102 -- Initialize_Return_Object --
7103 ------------------------------
7105 procedure Initialize_Return_Object
7106 (Tag_Assign : Node_Id;
7107 Adj_Call : Node_Id;
7108 Expr : Node_Id;
7109 Init_Stmt : Node_Id;
7110 After : Node_Id)
7112 begin
7113 if Present (Tag_Assign) then
7114 Insert_Action_After (After, Tag_Assign);
7115 end if;
7117 if Present (Adj_Call) then
7118 Insert_Action_After (After, Adj_Call);
7119 end if;
7121 if No (Expr) then
7122 Default_Initialize_Object (After);
7124 elsif Is_Delayed_Aggregate (Expr)
7125 and then not No_Initialization (N)
7126 then
7127 Convert_Aggr_In_Object_Decl (N);
7129 elsif Present (Init_Stmt) then
7130 Insert_Action_After (After, Init_Stmt);
7131 Set_Expression (N, Empty);
7132 end if;
7133 end Initialize_Return_Object;
7135 --------------------------------
7136 -- Is_Renamable_Function_Call --
7137 --------------------------------
7139 function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean is
7140 begin
7141 return not Is_Library_Level_Entity (Def_Id)
7142 and then Is_Captured_Function_Call (Expr)
7143 and then (not Special_Ret_Obj
7144 or else
7145 (Is_Related_To_Func_Return (Entity (Prefix (Expr)))
7146 and then Needs_Secondary_Stack (Etype (Expr)) =
7147 Needs_Secondary_Stack (Etype (Func_Id))));
7148 end Is_Renamable_Function_Call;
7150 -------------------------------
7151 -- Make_Allocator_For_Return --
7152 -------------------------------
7154 function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
7155 Alloc : Node_Id;
7156 Alloc_Expr : Entity_Id;
7158 begin
7159 -- If the return object's declaration includes an expression and the
7160 -- declaration isn't marked as No_Initialization, then we generate an
7161 -- allocator with a qualified expression. Although this is necessary
7162 -- only in the case where the result type is an interface (or class-
7163 -- wide interface), we do it in all cases for the sake of consistency
7164 -- instead of subsequently generating a separate assignment.
7166 if Present (Expr)
7167 and then not Is_Delayed_Aggregate (Expr)
7168 and then not No_Initialization (N)
7169 then
7170 -- Ada 2005 (AI95-344): If the result type is class-wide, insert
7171 -- a check that the level of the return expression's underlying
7172 -- type is not deeper than the level of the master enclosing the
7173 -- function.
7175 -- AI12-043: The check is made immediately after the return object
7176 -- is created.
7178 if Is_Class_Wide_Type (Etype (Func_Id)) then
7179 Apply_CW_Accessibility_Check (Expr, Func_Id);
7180 end if;
7182 Alloc_Expr := New_Copy_Tree (Expr);
7184 -- In the constrained array case, deal with a potential sliding.
7185 -- In the interface case, put back a conversion that we may have
7186 -- removed earlier in the processing.
7188 if (Ekind (Typ) = E_Array_Subtype
7189 or else (Is_Interface (Typ)
7190 and then Is_Class_Wide_Type (Etype (Alloc_Expr))))
7191 and then Typ /= Etype (Alloc_Expr)
7192 then
7193 Alloc_Expr := Convert_To (Typ, Alloc_Expr);
7194 end if;
7196 -- We always use the type of the expression for the qualified
7197 -- expression, rather than the return object's type. We cannot
7198 -- always use the return object's type because the expression
7199 -- might be of a specific type and the return object mignt not.
7201 Alloc :=
7202 Make_Allocator (Loc,
7203 Expression =>
7204 Make_Qualified_Expression (Loc,
7205 Subtype_Mark =>
7206 New_Occurrence_Of (Etype (Alloc_Expr), Loc),
7207 Expression => Alloc_Expr));
7209 else
7210 Alloc :=
7211 Make_Allocator (Loc,
7212 Expression => New_Occurrence_Of (Typ, Loc));
7214 -- If the return object requires default initialization, then it
7215 -- will happen later following the elaboration of the renaming.
7216 -- If we don't turn it off here, then the object will be default
7217 -- initialized twice.
7219 Set_No_Initialization (Alloc);
7220 end if;
7222 -- Set the flag indicating that the allocator is made for a special
7223 -- return object. This is used to bypass various legality checks as
7224 -- well as to make sure that the result is not adjusted twice.
7226 Set_For_Special_Return_Object (Alloc);
7228 return Alloc;
7229 end Make_Allocator_For_Return;
7231 ----------------------
7232 -- OK_To_Rename_Ref --
7233 ----------------------
7235 function OK_To_Rename_Ref (N : Node_Id) return Boolean is
7236 begin
7237 return Is_Entity_Name (N)
7238 and then Ekind (Entity (N)) = E_Variable
7239 and then OK_To_Rename (Entity (N));
7240 end OK_To_Rename_Ref;
7242 -- Local variables
7244 Adj_Call : Node_Id := Empty;
7245 Expr_Q : Node_Id := Empty;
7246 Tag_Assign : Node_Id := Empty;
7248 Init_After : Node_Id := N;
7249 -- Node after which the initialization actions are to be inserted. This
7250 -- is normally N, except for the case of a shared passive variable, in
7251 -- which case the init proc call must be inserted only after the bodies
7252 -- of the shared variable procedures have been seen.
7254 Rewrite_As_Renaming : Boolean := False;
7255 -- Whether to turn the declaration into a renaming at the end
7257 -- Start of processing for Expand_N_Object_Declaration
7259 begin
7260 -- Don't do anything for deferred constants. All proper actions will be
7261 -- expanded during the full declaration.
7263 if No (Expr) and Constant_Present (N) then
7264 return;
7265 end if;
7267 -- The type of the object cannot be abstract. This is diagnosed at the
7268 -- point the object is frozen, which happens after the declaration is
7269 -- fully expanded, so simply return now.
7271 if Is_Abstract_Type (Typ) then
7272 return;
7273 end if;
7275 -- No action needed for the internal imported dummy object added by
7276 -- Make_DT to compute the offset of the components that reference
7277 -- secondary dispatch tables; required to avoid never-ending loop
7278 -- processing this internal object declaration.
7280 if Tagged_Type_Expansion
7281 and then Is_Internal (Def_Id)
7282 and then Is_Imported (Def_Id)
7283 and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
7284 then
7285 return;
7286 end if;
7288 -- Make shared memory routines for shared passive variable
7290 if Is_Shared_Passive (Def_Id) then
7291 Init_After := Make_Shared_Var_Procs (N);
7292 end if;
7294 -- If tasks are being declared, make sure we have an activation chain
7295 -- defined for the tasks (has no effect if we already have one), and
7296 -- also that a Master variable is established (and that the appropriate
7297 -- enclosing construct is established as a task master).
7299 if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
7300 Build_Activation_Chain_Entity (N);
7302 if Has_Task (Typ) then
7303 Build_Master_Entity (Def_Id);
7305 -- Handle objects initialized with BIP function calls
7307 elsif Present (Expr) then
7308 Expr_Q := Unqualify (Expr);
7310 if Is_Build_In_Place_Function_Call (Expr_Q)
7311 or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
7312 or else (Nkind (Expr_Q) = N_Reference
7313 and then
7314 Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
7315 then
7316 Build_Master_Entity (Def_Id);
7317 end if;
7318 end if;
7319 end if;
7321 -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
7322 -- restrictions are active then default-sized secondary stacks are
7323 -- generated by the binder and allocated by SS_Init. To provide the
7324 -- binder the number of stacks to generate, the number of default-sized
7325 -- stacks required for task objects contained within the object
7326 -- declaration N is calculated here as it is at this point where
7327 -- unconstrained types become constrained. The result is stored in the
7328 -- enclosing unit's Unit_Record.
7330 -- Note if N is an array object declaration that has an initialization
7331 -- expression, a second object declaration for the initialization
7332 -- expression is created by the compiler. To prevent double counting
7333 -- of the stacks in this scenario, the stacks of the first array are
7334 -- not counted.
7336 if Might_Have_Tasks (Typ)
7337 and then not Restriction_Active (No_Secondary_Stack)
7338 and then (Restriction_Active (No_Implicit_Heap_Allocations)
7339 or else Restriction_Active (No_Implicit_Task_Allocations))
7340 and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype
7341 and then (Has_Init_Expression (N)))
7342 then
7343 declare
7344 PS_Count, SS_Count : Int := 0;
7345 begin
7346 Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count);
7347 Increment_Primary_Stack_Count (PS_Count);
7348 Increment_Sec_Stack_Count (SS_Count);
7349 end;
7350 end if;
7352 -- Default initialization required, and no expression present
7354 if No (Expr) then
7355 -- If we have a type with a variant part, the initialization proc
7356 -- will contain implicit tests of the discriminant values, which
7357 -- counts as a violation of the restriction No_Implicit_Conditionals.
7359 if Has_Variant_Part (Typ) then
7360 declare
7361 Msg : Boolean;
7363 begin
7364 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
7366 if Msg then
7367 Error_Msg_N
7368 ("\initialization of variant record tests discriminants",
7369 Obj_Def);
7370 return;
7371 end if;
7372 end;
7373 end if;
7375 -- For the default initialization case, if we have a private type
7376 -- with invariants, and invariant checks are enabled, then insert an
7377 -- invariant check after the object declaration. Note that it is OK
7378 -- to clobber the object with an invalid value since if the exception
7379 -- is raised, then the object will go out of scope. In the case where
7380 -- an array object is initialized with an aggregate, the expression
7381 -- is removed. Check flag Has_Init_Expression to avoid generating a
7382 -- junk invariant check and flag No_Initialization to avoid checking
7383 -- an uninitialized object such as a compiler temporary used for an
7384 -- aggregate.
7386 if Has_Invariants (Base_Typ)
7387 and then Present (Invariant_Procedure (Base_Typ))
7388 and then not Has_Init_Expression (N)
7389 and then not No_Initialization (N)
7390 then
7391 -- If entity has an address clause or aspect, make invariant
7392 -- call into a freeze action for the explicit freeze node for
7393 -- object. Otherwise insert invariant check after declaration.
7395 if Present (Following_Address_Clause (N))
7396 or else Has_Aspect (Def_Id, Aspect_Address)
7397 then
7398 Ensure_Freeze_Node (Def_Id);
7399 Set_Has_Delayed_Freeze (Def_Id);
7400 Set_Is_Frozen (Def_Id, False);
7402 if not Partial_View_Has_Unknown_Discr (Typ) then
7403 Append_Freeze_Action (Def_Id,
7404 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
7405 end if;
7407 elsif not Partial_View_Has_Unknown_Discr (Typ) then
7408 Insert_After (N,
7409 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
7410 end if;
7411 end if;
7413 if not Special_Ret_Obj then
7414 Default_Initialize_Object (Init_After);
7415 end if;
7417 -- Generate attribute for Persistent_BSS if needed
7419 if Persistent_BSS_Mode
7420 and then Comes_From_Source (N)
7421 and then Is_Potentially_Persistent_Type (Typ)
7422 and then not Has_Init_Expression (N)
7423 and then Is_Library_Level_Entity (Def_Id)
7424 then
7425 declare
7426 Prag : Node_Id;
7427 begin
7428 Prag :=
7429 Make_Linker_Section_Pragma
7430 (Def_Id, Sloc (N), ".persistent.bss");
7431 Insert_After (N, Prag);
7432 Analyze (Prag);
7433 end;
7434 end if;
7436 -- If access type, then we know it is null if not initialized
7438 if Is_Access_Type (Typ) then
7439 Set_Is_Known_Null (Def_Id);
7440 end if;
7442 -- Explicit initialization present
7444 else
7445 -- Obtain actual expression from qualified expression
7447 Expr_Q := Unqualify (Expr);
7449 -- When we have the appropriate type of aggregate in the expression
7450 -- (it has been determined during analysis of the aggregate by
7451 -- setting the delay flag), let's perform in place assignment and
7452 -- thus avoid creating a temporary.
7454 if Is_Delayed_Aggregate (Expr_Q) then
7456 -- An aggregate that must be built in place is not resolved and
7457 -- expanded until the enclosing construct is expanded. This will
7458 -- happen when the aggregate is limited and the declared object
7459 -- has a following address clause; it happens also when generating
7460 -- C code for an aggregate that has an alignment or address clause
7461 -- (see Analyze_Object_Declaration). Resolution is done without
7462 -- expansion because it will take place when the declaration
7463 -- itself is expanded.
7465 if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
7466 and then not Analyzed (Expr)
7467 then
7468 Expander_Mode_Save_And_Set (False);
7469 Resolve (Expr, Typ);
7470 Expander_Mode_Restore;
7471 end if;
7473 if not Special_Ret_Obj then
7474 Convert_Aggr_In_Object_Decl (N);
7475 end if;
7477 -- Ada 2005 (AI-318-02): If the initialization expression is a call
7478 -- to a build-in-place function, then access to the declared object
7479 -- must be passed to the function. Currently we limit such functions
7480 -- to those with constrained limited result subtypes, but eventually
7481 -- plan to expand the allowed forms of functions that are treated as
7482 -- build-in-place.
7484 elsif Is_Build_In_Place_Function_Call (Expr_Q) then
7485 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
7487 -- The previous call expands the expression initializing the
7488 -- built-in-place object into further code that will be analyzed
7489 -- later. No further expansion needed here.
7491 return;
7493 -- This is the same as the previous 'elsif', except that the call has
7494 -- been transformed by other expansion activities into something like
7495 -- F(...)'Reference.
7497 elsif Nkind (Expr_Q) = N_Reference
7498 and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
7499 and then not Is_Expanded_Build_In_Place_Call
7500 (Unqual_Conv (Prefix (Expr_Q)))
7501 then
7502 Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
7504 -- The previous call expands the expression initializing the
7505 -- built-in-place object into further code that will be analyzed
7506 -- later. No further expansion needed here.
7508 return;
7510 -- Ada 2005 (AI-318-02): Specialization of the previous case for
7511 -- expressions containing a build-in-place function call whose
7512 -- returned object covers interface types, and Expr_Q has calls to
7513 -- Ada.Tags.Displace to displace the pointer to the returned build-
7514 -- in-place object to reference the secondary dispatch table of a
7515 -- covered interface type.
7517 elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
7518 Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
7520 -- The previous call expands the expression initializing the
7521 -- built-in-place object into further code that will be analyzed
7522 -- later. No further expansion needed here.
7524 return;
7526 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
7527 -- class-wide interface object to ensure that we copy the full
7528 -- object, unless we are targetting a VM where interfaces are handled
7529 -- by VM itself. Note that if the root type of Typ is an ancestor of
7530 -- Expr's type, both types share the same dispatch table and there is
7531 -- no need to displace the pointer.
7533 elsif Is_Interface (Typ)
7535 -- Avoid never-ending recursion because if Equivalent_Type is set
7536 -- then we've done it already and must not do it again.
7538 and then not
7539 (Nkind (Obj_Def) = N_Identifier
7540 and then Present (Equivalent_Type (Entity (Obj_Def))))
7541 then
7542 pragma Assert (Is_Class_Wide_Type (Typ));
7544 -- If the original node of the expression was a conversion
7545 -- to this specific class-wide interface type then restore
7546 -- the original node because we must copy the object before
7547 -- displacing the pointer to reference the secondary tag
7548 -- component. This code must be kept synchronized with the
7549 -- expansion done by routine Expand_Interface_Conversion
7551 if not Comes_From_Source (Expr)
7552 and then Nkind (Expr) = N_Explicit_Dereference
7553 and then Nkind (Original_Node (Expr)) = N_Type_Conversion
7554 and then Etype (Original_Node (Expr)) = Typ
7555 then
7556 Rewrite (Expr, Original_Node (Expression (N)));
7557 end if;
7559 -- Avoid expansion of redundant interface conversion
7561 if Nkind (Expr) = N_Type_Conversion
7562 and then Etype (Expr) = Typ
7563 then
7564 Expr_Q := Expression (Expr);
7565 else
7566 Expr_Q := Expr;
7567 end if;
7569 -- We may use a renaming if the initialization expression is a
7570 -- captured function call that meets a few conditions.
7572 Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q);
7574 -- If the object is a special return object, then bypass special
7575 -- treatment of class-wide interface initialization below. In this
7576 -- case, the expansion of the return object will take care of this
7577 -- initialization via the expansion of the allocator.
7579 if Special_Ret_Obj and then not Rewrite_As_Renaming then
7581 -- If the type needs finalization and is not inherently
7582 -- limited, then the target is adjusted after the copy
7583 -- and attached to the finalization list.
7585 if Needs_Finalization (Typ)
7586 and then not Is_Limited_View (Typ)
7587 then
7588 Adj_Call :=
7589 Make_Adjust_Call (
7590 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
7591 Typ => Base_Typ);
7592 end if;
7594 -- Renaming an expression of the object's type is immediate
7596 elsif Rewrite_As_Renaming
7597 and then Base_Type (Etype (Expr_Q)) = Base_Type (Typ)
7598 then
7599 null;
7601 elsif Tagged_Type_Expansion then
7602 declare
7603 Iface : constant Entity_Id := Root_Type (Typ);
7605 Expr_Typ : Entity_Id;
7606 New_Expr : Node_Id;
7607 Obj_Id : Entity_Id;
7608 Ptr_Obj_Decl : Node_Id;
7609 Ptr_Obj_Id : Entity_Id;
7610 Tag_Comp : Node_Id;
7612 begin
7613 Expr_Typ := Base_Type (Etype (Expr_Q));
7614 if Is_Class_Wide_Type (Expr_Typ) then
7615 Expr_Typ := Root_Type (Expr_Typ);
7616 end if;
7618 -- Rename limited objects since they cannot be copied
7620 if Is_Limited_Record (Expr_Typ) then
7621 Rewrite_As_Renaming := True;
7622 end if;
7624 Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
7626 -- Replace
7627 -- IW : I'Class := Expr;
7628 -- by
7629 -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
7630 -- type Ityp is not null access I'Class;
7631 -- Rnn : constant Ityp :=
7632 -- Ityp!(Displace (Dnn'Address, I'Tag));
7633 -- IW : I'Class renames Rnn.all;
7635 if Rewrite_As_Renaming then
7636 New_Expr :=
7637 Make_Explicit_Dereference (Loc,
7638 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7639 Make_Attribute_Reference (Loc,
7640 Prefix => Relocate_Node (Expr_Q),
7641 Attribute_Name => Name_Address)));
7643 -- Suppress junk access checks on RE_Tag_Ptr
7645 Insert_Action (N,
7646 Make_Object_Renaming_Declaration (Loc,
7647 Defining_Identifier => Obj_Id,
7648 Subtype_Mark =>
7649 New_Occurrence_Of (RTE (RE_Tag), Loc),
7650 Name => New_Expr),
7651 Suppress => Access_Check);
7653 -- Dynamically reference the tag associated with the
7654 -- interface.
7656 Tag_Comp :=
7657 Make_Function_Call (Loc,
7658 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
7659 Parameter_Associations => New_List (
7660 Make_Attribute_Reference (Loc,
7661 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7662 Attribute_Name => Name_Address),
7663 New_Occurrence_Of
7664 (Node (First_Elmt (Access_Disp_Table (Iface))),
7665 Loc)));
7667 -- Replace
7668 -- IW : I'Class := Expr;
7669 -- by
7670 -- Dnn : Typ := Expr;
7671 -- type Ityp is not null access I'Class;
7672 -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
7673 -- IW : I'Class renames Rnn.all;
7675 elsif Has_Tag_Of_Type (Expr_Q)
7676 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
7677 and then (Expr_Typ = Etype (Expr_Typ)
7678 or else not
7679 Is_Variable_Size_Record (Etype (Expr_Typ)))
7680 then
7681 Insert_Action (N,
7682 Make_Object_Declaration (Loc,
7683 Defining_Identifier => Obj_Id,
7684 Object_Definition =>
7685 New_Occurrence_Of (Expr_Typ, Loc),
7686 Expression => Relocate_Node (Expr_Q)));
7688 -- Statically reference the tag associated with the
7689 -- interface
7691 Tag_Comp :=
7692 Make_Selected_Component (Loc,
7693 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7694 Selector_Name =>
7695 New_Occurrence_Of
7696 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
7698 -- Replace
7699 -- IW : I'Class := Expr;
7700 -- by
7701 -- type Equiv_Record is record ... end record;
7702 -- implicit subtype CW is <Class_Wide_Subtype>;
7703 -- Dnn : CW := CW!(Expr);
7704 -- type Ityp is not null access I'Class;
7705 -- Rnn : constant Ityp :=
7706 -- Ityp!(Displace (Dnn'Address, I'Tag));
7707 -- IW : I'Class renames Rnn.all;
7709 else
7710 -- Generate the equivalent record type and update the
7711 -- subtype indication to reference it.
7713 Expand_Subtype_From_Expr
7714 (N => N,
7715 Unc_Type => Typ,
7716 Subtype_Indic => Obj_Def,
7717 Exp => Expr_Q);
7719 -- For interface types we use 'Address which displaces
7720 -- the pointer to the base of the object (if required).
7722 if Is_Interface (Etype (Expr_Q)) then
7723 New_Expr :=
7724 Unchecked_Convert_To (Etype (Obj_Def),
7725 Make_Explicit_Dereference (Loc,
7726 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
7727 Make_Attribute_Reference (Loc,
7728 Prefix => Relocate_Node (Expr_Q),
7729 Attribute_Name => Name_Address))));
7731 -- For other types, no displacement is needed
7733 else
7734 New_Expr := Relocate_Node (Expr_Q);
7735 end if;
7737 -- Suppress junk access checks on RE_Tag_Ptr
7739 Insert_Action (N,
7740 Make_Object_Declaration (Loc,
7741 Defining_Identifier => Obj_Id,
7742 Object_Definition =>
7743 New_Occurrence_Of (Etype (Obj_Def), Loc),
7744 Expression => New_Expr),
7745 Suppress => Access_Check);
7747 -- Dynamically reference the tag associated with the
7748 -- interface.
7750 Tag_Comp :=
7751 Make_Function_Call (Loc,
7752 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
7753 Parameter_Associations => New_List (
7754 Make_Attribute_Reference (Loc,
7755 Prefix => New_Occurrence_Of (Obj_Id, Loc),
7756 Attribute_Name => Name_Address),
7757 New_Occurrence_Of
7758 (Node (First_Elmt (Access_Disp_Table (Iface))),
7759 Loc)));
7760 end if;
7762 -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
7763 -- to do the final conversion, but we insert an intermediate
7764 -- temporary before the dereference so that we can process
7765 -- the expansion as part of the analysis of the declaration
7766 -- of this temporary, and then rewrite manually the original
7767 -- object as the simple renaming of this dereference.
7769 Tag_Comp := Convert_Tag_To_Interface (Typ, Tag_Comp);
7770 pragma Assert (Nkind (Tag_Comp) = N_Explicit_Dereference
7771 and then
7772 Nkind (Prefix (Tag_Comp)) = N_Unchecked_Type_Conversion);
7774 Ptr_Obj_Id := Make_Temporary (Loc, 'R');
7776 Ptr_Obj_Decl :=
7777 Make_Object_Declaration (Loc,
7778 Defining_Identifier => Ptr_Obj_Id,
7779 Constant_Present => True,
7780 Object_Definition =>
7781 New_Occurrence_Of
7782 (Entity (Subtype_Mark (Prefix (Tag_Comp))), Loc),
7783 Expression => Prefix (Tag_Comp));
7785 Insert_Action (N, Ptr_Obj_Decl, Suppress => All_Checks);
7787 Set_Prefix (Tag_Comp, New_Occurrence_Of (Ptr_Obj_Id, Loc));
7788 Expr_Q := Tag_Comp;
7789 Set_Etype (Expr_Q, Typ);
7790 Set_Parent (Expr_Q, N);
7792 Rewrite_As_Renaming := True;
7793 end;
7795 else
7796 return;
7797 end if;
7799 -- Common case of explicit object initialization
7801 else
7802 -- Small optimization: if the expression is a function call and
7803 -- the object is stand-alone, not declared at library level and of
7804 -- a class-wide type, then we capture the result of the call into
7805 -- a temporary, with the benefit that, if the result's type does
7806 -- not need finalization, nothing will be finalized and, if it
7807 -- does, the temporary only will be finalized by means of a direct
7808 -- call to the Finalize primitive if the result's type is not a
7809 -- class-wide type; whereas, in both cases, the stand-alone object
7810 -- itself would be finalized by means of a dispatching call to the
7811 -- Deep_Finalize routine.
7813 if Nkind (Expr_Q) = N_Function_Call
7814 and then not Special_Ret_Obj
7815 and then not Is_Library_Level_Entity (Def_Id)
7816 and then Is_Class_Wide_Type (Typ)
7817 then
7818 Remove_Side_Effects (Expr_Q);
7819 end if;
7821 -- In most cases, we must check that the initial value meets any
7822 -- constraint imposed by the declared type. However, there is one
7823 -- very important exception to this rule. If the entity has an
7824 -- unconstrained nominal subtype, then it acquired its constraints
7825 -- from the expression in the first place, and not only does this
7826 -- mean that the constraint check is not needed, but an attempt to
7827 -- perform the constraint check can cause order of elaboration
7828 -- problems.
7830 if not Is_Constr_Subt_For_U_Nominal (Typ) then
7832 -- If this is an allocator for an aggregate that has been
7833 -- allocated in place, delay checks until assignments are
7834 -- made, because the discriminants are not initialized.
7836 if Nkind (Expr) = N_Allocator
7837 and then No_Initialization (Expr)
7838 then
7839 null;
7841 -- Otherwise apply a constraint check now if no prev error
7843 elsif Nkind (Expr) /= N_Error then
7844 Apply_Constraint_Check (Expr, Typ);
7846 -- Deal with possible range check
7848 if Do_Range_Check (Expr) then
7850 -- If assignment checks are suppressed, turn off flag
7852 if Suppress_Assignment_Checks (N) then
7853 Set_Do_Range_Check (Expr, False);
7855 -- Otherwise generate the range check
7857 else
7858 Generate_Range_Check
7859 (Expr, Typ, CE_Range_Check_Failed);
7860 end if;
7861 end if;
7862 end if;
7863 end if;
7865 -- For tagged types, when an init value is given, the tag has to
7866 -- be re-initialized separately in order to avoid the propagation
7867 -- of a wrong tag coming from a view conversion unless the type
7868 -- is class wide (in this case the tag comes from the init value).
7869 -- Suppress the tag assignment when not Tagged_Type_Expansion
7870 -- because tags are represented implicitly in objects. Ditto for
7871 -- types that are CPP_CLASS, and for initializations that are
7872 -- aggregates, because they have to have the right tag.
7874 -- The re-assignment of the tag has to be done even if the object
7875 -- is a constant. The assignment must be analyzed after the
7876 -- declaration. If an address clause follows, this is handled as
7877 -- part of the freeze actions for the object, otherwise insert
7878 -- tag assignment here.
7880 Tag_Assign := Make_Tag_Assignment (N);
7882 if Present (Tag_Assign) then
7883 if Present (Following_Address_Clause (N)) then
7884 Ensure_Freeze_Node (Def_Id);
7885 elsif not Special_Ret_Obj then
7886 Insert_Action_After (Init_After, Tag_Assign);
7887 end if;
7889 -- Handle C++ constructor calls. Note that we do not check that
7890 -- Typ is a tagged type since the equivalent Ada type of a C++
7891 -- class that has no virtual methods is an untagged limited
7892 -- record type.
7894 elsif Is_CPP_Constructor_Call (Expr) then
7895 declare
7896 Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
7898 begin
7899 -- The call to the initialization procedure does NOT freeze
7900 -- the object being initialized.
7902 Set_Must_Not_Freeze (Id_Ref);
7903 Set_Assignment_OK (Id_Ref);
7905 Insert_Actions_After (Init_After,
7906 Build_Initialization_Call (Loc, Id_Ref, Typ,
7907 Constructor_Ref => Expr));
7909 -- We remove here the original call to the constructor
7910 -- to avoid its management in the backend
7912 Set_Expression (N, Empty);
7913 return;
7914 end;
7916 -- Handle initialization of limited tagged types
7918 elsif Is_Tagged_Type (Typ)
7919 and then Is_Class_Wide_Type (Typ)
7920 and then Is_Limited_Record (Typ)
7921 and then not Is_Limited_Interface (Typ)
7922 then
7923 -- Given that the type is limited we cannot perform a copy. If
7924 -- Expr_Q is the reference to a variable we mark the variable
7925 -- as OK_To_Rename to expand this declaration into a renaming
7926 -- declaration (see below).
7928 if Is_Entity_Name (Expr_Q) then
7929 Set_OK_To_Rename (Entity (Expr_Q));
7931 -- If we cannot convert the expression into a renaming we must
7932 -- consider it an internal error because the backend does not
7933 -- have support to handle it. But avoid crashing on a raise
7934 -- expression or conditional expression.
7936 elsif Nkind (Original_Node (Expr_Q)) not in
7937 N_Raise_Expression | N_If_Expression | N_Case_Expression
7938 then
7939 raise Program_Error;
7940 end if;
7942 -- For discrete types, set the Is_Known_Valid flag if the
7943 -- initializing value is known to be valid. Only do this for
7944 -- source assignments, since otherwise we can end up turning
7945 -- on the known valid flag prematurely from inserted code.
7947 elsif Comes_From_Source (N)
7948 and then Is_Discrete_Type (Typ)
7949 and then Expr_Known_Valid (Expr)
7950 and then Safe_To_Capture_Value (N, Def_Id)
7951 then
7952 Set_Is_Known_Valid (Def_Id);
7954 -- For access types, set the Is_Known_Non_Null flag if the
7955 -- initializing value is known to be non-null. We can also
7956 -- set Can_Never_Be_Null if this is a constant.
7958 elsif Is_Access_Type (Typ) and then Known_Non_Null (Expr) then
7959 Set_Is_Known_Non_Null (Def_Id, True);
7961 if Constant_Present (N) then
7962 Set_Can_Never_Be_Null (Def_Id);
7963 end if;
7964 end if;
7966 -- If validity checking on copies, validate initial expression.
7967 -- But skip this if declaration is for a generic type, since it
7968 -- makes no sense to validate generic types. Not clear if this
7969 -- can happen for legal programs, but it definitely can arise
7970 -- from previous instantiation errors.
7972 if Validity_Checks_On
7973 and then Comes_From_Source (N)
7974 and then Validity_Check_Copies
7975 and then not Is_Generic_Type (Typ)
7976 then
7977 Ensure_Valid (Expr);
7979 if Safe_To_Capture_Value (N, Def_Id) then
7980 Set_Is_Known_Valid (Def_Id);
7981 end if;
7982 end if;
7984 -- Now determine whether we will use a renaming
7986 Rewrite_As_Renaming :=
7988 -- The declaration cannot be rewritten if it has got constraints
7990 Is_Entity_Name (Original_Node (Obj_Def))
7992 -- Nor if it is effectively an unconstrained declaration
7994 and then not (Is_Array_Type (Typ)
7995 and then Is_Constr_Subt_For_UN_Aliased (Typ))
7997 -- We may use a renaming if the initialization expression is a
7998 -- captured function call that meets a few conditions.
8000 and then
8001 (Is_Renamable_Function_Call (Expr_Q)
8003 -- Or else if it is a variable with OK_To_Rename set
8005 or else (OK_To_Rename_Ref (Expr_Q)
8006 and then not Special_Ret_Obj)
8008 -- Or else if it is a slice of such a variable
8010 or else (Nkind (Expr_Q) = N_Slice
8011 and then OK_To_Rename_Ref (Prefix (Expr_Q))
8012 and then not Special_Ret_Obj));
8014 -- If the type needs finalization and is not inherently limited,
8015 -- then the target is adjusted after the copy and attached to the
8016 -- finalization list. However, no adjustment is needed in the case
8017 -- where the object has been initialized by a call to a function
8018 -- returning on the primary stack (see Expand_Ctrl_Function_Call)
8019 -- since no copy occurred, given that the type is by-reference.
8020 -- Similarly, no adjustment is needed if we are going to rewrite
8021 -- the object declaration into a renaming declaration.
8023 if Needs_Finalization (Typ)
8024 and then not Is_Limited_View (Typ)
8025 and then Nkind (Expr_Q) /= N_Function_Call
8026 and then not Rewrite_As_Renaming
8027 then
8028 Adj_Call :=
8029 Make_Adjust_Call (
8030 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
8031 Typ => Base_Typ);
8033 if Present (Adj_Call) and then not Special_Ret_Obj then
8034 Insert_Action_After (Init_After, Adj_Call);
8035 end if;
8036 end if;
8037 end if;
8039 -- Cases where the back end cannot handle the initialization
8040 -- directly. In such cases, we expand an assignment that will
8041 -- be appropriately handled by Expand_N_Assignment_Statement.
8043 -- The exclusion of the unconstrained case is wrong, but for now it
8044 -- is too much trouble ???
8046 if (Is_Possibly_Unaligned_Slice (Expr)
8047 or else (Is_Possibly_Unaligned_Object (Expr)
8048 and then not Represented_As_Scalar (Etype (Expr))))
8049 and then not (Is_Array_Type (Etype (Expr))
8050 and then not Is_Constrained (Etype (Expr)))
8051 then
8052 declare
8053 Stat : constant Node_Id :=
8054 Make_Assignment_Statement (Loc,
8055 Name => New_Occurrence_Of (Def_Id, Loc),
8056 Expression => Relocate_Node (Expr));
8057 begin
8058 Set_Assignment_OK (Name (Stat));
8059 Set_No_Ctrl_Actions (Stat);
8060 Insert_Action_After (Init_After, Stat);
8061 Set_Expression (N, Empty);
8062 Set_No_Initialization (N);
8063 end;
8064 end if;
8065 end if;
8067 if Nkind (Obj_Def) = N_Access_Definition
8068 and then not Is_Local_Anonymous_Access (Typ)
8069 then
8070 -- An Ada 2012 stand-alone object of an anonymous access type
8072 declare
8073 Loc : constant Source_Ptr := Sloc (N);
8075 Level : constant Entity_Id :=
8076 Make_Defining_Identifier (Sloc (N),
8077 Chars =>
8078 New_External_Name (Chars (Def_Id), Suffix => "L"));
8080 Level_Decl : Node_Id;
8081 Level_Expr : Node_Id;
8083 begin
8084 Mutate_Ekind (Level, Ekind (Def_Id));
8085 Set_Etype (Level, Standard_Natural);
8086 Set_Scope (Level, Scope (Def_Id));
8088 -- Set accessibility level of null
8090 if No (Expr) then
8091 Level_Expr :=
8092 Make_Integer_Literal
8093 (Loc, Scope_Depth (Standard_Standard));
8095 -- When the expression of the object is a function which returns
8096 -- an anonymous access type the master of the call is the object
8097 -- being initialized instead of the type.
8099 elsif Nkind (Expr) = N_Function_Call
8100 and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
8101 then
8102 Level_Expr := Accessibility_Level
8103 (Def_Id, Object_Decl_Level);
8105 -- General case
8107 else
8108 Level_Expr := Accessibility_Level (Expr, Dynamic_Level);
8109 end if;
8111 Level_Decl :=
8112 Make_Object_Declaration (Loc,
8113 Defining_Identifier => Level,
8114 Object_Definition =>
8115 New_Occurrence_Of (Standard_Natural, Loc),
8116 Expression => Level_Expr,
8117 Constant_Present => Constant_Present (N),
8118 Has_Init_Expression => True);
8120 Insert_Action_After (Init_After, Level_Decl);
8122 Set_Extra_Accessibility (Def_Id, Level);
8123 end;
8124 end if;
8126 -- If the object is default initialized and its type is subject to
8127 -- pragma Default_Initial_Condition, add a runtime check to verify
8128 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
8130 -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
8132 -- Note that the check is generated for source objects only
8134 if Comes_From_Source (Def_Id)
8135 and then Has_DIC (Typ)
8136 and then Present (DIC_Procedure (Typ))
8137 and then not Has_Null_Body (DIC_Procedure (Typ))
8138 and then not Has_Init_Expression (N)
8139 and then No (Expr)
8140 and then not Is_Imported (Def_Id)
8141 then
8142 declare
8143 DIC_Call : constant Node_Id :=
8144 Build_DIC_Call
8145 (Loc, New_Occurrence_Of (Def_Id, Loc), Typ);
8146 begin
8147 if Present (Next_N) then
8148 Insert_Before_And_Analyze (Next_N, DIC_Call);
8150 -- The object declaration is the last node in a declarative or a
8151 -- statement list.
8153 else
8154 Append_To (List_Containing (N), DIC_Call);
8155 Analyze (DIC_Call);
8156 end if;
8157 end;
8158 end if;
8160 -- If this is the return object of a build-in-place function, locate the
8161 -- implicit BIPaccess parameter designating the caller-supplied return
8162 -- object and convert the declaration to a renaming of a dereference of
8163 -- this parameter. If the declaration includes an expression, add an
8164 -- assignment statement to ensure the return object gets initialized.
8166 -- Result : T [:= <expression>];
8168 -- is converted to
8170 -- Result : T renames BIPaccess.all;
8171 -- [Result := <expression>;]
8173 -- in the constrained case, or to
8175 -- type Txx is access all ...;
8176 -- Rxx : Txx := null;
8178 -- if BIPalloc = 1 then
8179 -- Rxx := BIPaccess;
8180 -- Rxx.all := <expression>;
8181 -- elsif BIPalloc = 2 then
8182 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8183 -- system__secondary_stack__ss_pool][procedure_to_call =
8184 -- system__secondary_stack__ss_allocate];
8185 -- elsif BIPalloc = 3 then
8186 -- Rxx := new <expression-type>'(<expression>)
8187 -- elsif BIPalloc = 4 then
8188 -- Pxx : system__storage_pools__root_storage_pool renames
8189 -- BIPstoragepool.all;
8190 -- Rxx := new <expression-type>'(<expression>)[storage_pool =
8191 -- Pxx][procedure_to_call =
8192 -- system__storage_pools__allocate_any];
8193 -- else
8194 -- [program_error "build in place mismatch"]
8195 -- end if;
8197 -- Result : T renames Rxx.all;
8199 -- in the unconstrained case.
8201 if Is_Build_In_Place_Return_Object (Def_Id) then
8202 declare
8203 Init_Stmt : Node_Id;
8204 Obj_Acc_Formal : Entity_Id;
8206 begin
8207 -- Retrieve the implicit access parameter passed by the caller
8209 Obj_Acc_Formal :=
8210 Build_In_Place_Formal (Func_Id, BIP_Object_Access);
8212 -- If the return object's declaration includes an expression
8213 -- and the declaration isn't marked as No_Initialization, then
8214 -- we need to generate an assignment to the object and insert
8215 -- it after the declaration before rewriting it as a renaming
8216 -- (otherwise we'll lose the initialization). The case where
8217 -- the result type is an interface (or class-wide interface)
8218 -- is also excluded because the context of the function call
8219 -- must be unconstrained, so the initialization will always
8220 -- be done as part of an allocator evaluation (storage pool
8221 -- or secondary stack), never to a constrained target object
8222 -- passed in by the caller. Besides the assignment being
8223 -- unneeded in this case, it avoids problems with trying to
8224 -- generate a dispatching assignment when the return expression
8225 -- is a nonlimited descendant of a limited interface (the
8226 -- interface has no assignment operation).
8228 if Present (Expr_Q)
8229 and then not Is_Delayed_Aggregate (Expr_Q)
8230 and then not No_Initialization (N)
8231 and then not Is_Interface (Typ)
8232 then
8233 if Is_Class_Wide_Type (Typ)
8234 and then not Is_Class_Wide_Type (Etype (Expr_Q))
8235 then
8236 Init_Stmt :=
8237 Make_Assignment_Statement (Loc,
8238 Name => New_Occurrence_Of (Def_Id, Loc),
8239 Expression =>
8240 Make_Type_Conversion (Loc,
8241 Subtype_Mark =>
8242 New_Occurrence_Of (Typ, Loc),
8243 Expression => New_Copy_Tree (Expr_Q)));
8245 else
8246 Init_Stmt :=
8247 Make_Assignment_Statement (Loc,
8248 Name => New_Occurrence_Of (Def_Id, Loc),
8249 Expression => New_Copy_Tree (Expr_Q));
8250 end if;
8252 Set_Assignment_OK (Name (Init_Stmt));
8253 Set_No_Ctrl_Actions (Init_Stmt);
8255 else
8256 Init_Stmt := Empty;
8257 end if;
8259 -- When the function's subtype is unconstrained, a run-time
8260 -- test may be needed to decide the form of allocation to use
8261 -- for the return object. The function has an implicit formal
8262 -- parameter indicating this. If the BIP_Alloc_Form formal has
8263 -- the value one, then the caller has passed access to an
8264 -- existing object for use as the return object. If the value
8265 -- is two, then the return object must be allocated on the
8266 -- secondary stack. If the value is three, then the return
8267 -- object must be allocated on the heap. Otherwise, the object
8268 -- must be allocated in a storage pool. We generate an if
8269 -- statement to test the BIP_Alloc_Form formal and initialize
8270 -- a local access value appropriately.
8272 if Needs_BIP_Alloc_Form (Func_Id) then
8273 declare
8274 Desig_Typ : constant Entity_Id :=
8275 (if Ekind (Typ) = E_Array_Subtype
8276 then Etype (Func_Id) else Typ);
8277 -- Ensure that the we use a fat pointer when allocating
8278 -- an unconstrained array on the heap. In this case the
8279 -- result object's type is a constrained array type even
8280 -- though the function's type is unconstrained.
8282 Obj_Alloc_Formal : constant Entity_Id :=
8283 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
8284 Pool_Id : constant Entity_Id :=
8285 Make_Temporary (Loc, 'P');
8287 Acc_Typ : Entity_Id;
8288 Alloc_Obj_Decl : Node_Id;
8289 Alloc_Obj_Id : Entity_Id;
8290 Alloc_Stmt : Node_Id;
8291 Guard_Except : Node_Id;
8292 Heap_Allocator : Node_Id;
8293 Pool_Allocator : Node_Id;
8294 Pool_Decl : Node_Id;
8295 Ptr_Typ_Decl : Node_Id;
8296 SS_Allocator : Node_Id;
8298 begin
8299 -- Create an access type designating the function's
8300 -- result subtype.
8302 Acc_Typ := Make_Temporary (Loc, 'A');
8304 Ptr_Typ_Decl :=
8305 Make_Full_Type_Declaration (Loc,
8306 Defining_Identifier => Acc_Typ,
8307 Type_Definition =>
8308 Make_Access_To_Object_Definition (Loc,
8309 All_Present => True,
8310 Subtype_Indication =>
8311 New_Occurrence_Of (Desig_Typ, Loc)));
8313 Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks);
8315 -- Create an access object that will be initialized to an
8316 -- access value denoting the return object, either coming
8317 -- from an implicit access value passed in by the caller
8318 -- or from the result of an allocator.
8320 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
8322 Alloc_Obj_Decl :=
8323 Make_Object_Declaration (Loc,
8324 Defining_Identifier => Alloc_Obj_Id,
8325 Object_Definition =>
8326 New_Occurrence_Of (Acc_Typ, Loc));
8328 Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
8330 -- First create the Heap_Allocator
8332 Heap_Allocator := Make_Allocator_For_Return (Expr_Q);
8334 -- The Pool_Allocator is just like the Heap_Allocator,
8335 -- except we set Storage_Pool and Procedure_To_Call so
8336 -- it will use the user-defined storage pool.
8338 Pool_Allocator := Make_Allocator_For_Return (Expr_Q);
8340 -- Do not generate the renaming of the build-in-place
8341 -- pool parameter on ZFP because the parameter is not
8342 -- created in the first place.
8344 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
8345 Pool_Decl :=
8346 Make_Object_Renaming_Declaration (Loc,
8347 Defining_Identifier => Pool_Id,
8348 Subtype_Mark =>
8349 New_Occurrence_Of
8350 (RTE (RE_Root_Storage_Pool), Loc),
8351 Name =>
8352 Make_Explicit_Dereference (Loc,
8353 New_Occurrence_Of
8354 (Build_In_Place_Formal
8355 (Func_Id, BIP_Storage_Pool), Loc)));
8356 Set_Storage_Pool (Pool_Allocator, Pool_Id);
8357 Set_Procedure_To_Call
8358 (Pool_Allocator, RTE (RE_Allocate_Any));
8359 else
8360 Pool_Decl := Make_Null_Statement (Loc);
8361 end if;
8363 -- If the No_Allocators restriction is active, then only
8364 -- an allocator for secondary stack allocation is needed.
8365 -- It's OK for such allocators to have Comes_From_Source
8366 -- set to False, because gigi knows not to flag them as
8367 -- being a violation of No_Implicit_Heap_Allocations.
8369 if Restriction_Active (No_Allocators) then
8370 SS_Allocator := Heap_Allocator;
8371 Heap_Allocator := Make_Null (Loc);
8372 Pool_Allocator := Make_Null (Loc);
8374 -- Otherwise the heap and pool allocators may be needed,
8375 -- so we make another allocator for secondary stack
8376 -- allocation.
8378 else
8379 SS_Allocator := Make_Allocator_For_Return (Expr_Q);
8381 -- The heap and pool allocators are marked as
8382 -- Comes_From_Source since they correspond to an
8383 -- explicit user-written allocator (that is, it will
8384 -- only be executed on behalf of callers that call the
8385 -- function as initialization for such an allocator).
8386 -- Prevents errors when No_Implicit_Heap_Allocations
8387 -- is in force.
8389 Set_Comes_From_Source (Heap_Allocator, True);
8390 Set_Comes_From_Source (Pool_Allocator, True);
8391 end if;
8393 -- The allocator is returned on the secondary stack
8395 Check_Restriction (No_Secondary_Stack, N);
8396 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
8397 Set_Procedure_To_Call
8398 (SS_Allocator, RTE (RE_SS_Allocate));
8400 -- The allocator is returned on the secondary stack,
8401 -- so indicate that the function return, as well as
8402 -- all blocks that encloses the allocator, must not
8403 -- release it. The flags must be set now because
8404 -- the decision to use the secondary stack is done
8405 -- very late in the course of expanding the return
8406 -- statement, past the point where these flags are
8407 -- normally set.
8409 Set_Uses_Sec_Stack (Func_Id);
8410 Set_Uses_Sec_Stack (Scope (Def_Id));
8411 Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));
8413 -- Guard against poor expansion on the caller side by
8414 -- using a raise statement to catch out-of-range values
8415 -- of formal parameter BIP_Alloc_Form.
8417 if Exceptions_OK then
8418 Guard_Except :=
8419 Make_Raise_Program_Error (Loc,
8420 Reason => PE_Build_In_Place_Mismatch);
8421 else
8422 Guard_Except := Make_Null_Statement (Loc);
8423 end if;
8425 -- Create an if statement to test the BIP_Alloc_Form
8426 -- formal and initialize the access object to either the
8427 -- BIP_Object_Access formal (BIP_Alloc_Form =
8428 -- Caller_Allocation), the result of allocating the
8429 -- object in the secondary stack (BIP_Alloc_Form =
8430 -- Secondary_Stack), or else an allocator to create the
8431 -- return object in the heap or user-defined pool
8432 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
8434 -- ??? An unchecked type conversion must be made in the
8435 -- case of assigning the access object formal to the
8436 -- local access object, because a normal conversion would
8437 -- be illegal in some cases (such as converting access-
8438 -- to-unconstrained to access-to-constrained), but the
8439 -- the unchecked conversion will presumably fail to work
8440 -- right in just such cases. It's not clear at all how to
8441 -- handle this.
8443 Alloc_Stmt :=
8444 Make_If_Statement (Loc,
8445 Condition =>
8446 Make_Op_Eq (Loc,
8447 Left_Opnd =>
8448 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
8449 Right_Opnd =>
8450 Make_Integer_Literal (Loc,
8451 UI_From_Int (BIP_Allocation_Form'Pos
8452 (Caller_Allocation)))),
8454 Then_Statements => New_List (
8455 Make_Assignment_Statement (Loc,
8456 Name =>
8457 New_Occurrence_Of (Alloc_Obj_Id, Loc),
8458 Expression =>
8459 Unchecked_Convert_To
8460 (Acc_Typ,
8461 New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
8463 Elsif_Parts => New_List (
8464 Make_Elsif_Part (Loc,
8465 Condition =>
8466 Make_Op_Eq (Loc,
8467 Left_Opnd =>
8468 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
8469 Right_Opnd =>
8470 Make_Integer_Literal (Loc,
8471 UI_From_Int (BIP_Allocation_Form'Pos
8472 (Secondary_Stack)))),
8474 Then_Statements => New_List (
8475 Make_Assignment_Statement (Loc,
8476 Name =>
8477 New_Occurrence_Of (Alloc_Obj_Id, Loc),
8478 Expression => SS_Allocator))),
8480 Make_Elsif_Part (Loc,
8481 Condition =>
8482 Make_Op_Eq (Loc,
8483 Left_Opnd =>
8484 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
8485 Right_Opnd =>
8486 Make_Integer_Literal (Loc,
8487 UI_From_Int (BIP_Allocation_Form'Pos
8488 (Global_Heap)))),
8490 Then_Statements => New_List (
8491 Build_Heap_Or_Pool_Allocator
8492 (Temp_Id => Alloc_Obj_Id,
8493 Temp_Typ => Acc_Typ,
8494 Ret_Typ => Desig_Typ,
8495 Alloc_Expr => Heap_Allocator))),
8497 -- ??? If all is well, we can put the following
8498 -- 'elsif' in the 'else', but this is a useful
8499 -- self-check in case caller and callee don't agree
8500 -- on whether BIPAlloc and so on should be passed.
8502 Make_Elsif_Part (Loc,
8503 Condition =>
8504 Make_Op_Eq (Loc,
8505 Left_Opnd =>
8506 New_Occurrence_Of (Obj_Alloc_Formal, Loc),
8507 Right_Opnd =>
8508 Make_Integer_Literal (Loc,
8509 UI_From_Int (BIP_Allocation_Form'Pos
8510 (User_Storage_Pool)))),
8512 Then_Statements => New_List (
8513 Pool_Decl,
8514 Build_Heap_Or_Pool_Allocator
8515 (Temp_Id => Alloc_Obj_Id,
8516 Temp_Typ => Acc_Typ,
8517 Ret_Typ => Desig_Typ,
8518 Alloc_Expr => Pool_Allocator)))),
8520 -- Raise Program_Error if it's none of the above;
8521 -- this is a compiler bug.
8523 Else_Statements => New_List (Guard_Except));
8525 -- If a separate initialization assignment was created
8526 -- earlier, append that following the assignment of the
8527 -- implicit access formal to the access object, to ensure
8528 -- that the return object is initialized in that case. In
8529 -- this situation, the target of the assignment must be
8530 -- rewritten to denote a dereference of the access to the
8531 -- return object passed in by the caller.
8533 if Present (Init_Stmt) then
8534 Set_Name (Init_Stmt,
8535 Make_Explicit_Dereference (Loc,
8536 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
8537 Set_Assignment_OK (Name (Init_Stmt));
8539 Append_To (Then_Statements (Alloc_Stmt), Init_Stmt);
8540 Init_Stmt := Empty;
8541 end if;
8543 Insert_Action (N, Alloc_Stmt, Suppress => All_Checks);
8545 -- From now on, the type of the return object is the
8546 -- designated type.
8548 if Desig_Typ /= Typ then
8549 Set_Etype (Def_Id, Desig_Typ);
8550 Set_Actual_Subtype (Def_Id, Typ);
8551 end if;
8553 -- Remember the local access object for use in the
8554 -- dereference of the renaming created below.
8556 Obj_Acc_Formal := Alloc_Obj_Id;
8557 end;
8559 -- When the function's type is unconstrained and a run-time test
8560 -- is not needed, we nevertheless need to build the return using
8561 -- the return object's type.
8563 elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then
8564 declare
8565 Acc_Typ : Entity_Id;
8566 Alloc_Obj_Decl : Node_Id;
8567 Alloc_Obj_Id : Entity_Id;
8568 Ptr_Typ_Decl : Node_Id;
8570 begin
8571 -- Create an access type designating the function's
8572 -- result subtype.
8574 Acc_Typ := Make_Temporary (Loc, 'A');
8576 Ptr_Typ_Decl :=
8577 Make_Full_Type_Declaration (Loc,
8578 Defining_Identifier => Acc_Typ,
8579 Type_Definition =>
8580 Make_Access_To_Object_Definition (Loc,
8581 All_Present => True,
8582 Subtype_Indication =>
8583 New_Occurrence_Of (Typ, Loc)));
8585 Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks);
8587 -- Create an access object initialized to the conversion
8588 -- of the implicit access value passed in by the caller.
8590 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
8592 -- See the ??? comment a few lines above about the use of
8593 -- an unchecked conversion here.
8595 Alloc_Obj_Decl :=
8596 Make_Object_Declaration (Loc,
8597 Defining_Identifier => Alloc_Obj_Id,
8598 Constant_Present => True,
8599 Object_Definition =>
8600 New_Occurrence_Of (Acc_Typ, Loc),
8601 Expression =>
8602 Unchecked_Convert_To
8603 (Acc_Typ, New_Occurrence_Of (Obj_Acc_Formal, Loc)));
8605 Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
8607 -- Remember the local access object for use in the
8608 -- dereference of the renaming created below.
8610 Obj_Acc_Formal := Alloc_Obj_Id;
8611 end;
8612 end if;
8614 -- Initialize the object now that it has got its final subtype,
8615 -- but before rewriting it as a renaming.
8617 Initialize_Return_Object
8618 (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After);
8620 -- Replace the return object declaration with a renaming of a
8621 -- dereference of the access value designating the return object.
8623 Expr_Q :=
8624 Make_Explicit_Dereference (Loc,
8625 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
8626 Set_Etype (Expr_Q, Etype (Def_Id));
8628 Rewrite_As_Renaming := True;
8629 end;
8631 -- If we can rename the initialization expression, we need to make sure
8632 -- that we use the proper type in the case of a return object that lives
8633 -- on the secondary stack (see other cases below for a similar handling)
8634 -- and that the tag is assigned in the case of any return object.
8636 elsif Rewrite_As_Renaming then
8637 if Special_Ret_Obj then
8638 declare
8639 Desig_Typ : constant Entity_Id :=
8640 (if Ekind (Typ) = E_Array_Subtype
8641 then Etype (Func_Id) else Typ);
8643 begin
8644 -- From now on, the type of the return object is the
8645 -- designated type.
8647 if Desig_Typ /= Typ then
8648 Set_Etype (Def_Id, Desig_Typ);
8649 Set_Actual_Subtype (Def_Id, Typ);
8650 end if;
8652 if Present (Tag_Assign) then
8653 Insert_Action_After (Init_After, Tag_Assign);
8654 end if;
8656 -- Ada 2005 (AI95-344): If the result type is class-wide,
8657 -- insert a check that the level of the return expression's
8658 -- underlying type is not deeper than the level of the master
8659 -- enclosing the function.
8661 -- AI12-043: The check is made immediately after the return
8662 -- object is created.
8664 if Is_Class_Wide_Type (Etype (Func_Id)) then
8665 Apply_CW_Accessibility_Check (Expr_Q, Func_Id);
8666 end if;
8667 end;
8668 end if;
8670 -- If this is the return object of a function returning on the secondary
8671 -- stack, convert the declaration to a renaming of the dereference of ah
8672 -- allocator for the secondary stack.
8674 -- Result : T [:= <expression>];
8676 -- is converted to
8678 -- type Txx is access all ...;
8679 -- Rxx : constant Txx :=
8680 -- new <expression-type>['(<expression>)][storage_pool =
8681 -- system__secondary_stack__ss_pool][procedure_to_call =
8682 -- system__secondary_stack__ss_allocate];
8684 -- Result : T renames Rxx.all;
8686 elsif Is_Secondary_Stack_Return_Object (Def_Id) then
8687 declare
8688 Desig_Typ : constant Entity_Id :=
8689 (if Ekind (Typ) = E_Array_Subtype
8690 then Etype (Func_Id) else Typ);
8691 -- Ensure that the we use a fat pointer when allocating
8692 -- an unconstrained array on the heap. In this case the
8693 -- result object's type is a constrained array type even
8694 -- though the function's type is unconstrained.
8696 Acc_Typ : Entity_Id;
8697 Alloc_Obj_Decl : Node_Id;
8698 Alloc_Obj_Id : Entity_Id;
8699 Ptr_Type_Decl : Node_Id;
8701 begin
8702 -- Create an access type designating the function's
8703 -- result subtype.
8705 Acc_Typ := Make_Temporary (Loc, 'A');
8707 Ptr_Type_Decl :=
8708 Make_Full_Type_Declaration (Loc,
8709 Defining_Identifier => Acc_Typ,
8710 Type_Definition =>
8711 Make_Access_To_Object_Definition (Loc,
8712 All_Present => True,
8713 Subtype_Indication =>
8714 New_Occurrence_Of (Desig_Typ, Loc)));
8716 Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);
8718 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
8720 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
8722 Alloc_Obj_Decl :=
8723 Make_Object_Declaration (Loc,
8724 Defining_Identifier => Alloc_Obj_Id,
8725 Constant_Present => True,
8726 Object_Definition =>
8727 New_Occurrence_Of (Acc_Typ, Loc),
8728 Expression => Make_Allocator_For_Return (Expr_Q));
8730 Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
8732 Set_Uses_Sec_Stack (Func_Id);
8733 Set_Uses_Sec_Stack (Scope (Def_Id));
8734 Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));
8736 -- From now on, the type of the return object is the
8737 -- designated type.
8739 if Desig_Typ /= Typ then
8740 Set_Etype (Def_Id, Desig_Typ);
8741 Set_Actual_Subtype (Def_Id, Typ);
8742 end if;
8744 -- Initialize the object now that it has got its final subtype,
8745 -- but before rewriting it as a renaming.
8747 Initialize_Return_Object
8748 (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);
8750 -- Replace the return object declaration with a renaming of a
8751 -- dereference of the access value designating the return object.
8753 Expr_Q :=
8754 Make_Explicit_Dereference (Loc,
8755 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
8756 Set_Etype (Expr_Q, Etype (Def_Id));
8758 Rewrite_As_Renaming := True;
8759 end;
8761 -- If this is the return object of a function returning a by-reference
8762 -- type, convert the declaration to a renaming of the dereference of ah
8763 -- allocator for the return stack.
8765 -- Result : T [:= <expression>];
8767 -- is converted to
8769 -- type Txx is access all ...;
8770 -- Rxx : constant Txx :=
8771 -- new <expression-type>['(<expression>)][storage_pool =
8772 -- system__return_stack__rs_pool][procedure_to_call =
8773 -- system__return_stack__rs_allocate];
8775 -- Result : T renames Rxx.all;
8777 elsif Back_End_Return_Slot
8778 and then Is_By_Reference_Return_Object (Def_Id)
8779 then
8780 declare
8781 Acc_Typ : Entity_Id;
8782 Alloc_Obj_Decl : Node_Id;
8783 Alloc_Obj_Id : Entity_Id;
8784 Ptr_Type_Decl : Node_Id;
8786 begin
8787 -- Create an access type designating the function's
8788 -- result subtype.
8790 Acc_Typ := Make_Temporary (Loc, 'A');
8792 Ptr_Type_Decl :=
8793 Make_Full_Type_Declaration (Loc,
8794 Defining_Identifier => Acc_Typ,
8795 Type_Definition =>
8796 Make_Access_To_Object_Definition (Loc,
8797 All_Present => True,
8798 Subtype_Indication =>
8799 New_Occurrence_Of (Typ, Loc)));
8801 Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);
8803 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool));
8805 Alloc_Obj_Id := Make_Temporary (Loc, 'R');
8807 Alloc_Obj_Decl :=
8808 Make_Object_Declaration (Loc,
8809 Defining_Identifier => Alloc_Obj_Id,
8810 Constant_Present => True,
8811 Object_Definition =>
8812 New_Occurrence_Of (Acc_Typ, Loc),
8813 Expression => Make_Allocator_For_Return (Expr_Q));
8815 Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
8817 -- Initialize the object now that it has got its final subtype,
8818 -- but before rewriting it as a renaming.
8820 Initialize_Return_Object
8821 (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);
8823 -- Replace the return object declaration with a renaming of a
8824 -- dereference of the access value designating the return object.
8826 Expr_Q :=
8827 Make_Explicit_Dereference (Loc,
8828 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
8829 Set_Etype (Expr_Q, Etype (Def_Id));
8831 Rewrite_As_Renaming := True;
8832 end;
8833 end if;
8835 -- Final transformation - turn the object declaration into a renaming
8836 -- if appropriate. If this is the completion of a deferred constant
8837 -- declaration, then this transformation generates what would be
8838 -- illegal code if written by hand, but that's OK.
8840 if Rewrite_As_Renaming then
8841 Rewrite (N,
8842 Make_Object_Renaming_Declaration (Loc,
8843 Defining_Identifier => Def_Id,
8844 Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc),
8845 Name => Expr_Q));
8847 -- We do not analyze this renaming declaration, because all its
8848 -- components have already been analyzed, and if we were to go
8849 -- ahead and analyze it, we would in effect be trying to generate
8850 -- another declaration of X, which won't do.
8852 Set_Renamed_Object (Def_Id, Expr_Q);
8853 Set_Analyzed (N);
8855 -- We do need to deal with debug issues for this renaming
8857 -- First, if entity comes from source, then mark it as needing
8858 -- debug information, even though it is defined by a generated
8859 -- renaming that does not come from source.
8861 Set_Debug_Info_Defining_Id (N);
8863 -- Now call the routine to generate debug info for the renaming
8865 Insert_Action (N, Debug_Renaming_Declaration (N));
8866 end if;
8868 -- Exception on library entity not available
8870 exception
8871 when RE_Not_Available =>
8872 return;
8873 end Expand_N_Object_Declaration;
8875 ---------------------------------
8876 -- Expand_N_Subtype_Indication --
8877 ---------------------------------
8879 -- Add a check on the range of the subtype and deal with validity checking
8881 procedure Expand_N_Subtype_Indication (N : Node_Id) is
8882 Ran : constant Node_Id := Range_Expression (Constraint (N));
8883 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
8885 begin
8886 if Nkind (Constraint (N)) = N_Range_Constraint then
8887 Validity_Check_Range (Range_Expression (Constraint (N)));
8888 end if;
8890 -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3
8892 if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice
8893 and then Nkind (Parent (Parent (N))) not in
8894 N_Full_Type_Declaration | N_Object_Declaration
8895 then
8896 Apply_Range_Check (Ran, Typ);
8897 end if;
8898 end Expand_N_Subtype_Indication;
8900 ---------------------------
8901 -- Expand_N_Variant_Part --
8902 ---------------------------
8904 -- Note: this procedure no longer has any effect. It used to be that we
8905 -- would replace the choices in the last variant by a when others, and
8906 -- also expanded static predicates in variant choices here, but both of
8907 -- those activities were being done too early, since we can't check the
8908 -- choices until the statically predicated subtypes are frozen, which can
8909 -- happen as late as the free point of the record, and we can't change the
8910 -- last choice to an others before checking the choices, which is now done
8911 -- at the freeze point of the record.
8913 procedure Expand_N_Variant_Part (N : Node_Id) is
8914 begin
8915 null;
8916 end Expand_N_Variant_Part;
8918 ---------------------------------
8919 -- Expand_Previous_Access_Type --
8920 ---------------------------------
8922 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
8923 Ptr_Typ : Entity_Id;
8925 begin
8926 -- Find all access types in the current scope whose designated type is
8927 -- Def_Id and build master renamings for them.
8929 Ptr_Typ := First_Entity (Current_Scope);
8930 while Present (Ptr_Typ) loop
8931 if Is_Access_Type (Ptr_Typ)
8932 and then Designated_Type (Ptr_Typ) = Def_Id
8933 and then No (Master_Id (Ptr_Typ))
8934 then
8935 -- Ensure that the designated type has a master
8937 Build_Master_Entity (Def_Id);
8939 -- Private and incomplete types complicate the insertion of master
8940 -- renamings because the access type may precede the full view of
8941 -- the designated type. For this reason, the master renamings are
8942 -- inserted relative to the designated type.
8944 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
8945 end if;
8947 Next_Entity (Ptr_Typ);
8948 end loop;
8949 end Expand_Previous_Access_Type;
8951 -----------------------------
8952 -- Expand_Record_Extension --
8953 -----------------------------
8955 -- Add a field _parent at the beginning of the record extension. This is
8956 -- used to implement inheritance. Here are some examples of expansion:
8958 -- 1. no discriminants
8959 -- type T2 is new T1 with null record;
8960 -- gives
8961 -- type T2 is new T1 with record
8962 -- _Parent : T1;
8963 -- end record;
8965 -- 2. renamed discriminants
8966 -- type T2 (B, C : Int) is new T1 (A => B) with record
8967 -- _Parent : T1 (A => B);
8968 -- D : Int;
8969 -- end;
8971 -- 3. inherited discriminants
8972 -- type T2 is new T1 with record -- discriminant A inherited
8973 -- _Parent : T1 (A);
8974 -- D : Int;
8975 -- end;
8977 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
8978 Indic : constant Node_Id := Subtype_Indication (Def);
8979 Loc : constant Source_Ptr := Sloc (Def);
8980 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
8981 Par_Subtype : Entity_Id;
8982 Comp_List : Node_Id;
8983 Comp_Decl : Node_Id;
8984 Parent_N : Node_Id;
8985 D : Entity_Id;
8986 List_Constr : constant List_Id := New_List;
8988 begin
8989 -- Expand_Record_Extension is called directly from the semantics, so
8990 -- we must check to see whether expansion is active before proceeding,
8991 -- because this affects the visibility of selected components in bodies
8992 -- of instances. Within a generic we still need to set Parent_Subtype
8993 -- link because the visibility of inherited components will have to be
8994 -- verified in subsequent instances.
8996 if not Expander_Active then
8997 if Inside_A_Generic and then Ekind (T) = E_Record_Type then
8998 Set_Parent_Subtype (T, Etype (T));
8999 end if;
9000 return;
9001 end if;
9003 -- This may be a derivation of an untagged private type whose full
9004 -- view is tagged, in which case the Derived_Type_Definition has no
9005 -- extension part. Build an empty one now.
9007 if No (Rec_Ext_Part) then
9008 Rec_Ext_Part :=
9009 Make_Record_Definition (Loc,
9010 End_Label => Empty,
9011 Component_List => Empty,
9012 Null_Present => True);
9014 Set_Record_Extension_Part (Def, Rec_Ext_Part);
9015 Mark_Rewrite_Insertion (Rec_Ext_Part);
9016 end if;
9018 Comp_List := Component_List (Rec_Ext_Part);
9020 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
9022 -- If the derived type inherits its discriminants the type of the
9023 -- _parent field must be constrained by the inherited discriminants
9025 if Has_Discriminants (T)
9026 and then Nkind (Indic) /= N_Subtype_Indication
9027 and then not Is_Constrained (Entity (Indic))
9028 then
9029 D := First_Discriminant (T);
9030 while Present (D) loop
9031 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
9032 Next_Discriminant (D);
9033 end loop;
9035 Par_Subtype :=
9036 Process_Subtype (
9037 Make_Subtype_Indication (Loc,
9038 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
9039 Constraint =>
9040 Make_Index_Or_Discriminant_Constraint (Loc,
9041 Constraints => List_Constr)),
9042 Def);
9044 -- Otherwise the original subtype_indication is just what is needed
9046 else
9047 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
9048 end if;
9050 Set_Parent_Subtype (T, Par_Subtype);
9052 Comp_Decl :=
9053 Make_Component_Declaration (Loc,
9054 Defining_Identifier => Parent_N,
9055 Component_Definition =>
9056 Make_Component_Definition (Loc,
9057 Aliased_Present => False,
9058 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
9060 if Null_Present (Rec_Ext_Part) then
9061 Set_Component_List (Rec_Ext_Part,
9062 Make_Component_List (Loc,
9063 Component_Items => New_List (Comp_Decl),
9064 Variant_Part => Empty,
9065 Null_Present => False));
9066 Set_Null_Present (Rec_Ext_Part, False);
9068 elsif Null_Present (Comp_List)
9069 or else Is_Empty_List (Component_Items (Comp_List))
9070 then
9071 Set_Component_Items (Comp_List, New_List (Comp_Decl));
9072 Set_Null_Present (Comp_List, False);
9074 else
9075 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
9076 end if;
9078 Analyze (Comp_Decl);
9079 end Expand_Record_Extension;
9081 ------------------------
9082 -- Expand_Tagged_Root --
9083 ------------------------
9085 procedure Expand_Tagged_Root (T : Entity_Id) is
9086 Def : constant Node_Id := Type_Definition (Parent (T));
9087 Comp_List : Node_Id;
9088 Comp_Decl : Node_Id;
9089 Sloc_N : Source_Ptr;
9091 begin
9092 if Null_Present (Def) then
9093 Set_Component_List (Def,
9094 Make_Component_List (Sloc (Def),
9095 Component_Items => Empty_List,
9096 Variant_Part => Empty,
9097 Null_Present => True));
9098 end if;
9100 Comp_List := Component_List (Def);
9102 if Null_Present (Comp_List)
9103 or else Is_Empty_List (Component_Items (Comp_List))
9104 then
9105 Sloc_N := Sloc (Comp_List);
9106 else
9107 Sloc_N := Sloc (First (Component_Items (Comp_List)));
9108 end if;
9110 Comp_Decl :=
9111 Make_Component_Declaration (Sloc_N,
9112 Defining_Identifier => First_Tag_Component (T),
9113 Component_Definition =>
9114 Make_Component_Definition (Sloc_N,
9115 Aliased_Present => False,
9116 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
9118 if Null_Present (Comp_List)
9119 or else Is_Empty_List (Component_Items (Comp_List))
9120 then
9121 Set_Component_Items (Comp_List, New_List (Comp_Decl));
9122 Set_Null_Present (Comp_List, False);
9124 else
9125 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
9126 end if;
9128 -- We don't Analyze the whole expansion because the tag component has
9129 -- already been analyzed previously. Here we just insure that the tree
9130 -- is coherent with the semantic decoration
9132 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
9134 exception
9135 when RE_Not_Available =>
9136 return;
9137 end Expand_Tagged_Root;
9139 ------------------------------
9140 -- Freeze_Stream_Operations --
9141 ------------------------------
9143 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
9144 Names : constant array (1 .. 4) of TSS_Name_Type :=
9145 (TSS_Stream_Input,
9146 TSS_Stream_Output,
9147 TSS_Stream_Read,
9148 TSS_Stream_Write);
9149 Stream_Op : Entity_Id;
9151 begin
9152 -- Primitive operations of tagged types are frozen when the dispatch
9153 -- table is constructed.
9155 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
9156 return;
9157 end if;
9159 for J in Names'Range loop
9160 Stream_Op := TSS (Typ, Names (J));
9162 if Present (Stream_Op)
9163 and then Is_Subprogram (Stream_Op)
9164 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
9165 N_Subprogram_Declaration
9166 and then not Is_Frozen (Stream_Op)
9167 then
9168 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
9169 end if;
9170 end loop;
9171 end Freeze_Stream_Operations;
9173 -----------------
9174 -- Freeze_Type --
9175 -----------------
9177 -- Full type declarations are expanded at the point at which the type is
9178 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
9179 -- declarations generated by the freezing (e.g. the procedure generated
9180 -- for initialization) are chained in the Actions field list of the freeze
9181 -- node using Append_Freeze_Actions.
9183 -- WARNING: This routine manages Ghost regions. Return statements must be
9184 -- replaced by gotos which jump to the end of the routine and restore the
9185 -- Ghost mode.
9187 function Freeze_Type (N : Node_Id) return Boolean is
9188 procedure Process_RACW_Types (Typ : Entity_Id);
9189 -- Validate and generate stubs for all RACW types associated with type
9190 -- Typ.
9192 procedure Process_Pending_Access_Types (Typ : Entity_Id);
9193 -- Associate type Typ's Finalize_Address primitive with the finalization
9194 -- masters of pending access-to-Typ types.
9196 ------------------------
9197 -- Process_RACW_Types --
9198 ------------------------
9200 procedure Process_RACW_Types (Typ : Entity_Id) is
9201 List : constant Elist_Id := Access_Types_To_Process (N);
9202 E : Elmt_Id;
9203 Seen : Boolean := False;
9205 begin
9206 if Present (List) then
9207 E := First_Elmt (List);
9208 while Present (E) loop
9209 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
9210 Validate_RACW_Primitives (Node (E));
9211 Seen := True;
9212 end if;
9214 Next_Elmt (E);
9215 end loop;
9216 end if;
9218 -- If there are RACWs designating this type, make stubs now
9220 if Seen then
9221 Remote_Types_Tagged_Full_View_Encountered (Typ);
9222 end if;
9223 end Process_RACW_Types;
9225 ----------------------------------
9226 -- Process_Pending_Access_Types --
9227 ----------------------------------
9229 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
9230 E : Elmt_Id;
9232 begin
9233 -- Finalize_Address is not generated in CodePeer mode because the
9234 -- body contains address arithmetic. This processing is disabled.
9236 if CodePeer_Mode then
9237 null;
9239 -- Certain itypes are generated for contexts that cannot allocate
9240 -- objects and should not set primitive Finalize_Address.
9242 elsif Is_Itype (Typ)
9243 and then Nkind (Associated_Node_For_Itype (Typ)) =
9244 N_Explicit_Dereference
9245 then
9246 null;
9248 -- When an access type is declared after the incomplete view of a
9249 -- Taft-amendment type, the access type is considered pending in
9250 -- case the full view of the Taft-amendment type is controlled. If
9251 -- this is indeed the case, associate the Finalize_Address routine
9252 -- of the full view with the finalization masters of all pending
9253 -- access types. This scenario applies to anonymous access types as
9254 -- well.
9256 elsif Needs_Finalization (Typ)
9257 and then Present (Pending_Access_Types (Typ))
9258 then
9259 E := First_Elmt (Pending_Access_Types (Typ));
9260 while Present (E) loop
9262 -- Generate:
9263 -- Set_Finalize_Address
9264 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
9266 Append_Freeze_Action (Typ,
9267 Make_Set_Finalize_Address_Call
9268 (Loc => Sloc (N),
9269 Ptr_Typ => Node (E)));
9271 Next_Elmt (E);
9272 end loop;
9273 end if;
9274 end Process_Pending_Access_Types;
9276 -- Local variables
9278 Def_Id : constant Entity_Id := Entity (N);
9280 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9281 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9282 -- Save the Ghost-related attributes to restore on exit
9284 Result : Boolean := False;
9286 -- Start of processing for Freeze_Type
9288 begin
9289 -- The type being frozen may be subject to pragma Ghost. Set the mode
9290 -- now to ensure that any nodes generated during freezing are properly
9291 -- marked as Ghost.
9293 Set_Ghost_Mode (Def_Id);
9295 -- Process any remote access-to-class-wide types designating the type
9296 -- being frozen.
9298 Process_RACW_Types (Def_Id);
9300 -- Freeze processing for record types
9302 if Is_Record_Type (Def_Id) then
9303 if Ekind (Def_Id) = E_Record_Type then
9304 Expand_Freeze_Record_Type (N);
9305 elsif Is_Class_Wide_Type (Def_Id) then
9306 Expand_Freeze_Class_Wide_Type (N);
9307 end if;
9309 -- Freeze processing for array types
9311 elsif Is_Array_Type (Def_Id) then
9312 Expand_Freeze_Array_Type (N);
9314 -- Freeze processing for access types
9316 -- For pool-specific access types, find out the pool object used for
9317 -- this type, needs actual expansion of it in some cases. Here are the
9318 -- different cases :
9320 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
9321 -- ---> don't use any storage pool
9323 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
9324 -- Expand:
9325 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
9327 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9328 -- ---> Storage Pool is the specified one
9330 -- See GNAT Pool packages in the Run-Time for more details
9332 elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then
9333 declare
9334 Loc : constant Source_Ptr := Sloc (N);
9335 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
9337 Freeze_Action_Typ : Entity_Id;
9338 Pool_Object : Entity_Id;
9340 begin
9341 -- Case 1
9343 -- Rep Clause "for Def_Id'Storage_Size use 0;"
9344 -- ---> don't use any storage pool
9346 if No_Pool_Assigned (Def_Id) then
9347 null;
9349 -- Case 2
9351 -- Rep Clause : for Def_Id'Storage_Size use Expr.
9352 -- ---> Expand:
9353 -- Def_Id__Pool : Stack_Bounded_Pool
9354 -- (Expr, DT'Size, DT'Alignment);
9356 elsif Has_Storage_Size_Clause (Def_Id) then
9357 declare
9358 DT_Align : Node_Id;
9359 DT_Size : Node_Id;
9361 begin
9362 -- For unconstrained composite types we give a size of zero
9363 -- so that the pool knows that it needs a special algorithm
9364 -- for variable size object allocation.
9366 if Is_Composite_Type (Desig_Type)
9367 and then not Is_Constrained (Desig_Type)
9368 then
9369 DT_Size := Make_Integer_Literal (Loc, 0);
9370 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
9372 else
9373 DT_Size :=
9374 Make_Attribute_Reference (Loc,
9375 Prefix => New_Occurrence_Of (Desig_Type, Loc),
9376 Attribute_Name => Name_Max_Size_In_Storage_Elements);
9378 DT_Align :=
9379 Make_Attribute_Reference (Loc,
9380 Prefix => New_Occurrence_Of (Desig_Type, Loc),
9381 Attribute_Name => Name_Alignment);
9382 end if;
9384 Pool_Object :=
9385 Make_Defining_Identifier (Loc,
9386 Chars => New_External_Name (Chars (Def_Id), 'P'));
9388 -- We put the code associated with the pools in the entity
9389 -- that has the later freeze node, usually the access type
9390 -- but it can also be the designated_type; because the pool
9391 -- code requires both those types to be frozen
9393 if Is_Frozen (Desig_Type)
9394 and then (No (Freeze_Node (Desig_Type))
9395 or else Analyzed (Freeze_Node (Desig_Type)))
9396 then
9397 Freeze_Action_Typ := Def_Id;
9399 -- A Taft amendment type cannot get the freeze actions
9400 -- since the full view is not there.
9402 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
9403 and then No (Full_View (Desig_Type))
9404 then
9405 Freeze_Action_Typ := Def_Id;
9407 else
9408 Freeze_Action_Typ := Desig_Type;
9409 end if;
9411 Append_Freeze_Action (Freeze_Action_Typ,
9412 Make_Object_Declaration (Loc,
9413 Defining_Identifier => Pool_Object,
9414 Object_Definition =>
9415 Make_Subtype_Indication (Loc,
9416 Subtype_Mark =>
9417 New_Occurrence_Of
9418 (RTE (RE_Stack_Bounded_Pool), Loc),
9420 Constraint =>
9421 Make_Index_Or_Discriminant_Constraint (Loc,
9422 Constraints => New_List (
9424 -- First discriminant is the Pool Size
9426 New_Occurrence_Of (
9427 Storage_Size_Variable (Def_Id), Loc),
9429 -- Second discriminant is the element size
9431 DT_Size,
9433 -- Third discriminant is the alignment
9435 DT_Align)))));
9436 end;
9438 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
9440 -- Case 3
9442 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
9443 -- ---> Storage Pool is the specified one
9445 -- When compiling in Ada 2012 mode, ensure that the accessibility
9446 -- level of the subpool access type is not deeper than that of the
9447 -- pool_with_subpools.
9449 elsif Ada_Version >= Ada_2012
9450 and then Present (Associated_Storage_Pool (Def_Id))
9451 and then RTU_Loaded (System_Storage_Pools_Subpools)
9452 then
9453 declare
9454 Loc : constant Source_Ptr := Sloc (Def_Id);
9455 Pool : constant Entity_Id :=
9456 Associated_Storage_Pool (Def_Id);
9458 begin
9459 -- It is known that the accessibility level of the access
9460 -- type is deeper than that of the pool.
9462 if Type_Access_Level (Def_Id)
9463 > Static_Accessibility_Level (Pool, Object_Decl_Level)
9464 and then Is_Class_Wide_Type (Etype (Pool))
9465 and then not Accessibility_Checks_Suppressed (Def_Id)
9466 and then not Accessibility_Checks_Suppressed (Pool)
9467 then
9468 -- When the pool is of a class-wide type, it may or may
9469 -- not support subpools depending on the path of
9470 -- derivation. Generate:
9472 -- if Def_Id in RSPWS'Class then
9473 -- raise Program_Error;
9474 -- end if;
9476 Append_Freeze_Action (Def_Id,
9477 Make_If_Statement (Loc,
9478 Condition =>
9479 Make_In (Loc,
9480 Left_Opnd => New_Occurrence_Of (Pool, Loc),
9481 Right_Opnd =>
9482 New_Occurrence_Of
9483 (Class_Wide_Type
9484 (RTE
9485 (RE_Root_Storage_Pool_With_Subpools)),
9486 Loc)),
9487 Then_Statements => New_List (
9488 Make_Raise_Program_Error (Loc,
9489 Reason => PE_Accessibility_Check_Failed))));
9490 end if;
9491 end;
9492 end if;
9494 -- For access-to-controlled types (including class-wide types and
9495 -- Taft-amendment types, which potentially have controlled
9496 -- components), expand the list controller object that will store
9497 -- the dynamically allocated objects. Don't do this transformation
9498 -- for expander-generated access types, except do it for types
9499 -- that are the full view of types derived from other private
9500 -- types and for access types used to implement indirect temps.
9501 -- Also suppress the list controller in the case of a designated
9502 -- type with convention Java, since this is used when binding to
9503 -- Java API specs, where there's no equivalent of a finalization
9504 -- list and we don't want to pull in the finalization support if
9505 -- not needed.
9507 if not Comes_From_Source (Def_Id)
9508 and then not Has_Private_Declaration (Def_Id)
9509 and then not Old_Attr_Util.Indirect_Temps
9510 .Is_Access_Type_For_Indirect_Temp (Def_Id)
9511 then
9512 null;
9514 -- An exception is made for types defined in the run-time because
9515 -- Ada.Tags.Tag itself is such a type and cannot afford this
9516 -- unnecessary overhead that would generates a loop in the
9517 -- expansion scheme. Another exception is if Restrictions
9518 -- (No_Finalization) is active, since then we know nothing is
9519 -- controlled.
9521 elsif Restriction_Active (No_Finalization)
9522 or else In_Runtime (Def_Id)
9523 then
9524 null;
9526 -- Create a finalization master for an access-to-controlled type
9527 -- or an access-to-incomplete type. It is assumed that the full
9528 -- view will be controlled.
9530 elsif Needs_Finalization (Desig_Type)
9531 or else (Is_Incomplete_Type (Desig_Type)
9532 and then No (Full_View (Desig_Type)))
9533 then
9534 Build_Finalization_Master (Def_Id);
9536 -- Create a finalization master when the designated type contains
9537 -- a private component. It is assumed that the full view will be
9538 -- controlled.
9540 elsif Has_Private_Component (Desig_Type) then
9541 Build_Finalization_Master
9542 (Typ => Def_Id,
9543 For_Private => True,
9544 Context_Scope => Scope (Def_Id),
9545 Insertion_Node => Declaration_Node (Desig_Type));
9546 end if;
9547 end;
9549 -- Freeze processing for enumeration types
9551 elsif Ekind (Def_Id) = E_Enumeration_Type then
9553 -- We only have something to do if we have a non-standard
9554 -- representation (i.e. at least one literal whose pos value
9555 -- is not the same as its representation)
9557 if Has_Non_Standard_Rep (Def_Id) then
9558 Expand_Freeze_Enumeration_Type (N);
9559 end if;
9561 -- Private types that are completed by a derivation from a private
9562 -- type have an internally generated full view, that needs to be
9563 -- frozen. This must be done explicitly because the two views share
9564 -- the freeze node, and the underlying full view is not visible when
9565 -- the freeze node is analyzed.
9567 elsif Is_Private_Type (Def_Id)
9568 and then Is_Derived_Type (Def_Id)
9569 and then Present (Full_View (Def_Id))
9570 and then Is_Itype (Full_View (Def_Id))
9571 and then Has_Private_Declaration (Full_View (Def_Id))
9572 and then Freeze_Node (Full_View (Def_Id)) = N
9573 then
9574 Set_Entity (N, Full_View (Def_Id));
9575 Result := Freeze_Type (N);
9576 Set_Entity (N, Def_Id);
9578 -- All other types require no expander action. There are such cases
9579 -- (e.g. task types and protected types). In such cases, the freeze
9580 -- nodes are there for use by Gigi.
9582 end if;
9584 -- Complete the initialization of all pending access types' finalization
9585 -- masters now that the designated type has been is frozen and primitive
9586 -- Finalize_Address generated.
9588 Process_Pending_Access_Types (Def_Id);
9589 Freeze_Stream_Operations (N, Def_Id);
9591 -- Generate the [spec and] body of the invariant procedure tasked with
9592 -- the runtime verification of all invariants that pertain to the type.
9593 -- This includes invariants on the partial and full view, inherited
9594 -- class-wide invariants from parent types or interfaces, and invariants
9595 -- on array elements or record components. But skip internal types.
9597 if Is_Itype (Def_Id) then
9598 null;
9600 elsif Is_Interface (Def_Id) then
9602 -- Interfaces are treated as the partial view of a private type in
9603 -- order to achieve uniformity with the general case. As a result, an
9604 -- interface receives only a "partial" invariant procedure which is
9605 -- never called.
9607 if Has_Own_Invariants (Def_Id) then
9608 Build_Invariant_Procedure_Body
9609 (Typ => Def_Id,
9610 Partial_Invariant => Is_Interface (Def_Id));
9611 end if;
9613 -- Non-interface types
9615 -- Do not generate invariant procedure within other assertion
9616 -- subprograms, which may involve local declarations of local
9617 -- subtypes to which these checks do not apply.
9619 else
9620 if Has_Invariants (Def_Id) then
9621 if not Predicate_Check_In_Scope (Def_Id)
9622 or else (Ekind (Current_Scope) = E_Function
9623 and then Is_Predicate_Function (Current_Scope))
9624 then
9625 null;
9626 else
9627 Build_Invariant_Procedure_Body (Def_Id);
9628 end if;
9629 end if;
9631 -- Generate the [spec and] body of the procedure tasked with the
9632 -- run-time verification of pragma Default_Initial_Condition's
9633 -- expression.
9635 if Has_DIC (Def_Id) then
9636 Build_DIC_Procedure_Body (Def_Id);
9637 end if;
9638 end if;
9640 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9642 return Result;
9644 exception
9645 when RE_Not_Available =>
9646 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9648 return False;
9649 end Freeze_Type;
9651 -------------------------
9652 -- Get_Simple_Init_Val --
9653 -------------------------
9655 function Get_Simple_Init_Val
9656 (Typ : Entity_Id;
9657 N : Node_Id;
9658 Size : Uint := No_Uint) return Node_Id
9660 IV_Attribute : constant Boolean :=
9661 Nkind (N) = N_Attribute_Reference
9662 and then Attribute_Name (N) = Name_Invalid_Value;
9664 Loc : constant Source_Ptr := Sloc (N);
9666 procedure Extract_Subtype_Bounds
9667 (Lo_Bound : out Uint;
9668 Hi_Bound : out Uint);
9669 -- Inspect subtype Typ as well its ancestor subtypes and derived types
9670 -- to determine the best known information about the bounds of the type.
9671 -- The output parameters are set as follows:
9673 -- * Lo_Bound - Set to No_Unit when there is no information available,
9674 -- or to the known low bound.
9676 -- * Hi_Bound - Set to No_Unit when there is no information available,
9677 -- or to the known high bound.
9679 function Simple_Init_Array_Type return Node_Id;
9680 -- Build an expression to initialize array type Typ
9682 function Simple_Init_Defaulted_Type return Node_Id;
9683 -- Build an expression to initialize type Typ which is subject to
9684 -- aspect Default_Value.
9686 function Simple_Init_Initialize_Scalars_Type
9687 (Size_To_Use : Uint) return Node_Id;
9688 -- Build an expression to initialize scalar type Typ which is subject to
9689 -- pragma Initialize_Scalars. Size_To_Use is the size of the object.
9691 function Simple_Init_Normalize_Scalars_Type
9692 (Size_To_Use : Uint) return Node_Id;
9693 -- Build an expression to initialize scalar type Typ which is subject to
9694 -- pragma Normalize_Scalars. Size_To_Use is the size of the object.
9696 function Simple_Init_Private_Type return Node_Id;
9697 -- Build an expression to initialize private type Typ
9699 function Simple_Init_Scalar_Type return Node_Id;
9700 -- Build an expression to initialize scalar type Typ
9702 ----------------------------
9703 -- Extract_Subtype_Bounds --
9704 ----------------------------
9706 procedure Extract_Subtype_Bounds
9707 (Lo_Bound : out Uint;
9708 Hi_Bound : out Uint)
9710 ST1 : Entity_Id;
9711 ST2 : Entity_Id;
9712 Lo : Node_Id;
9713 Hi : Node_Id;
9714 Lo_Val : Uint;
9715 Hi_Val : Uint;
9717 begin
9718 Lo_Bound := No_Uint;
9719 Hi_Bound := No_Uint;
9721 -- Loop to climb ancestor subtypes and derived types
9723 ST1 := Typ;
9724 loop
9725 if not Is_Discrete_Type (ST1) then
9726 return;
9727 end if;
9729 Lo := Type_Low_Bound (ST1);
9730 Hi := Type_High_Bound (ST1);
9732 if Compile_Time_Known_Value (Lo) then
9733 Lo_Val := Expr_Value (Lo);
9735 if No (Lo_Bound) or else Lo_Bound < Lo_Val then
9736 Lo_Bound := Lo_Val;
9737 end if;
9738 end if;
9740 if Compile_Time_Known_Value (Hi) then
9741 Hi_Val := Expr_Value (Hi);
9743 if No (Hi_Bound) or else Hi_Bound > Hi_Val then
9744 Hi_Bound := Hi_Val;
9745 end if;
9746 end if;
9748 ST2 := Ancestor_Subtype (ST1);
9750 if No (ST2) then
9751 ST2 := Etype (ST1);
9752 end if;
9754 exit when ST1 = ST2;
9755 ST1 := ST2;
9756 end loop;
9757 end Extract_Subtype_Bounds;
9759 ----------------------------
9760 -- Simple_Init_Array_Type --
9761 ----------------------------
9763 function Simple_Init_Array_Type return Node_Id is
9764 Comp_Typ : constant Entity_Id := Component_Type (Typ);
9766 function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
9767 -- Initialize a single array dimension with index constraint Index
9769 --------------------
9770 -- Simple_Init_Dimension --
9771 --------------------
9773 function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
9774 begin
9775 -- Process the current dimension
9777 if Present (Index) then
9779 -- Build a suitable "others" aggregate for the next dimension,
9780 -- or initialize the component itself. Generate:
9782 -- (others => ...)
9784 return
9785 Make_Aggregate (Loc,
9786 Component_Associations => New_List (
9787 Make_Component_Association (Loc,
9788 Choices => New_List (Make_Others_Choice (Loc)),
9789 Expression =>
9790 Simple_Init_Dimension (Next_Index (Index)))));
9792 -- Otherwise all dimensions have been processed. Initialize the
9793 -- component itself.
9795 else
9796 return
9797 Get_Simple_Init_Val
9798 (Typ => Comp_Typ,
9799 N => N,
9800 Size => Esize (Comp_Typ));
9801 end if;
9802 end Simple_Init_Dimension;
9804 -- Start of processing for Simple_Init_Array_Type
9806 begin
9807 return Simple_Init_Dimension (First_Index (Typ));
9808 end Simple_Init_Array_Type;
9810 --------------------------------
9811 -- Simple_Init_Defaulted_Type --
9812 --------------------------------
9814 function Simple_Init_Defaulted_Type return Node_Id is
9815 Subtyp : Entity_Id := First_Subtype (Typ);
9817 begin
9818 -- When the first subtype is private, retrieve the expression of the
9819 -- Default_Value from the underlying type.
9821 if Is_Private_Type (Subtyp) then
9822 Subtyp := Full_View (Subtyp);
9823 end if;
9825 -- Use the Sloc of the context node when constructing the initial
9826 -- value because the expression of Default_Value may come from a
9827 -- different unit. Updating the Sloc will result in accurate error
9828 -- diagnostics.
9830 return
9831 OK_Convert_To
9832 (Typ => Typ,
9833 Expr =>
9834 New_Copy_Tree
9835 (Source => Default_Aspect_Value (Subtyp),
9836 New_Sloc => Loc));
9837 end Simple_Init_Defaulted_Type;
9839 -----------------------------------------
9840 -- Simple_Init_Initialize_Scalars_Type --
9841 -----------------------------------------
9843 function Simple_Init_Initialize_Scalars_Type
9844 (Size_To_Use : Uint) return Node_Id
9846 Float_Typ : Entity_Id;
9847 Hi_Bound : Uint;
9848 Lo_Bound : Uint;
9849 Scal_Typ : Scalar_Id;
9851 begin
9852 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
9854 -- Float types
9856 if Is_Floating_Point_Type (Typ) then
9857 Float_Typ := Root_Type (Typ);
9859 if Float_Typ = Standard_Short_Float then
9860 Scal_Typ := Name_Short_Float;
9861 elsif Float_Typ = Standard_Float then
9862 Scal_Typ := Name_Float;
9863 elsif Float_Typ = Standard_Long_Float then
9864 Scal_Typ := Name_Long_Float;
9865 else pragma Assert (Float_Typ = Standard_Long_Long_Float);
9866 Scal_Typ := Name_Long_Long_Float;
9867 end if;
9869 -- If zero is invalid, it is a convenient value to use that is for
9870 -- sure an appropriate invalid value in all situations.
9872 elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then
9873 return Make_Integer_Literal (Loc, 0);
9875 -- Unsigned types
9877 elsif Is_Unsigned_Type (Typ) then
9878 if Size_To_Use <= 8 then
9879 Scal_Typ := Name_Unsigned_8;
9880 elsif Size_To_Use <= 16 then
9881 Scal_Typ := Name_Unsigned_16;
9882 elsif Size_To_Use <= 32 then
9883 Scal_Typ := Name_Unsigned_32;
9884 elsif Size_To_Use <= 64 then
9885 Scal_Typ := Name_Unsigned_64;
9886 else
9887 Scal_Typ := Name_Unsigned_128;
9888 end if;
9890 -- Signed types
9892 else
9893 if Size_To_Use <= 8 then
9894 Scal_Typ := Name_Signed_8;
9895 elsif Size_To_Use <= 16 then
9896 Scal_Typ := Name_Signed_16;
9897 elsif Size_To_Use <= 32 then
9898 Scal_Typ := Name_Signed_32;
9899 elsif Size_To_Use <= 64 then
9900 Scal_Typ := Name_Signed_64;
9901 else
9902 Scal_Typ := Name_Signed_128;
9903 end if;
9904 end if;
9906 -- Use the values specified by pragma Initialize_Scalars or the ones
9907 -- provided by the binder. Higher precedence is given to the pragma.
9909 return Invalid_Scalar_Value (Loc, Scal_Typ);
9910 end Simple_Init_Initialize_Scalars_Type;
9912 ----------------------------------------
9913 -- Simple_Init_Normalize_Scalars_Type --
9914 ----------------------------------------
9916 function Simple_Init_Normalize_Scalars_Type
9917 (Size_To_Use : Uint) return Node_Id
9919 Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1);
9921 Expr : Node_Id;
9922 Hi_Bound : Uint;
9923 Lo_Bound : Uint;
9925 begin
9926 Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
9928 -- If zero is invalid, it is a convenient value to use that is for
9929 -- sure an appropriate invalid value in all situations.
9931 if Present (Lo_Bound) and then Lo_Bound > Uint_0 then
9932 Expr := Make_Integer_Literal (Loc, 0);
9934 -- Cases where all one bits is the appropriate invalid value
9936 -- For modular types, all 1 bits is either invalid or valid. If it
9937 -- is valid, then there is nothing that can be done since there are
9938 -- no invalid values (we ruled out zero already).
9940 -- For signed integer types that have no negative values, either
9941 -- there is room for negative values, or there is not. If there
9942 -- is, then all 1-bits may be interpreted as minus one, which is
9943 -- certainly invalid. Alternatively it is treated as the largest
9944 -- positive value, in which case the observation for modular types
9945 -- still applies.
9947 -- For float types, all 1-bits is a NaN (not a number), which is
9948 -- certainly an appropriately invalid value.
9950 elsif Is_Enumeration_Type (Typ)
9951 or else Is_Floating_Point_Type (Typ)
9952 or else Is_Unsigned_Type (Typ)
9953 then
9954 Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
9956 -- Resolve as Long_Long_Long_Unsigned, because the largest number
9957 -- we can generate is out of range of universal integer.
9959 Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned);
9961 -- Case of signed types
9963 else
9964 -- Normally we like to use the most negative number. The one
9965 -- exception is when this number is in the known subtype range and
9966 -- the largest positive number is not in the known subtype range.
9968 -- For this exceptional case, use largest positive value
9970 if Present (Lo_Bound) and then Present (Hi_Bound)
9971 and then Lo_Bound <= (-(2 ** Signed_Size))
9972 and then Hi_Bound < 2 ** Signed_Size
9973 then
9974 Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
9976 -- Normal case of largest negative value
9978 else
9979 Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
9980 end if;
9981 end if;
9983 return Expr;
9984 end Simple_Init_Normalize_Scalars_Type;
9986 ------------------------------
9987 -- Simple_Init_Private_Type --
9988 ------------------------------
9990 function Simple_Init_Private_Type return Node_Id is
9991 Under_Typ : constant Entity_Id := Underlying_Type (Typ);
9992 Expr : Node_Id;
9994 begin
9995 -- The availability of the underlying view must be checked by routine
9996 -- Needs_Simple_Initialization.
9998 pragma Assert (Present (Under_Typ));
10000 Expr := Get_Simple_Init_Val (Under_Typ, N, Size);
10002 -- If the initial value is null or an aggregate, qualify it with the
10003 -- underlying type in order to provide a proper context.
10005 if Nkind (Expr) in N_Aggregate | N_Null then
10006 Expr :=
10007 Make_Qualified_Expression (Loc,
10008 Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc),
10009 Expression => Expr);
10010 end if;
10012 Expr := Unchecked_Convert_To (Typ, Expr);
10014 -- Do not truncate the result when scalar types are involved and
10015 -- Initialize/Normalize_Scalars is in effect.
10017 if Nkind (Expr) = N_Unchecked_Type_Conversion
10018 and then Is_Scalar_Type (Under_Typ)
10019 then
10020 Set_No_Truncation (Expr);
10021 end if;
10023 return Expr;
10024 end Simple_Init_Private_Type;
10026 -----------------------------
10027 -- Simple_Init_Scalar_Type --
10028 -----------------------------
10030 function Simple_Init_Scalar_Type return Node_Id is
10031 Expr : Node_Id;
10032 Size_To_Use : Uint;
10034 begin
10035 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
10037 -- Determine the size of the object. This is either the size provided
10038 -- by the caller, or the Esize of the scalar type.
10040 if No (Size) or else Size <= Uint_0 then
10041 Size_To_Use := UI_Max (Uint_1, Esize (Typ));
10042 else
10043 Size_To_Use := Size;
10044 end if;
10046 -- The maximum size to use is System_Max_Integer_Size bits. This
10047 -- will create values of type Long_Long_Long_Unsigned and the range
10048 -- must fit this type.
10050 if Present (Size_To_Use)
10051 and then Size_To_Use > System_Max_Integer_Size
10052 then
10053 Size_To_Use := UI_From_Int (System_Max_Integer_Size);
10054 end if;
10056 if Normalize_Scalars and then not IV_Attribute then
10057 Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use);
10058 else
10059 Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use);
10060 end if;
10062 -- The final expression is obtained by doing an unchecked conversion
10063 -- of this result to the base type of the required subtype. Use the
10064 -- base type to prevent the unchecked conversion from chopping bits,
10065 -- and then we set Kill_Range_Check to preserve the "bad" value.
10067 Expr := Unchecked_Convert_To (Base_Type (Typ), Expr);
10069 -- Ensure that the expression is not truncated since the "bad" bits
10070 -- are desired, and also kill the range checks.
10072 if Nkind (Expr) = N_Unchecked_Type_Conversion then
10073 Set_Kill_Range_Check (Expr);
10074 Set_No_Truncation (Expr);
10075 end if;
10077 return Expr;
10078 end Simple_Init_Scalar_Type;
10080 -- Start of processing for Get_Simple_Init_Val
10082 begin
10083 if Is_Private_Type (Typ) then
10084 return Simple_Init_Private_Type;
10086 elsif Is_Scalar_Type (Typ) then
10087 if Has_Default_Aspect (Typ) then
10088 return Simple_Init_Defaulted_Type;
10089 else
10090 return Simple_Init_Scalar_Type;
10091 end if;
10093 -- Array type with Initialize or Normalize_Scalars
10095 elsif Is_Array_Type (Typ) then
10096 pragma Assert (Init_Or_Norm_Scalars);
10097 return Simple_Init_Array_Type;
10099 -- Access type is initialized to null
10101 elsif Is_Access_Type (Typ) then
10102 return Make_Null (Loc);
10104 -- No other possibilities should arise, since we should only be calling
10105 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
10106 -- indicating one of the above cases held.
10108 else
10109 raise Program_Error;
10110 end if;
10112 exception
10113 when RE_Not_Available =>
10114 return Empty;
10115 end Get_Simple_Init_Val;
10117 ------------------------------
10118 -- Has_New_Non_Standard_Rep --
10119 ------------------------------
10121 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
10122 begin
10123 if not Is_Derived_Type (T) then
10124 return Has_Non_Standard_Rep (T)
10125 or else Has_Non_Standard_Rep (Root_Type (T));
10127 -- If Has_Non_Standard_Rep is not set on the derived type, the
10128 -- representation is fully inherited.
10130 elsif not Has_Non_Standard_Rep (T) then
10131 return False;
10133 else
10134 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
10136 -- May need a more precise check here: the First_Rep_Item may be a
10137 -- stream attribute, which does not affect the representation of the
10138 -- type ???
10140 end if;
10141 end Has_New_Non_Standard_Rep;
10143 ----------------------
10144 -- Inline_Init_Proc --
10145 ----------------------
10147 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
10148 begin
10149 -- The initialization proc of protected records is not worth inlining.
10150 -- In addition, when compiled for another unit for inlining purposes,
10151 -- it may make reference to entities that have not been elaborated yet.
10152 -- The initialization proc of records that need finalization contains
10153 -- a nested clean-up procedure that makes it impractical to inline as
10154 -- well, except for simple controlled types themselves. And similar
10155 -- considerations apply to task types.
10157 if Is_Concurrent_Type (Typ) then
10158 return False;
10160 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
10161 return False;
10163 elsif Has_Task (Typ) then
10164 return False;
10166 else
10167 return True;
10168 end if;
10169 end Inline_Init_Proc;
10171 ----------------
10172 -- In_Runtime --
10173 ----------------
10175 function In_Runtime (E : Entity_Id) return Boolean is
10176 S1 : Entity_Id;
10178 begin
10179 S1 := Scope (E);
10180 while Scope (S1) /= Standard_Standard loop
10181 S1 := Scope (S1);
10182 end loop;
10184 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
10185 end In_Runtime;
10187 package body Initialization_Control is
10189 ------------------------
10190 -- Requires_Late_Init --
10191 ------------------------
10193 function Requires_Late_Init
10194 (Decl : Node_Id;
10195 Rec_Type : Entity_Id) return Boolean
10197 References_Current_Instance : Boolean := False;
10198 Has_Access_Discriminant : Boolean := False;
10199 Has_Internal_Call : Boolean := False;
10201 function Find_Access_Discriminant
10202 (N : Node_Id) return Traverse_Result;
10203 -- Look for a name denoting an access discriminant
10205 function Find_Current_Instance
10206 (N : Node_Id) return Traverse_Result;
10207 -- Look for a reference to the current instance of the type
10209 function Find_Internal_Call
10210 (N : Node_Id) return Traverse_Result;
10211 -- Look for an internal protected function call
10213 ------------------------------
10214 -- Find_Access_Discriminant --
10215 ------------------------------
10217 function Find_Access_Discriminant
10218 (N : Node_Id) return Traverse_Result is
10219 begin
10220 if Is_Entity_Name (N)
10221 and then Denotes_Discriminant (N)
10222 and then Is_Access_Type (Etype (N))
10223 then
10224 Has_Access_Discriminant := True;
10225 return Abandon;
10226 else
10227 return OK;
10228 end if;
10229 end Find_Access_Discriminant;
10231 ---------------------------
10232 -- Find_Current_Instance --
10233 ---------------------------
10235 function Find_Current_Instance
10236 (N : Node_Id) return Traverse_Result is
10237 begin
10238 if Is_Entity_Name (N)
10239 and then Present (Entity (N))
10240 and then Is_Current_Instance (N)
10241 then
10242 References_Current_Instance := True;
10243 return Abandon;
10244 else
10245 return OK;
10246 end if;
10247 end Find_Current_Instance;
10249 ------------------------
10250 -- Find_Internal_Call --
10251 ------------------------
10253 function Find_Internal_Call (N : Node_Id) return Traverse_Result is
10255 function Call_Scope (N : Node_Id) return Entity_Id;
10256 -- Return the scope enclosing a given call node N
10258 ----------------
10259 -- Call_Scope --
10260 ----------------
10262 function Call_Scope (N : Node_Id) return Entity_Id is
10263 Nam : constant Node_Id := Name (N);
10264 begin
10265 if Nkind (Nam) = N_Selected_Component then
10266 return Scope (Entity (Prefix (Nam)));
10267 else
10268 return Scope (Entity (Nam));
10269 end if;
10270 end Call_Scope;
10272 begin
10273 if Nkind (N) = N_Function_Call
10274 and then Call_Scope (N)
10275 = Corresponding_Concurrent_Type (Rec_Type)
10276 then
10277 Has_Internal_Call := True;
10278 return Abandon;
10279 else
10280 return OK;
10281 end if;
10282 end Find_Internal_Call;
10284 procedure Search_Access_Discriminant is new
10285 Traverse_Proc (Find_Access_Discriminant);
10287 procedure Search_Current_Instance is new
10288 Traverse_Proc (Find_Current_Instance);
10290 procedure Search_Internal_Call is new
10291 Traverse_Proc (Find_Internal_Call);
10293 -- Start of processing for Requires_Late_Init
10295 begin
10296 -- A component of an object is said to require late initialization
10297 -- if:
10299 -- it has an access discriminant value constrained by a per-object
10300 -- expression;
10302 if Has_Access_Constraint (Defining_Identifier (Decl))
10303 and then No (Expression (Decl))
10304 then
10305 return True;
10307 elsif Present (Expression (Decl)) then
10309 -- it has an initialization expression that includes a name
10310 -- denoting an access discriminant;
10312 Search_Access_Discriminant (Expression (Decl));
10314 if Has_Access_Discriminant then
10315 return True;
10316 end if;
10318 -- or it has an initialization expression that includes a
10319 -- reference to the current instance of the type either by
10320 -- name...
10322 Search_Current_Instance (Expression (Decl));
10324 if References_Current_Instance then
10325 return True;
10326 end if;
10328 -- ...or implicitly as the target object of a call.
10330 if Is_Protected_Record_Type (Rec_Type) then
10331 Search_Internal_Call (Expression (Decl));
10333 if Has_Internal_Call then
10334 return True;
10335 end if;
10336 end if;
10337 end if;
10339 return False;
10340 end Requires_Late_Init;
10342 -----------------------------
10343 -- Has_Late_Init_Component --
10344 -----------------------------
10346 function Has_Late_Init_Component
10347 (Tagged_Rec_Type : Entity_Id) return Boolean
10349 Comp_Id : Entity_Id :=
10350 First_Component (Implementation_Base_Type (Tagged_Rec_Type));
10351 begin
10352 while Present (Comp_Id) loop
10353 if Requires_Late_Init (Decl => Parent (Comp_Id),
10354 Rec_Type => Tagged_Rec_Type)
10355 then
10356 return True; -- found a component that requires late init
10358 elsif Chars (Comp_Id) = Name_uParent
10359 and then Has_Late_Init_Component (Etype (Comp_Id))
10360 then
10361 return True; -- an ancestor type has a late init component
10362 end if;
10364 Next_Component (Comp_Id);
10365 end loop;
10367 return False;
10368 end Has_Late_Init_Component;
10370 ------------------------
10371 -- Tag_Init_Condition --
10372 ------------------------
10374 function Tag_Init_Condition
10375 (Loc : Source_Ptr;
10376 Init_Control_Formal : Entity_Id) return Node_Id is
10377 begin
10378 return Make_Op_Eq (Loc,
10379 New_Occurrence_Of (Init_Control_Formal, Loc),
10380 Make_Mode_Literal (Loc, Full_Init));
10381 end Tag_Init_Condition;
10383 --------------------------
10384 -- Early_Init_Condition --
10385 --------------------------
10387 function Early_Init_Condition
10388 (Loc : Source_Ptr;
10389 Init_Control_Formal : Entity_Id) return Node_Id is
10390 begin
10391 return Make_Op_Ne (Loc,
10392 New_Occurrence_Of (Init_Control_Formal, Loc),
10393 Make_Mode_Literal (Loc, Late_Init_Only));
10394 end Early_Init_Condition;
10396 -------------------------
10397 -- Late_Init_Condition --
10398 -------------------------
10400 function Late_Init_Condition
10401 (Loc : Source_Ptr;
10402 Init_Control_Formal : Entity_Id) return Node_Id is
10403 begin
10404 return Make_Op_Ne (Loc,
10405 New_Occurrence_Of (Init_Control_Formal, Loc),
10406 Make_Mode_Literal (Loc, Early_Init_Only));
10407 end Late_Init_Condition;
10409 end Initialization_Control;
10411 ----------------------------
10412 -- Initialization_Warning --
10413 ----------------------------
10415 procedure Initialization_Warning (E : Entity_Id) is
10416 Warning_Needed : Boolean;
10418 begin
10419 Warning_Needed := False;
10421 if Ekind (Current_Scope) = E_Package
10422 and then Static_Elaboration_Desired (Current_Scope)
10423 then
10424 if Is_Type (E) then
10425 if Is_Record_Type (E) then
10426 if Has_Discriminants (E)
10427 or else Is_Limited_Type (E)
10428 or else Has_Non_Standard_Rep (E)
10429 then
10430 Warning_Needed := True;
10432 else
10433 -- Verify that at least one component has an initialization
10434 -- expression. No need for a warning on a type if all its
10435 -- components have no initialization.
10437 declare
10438 Comp : Entity_Id;
10440 begin
10441 Comp := First_Component (E);
10442 while Present (Comp) loop
10443 pragma Assert
10444 (Nkind (Parent (Comp)) = N_Component_Declaration);
10446 if Present (Expression (Parent (Comp))) then
10447 Warning_Needed := True;
10448 exit;
10449 end if;
10451 Next_Component (Comp);
10452 end loop;
10453 end;
10454 end if;
10456 if Warning_Needed then
10457 Error_Msg_N
10458 ("objects of the type cannot be initialized statically "
10459 & "by default??", Parent (E));
10460 end if;
10461 end if;
10463 else
10464 Error_Msg_N ("object cannot be initialized statically??", E);
10465 end if;
10466 end if;
10467 end Initialization_Warning;
10469 ------------------
10470 -- Init_Formals --
10471 ------------------
10473 function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id
10475 Loc : constant Source_Ptr := Sloc (Typ);
10476 Unc_Arr : constant Boolean :=
10477 Is_Array_Type (Typ) and then not Is_Constrained (Typ);
10478 With_Prot : constant Boolean :=
10479 Has_Protected (Typ)
10480 or else (Is_Record_Type (Typ)
10481 and then Is_Protected_Record_Type (Typ));
10482 With_Task : constant Boolean :=
10483 not Global_No_Tasking
10484 and then
10485 (Has_Task (Typ)
10486 or else (Is_Record_Type (Typ)
10487 and then Is_Task_Record_Type (Typ)));
10488 Formals : List_Id;
10490 begin
10491 -- The first parameter is always _Init : [in] out Typ. Note that we need
10492 -- it to be in/out in the case of an unconstrained array, because of the
10493 -- need to have the bounds, and in the case of protected or task record
10494 -- value, because there are default record fields that may be referenced
10495 -- in the generated initialization routine.
10497 Formals := New_List (
10498 Make_Parameter_Specification (Loc,
10499 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
10500 In_Present => Unc_Arr or else With_Prot or else With_Task,
10501 Out_Present => True,
10502 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
10504 -- For task record value, or type that contains tasks, add two more
10505 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
10506 -- We also add these parameters for the task record type case.
10508 if With_Task then
10509 Append_To (Formals,
10510 Make_Parameter_Specification (Loc,
10511 Defining_Identifier =>
10512 Make_Defining_Identifier (Loc, Name_uMaster),
10513 Parameter_Type =>
10514 New_Occurrence_Of (Standard_Integer, Loc)));
10516 Set_Has_Master_Entity (Proc_Id);
10518 -- Add _Chain (not done for sequential elaboration policy, see
10519 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
10521 if Partition_Elaboration_Policy /= 'S' then
10522 Append_To (Formals,
10523 Make_Parameter_Specification (Loc,
10524 Defining_Identifier =>
10525 Make_Defining_Identifier (Loc, Name_uChain),
10526 In_Present => True,
10527 Out_Present => True,
10528 Parameter_Type =>
10529 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
10530 end if;
10532 Append_To (Formals,
10533 Make_Parameter_Specification (Loc,
10534 Defining_Identifier =>
10535 Make_Defining_Identifier (Loc, Name_uTask_Name),
10536 In_Present => True,
10537 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
10538 end if;
10540 -- Due to certain edge cases such as arrays with null-excluding
10541 -- components being built with the secondary stack it becomes necessary
10542 -- to add a formal to the Init_Proc which controls whether we raise
10543 -- Constraint_Errors on generated calls for internal object
10544 -- declarations.
10546 if Needs_Conditional_Null_Excluding_Check (Typ) then
10547 Append_To (Formals,
10548 Make_Parameter_Specification (Loc,
10549 Defining_Identifier =>
10550 Make_Defining_Identifier (Loc,
10551 New_External_Name (Chars
10552 (Component_Type (Typ)), "_skip_null_excluding_check")),
10553 Expression => New_Occurrence_Of (Standard_False, Loc),
10554 In_Present => True,
10555 Parameter_Type =>
10556 New_Occurrence_Of (Standard_Boolean, Loc)));
10557 end if;
10559 return Formals;
10561 exception
10562 when RE_Not_Available =>
10563 return Empty_List;
10564 end Init_Formals;
10566 -------------------------
10567 -- Init_Secondary_Tags --
10568 -------------------------
10570 procedure Init_Secondary_Tags
10571 (Typ : Entity_Id;
10572 Target : Node_Id;
10573 Init_Tags_List : List_Id;
10574 Stmts_List : List_Id;
10575 Fixed_Comps : Boolean := True;
10576 Variable_Comps : Boolean := True)
10578 Loc : constant Source_Ptr := Sloc (Target);
10580 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
10581 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10583 procedure Initialize_Tag
10584 (Typ : Entity_Id;
10585 Iface : Entity_Id;
10586 Tag_Comp : Entity_Id;
10587 Iface_Tag : Node_Id);
10588 -- Initialize the tag of the secondary dispatch table of Typ associated
10589 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
10590 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
10591 -- of Typ CPP tagged type we generate code to inherit the contents of
10592 -- the dispatch table directly from the ancestor.
10594 --------------------
10595 -- Initialize_Tag --
10596 --------------------
10598 procedure Initialize_Tag
10599 (Typ : Entity_Id;
10600 Iface : Entity_Id;
10601 Tag_Comp : Entity_Id;
10602 Iface_Tag : Node_Id)
10604 Comp_Typ : Entity_Id;
10605 Offset_To_Top_Comp : Entity_Id := Empty;
10607 begin
10608 -- Initialize pointer to secondary DT associated with the interface
10610 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
10611 Append_To (Init_Tags_List,
10612 Make_Assignment_Statement (Loc,
10613 Name =>
10614 Make_Selected_Component (Loc,
10615 Prefix => New_Copy_Tree (Target),
10616 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
10617 Expression =>
10618 New_Occurrence_Of (Iface_Tag, Loc)));
10619 end if;
10621 Comp_Typ := Scope (Tag_Comp);
10623 -- Initialize the entries of the table of interfaces. We generate a
10624 -- different call when the parent of the type has variable size
10625 -- components.
10627 if Comp_Typ /= Etype (Comp_Typ)
10628 and then Is_Variable_Size_Record (Etype (Comp_Typ))
10629 and then Chars (Tag_Comp) /= Name_uTag
10630 then
10631 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
10633 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
10634 -- configurable run-time environment.
10636 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
10637 Error_Msg_CRT
10638 ("variable size record with interface types", Typ);
10639 return;
10640 end if;
10642 -- Generate:
10643 -- Set_Dynamic_Offset_To_Top
10644 -- (This => Init,
10645 -- Prim_T => Typ'Tag,
10646 -- Interface_T => Iface'Tag,
10647 -- Offset_Value => n,
10648 -- Offset_Func => Fn'Unrestricted_Access)
10650 Append_To (Stmts_List,
10651 Make_Procedure_Call_Statement (Loc,
10652 Name =>
10653 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
10654 Parameter_Associations => New_List (
10655 Make_Attribute_Reference (Loc,
10656 Prefix => New_Copy_Tree (Target),
10657 Attribute_Name => Name_Address),
10659 Unchecked_Convert_To (RTE (RE_Tag),
10660 New_Occurrence_Of
10661 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
10663 Unchecked_Convert_To (RTE (RE_Tag),
10664 New_Occurrence_Of
10665 (Node (First_Elmt (Access_Disp_Table (Iface))),
10666 Loc)),
10668 Unchecked_Convert_To
10669 (RTE (RE_Storage_Offset),
10670 Make_Op_Minus (Loc,
10671 Make_Attribute_Reference (Loc,
10672 Prefix =>
10673 Make_Selected_Component (Loc,
10674 Prefix => New_Copy_Tree (Target),
10675 Selector_Name =>
10676 New_Occurrence_Of (Tag_Comp, Loc)),
10677 Attribute_Name => Name_Position))),
10679 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
10680 Make_Attribute_Reference (Loc,
10681 Prefix => New_Occurrence_Of
10682 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
10683 Attribute_Name => Name_Unrestricted_Access)))));
10685 -- In this case the next component stores the value of the offset
10686 -- to the top.
10688 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
10689 pragma Assert (Present (Offset_To_Top_Comp));
10691 Append_To (Init_Tags_List,
10692 Make_Assignment_Statement (Loc,
10693 Name =>
10694 Make_Selected_Component (Loc,
10695 Prefix => New_Copy_Tree (Target),
10696 Selector_Name =>
10697 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
10699 Expression =>
10700 Make_Op_Minus (Loc,
10701 Make_Attribute_Reference (Loc,
10702 Prefix =>
10703 Make_Selected_Component (Loc,
10704 Prefix => New_Copy_Tree (Target),
10705 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
10706 Attribute_Name => Name_Position))));
10708 -- Normal case: No discriminants in the parent type
10710 else
10711 -- Don't need to set any value if the offset-to-top field is
10712 -- statically set or if this interface shares the primary
10713 -- dispatch table.
10715 if not Building_Static_Secondary_DT (Typ)
10716 and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
10717 then
10718 Append_To (Stmts_List,
10719 Build_Set_Static_Offset_To_Top (Loc,
10720 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
10721 Offset_Value =>
10722 Unchecked_Convert_To (RTE (RE_Storage_Offset),
10723 Make_Op_Minus (Loc,
10724 Make_Attribute_Reference (Loc,
10725 Prefix =>
10726 Make_Selected_Component (Loc,
10727 Prefix => New_Copy_Tree (Target),
10728 Selector_Name =>
10729 New_Occurrence_Of (Tag_Comp, Loc)),
10730 Attribute_Name => Name_Position)))));
10731 end if;
10733 -- Generate:
10734 -- Register_Interface_Offset
10735 -- (Prim_T => Typ'Tag,
10736 -- Interface_T => Iface'Tag,
10737 -- Is_Constant => True,
10738 -- Offset_Value => n,
10739 -- Offset_Func => null);
10741 if not Building_Static_Secondary_DT (Typ)
10742 and then RTE_Available (RE_Register_Interface_Offset)
10743 then
10744 Append_To (Stmts_List,
10745 Make_Procedure_Call_Statement (Loc,
10746 Name =>
10747 New_Occurrence_Of
10748 (RTE (RE_Register_Interface_Offset), Loc),
10749 Parameter_Associations => New_List (
10750 Unchecked_Convert_To (RTE (RE_Tag),
10751 New_Occurrence_Of
10752 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
10754 Unchecked_Convert_To (RTE (RE_Tag),
10755 New_Occurrence_Of
10756 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
10758 New_Occurrence_Of (Standard_True, Loc),
10760 Unchecked_Convert_To (RTE (RE_Storage_Offset),
10761 Make_Op_Minus (Loc,
10762 Make_Attribute_Reference (Loc,
10763 Prefix =>
10764 Make_Selected_Component (Loc,
10765 Prefix => New_Copy_Tree (Target),
10766 Selector_Name =>
10767 New_Occurrence_Of (Tag_Comp, Loc)),
10768 Attribute_Name => Name_Position))),
10770 Make_Null (Loc))));
10771 end if;
10772 end if;
10773 end Initialize_Tag;
10775 -- Local variables
10777 Full_Typ : Entity_Id;
10778 Ifaces_List : Elist_Id;
10779 Ifaces_Comp_List : Elist_Id;
10780 Ifaces_Tag_List : Elist_Id;
10781 Iface_Elmt : Elmt_Id;
10782 Iface_Comp_Elmt : Elmt_Id;
10783 Iface_Tag_Elmt : Elmt_Id;
10784 Tag_Comp : Node_Id;
10785 In_Variable_Pos : Boolean;
10787 -- Start of processing for Init_Secondary_Tags
10789 begin
10790 -- Handle private types
10792 if Present (Full_View (Typ)) then
10793 Full_Typ := Full_View (Typ);
10794 else
10795 Full_Typ := Typ;
10796 end if;
10798 Collect_Interfaces_Info
10799 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
10801 Iface_Elmt := First_Elmt (Ifaces_List);
10802 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
10803 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
10804 while Present (Iface_Elmt) loop
10805 Tag_Comp := Node (Iface_Comp_Elmt);
10807 -- Check if parent of record type has variable size components
10809 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
10810 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
10812 -- If we are compiling under the CPP full ABI compatibility mode and
10813 -- the ancestor is a CPP_Pragma tagged type then we generate code to
10814 -- initialize the secondary tag components from tags that reference
10815 -- secondary tables filled with copy of parent slots.
10817 if Is_CPP_Class (Root_Type (Full_Typ)) then
10819 -- Reject interface components located at variable offset in
10820 -- C++ derivations. This is currently unsupported.
10822 if not Fixed_Comps and then In_Variable_Pos then
10824 -- Locate the first dynamic component of the record. Done to
10825 -- improve the text of the warning.
10827 declare
10828 Comp : Entity_Id;
10829 Comp_Typ : Entity_Id;
10831 begin
10832 Comp := First_Entity (Typ);
10833 while Present (Comp) loop
10834 Comp_Typ := Etype (Comp);
10836 if Ekind (Comp) /= E_Discriminant
10837 and then not Is_Tag (Comp)
10838 then
10839 exit when
10840 (Is_Record_Type (Comp_Typ)
10841 and then
10842 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
10843 or else
10844 (Is_Array_Type (Comp_Typ)
10845 and then Is_Variable_Size_Array (Comp_Typ));
10846 end if;
10848 Next_Entity (Comp);
10849 end loop;
10851 pragma Assert (Present (Comp));
10853 -- Move this check to sem???
10854 Error_Msg_Node_2 := Comp;
10855 Error_Msg_NE
10856 ("parent type & with dynamic component & cannot be parent"
10857 & " of 'C'P'P derivation if new interfaces are present",
10858 Typ, Scope (Original_Record_Component (Comp)));
10860 Error_Msg_Sloc :=
10861 Sloc (Scope (Original_Record_Component (Comp)));
10862 Error_Msg_NE
10863 ("type derived from 'C'P'P type & defined #",
10864 Typ, Scope (Original_Record_Component (Comp)));
10866 -- Avoid duplicated warnings
10868 exit;
10869 end;
10871 -- Initialize secondary tags
10873 else
10874 Initialize_Tag
10875 (Typ => Full_Typ,
10876 Iface => Node (Iface_Elmt),
10877 Tag_Comp => Tag_Comp,
10878 Iface_Tag => Node (Iface_Tag_Elmt));
10879 end if;
10881 -- Otherwise generate code to initialize the tag
10883 else
10884 if (In_Variable_Pos and then Variable_Comps)
10885 or else (not In_Variable_Pos and then Fixed_Comps)
10886 then
10887 Initialize_Tag
10888 (Typ => Full_Typ,
10889 Iface => Node (Iface_Elmt),
10890 Tag_Comp => Tag_Comp,
10891 Iface_Tag => Node (Iface_Tag_Elmt));
10892 end if;
10893 end if;
10895 Next_Elmt (Iface_Elmt);
10896 Next_Elmt (Iface_Comp_Elmt);
10897 Next_Elmt (Iface_Tag_Elmt);
10898 end loop;
10899 end Init_Secondary_Tags;
10901 ----------------------------
10902 -- Is_Null_Statement_List --
10903 ----------------------------
10905 function Is_Null_Statement_List (Stmts : List_Id) return Boolean is
10906 Stmt : Node_Id;
10908 begin
10909 -- We must skip SCIL nodes because they may have been added to the list
10910 -- by Insert_Actions.
10912 Stmt := First_Non_SCIL_Node (Stmts);
10913 while Present (Stmt) loop
10914 if Nkind (Stmt) = N_Case_Statement then
10915 declare
10916 Alt : Node_Id;
10917 begin
10918 Alt := First (Alternatives (Stmt));
10919 while Present (Alt) loop
10920 if not Is_Null_Statement_List (Statements (Alt)) then
10921 return False;
10922 end if;
10924 Next (Alt);
10925 end loop;
10926 end;
10928 elsif Nkind (Stmt) /= N_Null_Statement then
10929 return False;
10930 end if;
10932 Stmt := Next_Non_SCIL_Node (Stmt);
10933 end loop;
10935 return True;
10936 end Is_Null_Statement_List;
10938 ----------------------------------------
10939 -- Make_Controlling_Function_Wrappers --
10940 ----------------------------------------
10942 procedure Make_Controlling_Function_Wrappers
10943 (Tag_Typ : Entity_Id;
10944 Decl_List : out List_Id;
10945 Body_List : out List_Id)
10947 Loc : constant Source_Ptr := Sloc (Tag_Typ);
10949 function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id;
10950 -- Returns a function specification with the same profile as Subp
10952 --------------------------------
10953 -- Make_Wrapper_Specification --
10954 --------------------------------
10956 function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id is
10957 begin
10958 return
10959 Make_Function_Specification (Loc,
10960 Defining_Unit_Name =>
10961 Make_Defining_Identifier (Loc,
10962 Chars => Chars (Subp)),
10963 Parameter_Specifications =>
10964 Copy_Parameter_List (Subp),
10965 Result_Definition =>
10966 New_Occurrence_Of (Etype (Subp), Loc));
10967 end Make_Wrapper_Specification;
10969 Prim_Elmt : Elmt_Id;
10970 Subp : Entity_Id;
10971 Actual_List : List_Id;
10972 Formal : Entity_Id;
10973 Par_Formal : Entity_Id;
10974 Ext_Aggr : Node_Id;
10975 Formal_Node : Node_Id;
10976 Func_Body : Node_Id;
10977 Func_Decl : Node_Id;
10978 Func_Id : Entity_Id;
10980 -- Start of processing for Make_Controlling_Function_Wrappers
10982 begin
10983 Decl_List := New_List;
10984 Body_List := New_List;
10986 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
10987 while Present (Prim_Elmt) loop
10988 Subp := Node (Prim_Elmt);
10990 -- If a primitive function with a controlling result of the type has
10991 -- not been overridden by the user, then we must create a wrapper
10992 -- function here that effectively overrides it and invokes the
10993 -- (non-abstract) parent function. This can only occur for a null
10994 -- extension. Note that functions with anonymous controlling access
10995 -- results don't qualify and must be overridden. We also exclude
10996 -- Input attributes, since each type will have its own version of
10997 -- Input constructed by the expander. The test for Comes_From_Source
10998 -- is needed to distinguish inherited operations from renamings
10999 -- (which also have Alias set). We exclude internal entities with
11000 -- Interface_Alias to avoid generating duplicated wrappers since
11001 -- the primitive which covers the interface is also available in
11002 -- the list of primitive operations.
11004 -- The function may be abstract, or require_Overriding may be set
11005 -- for it, because tests for null extensions may already have reset
11006 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
11007 -- set, functions that need wrappers are recognized by having an
11008 -- alias that returns the parent type.
11010 if Comes_From_Source (Subp)
11011 or else No (Alias (Subp))
11012 or else Present (Interface_Alias (Subp))
11013 or else Ekind (Subp) /= E_Function
11014 or else not Has_Controlling_Result (Subp)
11015 or else Is_Access_Type (Etype (Subp))
11016 or else Is_Abstract_Subprogram (Alias (Subp))
11017 or else Is_TSS (Subp, TSS_Stream_Input)
11018 then
11019 goto Next_Prim;
11021 elsif Is_Abstract_Subprogram (Subp)
11022 or else Requires_Overriding (Subp)
11023 or else
11024 (Is_Null_Extension (Etype (Subp))
11025 and then Etype (Alias (Subp)) /= Etype (Subp))
11026 then
11027 -- If there is a non-overloadable homonym in the current
11028 -- scope, the implicit declaration remains invisible.
11029 -- We check the current entity with the same name, or its
11030 -- homonym in case the derivation takes place after the
11031 -- hiding object declaration.
11033 if Present (Current_Entity (Subp)) then
11034 declare
11035 Curr : constant Entity_Id := Current_Entity (Subp);
11036 Prev : constant Entity_Id := Homonym (Curr);
11037 begin
11038 if (Comes_From_Source (Curr)
11039 and then Scope (Curr) = Current_Scope
11040 and then not Is_Overloadable (Curr))
11041 or else
11042 (Present (Prev)
11043 and then Comes_From_Source (Prev)
11044 and then Scope (Prev) = Current_Scope
11045 and then not Is_Overloadable (Prev))
11046 then
11047 goto Next_Prim;
11048 end if;
11049 end;
11050 end if;
11052 Func_Decl :=
11053 Make_Subprogram_Declaration (Loc,
11054 Specification => Make_Wrapper_Specification (Subp));
11056 Append_To (Decl_List, Func_Decl);
11058 -- Build a wrapper body that calls the parent function. The body
11059 -- contains a single return statement that returns an extension
11060 -- aggregate whose ancestor part is a call to the parent function,
11061 -- passing the formals as actuals (with any controlling arguments
11062 -- converted to the types of the corresponding formals of the
11063 -- parent function, which might be anonymous access types), and
11064 -- having a null extension.
11066 Formal := First_Formal (Subp);
11067 Par_Formal := First_Formal (Alias (Subp));
11068 Formal_Node :=
11069 First (Parameter_Specifications (Specification (Func_Decl)));
11071 if Present (Formal) then
11072 Actual_List := New_List;
11074 while Present (Formal) loop
11075 if Is_Controlling_Formal (Formal) then
11076 Append_To (Actual_List,
11077 Make_Type_Conversion (Loc,
11078 Subtype_Mark =>
11079 New_Occurrence_Of (Etype (Par_Formal), Loc),
11080 Expression =>
11081 New_Occurrence_Of
11082 (Defining_Identifier (Formal_Node), Loc)));
11083 else
11084 Append_To
11085 (Actual_List,
11086 New_Occurrence_Of
11087 (Defining_Identifier (Formal_Node), Loc));
11088 end if;
11090 Next_Formal (Formal);
11091 Next_Formal (Par_Formal);
11092 Next (Formal_Node);
11093 end loop;
11094 else
11095 Actual_List := No_List;
11096 end if;
11098 Ext_Aggr :=
11099 Make_Extension_Aggregate (Loc,
11100 Ancestor_Part =>
11101 Make_Function_Call (Loc,
11102 Name =>
11103 New_Occurrence_Of (Alias (Subp), Loc),
11104 Parameter_Associations => Actual_List),
11105 Null_Record_Present => True);
11107 -- GNATprove will use expression of an expression function as an
11108 -- implicit postcondition. GNAT will not benefit from expression
11109 -- function (and would struggle if we add an expression function
11110 -- to freezing actions).
11112 if GNATprove_Mode then
11113 Func_Body :=
11114 Make_Expression_Function (Loc,
11115 Specification =>
11116 Make_Wrapper_Specification (Subp),
11117 Expression => Ext_Aggr);
11118 else
11119 Func_Body :=
11120 Make_Subprogram_Body (Loc,
11121 Specification =>
11122 Make_Wrapper_Specification (Subp),
11123 Declarations => Empty_List,
11124 Handled_Statement_Sequence =>
11125 Make_Handled_Sequence_Of_Statements (Loc,
11126 Statements => New_List (
11127 Make_Simple_Return_Statement (Loc,
11128 Expression => Ext_Aggr))));
11129 end if;
11131 Append_To (Body_List, Func_Body);
11133 -- Replace the inherited function with the wrapper function in the
11134 -- primitive operations list. We add the minimum decoration needed
11135 -- to override interface primitives.
11137 Func_Id := Defining_Unit_Name (Specification (Func_Decl));
11139 Mutate_Ekind (Func_Id, E_Function);
11140 Set_Is_Wrapper (Func_Id);
11142 -- Corresponding_Spec will be set again to the same value during
11143 -- analysis, but we need this information earlier.
11144 -- Expand_N_Freeze_Entity needs to know whether a subprogram body
11145 -- is a wrapper's body in order to get check suppression right.
11147 Set_Corresponding_Spec (Func_Body, Func_Id);
11149 Override_Dispatching_Operation (Tag_Typ, Subp, New_Op => Func_Id);
11150 end if;
11152 <<Next_Prim>>
11153 Next_Elmt (Prim_Elmt);
11154 end loop;
11155 end Make_Controlling_Function_Wrappers;
11157 ------------------
11158 -- Make_Eq_Body --
11159 ------------------
11161 function Make_Eq_Body
11162 (Typ : Entity_Id;
11163 Eq_Name : Name_Id) return Node_Id
11165 Loc : constant Source_Ptr := Sloc (Parent (Typ));
11166 Decl : Node_Id;
11167 Def : constant Node_Id := Parent (Typ);
11168 Stmts : constant List_Id := New_List;
11169 Variant_Case : Boolean := Has_Discriminants (Typ);
11170 Comps : Node_Id := Empty;
11171 Typ_Def : Node_Id := Type_Definition (Def);
11173 begin
11174 Decl :=
11175 Predef_Spec_Or_Body (Loc,
11176 Tag_Typ => Typ,
11177 Name => Eq_Name,
11178 Profile => New_List (
11179 Make_Parameter_Specification (Loc,
11180 Defining_Identifier =>
11181 Make_Defining_Identifier (Loc, Name_X),
11182 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
11184 Make_Parameter_Specification (Loc,
11185 Defining_Identifier =>
11186 Make_Defining_Identifier (Loc, Name_Y),
11187 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
11189 Ret_Type => Standard_Boolean,
11190 For_Body => True);
11192 if Variant_Case then
11193 if Nkind (Typ_Def) = N_Derived_Type_Definition then
11194 Typ_Def := Record_Extension_Part (Typ_Def);
11195 end if;
11197 if Present (Typ_Def) then
11198 Comps := Component_List (Typ_Def);
11199 end if;
11201 Variant_Case :=
11202 Present (Comps) and then Present (Variant_Part (Comps));
11203 end if;
11205 if Variant_Case then
11206 Append_To (Stmts,
11207 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
11208 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
11209 Append_To (Stmts,
11210 Make_Simple_Return_Statement (Loc,
11211 Expression => New_Occurrence_Of (Standard_True, Loc)));
11213 else
11214 Append_To (Stmts,
11215 Make_Simple_Return_Statement (Loc,
11216 Expression =>
11217 Expand_Record_Equality
11218 (Typ,
11219 Typ => Typ,
11220 Lhs => Make_Identifier (Loc, Name_X),
11221 Rhs => Make_Identifier (Loc, Name_Y))));
11222 end if;
11224 Set_Handled_Statement_Sequence
11225 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
11226 return Decl;
11227 end Make_Eq_Body;
11229 ------------------
11230 -- Make_Eq_Case --
11231 ------------------
11233 -- <Make_Eq_If shared components>
11235 -- case X.D1 is
11236 -- when V1 => <Make_Eq_Case> on subcomponents
11237 -- ...
11238 -- when Vn => <Make_Eq_Case> on subcomponents
11239 -- end case;
11241 function Make_Eq_Case
11242 (E : Entity_Id;
11243 CL : Node_Id;
11244 Discrs : Elist_Id := New_Elmt_List) return List_Id
11246 Loc : constant Source_Ptr := Sloc (E);
11247 Result : constant List_Id := New_List;
11248 Variant : Node_Id;
11249 Alt_List : List_Id;
11251 function Corresponding_Formal (C : Node_Id) return Entity_Id;
11252 -- Given the discriminant that controls a given variant of an unchecked
11253 -- union, find the formal of the equality function that carries the
11254 -- inferred value of the discriminant.
11256 function External_Name (E : Entity_Id) return Name_Id;
11257 -- The value of a given discriminant is conveyed in the corresponding
11258 -- formal parameter of the equality routine. The name of this formal
11259 -- parameter carries a one-character suffix which is removed here.
11261 --------------------------
11262 -- Corresponding_Formal --
11263 --------------------------
11265 function Corresponding_Formal (C : Node_Id) return Entity_Id is
11266 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
11267 Elm : Elmt_Id;
11269 begin
11270 Elm := First_Elmt (Discrs);
11271 while Present (Elm) loop
11272 if Chars (Discr) = External_Name (Node (Elm)) then
11273 return Node (Elm);
11274 end if;
11276 Next_Elmt (Elm);
11277 end loop;
11279 -- A formal of the proper name must be found
11281 raise Program_Error;
11282 end Corresponding_Formal;
11284 -------------------
11285 -- External_Name --
11286 -------------------
11288 function External_Name (E : Entity_Id) return Name_Id is
11289 begin
11290 Get_Name_String (Chars (E));
11291 Name_Len := Name_Len - 1;
11292 return Name_Find;
11293 end External_Name;
11295 -- Start of processing for Make_Eq_Case
11297 begin
11298 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
11300 if No (Variant_Part (CL)) then
11301 return Result;
11302 end if;
11304 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
11306 if No (Variant) then
11307 return Result;
11308 end if;
11310 Alt_List := New_List;
11311 while Present (Variant) loop
11312 Append_To (Alt_List,
11313 Make_Case_Statement_Alternative (Loc,
11314 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
11315 Statements =>
11316 Make_Eq_Case (E, Component_List (Variant), Discrs)));
11317 Next_Non_Pragma (Variant);
11318 end loop;
11320 -- If we have an Unchecked_Union, use one of the parameters of the
11321 -- enclosing equality routine that captures the discriminant, to use
11322 -- as the expression in the generated case statement.
11324 if Is_Unchecked_Union (E) then
11325 Append_To (Result,
11326 Make_Case_Statement (Loc,
11327 Expression =>
11328 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
11329 Alternatives => Alt_List));
11331 else
11332 Append_To (Result,
11333 Make_Case_Statement (Loc,
11334 Expression =>
11335 Make_Selected_Component (Loc,
11336 Prefix => Make_Identifier (Loc, Name_X),
11337 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
11338 Alternatives => Alt_List));
11339 end if;
11341 return Result;
11342 end Make_Eq_Case;
11344 ----------------
11345 -- Make_Eq_If --
11346 ----------------
11348 -- Generates:
11350 -- if
11351 -- X.C1 /= Y.C1
11352 -- or else
11353 -- X.C2 /= Y.C2
11354 -- ...
11355 -- then
11356 -- return False;
11357 -- end if;
11359 -- or a null statement if the list L is empty
11361 -- Equality may be user-defined for a given component type, in which case
11362 -- a function call is constructed instead of an operator node. This is an
11363 -- Ada 2012 change in the composability of equality for untagged composite
11364 -- types.
11366 function Make_Eq_If
11367 (E : Entity_Id;
11368 L : List_Id) return Node_Id
11370 Loc : constant Source_Ptr := Sloc (E);
11372 C : Node_Id;
11373 Cond : Node_Id;
11374 Field_Name : Name_Id;
11375 Next_Test : Node_Id;
11376 Typ : Entity_Id;
11378 begin
11379 if No (L) then
11380 return Make_Null_Statement (Loc);
11382 else
11383 Cond := Empty;
11385 C := First_Non_Pragma (L);
11386 while Present (C) loop
11387 Typ := Etype (Defining_Identifier (C));
11388 Field_Name := Chars (Defining_Identifier (C));
11390 -- The tags must not be compared: they are not part of the value.
11391 -- Ditto for parent interfaces because their equality operator is
11392 -- abstract.
11394 -- Note also that in the following, we use Make_Identifier for
11395 -- the component names. Use of New_Occurrence_Of to identify the
11396 -- components would be incorrect because the wrong entities for
11397 -- discriminants could be picked up in the private type case.
11399 if Field_Name = Name_uParent
11400 and then Is_Interface (Typ)
11401 then
11402 null;
11404 elsif Field_Name /= Name_uTag then
11405 declare
11406 Lhs : constant Node_Id :=
11407 Make_Selected_Component (Loc,
11408 Prefix => Make_Identifier (Loc, Name_X),
11409 Selector_Name => Make_Identifier (Loc, Field_Name));
11411 Rhs : constant Node_Id :=
11412 Make_Selected_Component (Loc,
11413 Prefix => Make_Identifier (Loc, Name_Y),
11414 Selector_Name => Make_Identifier (Loc, Field_Name));
11415 Eq_Call : Node_Id;
11417 begin
11418 -- Build equality code with a user-defined operator, if
11419 -- available, and with the predefined "=" otherwise. For
11420 -- compatibility with older Ada versions, we also use the
11421 -- predefined operation if the component-type equality is
11422 -- abstract, rather than raising Program_Error.
11424 if Ada_Version < Ada_2012 then
11425 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
11427 else
11428 Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
11430 if No (Eq_Call) then
11431 Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
11433 -- If a component has a defined abstract equality, its
11434 -- application raises Program_Error on that component
11435 -- and therefore on the current variant.
11437 elsif Nkind (Eq_Call) = N_Raise_Program_Error then
11438 Set_Etype (Eq_Call, Standard_Boolean);
11439 Next_Test := Make_Op_Not (Loc, Eq_Call);
11441 else
11442 Next_Test := Make_Op_Not (Loc, Eq_Call);
11443 end if;
11444 end if;
11445 end;
11447 Evolve_Or_Else (Cond, Next_Test);
11448 end if;
11450 Next_Non_Pragma (C);
11451 end loop;
11453 if No (Cond) then
11454 return Make_Null_Statement (Loc);
11456 else
11457 return
11458 Make_Implicit_If_Statement (E,
11459 Condition => Cond,
11460 Then_Statements => New_List (
11461 Make_Simple_Return_Statement (Loc,
11462 Expression => New_Occurrence_Of (Standard_False, Loc))));
11463 end if;
11464 end if;
11465 end Make_Eq_If;
11467 -------------------
11468 -- Make_Neq_Body --
11469 -------------------
11471 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
11473 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
11474 -- Returns true if Prim is a renaming of an unresolved predefined
11475 -- inequality operation.
11477 --------------------------------
11478 -- Is_Predefined_Neq_Renaming --
11479 --------------------------------
11481 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
11482 begin
11483 return Chars (Prim) /= Name_Op_Ne
11484 and then Present (Alias (Prim))
11485 and then Comes_From_Source (Prim)
11486 and then Is_Intrinsic_Subprogram (Alias (Prim))
11487 and then Chars (Alias (Prim)) = Name_Op_Ne;
11488 end Is_Predefined_Neq_Renaming;
11490 -- Local variables
11492 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
11493 Decl : Node_Id;
11494 Eq_Prim : Entity_Id;
11495 Left_Op : Entity_Id;
11496 Renaming_Prim : Entity_Id;
11497 Right_Op : Entity_Id;
11498 Target : Entity_Id;
11500 -- Start of processing for Make_Neq_Body
11502 begin
11503 -- For a call on a renaming of a dispatching subprogram that is
11504 -- overridden, if the overriding occurred before the renaming, then
11505 -- the body executed is that of the overriding declaration, even if the
11506 -- overriding declaration is not visible at the place of the renaming;
11507 -- otherwise, the inherited or predefined subprogram is called, see
11508 -- (RM 8.5.4(8)).
11510 -- Stage 1: Search for a renaming of the inequality primitive and also
11511 -- search for an overriding of the equality primitive located before the
11512 -- renaming declaration.
11514 declare
11515 Elmt : Elmt_Id;
11516 Prim : Node_Id;
11518 begin
11519 Eq_Prim := Empty;
11520 Renaming_Prim := Empty;
11522 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
11523 while Present (Elmt) loop
11524 Prim := Node (Elmt);
11526 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
11527 if No (Renaming_Prim) then
11528 pragma Assert (No (Eq_Prim));
11529 Eq_Prim := Prim;
11530 end if;
11532 elsif Is_Predefined_Neq_Renaming (Prim) then
11533 Renaming_Prim := Prim;
11534 end if;
11536 Next_Elmt (Elmt);
11537 end loop;
11538 end;
11540 -- No further action needed if no renaming was found
11542 if No (Renaming_Prim) then
11543 return Empty;
11544 end if;
11546 -- Stage 2: Replace the renaming declaration by a subprogram declaration
11547 -- (required to add its body)
11549 Decl := Parent (Parent (Renaming_Prim));
11550 Rewrite (Decl,
11551 Make_Subprogram_Declaration (Loc,
11552 Specification => Specification (Decl)));
11553 Set_Analyzed (Decl);
11555 -- Remove the decoration of intrinsic renaming subprogram
11557 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
11558 Set_Convention (Renaming_Prim, Convention_Ada);
11559 Set_Alias (Renaming_Prim, Empty);
11560 Set_Has_Completion (Renaming_Prim, False);
11562 -- Stage 3: Build the corresponding body
11564 Left_Op := First_Formal (Renaming_Prim);
11565 Right_Op := Next_Formal (Left_Op);
11567 Decl :=
11568 Predef_Spec_Or_Body (Loc,
11569 Tag_Typ => Tag_Typ,
11570 Name => Chars (Renaming_Prim),
11571 Profile => New_List (
11572 Make_Parameter_Specification (Loc,
11573 Defining_Identifier =>
11574 Make_Defining_Identifier (Loc, Chars (Left_Op)),
11575 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
11577 Make_Parameter_Specification (Loc,
11578 Defining_Identifier =>
11579 Make_Defining_Identifier (Loc, Chars (Right_Op)),
11580 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
11582 Ret_Type => Standard_Boolean,
11583 For_Body => True);
11585 -- If the overriding of the equality primitive occurred before the
11586 -- renaming, then generate:
11588 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11589 -- begin
11590 -- return not Oeq (X, Y);
11591 -- end;
11593 if Present (Eq_Prim) then
11594 Target := Eq_Prim;
11596 -- Otherwise build a nested subprogram which performs the predefined
11597 -- evaluation of the equality operator. That is, generate:
11599 -- function <Neq_Name> (X : Y : Typ) return Boolean is
11600 -- function Oeq (X : Y) return Boolean is
11601 -- begin
11602 -- <<body of default implementation>>
11603 -- end;
11604 -- begin
11605 -- return not Oeq (X, Y);
11606 -- end;
11608 else
11609 declare
11610 Local_Subp : Node_Id;
11611 begin
11612 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
11613 Set_Declarations (Decl, New_List (Local_Subp));
11614 Target := Defining_Entity (Local_Subp);
11615 end;
11616 end if;
11618 Set_Handled_Statement_Sequence
11619 (Decl,
11620 Make_Handled_Sequence_Of_Statements (Loc, New_List (
11621 Make_Simple_Return_Statement (Loc,
11622 Expression =>
11623 Make_Op_Not (Loc,
11624 Make_Function_Call (Loc,
11625 Name => New_Occurrence_Of (Target, Loc),
11626 Parameter_Associations => New_List (
11627 Make_Identifier (Loc, Chars (Left_Op)),
11628 Make_Identifier (Loc, Chars (Right_Op)))))))));
11630 return Decl;
11631 end Make_Neq_Body;
11633 -------------------------------
11634 -- Make_Null_Procedure_Specs --
11635 -------------------------------
11637 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
11638 Decl_List : constant List_Id := New_List;
11639 Loc : constant Source_Ptr := Sloc (Tag_Typ);
11640 Formal : Entity_Id;
11641 New_Param_Spec : Node_Id;
11642 New_Spec : Node_Id;
11643 Parent_Subp : Entity_Id;
11644 Prim_Elmt : Elmt_Id;
11645 Subp : Entity_Id;
11647 begin
11648 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
11649 while Present (Prim_Elmt) loop
11650 Subp := Node (Prim_Elmt);
11652 -- If a null procedure inherited from an interface has not been
11653 -- overridden, then we build a null procedure declaration to
11654 -- override the inherited procedure.
11656 Parent_Subp := Alias (Subp);
11658 if Present (Parent_Subp)
11659 and then Is_Null_Interface_Primitive (Parent_Subp)
11660 then
11661 -- The null procedure spec is copied from the inherited procedure,
11662 -- except for the IS NULL (which must be added) and the overriding
11663 -- indicators (which must be removed, if present).
11665 New_Spec :=
11666 Copy_Subprogram_Spec (Subprogram_Specification (Subp), Loc);
11668 Set_Null_Present (New_Spec, True);
11669 Set_Must_Override (New_Spec, False);
11670 Set_Must_Not_Override (New_Spec, False);
11672 Formal := First_Formal (Subp);
11673 New_Param_Spec := First (Parameter_Specifications (New_Spec));
11675 while Present (Formal) loop
11677 -- For controlling arguments we must change their parameter
11678 -- type to reference the tagged type (instead of the interface
11679 -- type).
11681 if Is_Controlling_Formal (Formal) then
11682 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
11683 then
11684 Set_Parameter_Type (New_Param_Spec,
11685 New_Occurrence_Of (Tag_Typ, Loc));
11687 else pragma Assert
11688 (Nkind (Parameter_Type (Parent (Formal))) =
11689 N_Access_Definition);
11690 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
11691 New_Occurrence_Of (Tag_Typ, Loc));
11692 end if;
11693 end if;
11695 Next_Formal (Formal);
11696 Next (New_Param_Spec);
11697 end loop;
11699 Append_To (Decl_List,
11700 Make_Subprogram_Declaration (Loc,
11701 Specification => New_Spec));
11702 end if;
11704 Next_Elmt (Prim_Elmt);
11705 end loop;
11707 return Decl_List;
11708 end Make_Null_Procedure_Specs;
11710 ---------------------------------------
11711 -- Make_Predefined_Primitive_Eq_Spec --
11712 ---------------------------------------
11714 procedure Make_Predefined_Primitive_Eq_Spec
11715 (Tag_Typ : Entity_Id;
11716 Predef_List : List_Id;
11717 Renamed_Eq : out Entity_Id)
11719 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
11720 -- Returns true if Prim is a renaming of an unresolved predefined
11721 -- equality operation.
11723 -------------------------------
11724 -- Is_Predefined_Eq_Renaming --
11725 -------------------------------
11727 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
11728 begin
11729 return Chars (Prim) /= Name_Op_Eq
11730 and then Present (Alias (Prim))
11731 and then Comes_From_Source (Prim)
11732 and then Is_Intrinsic_Subprogram (Alias (Prim))
11733 and then Chars (Alias (Prim)) = Name_Op_Eq;
11734 end Is_Predefined_Eq_Renaming;
11736 -- Local variables
11738 Loc : constant Source_Ptr := Sloc (Tag_Typ);
11740 Eq_Name : Name_Id := Name_Op_Eq;
11741 Eq_Needed : Boolean := True;
11742 Eq_Spec : Node_Id;
11743 Prim : Elmt_Id;
11745 Has_Predef_Eq_Renaming : Boolean := False;
11746 -- Set to True if Tag_Typ has a primitive that renames the predefined
11747 -- equality operator. Used to implement (RM 8-5-4(8)).
11749 -- Start of processing for Make_Predefined_Primitive_Specs
11751 begin
11752 Renamed_Eq := Empty;
11754 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
11755 while Present (Prim) loop
11757 -- If a primitive is encountered that renames the predefined equality
11758 -- operator before reaching any explicit equality primitive, then we
11759 -- still need to create a predefined equality function, because calls
11760 -- to it can occur via the renaming. A new name is created for the
11761 -- equality to avoid conflicting with any user-defined equality.
11762 -- (Note that this doesn't account for renamings of equality nested
11763 -- within subpackages???)
11765 if Is_Predefined_Eq_Renaming (Node (Prim)) then
11766 Has_Predef_Eq_Renaming := True;
11767 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
11769 -- User-defined equality
11771 elsif Is_User_Defined_Equality (Node (Prim)) then
11772 if No (Alias (Node (Prim)))
11773 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
11774 N_Subprogram_Renaming_Declaration
11775 then
11776 Eq_Needed := False;
11777 exit;
11779 -- If the parent is not an interface type and has an abstract
11780 -- equality function explicitly defined in the sources, then the
11781 -- inherited equality is abstract as well, and no body can be
11782 -- created for it.
11784 elsif not Is_Interface (Etype (Tag_Typ))
11785 and then Present (Alias (Node (Prim)))
11786 and then Comes_From_Source (Alias (Node (Prim)))
11787 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
11788 then
11789 Eq_Needed := False;
11790 exit;
11792 -- If the type has an equality function corresponding with a
11793 -- primitive defined in an interface type, the inherited equality
11794 -- is abstract as well, and no body can be created for it.
11796 elsif Present (Alias (Node (Prim)))
11797 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
11798 and then
11799 Is_Interface
11800 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
11801 then
11802 Eq_Needed := False;
11803 exit;
11804 end if;
11805 end if;
11807 Next_Elmt (Prim);
11808 end loop;
11810 -- If a renaming of predefined equality was found but there was no
11811 -- user-defined equality (so Eq_Needed is still true), then set the name
11812 -- back to Name_Op_Eq. But in the case where a user-defined equality was
11813 -- located after such a renaming, then the predefined equality function
11814 -- is still needed, so Eq_Needed must be set back to True.
11816 if Eq_Name /= Name_Op_Eq then
11817 if Eq_Needed then
11818 Eq_Name := Name_Op_Eq;
11819 else
11820 Eq_Needed := True;
11821 end if;
11822 end if;
11824 if Eq_Needed then
11825 Eq_Spec := Predef_Spec_Or_Body (Loc,
11826 Tag_Typ => Tag_Typ,
11827 Name => Eq_Name,
11828 Profile => New_List (
11829 Make_Parameter_Specification (Loc,
11830 Defining_Identifier =>
11831 Make_Defining_Identifier (Loc, Name_X),
11832 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
11834 Make_Parameter_Specification (Loc,
11835 Defining_Identifier =>
11836 Make_Defining_Identifier (Loc, Name_Y),
11837 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
11838 Ret_Type => Standard_Boolean);
11839 Append_To (Predef_List, Eq_Spec);
11841 if Has_Predef_Eq_Renaming then
11842 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
11844 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
11845 while Present (Prim) loop
11847 -- Any renamings of equality that appeared before an overriding
11848 -- equality must be updated to refer to the entity for the
11849 -- predefined equality, otherwise calls via the renaming would
11850 -- get incorrectly resolved to call the user-defined equality
11851 -- function.
11853 if Is_Predefined_Eq_Renaming (Node (Prim)) then
11854 Set_Alias (Node (Prim), Renamed_Eq);
11856 -- Exit upon encountering a user-defined equality
11858 elsif Chars (Node (Prim)) = Name_Op_Eq
11859 and then No (Alias (Node (Prim)))
11860 then
11861 exit;
11862 end if;
11864 Next_Elmt (Prim);
11865 end loop;
11866 end if;
11867 end if;
11868 end Make_Predefined_Primitive_Eq_Spec;
11870 -------------------------------------
11871 -- Make_Predefined_Primitive_Specs --
11872 -------------------------------------
11874 procedure Make_Predefined_Primitive_Specs
11875 (Tag_Typ : Entity_Id;
11876 Predef_List : out List_Id;
11877 Renamed_Eq : out Entity_Id)
11879 Loc : constant Source_Ptr := Sloc (Tag_Typ);
11880 Res : constant List_Id := New_List;
11882 use Exp_Put_Image;
11884 begin
11885 Renamed_Eq := Empty;
11887 -- Spec of _Size
11889 Append_To (Res, Predef_Spec_Or_Body (Loc,
11890 Tag_Typ => Tag_Typ,
11891 Name => Name_uSize,
11892 Profile => New_List (
11893 Make_Parameter_Specification (Loc,
11894 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
11895 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
11897 Ret_Type => Standard_Long_Long_Integer));
11899 -- Spec of Put_Image
11901 if (not No_Run_Time_Mode)
11902 and then RTE_Available (RE_Root_Buffer_Type)
11903 then
11904 -- No_Run_Time_Mode implies that the declaration of Tag_Typ
11905 -- (like any tagged type) will be rejected. Given this, avoid
11906 -- cascading errors associated with the Tag_Typ's TSS_Put_Image
11907 -- procedure.
11909 Append_To (Res, Predef_Spec_Or_Body (Loc,
11910 Tag_Typ => Tag_Typ,
11911 Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
11912 Profile => Build_Put_Image_Profile (Loc, Tag_Typ)));
11913 end if;
11915 -- Specs for dispatching stream attributes
11917 declare
11918 Stream_Op_TSS_Names :
11919 constant array (Positive range <>) of TSS_Name_Type :=
11920 (TSS_Stream_Read,
11921 TSS_Stream_Write,
11922 TSS_Stream_Input,
11923 TSS_Stream_Output);
11925 begin
11926 for Op in Stream_Op_TSS_Names'Range loop
11927 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
11928 Append_To (Res,
11929 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
11930 Stream_Op_TSS_Names (Op)));
11931 end if;
11932 end loop;
11933 end;
11935 -- Spec of "=" is expanded if the type is not limited and if a user
11936 -- defined "=" was not already declared for the non-full view of a
11937 -- private extension.
11939 if not Is_Limited_Type (Tag_Typ) then
11940 Make_Predefined_Primitive_Eq_Spec (Tag_Typ, Res, Renamed_Eq);
11942 -- Spec for dispatching assignment
11944 Append_To (Res, Predef_Spec_Or_Body (Loc,
11945 Tag_Typ => Tag_Typ,
11946 Name => Name_uAssign,
11947 Profile => New_List (
11948 Make_Parameter_Specification (Loc,
11949 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
11950 Out_Present => True,
11951 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
11953 Make_Parameter_Specification (Loc,
11954 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
11955 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
11956 end if;
11958 -- Ada 2005: Generate declarations for the following primitive
11959 -- operations for limited interfaces and synchronized types that
11960 -- implement a limited interface.
11962 -- Disp_Asynchronous_Select
11963 -- Disp_Conditional_Select
11964 -- Disp_Get_Prim_Op_Kind
11965 -- Disp_Get_Task_Id
11966 -- Disp_Requeue
11967 -- Disp_Timed_Select
11969 -- Disable the generation of these bodies if Ravenscar or ZFP is active
11971 if Ada_Version >= Ada_2005
11972 and then not Restriction_Active (No_Select_Statements)
11973 and then RTE_Available (RE_Select_Specific_Data)
11974 then
11975 -- These primitives are defined abstract in interface types
11977 if Is_Interface (Tag_Typ)
11978 and then Is_Limited_Record (Tag_Typ)
11979 then
11980 Append_To (Res,
11981 Make_Abstract_Subprogram_Declaration (Loc,
11982 Specification =>
11983 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
11985 Append_To (Res,
11986 Make_Abstract_Subprogram_Declaration (Loc,
11987 Specification =>
11988 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
11990 Append_To (Res,
11991 Make_Abstract_Subprogram_Declaration (Loc,
11992 Specification =>
11993 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
11995 Append_To (Res,
11996 Make_Abstract_Subprogram_Declaration (Loc,
11997 Specification =>
11998 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
12000 Append_To (Res,
12001 Make_Abstract_Subprogram_Declaration (Loc,
12002 Specification =>
12003 Make_Disp_Requeue_Spec (Tag_Typ)));
12005 Append_To (Res,
12006 Make_Abstract_Subprogram_Declaration (Loc,
12007 Specification =>
12008 Make_Disp_Timed_Select_Spec (Tag_Typ)));
12010 -- If ancestor is an interface type, declare non-abstract primitives
12011 -- to override the abstract primitives of the interface type.
12013 -- In VM targets we define these primitives in all root tagged types
12014 -- that are not interface types. Done because in VM targets we don't
12015 -- have secondary dispatch tables and any derivation of Tag_Typ may
12016 -- cover limited interfaces (which always have these primitives since
12017 -- they may be ancestors of synchronized interface types).
12019 elsif (not Is_Interface (Tag_Typ)
12020 and then Is_Interface (Etype (Tag_Typ))
12021 and then Is_Limited_Record (Etype (Tag_Typ)))
12022 or else
12023 (Is_Concurrent_Record_Type (Tag_Typ)
12024 and then Has_Interfaces (Tag_Typ))
12025 or else
12026 (not Tagged_Type_Expansion
12027 and then not Is_Interface (Tag_Typ)
12028 and then Tag_Typ = Root_Type (Tag_Typ))
12029 then
12030 Append_To (Res,
12031 Make_Subprogram_Declaration (Loc,
12032 Specification =>
12033 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
12035 Append_To (Res,
12036 Make_Subprogram_Declaration (Loc,
12037 Specification =>
12038 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
12040 Append_To (Res,
12041 Make_Subprogram_Declaration (Loc,
12042 Specification =>
12043 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
12045 Append_To (Res,
12046 Make_Subprogram_Declaration (Loc,
12047 Specification =>
12048 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
12050 Append_To (Res,
12051 Make_Subprogram_Declaration (Loc,
12052 Specification =>
12053 Make_Disp_Requeue_Spec (Tag_Typ)));
12055 Append_To (Res,
12056 Make_Subprogram_Declaration (Loc,
12057 Specification =>
12058 Make_Disp_Timed_Select_Spec (Tag_Typ)));
12059 end if;
12060 end if;
12062 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
12063 -- regardless of whether they are controlled or may contain controlled
12064 -- components.
12066 -- Do not generate the routines if finalization is disabled
12068 if Restriction_Active (No_Finalization) then
12069 null;
12071 else
12072 if not Is_Limited_Type (Tag_Typ) then
12073 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
12074 end if;
12076 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
12077 end if;
12079 Predef_List := Res;
12080 end Make_Predefined_Primitive_Specs;
12082 -------------------------
12083 -- Make_Tag_Assignment --
12084 -------------------------
12086 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
12087 Loc : constant Source_Ptr := Sloc (N);
12088 Def_If : constant Entity_Id := Defining_Identifier (N);
12089 Expr : constant Node_Id := Expression (N);
12090 Typ : constant Entity_Id := Etype (Def_If);
12091 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
12093 New_Ref : Node_Id;
12095 begin
12096 -- This expansion activity is called during analysis
12098 if Is_Tagged_Type (Typ)
12099 and then not Is_Class_Wide_Type (Typ)
12100 and then not Is_CPP_Class (Typ)
12101 and then Tagged_Type_Expansion
12102 and then Nkind (Expr) /= N_Aggregate
12103 and then (Nkind (Expr) /= N_Qualified_Expression
12104 or else Nkind (Expression (Expr)) /= N_Aggregate)
12105 then
12106 New_Ref :=
12107 Make_Selected_Component (Loc,
12108 Prefix => New_Occurrence_Of (Def_If, Loc),
12109 Selector_Name =>
12110 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
12112 Set_Assignment_OK (New_Ref);
12114 return
12115 Make_Assignment_Statement (Loc,
12116 Name => New_Ref,
12117 Expression =>
12118 Unchecked_Convert_To (RTE (RE_Tag),
12119 New_Occurrence_Of
12120 (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
12121 else
12122 return Empty;
12123 end if;
12124 end Make_Tag_Assignment;
12126 ----------------------
12127 -- Predef_Deep_Spec --
12128 ----------------------
12130 function Predef_Deep_Spec
12131 (Loc : Source_Ptr;
12132 Tag_Typ : Entity_Id;
12133 Name : TSS_Name_Type;
12134 For_Body : Boolean := False) return Node_Id
12136 Formals : List_Id;
12138 begin
12139 -- V : in out Tag_Typ
12141 Formals := New_List (
12142 Make_Parameter_Specification (Loc,
12143 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
12144 In_Present => True,
12145 Out_Present => True,
12146 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
12148 -- F : Boolean := True
12150 if Name = TSS_Deep_Adjust
12151 or else Name = TSS_Deep_Finalize
12152 then
12153 Append_To (Formals,
12154 Make_Parameter_Specification (Loc,
12155 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
12156 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
12157 Expression => New_Occurrence_Of (Standard_True, Loc)));
12158 end if;
12160 return
12161 Predef_Spec_Or_Body (Loc,
12162 Name => Make_TSS_Name (Tag_Typ, Name),
12163 Tag_Typ => Tag_Typ,
12164 Profile => Formals,
12165 For_Body => For_Body);
12167 exception
12168 when RE_Not_Available =>
12169 return Empty;
12170 end Predef_Deep_Spec;
12172 -------------------------
12173 -- Predef_Spec_Or_Body --
12174 -------------------------
12176 function Predef_Spec_Or_Body
12177 (Loc : Source_Ptr;
12178 Tag_Typ : Entity_Id;
12179 Name : Name_Id;
12180 Profile : List_Id;
12181 Ret_Type : Entity_Id := Empty;
12182 For_Body : Boolean := False) return Node_Id
12184 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
12185 Spec : Node_Id;
12187 begin
12188 Set_Is_Public (Id, Is_Public (Tag_Typ));
12190 -- The internal flag is set to mark these declarations because they have
12191 -- specific properties. First, they are primitives even if they are not
12192 -- defined in the type scope (the freezing point is not necessarily in
12193 -- the same scope). Second, the predefined equality can be overridden by
12194 -- a user-defined equality, no body will be generated in this case.
12196 Set_Is_Internal (Id);
12198 if not Debug_Generated_Code then
12199 Set_Debug_Info_Off (Id);
12200 end if;
12202 if No (Ret_Type) then
12203 Spec :=
12204 Make_Procedure_Specification (Loc,
12205 Defining_Unit_Name => Id,
12206 Parameter_Specifications => Profile);
12207 else
12208 Spec :=
12209 Make_Function_Specification (Loc,
12210 Defining_Unit_Name => Id,
12211 Parameter_Specifications => Profile,
12212 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
12213 end if;
12215 -- Declare an abstract subprogram for primitive subprograms of an
12216 -- interface type (except for "=").
12218 if Is_Interface (Tag_Typ) then
12219 if Name /= Name_Op_Eq then
12220 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
12222 -- The equality function (if any) for an interface type is defined
12223 -- to be nonabstract, so we create an expression function for it that
12224 -- always returns False. Note that the function can never actually be
12225 -- invoked because interface types are abstract, so there aren't any
12226 -- objects of such types (and their equality operation will always
12227 -- dispatch).
12229 else
12230 return Make_Expression_Function
12231 (Loc, Spec, New_Occurrence_Of (Standard_False, Loc));
12232 end if;
12234 -- If body case, return empty subprogram body. Note that this is ill-
12235 -- formed, because there is not even a null statement, and certainly not
12236 -- a return in the function case. The caller is expected to do surgery
12237 -- on the body to add the appropriate stuff.
12239 elsif For_Body then
12240 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
12242 -- For the case of an Input attribute predefined for an abstract type,
12243 -- generate an abstract specification. This will never be called, but we
12244 -- need the slot allocated in the dispatching table so that attributes
12245 -- typ'Class'Input and typ'Class'Output will work properly.
12247 elsif Is_TSS (Name, TSS_Stream_Input)
12248 and then Is_Abstract_Type (Tag_Typ)
12249 then
12250 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
12252 -- Normal spec case, where we return a subprogram declaration
12254 else
12255 return Make_Subprogram_Declaration (Loc, Spec);
12256 end if;
12257 end Predef_Spec_Or_Body;
12259 -----------------------------
12260 -- Predef_Stream_Attr_Spec --
12261 -----------------------------
12263 function Predef_Stream_Attr_Spec
12264 (Loc : Source_Ptr;
12265 Tag_Typ : Entity_Id;
12266 Name : TSS_Name_Type) return Node_Id
12268 Ret_Type : Entity_Id;
12270 begin
12271 if Name = TSS_Stream_Input then
12272 Ret_Type := Tag_Typ;
12273 else
12274 Ret_Type := Empty;
12275 end if;
12277 return
12278 Predef_Spec_Or_Body
12279 (Loc,
12280 Name => Make_TSS_Name (Tag_Typ, Name),
12281 Tag_Typ => Tag_Typ,
12282 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
12283 Ret_Type => Ret_Type,
12284 For_Body => False);
12285 end Predef_Stream_Attr_Spec;
12287 ----------------------------------
12288 -- Predefined_Primitive_Eq_Body --
12289 ----------------------------------
12291 procedure Predefined_Primitive_Eq_Body
12292 (Tag_Typ : Entity_Id;
12293 Predef_List : List_Id;
12294 Renamed_Eq : Entity_Id)
12296 Decl : Node_Id;
12297 Eq_Needed : Boolean;
12298 Eq_Name : Name_Id;
12299 Prim : Elmt_Id;
12301 begin
12302 -- See if we have a predefined "=" operator
12304 if Present (Renamed_Eq) then
12305 Eq_Needed := True;
12306 Eq_Name := Chars (Renamed_Eq);
12308 -- If the parent is an interface type then it has defined all the
12309 -- predefined primitives abstract and we need to check if the type
12310 -- has some user defined "=" function which matches the profile of
12311 -- the Ada predefined equality operator to avoid generating it.
12313 elsif Is_Interface (Etype (Tag_Typ)) then
12314 Eq_Needed := True;
12315 Eq_Name := Name_Op_Eq;
12317 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
12318 while Present (Prim) loop
12319 if Is_User_Defined_Equality (Node (Prim))
12320 and then not Is_Internal (Node (Prim))
12321 then
12322 Eq_Needed := False;
12323 Eq_Name := No_Name;
12324 exit;
12325 end if;
12327 Next_Elmt (Prim);
12328 end loop;
12330 else
12331 Eq_Needed := False;
12332 Eq_Name := No_Name;
12334 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
12335 while Present (Prim) loop
12336 if Is_User_Defined_Equality (Node (Prim))
12337 and then Is_Internal (Node (Prim))
12338 then
12339 Eq_Needed := True;
12340 Eq_Name := Name_Op_Eq;
12341 exit;
12342 end if;
12344 Next_Elmt (Prim);
12345 end loop;
12346 end if;
12348 -- If equality is needed, we will have its name
12350 pragma Assert (Eq_Needed = Present (Eq_Name));
12352 -- Body for equality
12354 if Eq_Needed then
12355 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
12356 Append_To (Predef_List, Decl);
12357 end if;
12359 -- Body for inequality (if required)
12361 Decl := Make_Neq_Body (Tag_Typ);
12363 if Present (Decl) then
12364 Append_To (Predef_List, Decl);
12365 end if;
12366 end Predefined_Primitive_Eq_Body;
12368 ---------------------------------
12369 -- Predefined_Primitive_Bodies --
12370 ---------------------------------
12372 function Predefined_Primitive_Bodies
12373 (Tag_Typ : Entity_Id;
12374 Renamed_Eq : Entity_Id) return List_Id
12376 Loc : constant Source_Ptr := Sloc (Tag_Typ);
12377 Res : constant List_Id := New_List;
12378 Adj_Call : Node_Id;
12379 Decl : Node_Id;
12380 Fin_Call : Node_Id;
12381 Ent : Entity_Id;
12383 pragma Warnings (Off, Ent);
12385 use Exp_Put_Image;
12387 begin
12388 pragma Assert (not Is_Interface (Tag_Typ));
12390 -- Body of _Size
12392 Decl := Predef_Spec_Or_Body (Loc,
12393 Tag_Typ => Tag_Typ,
12394 Name => Name_uSize,
12395 Profile => New_List (
12396 Make_Parameter_Specification (Loc,
12397 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
12398 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
12400 Ret_Type => Standard_Long_Long_Integer,
12401 For_Body => True);
12403 Set_Handled_Statement_Sequence (Decl,
12404 Make_Handled_Sequence_Of_Statements (Loc, New_List (
12405 Make_Simple_Return_Statement (Loc,
12406 Expression =>
12407 Make_Attribute_Reference (Loc,
12408 Prefix => Make_Identifier (Loc, Name_X),
12409 Attribute_Name => Name_Size)))));
12411 Append_To (Res, Decl);
12413 -- Body of Put_Image
12415 if No (TSS (Tag_Typ, TSS_Put_Image))
12416 and then (not No_Run_Time_Mode)
12417 and then RTE_Available (RE_Root_Buffer_Type)
12418 then
12419 Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
12420 Append_To (Res, Decl);
12421 end if;
12423 -- Bodies for Dispatching stream IO routines. We need these only for
12424 -- non-limited types (in the limited case there is no dispatching).
12425 -- We also skip them if dispatching or finalization are not available
12426 -- or if stream operations are prohibited by restriction No_Streams or
12427 -- from use of pragma/aspect No_Tagged_Streams.
12429 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
12430 and then No (TSS (Tag_Typ, TSS_Stream_Read))
12431 then
12432 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
12433 Append_To (Res, Decl);
12434 end if;
12436 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
12437 and then No (TSS (Tag_Typ, TSS_Stream_Write))
12438 then
12439 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
12440 Append_To (Res, Decl);
12441 end if;
12443 -- Skip body of _Input for the abstract case, since the corresponding
12444 -- spec is abstract (see Predef_Spec_Or_Body).
12446 if not Is_Abstract_Type (Tag_Typ)
12447 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
12448 and then No (TSS (Tag_Typ, TSS_Stream_Input))
12449 then
12450 Build_Record_Or_Elementary_Input_Function
12451 (Loc, Tag_Typ, Decl, Ent);
12452 Append_To (Res, Decl);
12453 end if;
12455 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
12456 and then No (TSS (Tag_Typ, TSS_Stream_Output))
12457 then
12458 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
12459 Append_To (Res, Decl);
12460 end if;
12462 -- Ada 2005: Generate bodies for the following primitive operations for
12463 -- limited interfaces and synchronized types that implement a limited
12464 -- interface.
12466 -- disp_asynchronous_select
12467 -- disp_conditional_select
12468 -- disp_get_prim_op_kind
12469 -- disp_get_task_id
12470 -- disp_timed_select
12472 -- The interface versions will have null bodies
12474 -- Disable the generation of these bodies if Ravenscar or ZFP is active
12476 -- In VM targets we define these primitives in all root tagged types
12477 -- that are not interface types. Done because in VM targets we don't
12478 -- have secondary dispatch tables and any derivation of Tag_Typ may
12479 -- cover limited interfaces (which always have these primitives since
12480 -- they may be ancestors of synchronized interface types).
12482 if Ada_Version >= Ada_2005
12483 and then
12484 ((Is_Interface (Etype (Tag_Typ))
12485 and then Is_Limited_Record (Etype (Tag_Typ)))
12486 or else
12487 (Is_Concurrent_Record_Type (Tag_Typ)
12488 and then Has_Interfaces (Tag_Typ))
12489 or else
12490 (not Tagged_Type_Expansion
12491 and then Tag_Typ = Root_Type (Tag_Typ)))
12492 and then not Restriction_Active (No_Select_Statements)
12493 and then RTE_Available (RE_Select_Specific_Data)
12494 then
12495 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
12496 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
12497 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
12498 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
12499 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
12500 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
12501 end if;
12503 if not Is_Limited_Type (Tag_Typ) then
12504 -- Body for equality and inequality
12506 Predefined_Primitive_Eq_Body (Tag_Typ, Res, Renamed_Eq);
12508 -- Body for dispatching assignment
12510 Decl :=
12511 Predef_Spec_Or_Body (Loc,
12512 Tag_Typ => Tag_Typ,
12513 Name => Name_uAssign,
12514 Profile => New_List (
12515 Make_Parameter_Specification (Loc,
12516 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
12517 Out_Present => True,
12518 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
12520 Make_Parameter_Specification (Loc,
12521 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
12522 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
12523 For_Body => True);
12525 Set_Handled_Statement_Sequence (Decl,
12526 Make_Handled_Sequence_Of_Statements (Loc, New_List (
12527 Make_Assignment_Statement (Loc,
12528 Name => Make_Identifier (Loc, Name_X),
12529 Expression => Make_Identifier (Loc, Name_Y)))));
12531 Append_To (Res, Decl);
12532 end if;
12534 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
12535 -- tagged types which do not contain controlled components.
12537 -- Do not generate the routines if finalization is disabled
12539 if Restriction_Active (No_Finalization) then
12540 null;
12542 elsif not Has_Controlled_Component (Tag_Typ) then
12543 if not Is_Limited_Type (Tag_Typ) then
12544 Adj_Call := Empty;
12545 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
12547 if Is_Controlled (Tag_Typ) then
12548 Adj_Call :=
12549 Make_Adjust_Call (
12550 Obj_Ref => Make_Identifier (Loc, Name_V),
12551 Typ => Tag_Typ);
12552 end if;
12554 if No (Adj_Call) then
12555 Adj_Call := Make_Null_Statement (Loc);
12556 end if;
12558 Set_Handled_Statement_Sequence (Decl,
12559 Make_Handled_Sequence_Of_Statements (Loc,
12560 Statements => New_List (Adj_Call)));
12562 Append_To (Res, Decl);
12563 end if;
12565 Fin_Call := Empty;
12566 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
12568 if Is_Controlled (Tag_Typ) then
12569 Fin_Call :=
12570 Make_Final_Call
12571 (Obj_Ref => Make_Identifier (Loc, Name_V),
12572 Typ => Tag_Typ);
12573 end if;
12575 if No (Fin_Call) then
12576 Fin_Call := Make_Null_Statement (Loc);
12577 end if;
12579 Set_Handled_Statement_Sequence (Decl,
12580 Make_Handled_Sequence_Of_Statements (Loc,
12581 Statements => New_List (Fin_Call)));
12583 Append_To (Res, Decl);
12584 end if;
12586 return Res;
12587 end Predefined_Primitive_Bodies;
12589 ---------------------------------
12590 -- Predefined_Primitive_Freeze --
12591 ---------------------------------
12593 function Predefined_Primitive_Freeze
12594 (Tag_Typ : Entity_Id) return List_Id
12596 Res : constant List_Id := New_List;
12597 Prim : Elmt_Id;
12598 Frnodes : List_Id;
12600 begin
12601 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
12602 while Present (Prim) loop
12603 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
12604 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
12606 if Present (Frnodes) then
12607 Append_List_To (Res, Frnodes);
12608 end if;
12609 end if;
12611 Next_Elmt (Prim);
12612 end loop;
12614 return Res;
12615 end Predefined_Primitive_Freeze;
12617 -------------------------
12618 -- Stream_Operation_OK --
12619 -------------------------
12621 function Stream_Operation_OK
12622 (Typ : Entity_Id;
12623 Operation : TSS_Name_Type) return Boolean
12625 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
12627 begin
12628 -- Special case of a limited type extension: a default implementation
12629 -- of the stream attributes Read or Write exists if that attribute
12630 -- has been specified or is available for an ancestor type; a default
12631 -- implementation of the attribute Output (resp. Input) exists if the
12632 -- attribute has been specified or Write (resp. Read) is available for
12633 -- an ancestor type. The last condition only applies under Ada 2005.
12635 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
12636 if Operation = TSS_Stream_Read then
12637 Has_Predefined_Or_Specified_Stream_Attribute :=
12638 Has_Specified_Stream_Read (Typ);
12640 elsif Operation = TSS_Stream_Write then
12641 Has_Predefined_Or_Specified_Stream_Attribute :=
12642 Has_Specified_Stream_Write (Typ);
12644 elsif Operation = TSS_Stream_Input then
12645 Has_Predefined_Or_Specified_Stream_Attribute :=
12646 Has_Specified_Stream_Input (Typ)
12647 or else
12648 (Ada_Version >= Ada_2005
12649 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
12651 elsif Operation = TSS_Stream_Output then
12652 Has_Predefined_Or_Specified_Stream_Attribute :=
12653 Has_Specified_Stream_Output (Typ)
12654 or else
12655 (Ada_Version >= Ada_2005
12656 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
12657 end if;
12659 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
12661 if not Has_Predefined_Or_Specified_Stream_Attribute
12662 and then Is_Derived_Type (Typ)
12663 and then (Operation = TSS_Stream_Read
12664 or else Operation = TSS_Stream_Write)
12665 then
12666 Has_Predefined_Or_Specified_Stream_Attribute :=
12667 Present
12668 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
12669 end if;
12670 end if;
12672 -- If the type is not limited, or else is limited but the attribute is
12673 -- explicitly specified or is predefined for the type, then return True,
12674 -- unless other conditions prevail, such as restrictions prohibiting
12675 -- streams or dispatching operations. We also return True for limited
12676 -- interfaces, because they may be extended by nonlimited types and
12677 -- permit inheritance in this case (addresses cases where an abstract
12678 -- extension doesn't get 'Input declared, as per comments below, but
12679 -- 'Class'Input must still be allowed). Note that attempts to apply
12680 -- stream attributes to a limited interface or its class-wide type
12681 -- (or limited extensions thereof) will still get properly rejected
12682 -- by Check_Stream_Attribute.
12684 -- We exclude the Input operation from being a predefined subprogram in
12685 -- the case where the associated type is an abstract extension, because
12686 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
12687 -- we don't want an abstract version created because types derived from
12688 -- the abstract type may not even have Input available (for example if
12689 -- derived from a private view of the abstract type that doesn't have
12690 -- a visible Input).
12692 -- Do not generate stream routines for type Finalization_Master because
12693 -- a master may never appear in types and therefore cannot be read or
12694 -- written.
12696 return
12697 (not Is_Limited_Type (Typ)
12698 or else Is_Interface (Typ)
12699 or else Has_Predefined_Or_Specified_Stream_Attribute)
12700 and then
12701 (Operation /= TSS_Stream_Input
12702 or else not Is_Abstract_Type (Typ)
12703 or else not Is_Derived_Type (Typ))
12704 and then not Has_Unknown_Discriminants (Typ)
12705 and then not Is_Concurrent_Interface (Typ)
12706 and then not Restriction_Active (No_Streams)
12707 and then not Restriction_Active (No_Dispatch)
12708 and then No (No_Tagged_Streams_Pragma (Typ))
12709 and then not No_Run_Time_Mode
12710 and then RTE_Available (RE_Tag)
12711 and then No (Type_Without_Stream_Operation (Typ))
12712 and then RTE_Available (RE_Root_Stream_Type)
12713 and then not Is_RTE (Typ, RE_Finalization_Master);
12714 end Stream_Operation_OK;
12716 end Exp_Ch3;