File : exp_ch3.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Aggr; use Exp_Aggr;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch4; use Exp_Ch4;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Dbug; use Exp_Dbug;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Dist; use Exp_Dist;
41 with Exp_Smem; use Exp_Smem;
42 with Exp_Strm; use Exp_Strm;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Inline; use Inline;
48 with Namet; use Namet;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
51 with Opt; use Opt;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
55 with Sem; use Sem;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Attr; use Sem_Attr;
58 with Sem_Cat; use Sem_Cat;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch6; use Sem_Ch6;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Mech; use Sem_Mech;
65 with Sem_Res; use Sem_Res;
66 with Sem_SCIL; use Sem_SCIL;
67 with Sem_Type; use Sem_Type;
68 with Sem_Util; use Sem_Util;
69 with Sinfo; use Sinfo;
70 with Stand; use Stand;
71 with Snames; use Snames;
72 with Targparm; use Targparm;
73 with Tbuild; use Tbuild;
74 with Ttypes; use Ttypes;
75 with Validsw; use Validsw;
76
77 package body Exp_Ch3 is
78
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
82
83 procedure Adjust_Discriminants (Rtype : Entity_Id);
84 -- This is used when freezing a record type. It attempts to construct
85 -- more restrictive subtypes for discriminants so that the max size of
86 -- the record can be calculated more accurately. See the body of this
87 -- procedure for details.
88
89 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
90 -- Build initialization procedure for given array type. Nod is a node
91 -- used for attachment of any actions required in its construction.
92 -- It also supplies the source location used for the procedure.
93
94 function Build_Discriminant_Formals
95 (Rec_Id : Entity_Id;
96 Use_Dl : Boolean) return List_Id;
97 -- This function uses the discriminants of a type to build a list of
98 -- formal parameters, used in Build_Init_Procedure among other places.
99 -- If the flag Use_Dl is set, the list is built using the already
100 -- defined discriminals of the type, as is the case for concurrent
101 -- types with discriminants. Otherwise new identifiers are created,
102 -- with the source names of the discriminants.
103
104 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
105 -- This function builds a static aggregate that can serve as the initial
106 -- value for an array type whose bounds are static, and whose component
107 -- type is a composite type that has a static equivalent aggregate.
108 -- The equivalent array aggregate is used both for object initialization
109 -- and for component initialization, when used in the following function.
110
111 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
112 -- This function builds a static aggregate that can serve as the initial
113 -- value for a record type whose components are scalar and initialized
114 -- with compile-time values, or arrays with similar initialization or
115 -- defaults. When possible, initialization of an object of the type can
116 -- be achieved by using a copy of the aggregate as an initial value, thus
117 -- removing the implicit call that would otherwise constitute elaboration
118 -- code.
119
120 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
121 -- Build record initialization procedure. N is the type declaration
122 -- node, and Rec_Ent is the corresponding entity for the record type.
123
124 procedure Build_Slice_Assignment (Typ : Entity_Id);
125 -- Build assignment procedure for one-dimensional arrays of controlled
126 -- types. Other array and slice assignments are expanded in-line, but
127 -- the code expansion for controlled components (when control actions
128 -- are active) can lead to very large blocks that GCC3 handles poorly.
129
130 procedure Build_Untagged_Equality (Typ : Entity_Id);
131 -- AI05-0123: Equality on untagged records composes. This procedure
132 -- builds the equality routine for an untagged record that has components
133 -- of a record type that has user-defined primitive equality operations.
134 -- The resulting operation is a TSS subprogram.
135
136 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
137 -- Create An Equality function for the untagged variant record Typ and
138 -- attach it to the TSS list
139
140 procedure Check_Stream_Attributes (Typ : Entity_Id);
141 -- Check that if a limited extension has a parent with user-defined stream
142 -- attributes, and does not itself have user-defined stream-attributes,
143 -- then any limited component of the extension also has the corresponding
144 -- user-defined stream attributes.
145
146 procedure Clean_Task_Names
147 (Typ : Entity_Id;
148 Proc_Id : Entity_Id);
149 -- If an initialization procedure includes calls to generate names
150 -- for task subcomponents, indicate that secondary stack cleanup is
151 -- needed after an initialization. Typ is the component type, and Proc_Id
152 -- the initialization procedure for the enclosing composite type.
153
154 procedure Expand_Freeze_Array_Type (N : Node_Id);
155 -- Freeze an array type. Deals with building the initialization procedure,
156 -- creating the packed array type for a packed array and also with the
157 -- creation of the controlling procedures for the controlled case. The
158 -- argument N is the N_Freeze_Entity node for the type.
159
160 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
161 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose
162 -- of finalizing controlled derivations from the class-wide's root type.
163
164 procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
165 -- Freeze enumeration type with non-standard representation. Builds the
166 -- array and function needed to convert between enumeration pos and
167 -- enumeration representation values. N is the N_Freeze_Entity node
168 -- for the type.
169
170 procedure Expand_Freeze_Record_Type (N : Node_Id);
171 -- Freeze record type. Builds all necessary discriminant checking
172 -- and other ancillary functions, and builds dispatch tables where
173 -- needed. The argument N is the N_Freeze_Entity node. This processing
174 -- applies only to E_Record_Type entities, not to class wide types,
175 -- record subtypes, or private types.
176
177 procedure Expand_Tagged_Root (T : Entity_Id);
178 -- Add a field _Tag at the beginning of the record. This field carries
179 -- the value of the access to the Dispatch table. This procedure is only
180 -- called on root type, the _Tag field being inherited by the descendants.
181
182 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
183 -- Treat user-defined stream operations as renaming_as_body if the
184 -- subprogram they rename is not frozen when the type is frozen.
185
186 procedure Initialization_Warning (E : Entity_Id);
187 -- If static elaboration of the package is requested, indicate
188 -- when a type does meet the conditions for static initialization. If
189 -- E is a type, it has components that have no static initialization.
190 -- if E is an entity, its initial expression is not compile-time known.
191
192 function Init_Formals (Typ : Entity_Id) return List_Id;
193 -- This function builds the list of formals for an initialization routine.
194 -- The first formal is always _Init with the given type. For task value
195 -- record types and types containing tasks, three additional formals are
196 -- added:
197 --
198 -- _Master : Master_Id
199 -- _Chain : in out Activation_Chain
200 -- _Task_Name : String
201 --
202 -- The caller must append additional entries for discriminants if required.
203
204 function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
205 -- Returns true if the initialization procedure of Typ should be inlined
206
207 function In_Runtime (E : Entity_Id) return Boolean;
208 -- Check if E is defined in the RTL (in a child of Ada or System). Used
209 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
210
211 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
212 -- Returns true if Prim is a user defined equality function
213
214 function Make_Eq_Body
215 (Typ : Entity_Id;
216 Eq_Name : Name_Id) return Node_Id;
217 -- Build the body of a primitive equality operation for a tagged record
218 -- type, or in Ada 2012 for any record type that has components with a
219 -- user-defined equality. Factored out of Predefined_Primitive_Bodies.
220
221 function Make_Eq_Case
222 (E : Entity_Id;
223 CL : Node_Id;
224 Discrs : Elist_Id := New_Elmt_List) return List_Id;
225 -- Building block for variant record equality. Defined to share the code
226 -- between the tagged and untagged case. Given a Component_List node CL,
227 -- it generates an 'if' followed by a 'case' statement that compares all
228 -- components of local temporaries named X and Y (that are declared as
229 -- formals at some upper level). E provides the Sloc to be used for the
230 -- generated code.
231 --
232 -- IF E is an unchecked_union, Discrs is the list of formals created for
233 -- the inferred discriminants of one operand. These formals are used in
234 -- the generated case statements for each variant of the unchecked union.
235
236 function Make_Eq_If
237 (E : Entity_Id;
238 L : List_Id) return Node_Id;
239 -- Building block for variant record equality. Defined to share the code
240 -- between the tagged and untagged case. Given the list of components
241 -- (or discriminants) L, it generates a return statement that compares all
242 -- components of local temporaries named X and Y (that are declared as
243 -- formals at some upper level). E provides the Sloc to be used for the
244 -- generated code.
245
246 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
247 -- Search for a renaming of the inequality dispatching primitive of
248 -- this tagged type. If found then build and return the corresponding
249 -- rename-as-body inequality subprogram; otherwise return Empty.
250
251 procedure Make_Predefined_Primitive_Specs
252 (Tag_Typ : Entity_Id;
253 Predef_List : out List_Id;
254 Renamed_Eq : out Entity_Id);
255 -- Create a list with the specs of the predefined primitive operations.
256 -- For tagged types that are interfaces all these primitives are defined
257 -- abstract.
258 --
259 -- The following entries are present for all tagged types, and provide
260 -- the results of the corresponding attribute applied to the object.
261 -- Dispatching is required in general, since the result of the attribute
262 -- will vary with the actual object subtype.
263 --
264 -- _size provides result of 'Size attribute
265 -- typSR provides result of 'Read attribute
266 -- typSW provides result of 'Write attribute
267 -- typSI provides result of 'Input attribute
268 -- typSO provides result of 'Output attribute
269 --
270 -- The following entries are additionally present for non-limited tagged
271 -- types, and implement additional dispatching operations for predefined
272 -- operations:
273 --
274 -- _equality implements "=" operator
275 -- _assign implements assignment operation
276 -- typDF implements deep finalization
277 -- typDA implements deep adjust
278 --
279 -- The latter two are empty procedures unless the type contains some
280 -- controlled components that require finalization actions (the deep
281 -- in the name refers to the fact that the action applies to components).
282 --
283 -- The list is returned in Predef_List. The Parameter Renamed_Eq either
284 -- returns the value Empty, or else the defining unit name for the
285 -- predefined equality function in the case where the type has a primitive
286 -- operation that is a renaming of predefined equality (but only if there
287 -- is also an overriding user-defined equality function). The returned
288 -- Renamed_Eq will be passed to the corresponding parameter of
289 -- Predefined_Primitive_Bodies.
290
291 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
292 -- Returns True if there are representation clauses for type T that are not
293 -- inherited. If the result is false, the init_proc and the discriminant
294 -- checking functions of the parent can be reused by a derived type.
295
296 procedure Make_Controlling_Function_Wrappers
297 (Tag_Typ : Entity_Id;
298 Decl_List : out List_Id;
299 Body_List : out List_Id);
300 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
301 -- associated with inherited functions with controlling results which
302 -- are not overridden. The body of each wrapper function consists solely
303 -- of a return statement whose expression is an extension aggregate
304 -- invoking the inherited subprogram's parent subprogram and extended
305 -- with a null association list.
306
307 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
308 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
309 -- null procedures inherited from an interface type that have not been
310 -- overridden. Only one null procedure will be created for a given set of
311 -- inherited null procedures with homographic profiles.
312
313 function Predef_Spec_Or_Body
314 (Loc : Source_Ptr;
315 Tag_Typ : Entity_Id;
316 Name : Name_Id;
317 Profile : List_Id;
318 Ret_Type : Entity_Id := Empty;
319 For_Body : Boolean := False) return Node_Id;
320 -- This function generates the appropriate expansion for a predefined
321 -- primitive operation specified by its name, parameter profile and
322 -- return type (Empty means this is a procedure). If For_Body is false,
323 -- then the returned node is a subprogram declaration. If For_Body is
324 -- true, then the returned node is a empty subprogram body containing
325 -- no declarations and no statements.
326
327 function Predef_Stream_Attr_Spec
328 (Loc : Source_Ptr;
329 Tag_Typ : Entity_Id;
330 Name : TSS_Name_Type;
331 For_Body : Boolean := False) return Node_Id;
332 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
333 -- input and output attribute whose specs are constructed in Exp_Strm.
334
335 function Predef_Deep_Spec
336 (Loc : Source_Ptr;
337 Tag_Typ : Entity_Id;
338 Name : TSS_Name_Type;
339 For_Body : Boolean := False) return Node_Id;
340 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
341 -- and _deep_finalize
342
343 function Predefined_Primitive_Bodies
344 (Tag_Typ : Entity_Id;
345 Renamed_Eq : Entity_Id) return List_Id;
346 -- Create the bodies of the predefined primitives that are described in
347 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
348 -- the defining unit name of the type's predefined equality as returned
349 -- by Make_Predefined_Primitive_Specs.
350
351 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
352 -- Freeze entities of all predefined primitive operations. This is needed
353 -- because the bodies of these operations do not normally do any freezing.
354
355 function Stream_Operation_OK
356 (Typ : Entity_Id;
357 Operation : TSS_Name_Type) return Boolean;
358 -- Check whether the named stream operation must be emitted for a given
359 -- type. The rules for inheritance of stream attributes by type extensions
360 -- are enforced by this function. Furthermore, various restrictions prevent
361 -- the generation of these operations, as a useful optimization or for
362 -- certification purposes and to save unnecessary generated code.
363
364 --------------------------
365 -- Adjust_Discriminants --
366 --------------------------
367
368 -- This procedure attempts to define subtypes for discriminants that are
369 -- more restrictive than those declared. Such a replacement is possible if
370 -- we can demonstrate that values outside the restricted range would cause
371 -- constraint errors in any case. The advantage of restricting the
372 -- discriminant types in this way is that the maximum size of the variant
373 -- record can be calculated more conservatively.
374
375 -- An example of a situation in which we can perform this type of
376 -- restriction is the following:
377
378 -- subtype B is range 1 .. 10;
379 -- type Q is array (B range <>) of Integer;
380
381 -- type V (N : Natural) is record
382 -- C : Q (1 .. N);
383 -- end record;
384
385 -- In this situation, we can restrict the upper bound of N to 10, since
386 -- any larger value would cause a constraint error in any case.
387
388 -- There are many situations in which such restriction is possible, but
389 -- for now, we just look for cases like the above, where the component
390 -- in question is a one dimensional array whose upper bound is one of
391 -- the record discriminants. Also the component must not be part of
392 -- any variant part, since then the component does not always exist.
393
394 procedure Adjust_Discriminants (Rtype : Entity_Id) is
395 Loc : constant Source_Ptr := Sloc (Rtype);
396 Comp : Entity_Id;
397 Ctyp : Entity_Id;
398 Ityp : Entity_Id;
399 Lo : Node_Id;
400 Hi : Node_Id;
401 P : Node_Id;
402 Loval : Uint;
403 Discr : Entity_Id;
404 Dtyp : Entity_Id;
405 Dhi : Node_Id;
406 Dhiv : Uint;
407 Ahi : Node_Id;
408 Ahiv : Uint;
409 Tnn : Entity_Id;
410
411 begin
412 Comp := First_Component (Rtype);
413 while Present (Comp) loop
414
415 -- If our parent is a variant, quit, we do not look at components
416 -- that are in variant parts, because they may not always exist.
417
418 P := Parent (Comp); -- component declaration
419 P := Parent (P); -- component list
420
421 exit when Nkind (Parent (P)) = N_Variant;
422
423 -- We are looking for a one dimensional array type
424
425 Ctyp := Etype (Comp);
426
427 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
428 goto Continue;
429 end if;
430
431 -- The lower bound must be constant, and the upper bound is a
432 -- discriminant (which is a discriminant of the current record).
433
434 Ityp := Etype (First_Index (Ctyp));
435 Lo := Type_Low_Bound (Ityp);
436 Hi := Type_High_Bound (Ityp);
437
438 if not Compile_Time_Known_Value (Lo)
439 or else Nkind (Hi) /= N_Identifier
440 or else No (Entity (Hi))
441 or else Ekind (Entity (Hi)) /= E_Discriminant
442 then
443 goto Continue;
444 end if;
445
446 -- We have an array with appropriate bounds
447
448 Loval := Expr_Value (Lo);
449 Discr := Entity (Hi);
450 Dtyp := Etype (Discr);
451
452 -- See if the discriminant has a known upper bound
453
454 Dhi := Type_High_Bound (Dtyp);
455
456 if not Compile_Time_Known_Value (Dhi) then
457 goto Continue;
458 end if;
459
460 Dhiv := Expr_Value (Dhi);
461
462 -- See if base type of component array has known upper bound
463
464 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
465
466 if not Compile_Time_Known_Value (Ahi) then
467 goto Continue;
468 end if;
469
470 Ahiv := Expr_Value (Ahi);
471
472 -- The condition for doing the restriction is that the high bound
473 -- of the discriminant is greater than the low bound of the array,
474 -- and is also greater than the high bound of the base type index.
475
476 if Dhiv > Loval and then Dhiv > Ahiv then
477
478 -- We can reset the upper bound of the discriminant type to
479 -- whichever is larger, the low bound of the component, or
480 -- the high bound of the base type array index.
481
482 -- We build a subtype that is declared as
483
484 -- subtype Tnn is discr_type range discr_type'First .. max;
485
486 -- And insert this declaration into the tree. The type of the
487 -- discriminant is then reset to this more restricted subtype.
488
489 Tnn := Make_Temporary (Loc, 'T');
490
491 Insert_Action (Declaration_Node (Rtype),
492 Make_Subtype_Declaration (Loc,
493 Defining_Identifier => Tnn,
494 Subtype_Indication =>
495 Make_Subtype_Indication (Loc,
496 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
497 Constraint =>
498 Make_Range_Constraint (Loc,
499 Range_Expression =>
500 Make_Range (Loc,
501 Low_Bound =>
502 Make_Attribute_Reference (Loc,
503 Attribute_Name => Name_First,
504 Prefix => New_Occurrence_Of (Dtyp, Loc)),
505 High_Bound =>
506 Make_Integer_Literal (Loc,
507 Intval => UI_Max (Loval, Ahiv)))))));
508
509 Set_Etype (Discr, Tnn);
510 end if;
511
512 <<Continue>>
513 Next_Component (Comp);
514 end loop;
515 end Adjust_Discriminants;
516
517 ---------------------------
518 -- Build_Array_Init_Proc --
519 ---------------------------
520
521 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
522 Comp_Type : constant Entity_Id := Component_Type (A_Type);
523 Body_Stmts : List_Id;
524 Has_Default_Init : Boolean;
525 Index_List : List_Id;
526 Loc : Source_Ptr;
527 Proc_Id : Entity_Id;
528
529 function Init_Component return List_Id;
530 -- Create one statement to initialize one array component, designated
531 -- by a full set of indexes.
532
533 function Init_One_Dimension (N : Int) return List_Id;
534 -- Create loop to initialize one dimension of the array. The single
535 -- statement in the loop body initializes the inner dimensions if any,
536 -- or else the single component. Note that this procedure is called
537 -- recursively, with N being the dimension to be initialized. A call
538 -- with N greater than the number of dimensions simply generates the
539 -- component initialization, terminating the recursion.
540
541 --------------------
542 -- Init_Component --
543 --------------------
544
545 function Init_Component return List_Id is
546 Comp : Node_Id;
547
548 begin
549 Comp :=
550 Make_Indexed_Component (Loc,
551 Prefix => Make_Identifier (Loc, Name_uInit),
552 Expressions => Index_List);
553
554 if Has_Default_Aspect (A_Type) then
555 Set_Assignment_OK (Comp);
556 return New_List (
557 Make_Assignment_Statement (Loc,
558 Name => Comp,
559 Expression =>
560 Convert_To (Comp_Type,
561 Default_Aspect_Component_Value (First_Subtype (A_Type)))));
562
563 elsif Needs_Simple_Initialization (Comp_Type) then
564 Set_Assignment_OK (Comp);
565 return New_List (
566 Make_Assignment_Statement (Loc,
567 Name => Comp,
568 Expression =>
569 Get_Simple_Init_Val
570 (Comp_Type, Nod, Component_Size (A_Type))));
571
572 else
573 Clean_Task_Names (Comp_Type, Proc_Id);
574 return
575 Build_Initialization_Call
576 (Loc, Comp, Comp_Type,
577 In_Init_Proc => True,
578 Enclos_Type => A_Type);
579 end if;
580 end Init_Component;
581
582 ------------------------
583 -- Init_One_Dimension --
584 ------------------------
585
586 function Init_One_Dimension (N : Int) return List_Id is
587 Index : Entity_Id;
588
589 begin
590 -- If the component does not need initializing, then there is nothing
591 -- to do here, so we return a null body. This occurs when generating
592 -- the dummy Init_Proc needed for Initialize_Scalars processing.
593
594 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
595 and then not Needs_Simple_Initialization (Comp_Type)
596 and then not Has_Task (Comp_Type)
597 and then not Has_Default_Aspect (A_Type)
598 then
599 return New_List (Make_Null_Statement (Loc));
600
601 -- If all dimensions dealt with, we simply initialize the component
602
603 elsif N > Number_Dimensions (A_Type) then
604 return Init_Component;
605
606 -- Here we generate the required loop
607
608 else
609 Index :=
610 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
611
612 Append (New_Occurrence_Of (Index, Loc), Index_List);
613
614 return New_List (
615 Make_Implicit_Loop_Statement (Nod,
616 Identifier => Empty,
617 Iteration_Scheme =>
618 Make_Iteration_Scheme (Loc,
619 Loop_Parameter_Specification =>
620 Make_Loop_Parameter_Specification (Loc,
621 Defining_Identifier => Index,
622 Discrete_Subtype_Definition =>
623 Make_Attribute_Reference (Loc,
624 Prefix =>
625 Make_Identifier (Loc, Name_uInit),
626 Attribute_Name => Name_Range,
627 Expressions => New_List (
628 Make_Integer_Literal (Loc, N))))),
629 Statements => Init_One_Dimension (N + 1)));
630 end if;
631 end Init_One_Dimension;
632
633 -- Start of processing for Build_Array_Init_Proc
634
635 begin
636 -- The init proc is created when analyzing the freeze node for the type,
637 -- but it properly belongs with the array type declaration. However, if
638 -- the freeze node is for a subtype of a type declared in another unit
639 -- it seems preferable to use the freeze node as the source location of
640 -- the init proc. In any case this is preferable for gcov usage, and
641 -- the Sloc is not otherwise used by the compiler.
642
643 if In_Open_Scopes (Scope (A_Type)) then
644 Loc := Sloc (A_Type);
645 else
646 Loc := Sloc (Nod);
647 end if;
648
649 -- Nothing to generate in the following cases:
650
651 -- 1. Initialization is suppressed for the type
652 -- 2. An initialization already exists for the base type
653
654 if Initialization_Suppressed (A_Type)
655 or else Present (Base_Init_Proc (A_Type))
656 then
657 return;
658 end if;
659
660 Index_List := New_List;
661
662 -- We need an initialization procedure if any of the following is true:
663
664 -- 1. The component type has an initialization procedure
665 -- 2. The component type needs simple initialization
666 -- 3. Tasks are present
667 -- 4. The type is marked as a public entity
668 -- 5. The array type has a Default_Component_Value aspect
669
670 -- The reason for the public entity test is to deal properly with the
671 -- Initialize_Scalars pragma. This pragma can be set in the client and
672 -- not in the declaring package, this means the client will make a call
673 -- to the initialization procedure (because one of conditions 1-3 must
674 -- apply in this case), and we must generate a procedure (even if it is
675 -- null) to satisfy the call in this case.
676
677 -- Exception: do not build an array init_proc for a type whose root
678 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
679 -- is no place to put the code, and in any case we handle initialization
680 -- of such types (in the Initialize_Scalars case, that's the only time
681 -- the issue arises) in a special manner anyway which does not need an
682 -- init_proc.
683
684 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
685 or else Needs_Simple_Initialization (Comp_Type)
686 or else Has_Task (Comp_Type)
687 or else Has_Default_Aspect (A_Type);
688
689 if Has_Default_Init
690 or else (not Restriction_Active (No_Initialize_Scalars)
691 and then Is_Public (A_Type)
692 and then not Is_Standard_String_Type (A_Type))
693 then
694 Proc_Id :=
695 Make_Defining_Identifier (Loc,
696 Chars => Make_Init_Proc_Name (A_Type));
697
698 -- If No_Default_Initialization restriction is active, then we don't
699 -- want to build an init_proc, but we need to mark that an init_proc
700 -- would be needed if this restriction was not active (so that we can
701 -- detect attempts to call it), so set a dummy init_proc in place.
702 -- This is only done though when actual default initialization is
703 -- needed (and not done when only Is_Public is True), since otherwise
704 -- objects such as arrays of scalars could be wrongly flagged as
705 -- violating the restriction.
706
707 if Restriction_Active (No_Default_Initialization) then
708 if Has_Default_Init then
709 Set_Init_Proc (A_Type, Proc_Id);
710 end if;
711
712 return;
713 end if;
714
715 Body_Stmts := Init_One_Dimension (1);
716
717 Discard_Node (
718 Make_Subprogram_Body (Loc,
719 Specification =>
720 Make_Procedure_Specification (Loc,
721 Defining_Unit_Name => Proc_Id,
722 Parameter_Specifications => Init_Formals (A_Type)),
723 Declarations => New_List,
724 Handled_Statement_Sequence =>
725 Make_Handled_Sequence_Of_Statements (Loc,
726 Statements => Body_Stmts)));
727
728 Set_Ekind (Proc_Id, E_Procedure);
729 Set_Is_Public (Proc_Id, Is_Public (A_Type));
730 Set_Is_Internal (Proc_Id);
731 Set_Has_Completion (Proc_Id);
732
733 if not Debug_Generated_Code then
734 Set_Debug_Info_Off (Proc_Id);
735 end if;
736
737 -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
738 -- component type itself (see also Build_Record_Init_Proc).
739
740 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
741
742 -- Associate Init_Proc with type, and determine if the procedure
743 -- is null (happens because of the Initialize_Scalars pragma case,
744 -- where we have to generate a null procedure in case it is called
745 -- by a client with Initialize_Scalars set). Such procedures have
746 -- to be generated, but do not have to be called, so we mark them
747 -- as null to suppress the call.
748
749 Set_Init_Proc (A_Type, Proc_Id);
750
751 if List_Length (Body_Stmts) = 1
752
753 -- We must skip SCIL nodes because they may have been added to this
754 -- list by Insert_Actions.
755
756 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
757 then
758 Set_Is_Null_Init_Proc (Proc_Id);
759
760 else
761 -- Try to build a static aggregate to statically initialize
762 -- objects of the type. This can only be done for constrained
763 -- one-dimensional arrays with static bounds.
764
765 Set_Static_Initialization
766 (Proc_Id,
767 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
768 end if;
769 end if;
770 end Build_Array_Init_Proc;
771
772 --------------------------------
773 -- Build_Discr_Checking_Funcs --
774 --------------------------------
775
776 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
777 Rec_Id : Entity_Id;
778 Loc : Source_Ptr;
779 Enclosing_Func_Id : Entity_Id;
780 Sequence : Nat := 1;
781 Type_Def : Node_Id;
782 V : Node_Id;
783
784 function Build_Case_Statement
785 (Case_Id : Entity_Id;
786 Variant : Node_Id) return Node_Id;
787 -- Build a case statement containing only two alternatives. The first
788 -- alternative corresponds exactly to the discrete choices given on the
789 -- variant with contains the components that we are generating the
790 -- checks for. If the discriminant is one of these return False. The
791 -- second alternative is an OTHERS choice that will return True
792 -- indicating the discriminant did not match.
793
794 function Build_Dcheck_Function
795 (Case_Id : Entity_Id;
796 Variant : Node_Id) return Entity_Id;
797 -- Build the discriminant checking function for a given variant
798
799 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
800 -- Builds the discriminant checking function for each variant of the
801 -- given variant part of the record type.
802
803 --------------------------
804 -- Build_Case_Statement --
805 --------------------------
806
807 function Build_Case_Statement
808 (Case_Id : Entity_Id;
809 Variant : Node_Id) return Node_Id
810 is
811 Alt_List : constant List_Id := New_List;
812 Actuals_List : List_Id;
813 Case_Node : Node_Id;
814 Case_Alt_Node : Node_Id;
815 Choice : Node_Id;
816 Choice_List : List_Id;
817 D : Entity_Id;
818 Return_Node : Node_Id;
819
820 begin
821 Case_Node := New_Node (N_Case_Statement, Loc);
822
823 -- Replace the discriminant which controls the variant with the name
824 -- of the formal of the checking function.
825
826 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
827
828 Choice := First (Discrete_Choices (Variant));
829
830 if Nkind (Choice) = N_Others_Choice then
831 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
832 else
833 Choice_List := New_Copy_List (Discrete_Choices (Variant));
834 end if;
835
836 if not Is_Empty_List (Choice_List) then
837 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
838 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
839
840 -- In case this is a nested variant, we need to return the result
841 -- of the discriminant checking function for the immediately
842 -- enclosing variant.
843
844 if Present (Enclosing_Func_Id) then
845 Actuals_List := New_List;
846
847 D := First_Discriminant (Rec_Id);
848 while Present (D) loop
849 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
850 Next_Discriminant (D);
851 end loop;
852
853 Return_Node :=
854 Make_Simple_Return_Statement (Loc,
855 Expression =>
856 Make_Function_Call (Loc,
857 Name =>
858 New_Occurrence_Of (Enclosing_Func_Id, Loc),
859 Parameter_Associations =>
860 Actuals_List));
861
862 else
863 Return_Node :=
864 Make_Simple_Return_Statement (Loc,
865 Expression =>
866 New_Occurrence_Of (Standard_False, Loc));
867 end if;
868
869 Set_Statements (Case_Alt_Node, New_List (Return_Node));
870 Append (Case_Alt_Node, Alt_List);
871 end if;
872
873 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
874 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
875 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
876
877 Return_Node :=
878 Make_Simple_Return_Statement (Loc,
879 Expression =>
880 New_Occurrence_Of (Standard_True, Loc));
881
882 Set_Statements (Case_Alt_Node, New_List (Return_Node));
883 Append (Case_Alt_Node, Alt_List);
884
885 Set_Alternatives (Case_Node, Alt_List);
886 return Case_Node;
887 end Build_Case_Statement;
888
889 ---------------------------
890 -- Build_Dcheck_Function --
891 ---------------------------
892
893 function Build_Dcheck_Function
894 (Case_Id : Entity_Id;
895 Variant : Node_Id) return Entity_Id
896 is
897 Body_Node : Node_Id;
898 Func_Id : Entity_Id;
899 Parameter_List : List_Id;
900 Spec_Node : Node_Id;
901
902 begin
903 Body_Node := New_Node (N_Subprogram_Body, Loc);
904 Sequence := Sequence + 1;
905
906 Func_Id :=
907 Make_Defining_Identifier (Loc,
908 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
909 Set_Is_Discriminant_Check_Function (Func_Id);
910
911 Spec_Node := New_Node (N_Function_Specification, Loc);
912 Set_Defining_Unit_Name (Spec_Node, Func_Id);
913
914 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
915
916 Set_Parameter_Specifications (Spec_Node, Parameter_List);
917 Set_Result_Definition (Spec_Node,
918 New_Occurrence_Of (Standard_Boolean, Loc));
919 Set_Specification (Body_Node, Spec_Node);
920 Set_Declarations (Body_Node, New_List);
921
922 Set_Handled_Statement_Sequence (Body_Node,
923 Make_Handled_Sequence_Of_Statements (Loc,
924 Statements => New_List (
925 Build_Case_Statement (Case_Id, Variant))));
926
927 Set_Ekind (Func_Id, E_Function);
928 Set_Mechanism (Func_Id, Default_Mechanism);
929 Set_Is_Inlined (Func_Id, True);
930 Set_Is_Pure (Func_Id, True);
931 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
932 Set_Is_Internal (Func_Id, True);
933
934 if not Debug_Generated_Code then
935 Set_Debug_Info_Off (Func_Id);
936 end if;
937
938 Analyze (Body_Node);
939
940 Append_Freeze_Action (Rec_Id, Body_Node);
941 Set_Dcheck_Function (Variant, Func_Id);
942 return Func_Id;
943 end Build_Dcheck_Function;
944
945 ----------------------------
946 -- Build_Dcheck_Functions --
947 ----------------------------
948
949 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
950 Component_List_Node : Node_Id;
951 Decl : Entity_Id;
952 Discr_Name : Entity_Id;
953 Func_Id : Entity_Id;
954 Variant : Node_Id;
955 Saved_Enclosing_Func_Id : Entity_Id;
956
957 begin
958 -- Build the discriminant-checking function for each variant, and
959 -- label all components of that variant with the function's name.
960 -- We only Generate a discriminant-checking function when the
961 -- variant is not empty, to prevent the creation of dead code.
962 -- The exception to that is when Frontend_Layout_On_Target is set,
963 -- because the variant record size function generated in package
964 -- Layout needs to generate calls to all discriminant-checking
965 -- functions, including those for empty variants.
966
967 Discr_Name := Entity (Name (Variant_Part_Node));
968 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
969
970 while Present (Variant) loop
971 Component_List_Node := Component_List (Variant);
972
973 if not Null_Present (Component_List_Node)
974 or else Frontend_Layout_On_Target
975 then
976 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
977
978 Decl :=
979 First_Non_Pragma (Component_Items (Component_List_Node));
980 while Present (Decl) loop
981 Set_Discriminant_Checking_Func
982 (Defining_Identifier (Decl), Func_Id);
983 Next_Non_Pragma (Decl);
984 end loop;
985
986 if Present (Variant_Part (Component_List_Node)) then
987 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
988 Enclosing_Func_Id := Func_Id;
989 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
990 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
991 end if;
992 end if;
993
994 Next_Non_Pragma (Variant);
995 end loop;
996 end Build_Dcheck_Functions;
997
998 -- Start of processing for Build_Discr_Checking_Funcs
999
1000 begin
1001 -- Only build if not done already
1002
1003 if not Discr_Check_Funcs_Built (N) then
1004 Type_Def := Type_Definition (N);
1005
1006 if Nkind (Type_Def) = N_Record_Definition then
1007 if No (Component_List (Type_Def)) then -- null record.
1008 return;
1009 else
1010 V := Variant_Part (Component_List (Type_Def));
1011 end if;
1012
1013 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1014 if No (Component_List (Record_Extension_Part (Type_Def))) then
1015 return;
1016 else
1017 V := Variant_Part
1018 (Component_List (Record_Extension_Part (Type_Def)));
1019 end if;
1020 end if;
1021
1022 Rec_Id := Defining_Identifier (N);
1023
1024 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1025 Loc := Sloc (N);
1026 Enclosing_Func_Id := Empty;
1027 Build_Dcheck_Functions (V);
1028 end if;
1029
1030 Set_Discr_Check_Funcs_Built (N);
1031 end if;
1032 end Build_Discr_Checking_Funcs;
1033
1034 --------------------------------
1035 -- Build_Discriminant_Formals --
1036 --------------------------------
1037
1038 function Build_Discriminant_Formals
1039 (Rec_Id : Entity_Id;
1040 Use_Dl : Boolean) return List_Id
1041 is
1042 Loc : Source_Ptr := Sloc (Rec_Id);
1043 Parameter_List : constant List_Id := New_List;
1044 D : Entity_Id;
1045 Formal : Entity_Id;
1046 Formal_Type : Entity_Id;
1047 Param_Spec_Node : Node_Id;
1048
1049 begin
1050 if Has_Discriminants (Rec_Id) then
1051 D := First_Discriminant (Rec_Id);
1052 while Present (D) loop
1053 Loc := Sloc (D);
1054
1055 if Use_Dl then
1056 Formal := Discriminal (D);
1057 Formal_Type := Etype (Formal);
1058 else
1059 Formal := Make_Defining_Identifier (Loc, Chars (D));
1060 Formal_Type := Etype (D);
1061 end if;
1062
1063 Param_Spec_Node :=
1064 Make_Parameter_Specification (Loc,
1065 Defining_Identifier => Formal,
1066 Parameter_Type =>
1067 New_Occurrence_Of (Formal_Type, Loc));
1068 Append (Param_Spec_Node, Parameter_List);
1069 Next_Discriminant (D);
1070 end loop;
1071 end if;
1072
1073 return Parameter_List;
1074 end Build_Discriminant_Formals;
1075
1076 --------------------------------------
1077 -- Build_Equivalent_Array_Aggregate --
1078 --------------------------------------
1079
1080 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1081 Loc : constant Source_Ptr := Sloc (T);
1082 Comp_Type : constant Entity_Id := Component_Type (T);
1083 Index_Type : constant Entity_Id := Etype (First_Index (T));
1084 Proc : constant Entity_Id := Base_Init_Proc (T);
1085 Lo, Hi : Node_Id;
1086 Aggr : Node_Id;
1087 Expr : Node_Id;
1088
1089 begin
1090 if not Is_Constrained (T)
1091 or else Number_Dimensions (T) > 1
1092 or else No (Proc)
1093 then
1094 Initialization_Warning (T);
1095 return Empty;
1096 end if;
1097
1098 Lo := Type_Low_Bound (Index_Type);
1099 Hi := Type_High_Bound (Index_Type);
1100
1101 if not Compile_Time_Known_Value (Lo)
1102 or else not Compile_Time_Known_Value (Hi)
1103 then
1104 Initialization_Warning (T);
1105 return Empty;
1106 end if;
1107
1108 if Is_Record_Type (Comp_Type)
1109 and then Present (Base_Init_Proc (Comp_Type))
1110 then
1111 Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1112
1113 if No (Expr) then
1114 Initialization_Warning (T);
1115 return Empty;
1116 end if;
1117
1118 else
1119 Initialization_Warning (T);
1120 return Empty;
1121 end if;
1122
1123 Aggr := Make_Aggregate (Loc, No_List, New_List);
1124 Set_Etype (Aggr, T);
1125 Set_Aggregate_Bounds (Aggr,
1126 Make_Range (Loc,
1127 Low_Bound => New_Copy (Lo),
1128 High_Bound => New_Copy (Hi)));
1129 Set_Parent (Aggr, Parent (Proc));
1130
1131 Append_To (Component_Associations (Aggr),
1132 Make_Component_Association (Loc,
1133 Choices =>
1134 New_List (
1135 Make_Range (Loc,
1136 Low_Bound => New_Copy (Lo),
1137 High_Bound => New_Copy (Hi))),
1138 Expression => Expr));
1139
1140 if Static_Array_Aggregate (Aggr) then
1141 return Aggr;
1142 else
1143 Initialization_Warning (T);
1144 return Empty;
1145 end if;
1146 end Build_Equivalent_Array_Aggregate;
1147
1148 ---------------------------------------
1149 -- Build_Equivalent_Record_Aggregate --
1150 ---------------------------------------
1151
1152 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1153 Agg : Node_Id;
1154 Comp : Entity_Id;
1155 Comp_Type : Entity_Id;
1156
1157 -- Start of processing for Build_Equivalent_Record_Aggregate
1158
1159 begin
1160 if not Is_Record_Type (T)
1161 or else Has_Discriminants (T)
1162 or else Is_Limited_Type (T)
1163 or else Has_Non_Standard_Rep (T)
1164 then
1165 Initialization_Warning (T);
1166 return Empty;
1167 end if;
1168
1169 Comp := First_Component (T);
1170
1171 -- A null record needs no warning
1172
1173 if No (Comp) then
1174 return Empty;
1175 end if;
1176
1177 while Present (Comp) loop
1178
1179 -- Array components are acceptable if initialized by a positional
1180 -- aggregate with static components.
1181
1182 if Is_Array_Type (Etype (Comp)) then
1183 Comp_Type := Component_Type (Etype (Comp));
1184
1185 if Nkind (Parent (Comp)) /= N_Component_Declaration
1186 or else No (Expression (Parent (Comp)))
1187 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1188 then
1189 Initialization_Warning (T);
1190 return Empty;
1191
1192 elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1193 and then
1194 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1195 or else
1196 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1197 then
1198 Initialization_Warning (T);
1199 return Empty;
1200
1201 elsif
1202 not Static_Array_Aggregate (Expression (Parent (Comp)))
1203 then
1204 Initialization_Warning (T);
1205 return Empty;
1206 end if;
1207
1208 elsif Is_Scalar_Type (Etype (Comp)) then
1209 Comp_Type := Etype (Comp);
1210
1211 if Nkind (Parent (Comp)) /= N_Component_Declaration
1212 or else No (Expression (Parent (Comp)))
1213 or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1214 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1215 or else not
1216 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1217 then
1218 Initialization_Warning (T);
1219 return Empty;
1220 end if;
1221
1222 -- For now, other types are excluded
1223
1224 else
1225 Initialization_Warning (T);
1226 return Empty;
1227 end if;
1228
1229 Next_Component (Comp);
1230 end loop;
1231
1232 -- All components have static initialization. Build positional aggregate
1233 -- from the given expressions or defaults.
1234
1235 Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1236 Set_Parent (Agg, Parent (T));
1237
1238 Comp := First_Component (T);
1239 while Present (Comp) loop
1240 Append
1241 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1242 Next_Component (Comp);
1243 end loop;
1244
1245 Analyze_And_Resolve (Agg, T);
1246 return Agg;
1247 end Build_Equivalent_Record_Aggregate;
1248
1249 -------------------------------
1250 -- Build_Initialization_Call --
1251 -------------------------------
1252
1253 -- References to a discriminant inside the record type declaration can
1254 -- appear either in the subtype_indication to constrain a record or an
1255 -- array, or as part of a larger expression given for the initial value
1256 -- of a component. In both of these cases N appears in the record
1257 -- initialization procedure and needs to be replaced by the formal
1258 -- parameter of the initialization procedure which corresponds to that
1259 -- discriminant.
1260
1261 -- In the example below, references to discriminants D1 and D2 in proc_1
1262 -- are replaced by references to formals with the same name
1263 -- (discriminals)
1264
1265 -- A similar replacement is done for calls to any record initialization
1266 -- procedure for any components that are themselves of a record type.
1267
1268 -- type R (D1, D2 : Integer) is record
1269 -- X : Integer := F * D1;
1270 -- Y : Integer := F * D2;
1271 -- end record;
1272
1273 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1274 -- begin
1275 -- Out_2.D1 := D1;
1276 -- Out_2.D2 := D2;
1277 -- Out_2.X := F * D1;
1278 -- Out_2.Y := F * D2;
1279 -- end;
1280
1281 function Build_Initialization_Call
1282 (Loc : Source_Ptr;
1283 Id_Ref : Node_Id;
1284 Typ : Entity_Id;
1285 In_Init_Proc : Boolean := False;
1286 Enclos_Type : Entity_Id := Empty;
1287 Discr_Map : Elist_Id := New_Elmt_List;
1288 With_Default_Init : Boolean := False;
1289 Constructor_Ref : Node_Id := Empty) return List_Id
1290 is
1291 Res : constant List_Id := New_List;
1292 Arg : Node_Id;
1293 Args : List_Id;
1294 Decls : List_Id;
1295 Decl : Node_Id;
1296 Discr : Entity_Id;
1297 First_Arg : Node_Id;
1298 Full_Init_Type : Entity_Id;
1299 Full_Type : Entity_Id;
1300 Init_Type : Entity_Id;
1301 Proc : Entity_Id;
1302
1303 begin
1304 pragma Assert (Constructor_Ref = Empty
1305 or else Is_CPP_Constructor_Call (Constructor_Ref));
1306
1307 if No (Constructor_Ref) then
1308 Proc := Base_Init_Proc (Typ);
1309 else
1310 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1311 end if;
1312
1313 pragma Assert (Present (Proc));
1314 Init_Type := Etype (First_Formal (Proc));
1315 Full_Init_Type := Underlying_Type (Init_Type);
1316
1317 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1318 -- is active (in which case we make the call anyway, since in the
1319 -- actual compiled client it may be non null).
1320
1321 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1322 return Empty_List;
1323 end if;
1324
1325 -- Use the [underlying] full view when dealing with a private type. This
1326 -- may require several steps depending on derivations.
1327
1328 Full_Type := Typ;
1329 loop
1330 if Is_Private_Type (Full_Type) then
1331 if Present (Full_View (Full_Type)) then
1332 Full_Type := Full_View (Full_Type);
1333
1334 elsif Present (Underlying_Full_View (Full_Type)) then
1335 Full_Type := Underlying_Full_View (Full_Type);
1336
1337 -- When a private type acts as a generic actual and lacks a full
1338 -- view, use the base type.
1339
1340 elsif Is_Generic_Actual_Type (Full_Type) then
1341 Full_Type := Base_Type (Full_Type);
1342
1343 -- The loop has recovered the [underlying] full view, stop the
1344 -- traversal.
1345
1346 else
1347 exit;
1348 end if;
1349
1350 -- The type is not private, nothing to do
1351
1352 else
1353 exit;
1354 end if;
1355 end loop;
1356
1357 -- If Typ is derived, the procedure is the initialization procedure for
1358 -- the root type. Wrap the argument in an conversion to make it type
1359 -- honest. Actually it isn't quite type honest, because there can be
1360 -- conflicts of views in the private type case. That is why we set
1361 -- Conversion_OK in the conversion node.
1362
1363 if (Is_Record_Type (Typ)
1364 or else Is_Array_Type (Typ)
1365 or else Is_Private_Type (Typ))
1366 and then Init_Type /= Base_Type (Typ)
1367 then
1368 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1369 Set_Etype (First_Arg, Init_Type);
1370
1371 else
1372 First_Arg := Id_Ref;
1373 end if;
1374
1375 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1376
1377 -- In the tasks case, add _Master as the value of the _Master parameter
1378 -- and _Chain as the value of the _Chain parameter. At the outer level,
1379 -- these will be variables holding the corresponding values obtained
1380 -- from GNARL. At inner levels, they will be the parameters passed down
1381 -- through the outer routines.
1382
1383 if Has_Task (Full_Type) then
1384 if Restriction_Active (No_Task_Hierarchy) then
1385 Append_To (Args,
1386 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1387 else
1388 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1389 end if;
1390
1391 -- Add _Chain (not done for sequential elaboration policy, see
1392 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1393
1394 if Partition_Elaboration_Policy /= 'S' then
1395 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1396 end if;
1397
1398 -- Ada 2005 (AI-287): In case of default initialized components
1399 -- with tasks, we generate a null string actual parameter.
1400 -- This is just a workaround that must be improved later???
1401
1402 if With_Default_Init then
1403 Append_To (Args,
1404 Make_String_Literal (Loc,
1405 Strval => ""));
1406
1407 else
1408 Decls :=
1409 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1410 Decl := Last (Decls);
1411
1412 Append_To (Args,
1413 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1414 Append_List (Decls, Res);
1415 end if;
1416
1417 else
1418 Decls := No_List;
1419 Decl := Empty;
1420 end if;
1421
1422 -- Add discriminant values if discriminants are present
1423
1424 if Has_Discriminants (Full_Init_Type) then
1425 Discr := First_Discriminant (Full_Init_Type);
1426 while Present (Discr) loop
1427
1428 -- If this is a discriminated concurrent type, the init_proc
1429 -- for the corresponding record is being called. Use that type
1430 -- directly to find the discriminant value, to handle properly
1431 -- intervening renamed discriminants.
1432
1433 declare
1434 T : Entity_Id := Full_Type;
1435
1436 begin
1437 if Is_Protected_Type (T) then
1438 T := Corresponding_Record_Type (T);
1439 end if;
1440
1441 Arg :=
1442 Get_Discriminant_Value (
1443 Discr,
1444 T,
1445 Discriminant_Constraint (Full_Type));
1446 end;
1447
1448 -- If the target has access discriminants, and is constrained by
1449 -- an access to the enclosing construct, i.e. a current instance,
1450 -- replace the reference to the type by a reference to the object.
1451
1452 if Nkind (Arg) = N_Attribute_Reference
1453 and then Is_Access_Type (Etype (Arg))
1454 and then Is_Entity_Name (Prefix (Arg))
1455 and then Is_Type (Entity (Prefix (Arg)))
1456 then
1457 Arg :=
1458 Make_Attribute_Reference (Loc,
1459 Prefix => New_Copy (Prefix (Id_Ref)),
1460 Attribute_Name => Name_Unrestricted_Access);
1461
1462 elsif In_Init_Proc then
1463
1464 -- Replace any possible references to the discriminant in the
1465 -- call to the record initialization procedure with references
1466 -- to the appropriate formal parameter.
1467
1468 if Nkind (Arg) = N_Identifier
1469 and then Ekind (Entity (Arg)) = E_Discriminant
1470 then
1471 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
1472
1473 -- Otherwise make a copy of the default expression. Note that
1474 -- we use the current Sloc for this, because we do not want the
1475 -- call to appear to be at the declaration point. Within the
1476 -- expression, replace discriminants with their discriminals.
1477
1478 else
1479 Arg :=
1480 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1481 end if;
1482
1483 else
1484 if Is_Constrained (Full_Type) then
1485 Arg := Duplicate_Subexpr_No_Checks (Arg);
1486 else
1487 -- The constraints come from the discriminant default exps,
1488 -- they must be reevaluated, so we use New_Copy_Tree but we
1489 -- ensure the proper Sloc (for any embedded calls).
1490
1491 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1492 end if;
1493 end if;
1494
1495 -- Ada 2005 (AI-287): In case of default initialized components,
1496 -- if the component is constrained with a discriminant of the
1497 -- enclosing type, we need to generate the corresponding selected
1498 -- component node to access the discriminant value. In other cases
1499 -- this is not required, either because we are inside the init
1500 -- proc and we use the corresponding formal, or else because the
1501 -- component is constrained by an expression.
1502
1503 if With_Default_Init
1504 and then Nkind (Id_Ref) = N_Selected_Component
1505 and then Nkind (Arg) = N_Identifier
1506 and then Ekind (Entity (Arg)) = E_Discriminant
1507 then
1508 Append_To (Args,
1509 Make_Selected_Component (Loc,
1510 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1511 Selector_Name => Arg));
1512 else
1513 Append_To (Args, Arg);
1514 end if;
1515
1516 Next_Discriminant (Discr);
1517 end loop;
1518 end if;
1519
1520 -- If this is a call to initialize the parent component of a derived
1521 -- tagged type, indicate that the tag should not be set in the parent.
1522
1523 if Is_Tagged_Type (Full_Init_Type)
1524 and then not Is_CPP_Class (Full_Init_Type)
1525 and then Nkind (Id_Ref) = N_Selected_Component
1526 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1527 then
1528 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1529
1530 elsif Present (Constructor_Ref) then
1531 Append_List_To (Args,
1532 New_Copy_List (Parameter_Associations (Constructor_Ref)));
1533 end if;
1534
1535 Append_To (Res,
1536 Make_Procedure_Call_Statement (Loc,
1537 Name => New_Occurrence_Of (Proc, Loc),
1538 Parameter_Associations => Args));
1539
1540 if Needs_Finalization (Typ)
1541 and then Nkind (Id_Ref) = N_Selected_Component
1542 then
1543 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1544 Append_To (Res,
1545 Make_Init_Call
1546 (Obj_Ref => New_Copy_Tree (First_Arg),
1547 Typ => Typ));
1548 end if;
1549 end if;
1550
1551 return Res;
1552
1553 exception
1554 when RE_Not_Available =>
1555 return Empty_List;
1556 end Build_Initialization_Call;
1557
1558 ----------------------------
1559 -- Build_Record_Init_Proc --
1560 ----------------------------
1561
1562 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1563 Decls : constant List_Id := New_List;
1564 Discr_Map : constant Elist_Id := New_Elmt_List;
1565 Loc : constant Source_Ptr := Sloc (Rec_Ent);
1566 Counter : Nat := 0;
1567 Proc_Id : Entity_Id;
1568 Rec_Type : Entity_Id;
1569 Set_Tag : Entity_Id := Empty;
1570
1571 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1572 -- Build an assignment statement which assigns the default expression
1573 -- to its corresponding record component if defined. The left hand side
1574 -- of the assignment is marked Assignment_OK so that initialization of
1575 -- limited private records works correctly. This routine may also build
1576 -- an adjustment call if the component is controlled.
1577
1578 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1579 -- If the record has discriminants, add assignment statements to
1580 -- Statement_List to initialize the discriminant values from the
1581 -- arguments of the initialization procedure.
1582
1583 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1584 -- Build a list representing a sequence of statements which initialize
1585 -- components of the given component list. This may involve building
1586 -- case statements for the variant parts. Append any locally declared
1587 -- objects on list Decls.
1588
1589 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1590 -- Given an untagged type-derivation that declares discriminants, e.g.
1591 --
1592 -- type R (R1, R2 : Integer) is record ... end record;
1593 -- type D (D1 : Integer) is new R (1, D1);
1594 --
1595 -- we make the _init_proc of D be
1596 --
1597 -- procedure _init_proc (X : D; D1 : Integer) is
1598 -- begin
1599 -- _init_proc (R (X), 1, D1);
1600 -- end _init_proc;
1601 --
1602 -- This function builds the call statement in this _init_proc.
1603
1604 procedure Build_CPP_Init_Procedure;
1605 -- Build the tree corresponding to the procedure specification and body
1606 -- of the IC procedure that initializes the C++ part of the dispatch
1607 -- table of an Ada tagged type that is a derivation of a CPP type.
1608 -- Install it as the CPP_Init TSS.
1609
1610 procedure Build_Init_Procedure;
1611 -- Build the tree corresponding to the procedure specification and body
1612 -- of the initialization procedure and install it as the _init TSS.
1613
1614 procedure Build_Offset_To_Top_Functions;
1615 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1616 -- and body of Offset_To_Top, a function used in conjuction with types
1617 -- having secondary dispatch tables.
1618
1619 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1620 -- Add range checks to components of discriminated records. S is a
1621 -- subtype indication of a record component. Check_List is a list
1622 -- to which the check actions are appended.
1623
1624 function Component_Needs_Simple_Initialization
1625 (T : Entity_Id) return Boolean;
1626 -- Determine if a component needs simple initialization, given its type
1627 -- T. This routine is the same as Needs_Simple_Initialization except for
1628 -- components of type Tag and Interface_Tag. These two access types do
1629 -- not require initialization since they are explicitly initialized by
1630 -- other means.
1631
1632 function Parent_Subtype_Renaming_Discrims return Boolean;
1633 -- Returns True for base types N that rename discriminants, else False
1634
1635 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1636 -- Determine whether a record initialization procedure needs to be
1637 -- generated for the given record type.
1638
1639 ----------------------
1640 -- Build_Assignment --
1641 ----------------------
1642
1643 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1644 N_Loc : constant Source_Ptr := Sloc (N);
1645 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1646 Exp : Node_Id := N;
1647 Kind : Node_Kind := Nkind (N);
1648 Lhs : Node_Id;
1649 Res : List_Id;
1650
1651 begin
1652 Lhs :=
1653 Make_Selected_Component (N_Loc,
1654 Prefix => Make_Identifier (Loc, Name_uInit),
1655 Selector_Name => New_Occurrence_Of (Id, N_Loc));
1656 Set_Assignment_OK (Lhs);
1657
1658 -- Case of an access attribute applied to the current instance.
1659 -- Replace the reference to the type by a reference to the actual
1660 -- object. (Note that this handles the case of the top level of
1661 -- the expression being given by such an attribute, but does not
1662 -- cover uses nested within an initial value expression. Nested
1663 -- uses are unlikely to occur in practice, but are theoretically
1664 -- possible.) It is not clear how to handle them without fully
1665 -- traversing the expression. ???
1666
1667 if Kind = N_Attribute_Reference
1668 and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
1669 Name_Unrestricted_Access)
1670 and then Is_Entity_Name (Prefix (N))
1671 and then Is_Type (Entity (Prefix (N)))
1672 and then Entity (Prefix (N)) = Rec_Type
1673 then
1674 Exp :=
1675 Make_Attribute_Reference (N_Loc,
1676 Prefix =>
1677 Make_Identifier (N_Loc, Name_uInit),
1678 Attribute_Name => Name_Unrestricted_Access);
1679 end if;
1680
1681 -- Take a copy of Exp to ensure that later copies of this component
1682 -- declaration in derived types see the original tree, not a node
1683 -- rewritten during expansion of the init_proc. If the copy contains
1684 -- itypes, the scope of the new itypes is the init_proc being built.
1685
1686 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1687
1688 Res := New_List (
1689 Make_Assignment_Statement (Loc,
1690 Name => Lhs,
1691 Expression => Exp));
1692
1693 Set_No_Ctrl_Actions (First (Res));
1694
1695 -- Adjust the tag if tagged (because of possible view conversions).
1696 -- Suppress the tag adjustment when not Tagged_Type_Expansion because
1697 -- tags are represented implicitly in objects.
1698
1699 if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
1700 Append_To (Res,
1701 Make_Assignment_Statement (N_Loc,
1702 Name =>
1703 Make_Selected_Component (N_Loc,
1704 Prefix =>
1705 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1706 Selector_Name =>
1707 New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
1708
1709 Expression =>
1710 Unchecked_Convert_To (RTE (RE_Tag),
1711 New_Occurrence_Of
1712 (Node
1713 (First_Elmt
1714 (Access_Disp_Table (Underlying_Type (Typ)))),
1715 N_Loc))));
1716 end if;
1717
1718 -- Adjust the component if controlled except if it is an aggregate
1719 -- that will be expanded inline.
1720
1721 if Kind = N_Qualified_Expression then
1722 Kind := Nkind (Expression (N));
1723 end if;
1724
1725 if Needs_Finalization (Typ)
1726 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1727 and then not Is_Limited_View (Typ)
1728 then
1729 Append_To (Res,
1730 Make_Adjust_Call
1731 (Obj_Ref => New_Copy_Tree (Lhs),
1732 Typ => Etype (Id)));
1733 end if;
1734
1735 return Res;
1736
1737 exception
1738 when RE_Not_Available =>
1739 return Empty_List;
1740 end Build_Assignment;
1741
1742 ------------------------------------
1743 -- Build_Discriminant_Assignments --
1744 ------------------------------------
1745
1746 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1747 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1748 D : Entity_Id;
1749 D_Loc : Source_Ptr;
1750
1751 begin
1752 if Has_Discriminants (Rec_Type)
1753 and then not Is_Unchecked_Union (Rec_Type)
1754 then
1755 D := First_Discriminant (Rec_Type);
1756 while Present (D) loop
1757
1758 -- Don't generate the assignment for discriminants in derived
1759 -- tagged types if the discriminant is a renaming of some
1760 -- ancestor discriminant. This initialization will be done
1761 -- when initializing the _parent field of the derived record.
1762
1763 if Is_Tagged
1764 and then Present (Corresponding_Discriminant (D))
1765 then
1766 null;
1767
1768 else
1769 D_Loc := Sloc (D);
1770 Append_List_To (Statement_List,
1771 Build_Assignment (D,
1772 New_Occurrence_Of (Discriminal (D), D_Loc)));
1773 end if;
1774
1775 Next_Discriminant (D);
1776 end loop;
1777 end if;
1778 end Build_Discriminant_Assignments;
1779
1780 --------------------------
1781 -- Build_Init_Call_Thru --
1782 --------------------------
1783
1784 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1785 Parent_Proc : constant Entity_Id :=
1786 Base_Init_Proc (Etype (Rec_Type));
1787
1788 Parent_Type : constant Entity_Id :=
1789 Etype (First_Formal (Parent_Proc));
1790
1791 Uparent_Type : constant Entity_Id :=
1792 Underlying_Type (Parent_Type);
1793
1794 First_Discr_Param : Node_Id;
1795
1796 Arg : Node_Id;
1797 Args : List_Id;
1798 First_Arg : Node_Id;
1799 Parent_Discr : Entity_Id;
1800 Res : List_Id;
1801
1802 begin
1803 -- First argument (_Init) is the object to be initialized.
1804 -- ??? not sure where to get a reasonable Loc for First_Arg
1805
1806 First_Arg :=
1807 OK_Convert_To (Parent_Type,
1808 New_Occurrence_Of
1809 (Defining_Identifier (First (Parameters)), Loc));
1810
1811 Set_Etype (First_Arg, Parent_Type);
1812
1813 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1814
1815 -- In the tasks case,
1816 -- add _Master as the value of the _Master parameter
1817 -- add _Chain as the value of the _Chain parameter.
1818 -- add _Task_Name as the value of the _Task_Name parameter.
1819 -- At the outer level, these will be variables holding the
1820 -- corresponding values obtained from GNARL or the expander.
1821 --
1822 -- At inner levels, they will be the parameters passed down through
1823 -- the outer routines.
1824
1825 First_Discr_Param := Next (First (Parameters));
1826
1827 if Has_Task (Rec_Type) then
1828 if Restriction_Active (No_Task_Hierarchy) then
1829 Append_To (Args,
1830 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1831 else
1832 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1833 end if;
1834
1835 -- Add _Chain (not done for sequential elaboration policy, see
1836 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
1837
1838 if Partition_Elaboration_Policy /= 'S' then
1839 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1840 end if;
1841
1842 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
1843 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
1844 end if;
1845
1846 -- Append discriminant values
1847
1848 if Has_Discriminants (Uparent_Type) then
1849 pragma Assert (not Is_Tagged_Type (Uparent_Type));
1850
1851 Parent_Discr := First_Discriminant (Uparent_Type);
1852 while Present (Parent_Discr) loop
1853
1854 -- Get the initial value for this discriminant
1855 -- ??? needs to be cleaned up to use parent_Discr_Constr
1856 -- directly.
1857
1858 declare
1859 Discr : Entity_Id :=
1860 First_Stored_Discriminant (Uparent_Type);
1861
1862 Discr_Value : Elmt_Id :=
1863 First_Elmt (Stored_Constraint (Rec_Type));
1864
1865 begin
1866 while Original_Record_Component (Parent_Discr) /= Discr loop
1867 Next_Stored_Discriminant (Discr);
1868 Next_Elmt (Discr_Value);
1869 end loop;
1870
1871 Arg := Node (Discr_Value);
1872 end;
1873
1874 -- Append it to the list
1875
1876 if Nkind (Arg) = N_Identifier
1877 and then Ekind (Entity (Arg)) = E_Discriminant
1878 then
1879 Append_To (Args,
1880 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
1881
1882 -- Case of access discriminants. We replace the reference
1883 -- to the type by a reference to the actual object.
1884
1885 -- Is above comment right??? Use of New_Copy below seems mighty
1886 -- suspicious ???
1887
1888 else
1889 Append_To (Args, New_Copy (Arg));
1890 end if;
1891
1892 Next_Discriminant (Parent_Discr);
1893 end loop;
1894 end if;
1895
1896 Res :=
1897 New_List (
1898 Make_Procedure_Call_Statement (Loc,
1899 Name =>
1900 New_Occurrence_Of (Parent_Proc, Loc),
1901 Parameter_Associations => Args));
1902
1903 return Res;
1904 end Build_Init_Call_Thru;
1905
1906 -----------------------------------
1907 -- Build_Offset_To_Top_Functions --
1908 -----------------------------------
1909
1910 procedure Build_Offset_To_Top_Functions is
1911
1912 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
1913 -- Generate:
1914 -- function Fxx (O : Address) return Storage_Offset is
1915 -- type Acc is access all <Typ>;
1916 -- begin
1917 -- return Acc!(O).Iface_Comp'Position;
1918 -- end Fxx;
1919
1920 ----------------------------------
1921 -- Build_Offset_To_Top_Function --
1922 ----------------------------------
1923
1924 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
1925 Body_Node : Node_Id;
1926 Func_Id : Entity_Id;
1927 Spec_Node : Node_Id;
1928 Acc_Type : Entity_Id;
1929
1930 begin
1931 Func_Id := Make_Temporary (Loc, 'F');
1932 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
1933
1934 -- Generate
1935 -- function Fxx (O : in Rec_Typ) return Storage_Offset;
1936
1937 Spec_Node := New_Node (N_Function_Specification, Loc);
1938 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1939 Set_Parameter_Specifications (Spec_Node, New_List (
1940 Make_Parameter_Specification (Loc,
1941 Defining_Identifier =>
1942 Make_Defining_Identifier (Loc, Name_uO),
1943 In_Present => True,
1944 Parameter_Type =>
1945 New_Occurrence_Of (RTE (RE_Address), Loc))));
1946 Set_Result_Definition (Spec_Node,
1947 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1948
1949 -- Generate
1950 -- function Fxx (O : in Rec_Typ) return Storage_Offset is
1951 -- begin
1952 -- return O.Iface_Comp'Position;
1953 -- end Fxx;
1954
1955 Body_Node := New_Node (N_Subprogram_Body, Loc);
1956 Set_Specification (Body_Node, Spec_Node);
1957
1958 Acc_Type := Make_Temporary (Loc, 'T');
1959 Set_Declarations (Body_Node, New_List (
1960 Make_Full_Type_Declaration (Loc,
1961 Defining_Identifier => Acc_Type,
1962 Type_Definition =>
1963 Make_Access_To_Object_Definition (Loc,
1964 All_Present => True,
1965 Null_Exclusion_Present => False,
1966 Constant_Present => False,
1967 Subtype_Indication =>
1968 New_Occurrence_Of (Rec_Type, Loc)))));
1969
1970 Set_Handled_Statement_Sequence (Body_Node,
1971 Make_Handled_Sequence_Of_Statements (Loc,
1972 Statements => New_List (
1973 Make_Simple_Return_Statement (Loc,
1974 Expression =>
1975 Make_Attribute_Reference (Loc,
1976 Prefix =>
1977 Make_Selected_Component (Loc,
1978 Prefix =>
1979 Unchecked_Convert_To (Acc_Type,
1980 Make_Identifier (Loc, Name_uO)),
1981 Selector_Name =>
1982 New_Occurrence_Of (Iface_Comp, Loc)),
1983 Attribute_Name => Name_Position)))));
1984
1985 Set_Ekind (Func_Id, E_Function);
1986 Set_Mechanism (Func_Id, Default_Mechanism);
1987 Set_Is_Internal (Func_Id, True);
1988
1989 if not Debug_Generated_Code then
1990 Set_Debug_Info_Off (Func_Id);
1991 end if;
1992
1993 Analyze (Body_Node);
1994
1995 Append_Freeze_Action (Rec_Type, Body_Node);
1996 end Build_Offset_To_Top_Function;
1997
1998 -- Local variables
1999
2000 Iface_Comp : Node_Id;
2001 Iface_Comp_Elmt : Elmt_Id;
2002 Ifaces_Comp_List : Elist_Id;
2003
2004 -- Start of processing for Build_Offset_To_Top_Functions
2005
2006 begin
2007 -- Offset_To_Top_Functions are built only for derivations of types
2008 -- with discriminants that cover interface types.
2009 -- Nothing is needed either in case of virtual targets, since
2010 -- interfaces are handled directly by the target.
2011
2012 if not Is_Tagged_Type (Rec_Type)
2013 or else Etype (Rec_Type) = Rec_Type
2014 or else not Has_Discriminants (Etype (Rec_Type))
2015 or else not Tagged_Type_Expansion
2016 then
2017 return;
2018 end if;
2019
2020 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
2021
2022 -- For each interface type with secondary dispatch table we generate
2023 -- the Offset_To_Top_Functions (required to displace the pointer in
2024 -- interface conversions)
2025
2026 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
2027 while Present (Iface_Comp_Elmt) loop
2028 Iface_Comp := Node (Iface_Comp_Elmt);
2029 pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2030
2031 -- If the interface is a parent of Rec_Type it shares the primary
2032 -- dispatch table and hence there is no need to build the function
2033
2034 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2035 Use_Full_View => True)
2036 then
2037 Build_Offset_To_Top_Function (Iface_Comp);
2038 end if;
2039
2040 Next_Elmt (Iface_Comp_Elmt);
2041 end loop;
2042 end Build_Offset_To_Top_Functions;
2043
2044 ------------------------------
2045 -- Build_CPP_Init_Procedure --
2046 ------------------------------
2047
2048 procedure Build_CPP_Init_Procedure is
2049 Body_Node : Node_Id;
2050 Body_Stmts : List_Id;
2051 Flag_Id : Entity_Id;
2052 Handled_Stmt_Node : Node_Id;
2053 Init_Tags_List : List_Id;
2054 Proc_Id : Entity_Id;
2055 Proc_Spec_Node : Node_Id;
2056
2057 begin
2058 -- Check cases requiring no IC routine
2059
2060 if not Is_CPP_Class (Root_Type (Rec_Type))
2061 or else Is_CPP_Class (Rec_Type)
2062 or else CPP_Num_Prims (Rec_Type) = 0
2063 or else not Tagged_Type_Expansion
2064 or else No_Run_Time_Mode
2065 then
2066 return;
2067 end if;
2068
2069 -- Generate:
2070
2071 -- Flag : Boolean := False;
2072 --
2073 -- procedure Typ_IC is
2074 -- begin
2075 -- if not Flag then
2076 -- Copy C++ dispatch table slots from parent
2077 -- Update C++ slots of overridden primitives
2078 -- end if;
2079 -- end;
2080
2081 Flag_Id := Make_Temporary (Loc, 'F');
2082
2083 Append_Freeze_Action (Rec_Type,
2084 Make_Object_Declaration (Loc,
2085 Defining_Identifier => Flag_Id,
2086 Object_Definition =>
2087 New_Occurrence_Of (Standard_Boolean, Loc),
2088 Expression =>
2089 New_Occurrence_Of (Standard_True, Loc)));
2090
2091 Body_Stmts := New_List;
2092 Body_Node := New_Node (N_Subprogram_Body, Loc);
2093
2094 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2095
2096 Proc_Id :=
2097 Make_Defining_Identifier (Loc,
2098 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2099
2100 Set_Ekind (Proc_Id, E_Procedure);
2101 Set_Is_Internal (Proc_Id);
2102
2103 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2104
2105 Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2106 Set_Specification (Body_Node, Proc_Spec_Node);
2107 Set_Declarations (Body_Node, New_List);
2108
2109 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2110
2111 Append_To (Init_Tags_List,
2112 Make_Assignment_Statement (Loc,
2113 Name =>
2114 New_Occurrence_Of (Flag_Id, Loc),
2115 Expression =>
2116 New_Occurrence_Of (Standard_False, Loc)));
2117
2118 Append_To (Body_Stmts,
2119 Make_If_Statement (Loc,
2120 Condition => New_Occurrence_Of (Flag_Id, Loc),
2121 Then_Statements => Init_Tags_List));
2122
2123 Handled_Stmt_Node :=
2124 New_Node (N_Handled_Sequence_Of_Statements, Loc);
2125 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2126 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2127 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2128
2129 if not Debug_Generated_Code then
2130 Set_Debug_Info_Off (Proc_Id);
2131 end if;
2132
2133 -- Associate CPP_Init_Proc with type
2134
2135 Set_Init_Proc (Rec_Type, Proc_Id);
2136 end Build_CPP_Init_Procedure;
2137
2138 --------------------------
2139 -- Build_Init_Procedure --
2140 --------------------------
2141
2142 procedure Build_Init_Procedure is
2143 Body_Stmts : List_Id;
2144 Body_Node : Node_Id;
2145 Handled_Stmt_Node : Node_Id;
2146 Init_Tags_List : List_Id;
2147 Parameters : List_Id;
2148 Proc_Spec_Node : Node_Id;
2149 Record_Extension_Node : Node_Id;
2150
2151 begin
2152 Body_Stmts := New_List;
2153 Body_Node := New_Node (N_Subprogram_Body, Loc);
2154 Set_Ekind (Proc_Id, E_Procedure);
2155
2156 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2157 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2158
2159 Parameters := Init_Formals (Rec_Type);
2160 Append_List_To (Parameters,
2161 Build_Discriminant_Formals (Rec_Type, True));
2162
2163 -- For tagged types, we add a flag to indicate whether the routine
2164 -- is called to initialize a parent component in the init_proc of
2165 -- a type extension. If the flag is false, we do not set the tag
2166 -- because it has been set already in the extension.
2167
2168 if Is_Tagged_Type (Rec_Type) then
2169 Set_Tag := Make_Temporary (Loc, 'P');
2170
2171 Append_To (Parameters,
2172 Make_Parameter_Specification (Loc,
2173 Defining_Identifier => Set_Tag,
2174 Parameter_Type =>
2175 New_Occurrence_Of (Standard_Boolean, Loc),
2176 Expression =>
2177 New_Occurrence_Of (Standard_True, Loc)));
2178 end if;
2179
2180 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2181 Set_Specification (Body_Node, Proc_Spec_Node);
2182 Set_Declarations (Body_Node, Decls);
2183
2184 -- N is a Derived_Type_Definition that renames the parameters of the
2185 -- ancestor type. We initialize it by expanding our discriminants and
2186 -- call the ancestor _init_proc with a type-converted object.
2187
2188 if Parent_Subtype_Renaming_Discrims then
2189 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2190
2191 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2192 Build_Discriminant_Assignments (Body_Stmts);
2193
2194 if not Null_Present (Type_Definition (N)) then
2195 Append_List_To (Body_Stmts,
2196 Build_Init_Statements (Component_List (Type_Definition (N))));
2197 end if;
2198
2199 -- N is a Derived_Type_Definition with a possible non-empty
2200 -- extension. The initialization of a type extension consists in the
2201 -- initialization of the components in the extension.
2202
2203 else
2204 Build_Discriminant_Assignments (Body_Stmts);
2205
2206 Record_Extension_Node :=
2207 Record_Extension_Part (Type_Definition (N));
2208
2209 if not Null_Present (Record_Extension_Node) then
2210 declare
2211 Stmts : constant List_Id :=
2212 Build_Init_Statements (
2213 Component_List (Record_Extension_Node));
2214
2215 begin
2216 -- The parent field must be initialized first because the
2217 -- offset of the new discriminants may depend on it. This is
2218 -- not needed if the parent is an interface type because in
2219 -- such case the initialization of the _parent field was not
2220 -- generated.
2221
2222 if not Is_Interface (Etype (Rec_Ent)) then
2223 declare
2224 Parent_IP : constant Name_Id :=
2225 Make_Init_Proc_Name (Etype (Rec_Ent));
2226 Stmt : Node_Id;
2227 IP_Call : Node_Id;
2228 IP_Stmts : List_Id;
2229
2230 begin
2231 -- Look for a call to the parent IP at the beginning
2232 -- of Stmts associated with the record extension
2233
2234 Stmt := First (Stmts);
2235 IP_Call := Empty;
2236 while Present (Stmt) loop
2237 if Nkind (Stmt) = N_Procedure_Call_Statement
2238 and then Chars (Name (Stmt)) = Parent_IP
2239 then
2240 IP_Call := Stmt;
2241 exit;
2242 end if;
2243
2244 Next (Stmt);
2245 end loop;
2246
2247 -- If found then move it to the beginning of the
2248 -- statements of this IP routine
2249
2250 if Present (IP_Call) then
2251 IP_Stmts := New_List;
2252 loop
2253 Stmt := Remove_Head (Stmts);
2254 Append_To (IP_Stmts, Stmt);
2255 exit when Stmt = IP_Call;
2256 end loop;
2257
2258 Prepend_List_To (Body_Stmts, IP_Stmts);
2259 end if;
2260 end;
2261 end if;
2262
2263 Append_List_To (Body_Stmts, Stmts);
2264 end;
2265 end if;
2266 end if;
2267
2268 -- Add here the assignment to instantiate the Tag
2269
2270 -- The assignment corresponds to the code:
2271
2272 -- _Init._Tag := Typ'Tag;
2273
2274 -- Suppress the tag assignment when not Tagged_Type_Expansion because
2275 -- tags are represented implicitly in objects. It is also suppressed
2276 -- in case of CPP_Class types because in this case the tag is
2277 -- initialized in the C++ side.
2278
2279 if Is_Tagged_Type (Rec_Type)
2280 and then Tagged_Type_Expansion
2281 and then not No_Run_Time_Mode
2282 then
2283 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2284 -- the actual object and invoke the IP of the parent (in this
2285 -- order). The tag must be initialized before the call to the IP
2286 -- of the parent and the assignments to other components because
2287 -- the initial value of the components may depend on the tag (eg.
2288 -- through a dispatching operation on an access to the current
2289 -- type). The tag assignment is not done when initializing the
2290 -- parent component of a type extension, because in that case the
2291 -- tag is set in the extension.
2292
2293 if not Is_CPP_Class (Root_Type (Rec_Type)) then
2294
2295 -- Initialize the primary tag component
2296
2297 Init_Tags_List := New_List (
2298 Make_Assignment_Statement (Loc,
2299 Name =>
2300 Make_Selected_Component (Loc,
2301 Prefix => Make_Identifier (Loc, Name_uInit),
2302 Selector_Name =>
2303 New_Occurrence_Of
2304 (First_Tag_Component (Rec_Type), Loc)),
2305 Expression =>
2306 New_Occurrence_Of
2307 (Node
2308 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2309
2310 -- Ada 2005 (AI-251): Initialize the secondary tags components
2311 -- located at fixed positions (tags whose position depends on
2312 -- variable size components are initialized later ---see below)
2313
2314 if Ada_Version >= Ada_2005
2315 and then not Is_Interface (Rec_Type)
2316 and then Has_Interfaces (Rec_Type)
2317 then
2318 Init_Secondary_Tags
2319 (Typ => Rec_Type,
2320 Target => Make_Identifier (Loc, Name_uInit),
2321 Stmts_List => Init_Tags_List,
2322 Fixed_Comps => True,
2323 Variable_Comps => False);
2324 end if;
2325
2326 Prepend_To (Body_Stmts,
2327 Make_If_Statement (Loc,
2328 Condition => New_Occurrence_Of (Set_Tag, Loc),
2329 Then_Statements => Init_Tags_List));
2330
2331 -- Case 2: CPP type. The imported C++ constructor takes care of
2332 -- tags initialization. No action needed here because the IP
2333 -- is built by Set_CPP_Constructors; in this case the IP is a
2334 -- wrapper that invokes the C++ constructor and copies the C++
2335 -- tags locally. Done to inherit the C++ slots in Ada derivations
2336 -- (see case 3).
2337
2338 elsif Is_CPP_Class (Rec_Type) then
2339 pragma Assert (False);
2340 null;
2341
2342 -- Case 3: Combined hierarchy containing C++ types and Ada tagged
2343 -- type derivations. Derivations of imported C++ classes add a
2344 -- complication, because we cannot inhibit tag setting in the
2345 -- constructor for the parent. Hence we initialize the tag after
2346 -- the call to the parent IP (that is, in reverse order compared
2347 -- with pure Ada hierarchies ---see comment on case 1).
2348
2349 else
2350 -- Initialize the primary tag
2351
2352 Init_Tags_List := New_List (
2353 Make_Assignment_Statement (Loc,
2354 Name =>
2355 Make_Selected_Component (Loc,
2356 Prefix => Make_Identifier (Loc, Name_uInit),
2357 Selector_Name =>
2358 New_Occurrence_Of
2359 (First_Tag_Component (Rec_Type), Loc)),
2360 Expression =>
2361 New_Occurrence_Of
2362 (Node
2363 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2364
2365 -- Ada 2005 (AI-251): Initialize the secondary tags components
2366 -- located at fixed positions (tags whose position depends on
2367 -- variable size components are initialized later ---see below)
2368
2369 if Ada_Version >= Ada_2005
2370 and then not Is_Interface (Rec_Type)
2371 and then Has_Interfaces (Rec_Type)
2372 then
2373 Init_Secondary_Tags
2374 (Typ => Rec_Type,
2375 Target => Make_Identifier (Loc, Name_uInit),
2376 Stmts_List => Init_Tags_List,
2377 Fixed_Comps => True,
2378 Variable_Comps => False);
2379 end if;
2380
2381 -- Initialize the tag component after invocation of parent IP.
2382
2383 -- Generate:
2384 -- parent_IP(_init.parent); // Invokes the C++ constructor
2385 -- [ typIC; ] // Inherit C++ slots from parent
2386 -- init_tags
2387
2388 declare
2389 Ins_Nod : Node_Id;
2390
2391 begin
2392 -- Search for the call to the IP of the parent. We assume
2393 -- that the first init_proc call is for the parent.
2394
2395 Ins_Nod := First (Body_Stmts);
2396 while Present (Next (Ins_Nod))
2397 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2398 or else not Is_Init_Proc (Name (Ins_Nod)))
2399 loop
2400 Next (Ins_Nod);
2401 end loop;
2402
2403 -- The IC routine copies the inherited slots of the C+ part
2404 -- of the dispatch table from the parent and updates the
2405 -- overridden C++ slots.
2406
2407 if CPP_Num_Prims (Rec_Type) > 0 then
2408 declare
2409 Init_DT : Entity_Id;
2410 New_Nod : Node_Id;
2411
2412 begin
2413 Init_DT := CPP_Init_Proc (Rec_Type);
2414 pragma Assert (Present (Init_DT));
2415
2416 New_Nod :=
2417 Make_Procedure_Call_Statement (Loc,
2418 New_Occurrence_Of (Init_DT, Loc));
2419 Insert_After (Ins_Nod, New_Nod);
2420
2421 -- Update location of init tag statements
2422
2423 Ins_Nod := New_Nod;
2424 end;
2425 end if;
2426
2427 Insert_List_After (Ins_Nod, Init_Tags_List);
2428 end;
2429 end if;
2430
2431 -- Ada 2005 (AI-251): Initialize the secondary tag components
2432 -- located at variable positions. We delay the generation of this
2433 -- code until here because the value of the attribute 'Position
2434 -- applied to variable size components of the parent type that
2435 -- depend on discriminants is only safely read at runtime after
2436 -- the parent components have been initialized.
2437
2438 if Ada_Version >= Ada_2005
2439 and then not Is_Interface (Rec_Type)
2440 and then Has_Interfaces (Rec_Type)
2441 and then Has_Discriminants (Etype (Rec_Type))
2442 and then Is_Variable_Size_Record (Etype (Rec_Type))
2443 then
2444 Init_Tags_List := New_List;
2445
2446 Init_Secondary_Tags
2447 (Typ => Rec_Type,
2448 Target => Make_Identifier (Loc, Name_uInit),
2449 Stmts_List => Init_Tags_List,
2450 Fixed_Comps => False,
2451 Variable_Comps => True);
2452
2453 if Is_Non_Empty_List (Init_Tags_List) then
2454 Append_List_To (Body_Stmts, Init_Tags_List);
2455 end if;
2456 end if;
2457 end if;
2458
2459 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2460 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2461
2462 -- Generate:
2463 -- Deep_Finalize (_init, C1, ..., CN);
2464 -- raise;
2465
2466 if Counter > 0
2467 and then Needs_Finalization (Rec_Type)
2468 and then not Is_Abstract_Type (Rec_Type)
2469 and then not Restriction_Active (No_Exception_Propagation)
2470 then
2471 declare
2472 DF_Call : Node_Id;
2473 DF_Id : Entity_Id;
2474
2475 begin
2476 -- Create a local version of Deep_Finalize which has indication
2477 -- of partial initialization state.
2478
2479 DF_Id := Make_Temporary (Loc, 'F');
2480
2481 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
2482
2483 DF_Call :=
2484 Make_Procedure_Call_Statement (Loc,
2485 Name => New_Occurrence_Of (DF_Id, Loc),
2486 Parameter_Associations => New_List (
2487 Make_Identifier (Loc, Name_uInit),
2488 New_Occurrence_Of (Standard_False, Loc)));
2489
2490 -- Do not emit warnings related to the elaboration order when a
2491 -- controlled object is declared before the body of Finalize is
2492 -- seen.
2493
2494 Set_No_Elaboration_Check (DF_Call);
2495
2496 Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2497 Make_Exception_Handler (Loc,
2498 Exception_Choices => New_List (
2499 Make_Others_Choice (Loc)),
2500 Statements => New_List (
2501 DF_Call,
2502 Make_Raise_Statement (Loc)))));
2503 end;
2504 else
2505 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2506 end if;
2507
2508 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2509
2510 if not Debug_Generated_Code then
2511 Set_Debug_Info_Off (Proc_Id);
2512 end if;
2513
2514 -- Associate Init_Proc with type, and determine if the procedure
2515 -- is null (happens because of the Initialize_Scalars pragma case,
2516 -- where we have to generate a null procedure in case it is called
2517 -- by a client with Initialize_Scalars set). Such procedures have
2518 -- to be generated, but do not have to be called, so we mark them
2519 -- as null to suppress the call.
2520
2521 Set_Init_Proc (Rec_Type, Proc_Id);
2522
2523 if List_Length (Body_Stmts) = 1
2524
2525 -- We must skip SCIL nodes because they may have been added to this
2526 -- list by Insert_Actions.
2527
2528 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2529 then
2530 Set_Is_Null_Init_Proc (Proc_Id);
2531 end if;
2532 end Build_Init_Procedure;
2533
2534 ---------------------------
2535 -- Build_Init_Statements --
2536 ---------------------------
2537
2538 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2539 Checks : constant List_Id := New_List;
2540 Actions : List_Id := No_List;
2541 Counter_Id : Entity_Id := Empty;
2542 Comp_Loc : Source_Ptr;
2543 Decl : Node_Id;
2544 Has_POC : Boolean;
2545 Id : Entity_Id;
2546 Parent_Stmts : List_Id;
2547 Stmts : List_Id;
2548 Typ : Entity_Id;
2549
2550 procedure Increment_Counter (Loc : Source_Ptr);
2551 -- Generate an "increment by one" statement for the current counter
2552 -- and append it to the list Stmts.
2553
2554 procedure Make_Counter (Loc : Source_Ptr);
2555 -- Create a new counter for the current component list. The routine
2556 -- creates a new defining Id, adds an object declaration and sets
2557 -- the Id generator for the next variant.
2558
2559 -----------------------
2560 -- Increment_Counter --
2561 -----------------------
2562
2563 procedure Increment_Counter (Loc : Source_Ptr) is
2564 begin
2565 -- Generate:
2566 -- Counter := Counter + 1;
2567
2568 Append_To (Stmts,
2569 Make_Assignment_Statement (Loc,
2570 Name => New_Occurrence_Of (Counter_Id, Loc),
2571 Expression =>
2572 Make_Op_Add (Loc,
2573 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
2574 Right_Opnd => Make_Integer_Literal (Loc, 1))));
2575 end Increment_Counter;
2576
2577 ------------------
2578 -- Make_Counter --
2579 ------------------
2580
2581 procedure Make_Counter (Loc : Source_Ptr) is
2582 begin
2583 -- Increment the Id generator
2584
2585 Counter := Counter + 1;
2586
2587 -- Create the entity and declaration
2588
2589 Counter_Id :=
2590 Make_Defining_Identifier (Loc,
2591 Chars => New_External_Name ('C', Counter));
2592
2593 -- Generate:
2594 -- Cnn : Integer := 0;
2595
2596 Append_To (Decls,
2597 Make_Object_Declaration (Loc,
2598 Defining_Identifier => Counter_Id,
2599 Object_Definition =>
2600 New_Occurrence_Of (Standard_Integer, Loc),
2601 Expression =>
2602 Make_Integer_Literal (Loc, 0)));
2603 end Make_Counter;
2604
2605 -- Start of processing for Build_Init_Statements
2606
2607 begin
2608 if Null_Present (Comp_List) then
2609 return New_List (Make_Null_Statement (Loc));
2610 end if;
2611
2612 Parent_Stmts := New_List;
2613 Stmts := New_List;
2614
2615 -- Loop through visible declarations of task types and protected
2616 -- types moving any expanded code from the spec to the body of the
2617 -- init procedure.
2618
2619 if Is_Task_Record_Type (Rec_Type)
2620 or else Is_Protected_Record_Type (Rec_Type)
2621 then
2622 declare
2623 Decl : constant Node_Id :=
2624 Parent (Corresponding_Concurrent_Type (Rec_Type));
2625 Def : Node_Id;
2626 N1 : Node_Id;
2627 N2 : Node_Id;
2628
2629 begin
2630 if Is_Task_Record_Type (Rec_Type) then
2631 Def := Task_Definition (Decl);
2632 else
2633 Def := Protected_Definition (Decl);
2634 end if;
2635
2636 if Present (Def) then
2637 N1 := First (Visible_Declarations (Def));
2638 while Present (N1) loop
2639 N2 := N1;
2640 N1 := Next (N1);
2641
2642 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2643 or else Nkind (N2) in N_Raise_xxx_Error
2644 or else Nkind (N2) = N_Procedure_Call_Statement
2645 then
2646 Append_To (Stmts,
2647 New_Copy_Tree (N2, New_Scope => Proc_Id));
2648 Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2649 Analyze (N2);
2650 end if;
2651 end loop;
2652 end if;
2653 end;
2654 end if;
2655
2656 -- Loop through components, skipping pragmas, in 2 steps. The first
2657 -- step deals with regular components. The second step deals with
2658 -- components that have per object constraints and no explicit
2659 -- initialization.
2660
2661 Has_POC := False;
2662
2663 -- First pass : regular components
2664
2665 Decl := First_Non_Pragma (Component_Items (Comp_List));
2666 while Present (Decl) loop
2667 Comp_Loc := Sloc (Decl);
2668 Build_Record_Checks
2669 (Subtype_Indication (Component_Definition (Decl)), Checks);
2670
2671 Id := Defining_Identifier (Decl);
2672 Typ := Etype (Id);
2673
2674 -- Leave any processing of per-object constrained component for
2675 -- the second pass.
2676
2677 if Has_Access_Constraint (Id) and then No (Expression (Decl)) then
2678 Has_POC := True;
2679
2680 -- Regular component cases
2681
2682 else
2683 -- In the context of the init proc, references to discriminants
2684 -- resolve to denote the discriminals: this is where we can
2685 -- freeze discriminant dependent component subtypes.
2686
2687 if not Is_Frozen (Typ) then
2688 Append_List_To (Stmts, Freeze_Entity (Typ, N));
2689 end if;
2690
2691 -- Explicit initialization
2692
2693 if Present (Expression (Decl)) then
2694 if Is_CPP_Constructor_Call (Expression (Decl)) then
2695 Actions :=
2696 Build_Initialization_Call
2697 (Comp_Loc,
2698 Id_Ref =>
2699 Make_Selected_Component (Comp_Loc,
2700 Prefix =>
2701 Make_Identifier (Comp_Loc, Name_uInit),
2702 Selector_Name =>
2703 New_Occurrence_Of (Id, Comp_Loc)),
2704 Typ => Typ,
2705 In_Init_Proc => True,
2706 Enclos_Type => Rec_Type,
2707 Discr_Map => Discr_Map,
2708 Constructor_Ref => Expression (Decl));
2709 else
2710 Actions := Build_Assignment (Id, Expression (Decl));
2711 end if;
2712
2713 -- CPU, Dispatching_Domain, Priority and Size components are
2714 -- filled with the corresponding rep item expression of the
2715 -- concurrent type (if any).
2716
2717 elsif Ekind (Scope (Id)) = E_Record_Type
2718 and then Present (Corresponding_Concurrent_Type (Scope (Id)))
2719 and then Nam_In (Chars (Id), Name_uCPU,
2720 Name_uDispatching_Domain,
2721 Name_uPriority)
2722 then
2723 declare
2724 Exp : Node_Id;
2725 Nam : Name_Id;
2726 Ritem : Node_Id;
2727
2728 begin
2729 if Chars (Id) = Name_uCPU then
2730 Nam := Name_CPU;
2731
2732 elsif Chars (Id) = Name_uDispatching_Domain then
2733 Nam := Name_Dispatching_Domain;
2734
2735 elsif Chars (Id) = Name_uPriority then
2736 Nam := Name_Priority;
2737 end if;
2738
2739 -- Get the Rep Item (aspect specification, attribute
2740 -- definition clause or pragma) of the corresponding
2741 -- concurrent type.
2742
2743 Ritem :=
2744 Get_Rep_Item
2745 (Corresponding_Concurrent_Type (Scope (Id)),
2746 Nam,
2747 Check_Parents => False);
2748
2749 if Present (Ritem) then
2750
2751 -- Pragma case
2752
2753 if Nkind (Ritem) = N_Pragma then
2754 Exp := First (Pragma_Argument_Associations (Ritem));
2755
2756 if Nkind (Exp) = N_Pragma_Argument_Association then
2757 Exp := Expression (Exp);
2758 end if;
2759
2760 -- Conversion for Priority expression
2761
2762 if Nam = Name_Priority then
2763 if Pragma_Name (Ritem) = Name_Priority
2764 and then not GNAT_Mode
2765 then
2766 Exp := Convert_To (RTE (RE_Priority), Exp);
2767 else
2768 Exp :=
2769 Convert_To (RTE (RE_Any_Priority), Exp);
2770 end if;
2771 end if;
2772
2773 -- Aspect/Attribute definition clause case
2774
2775 else
2776 Exp := Expression (Ritem);
2777
2778 -- Conversion for Priority expression
2779
2780 if Nam = Name_Priority then
2781 if Chars (Ritem) = Name_Priority
2782 and then not GNAT_Mode
2783 then
2784 Exp := Convert_To (RTE (RE_Priority), Exp);
2785 else
2786 Exp :=
2787 Convert_To (RTE (RE_Any_Priority), Exp);
2788 end if;
2789 end if;
2790 end if;
2791
2792 -- Conversion for Dispatching_Domain value
2793
2794 if Nam = Name_Dispatching_Domain then
2795 Exp :=
2796 Unchecked_Convert_To
2797 (RTE (RE_Dispatching_Domain_Access), Exp);
2798 end if;
2799
2800 Actions := Build_Assignment (Id, Exp);
2801
2802 -- Nothing needed if no Rep Item
2803
2804 else
2805 Actions := No_List;
2806 end if;
2807 end;
2808
2809 -- Composite component with its own Init_Proc
2810
2811 elsif not Is_Interface (Typ)
2812 and then Has_Non_Null_Base_Init_Proc (Typ)
2813 then
2814 Actions :=
2815 Build_Initialization_Call
2816 (Comp_Loc,
2817 Make_Selected_Component (Comp_Loc,
2818 Prefix =>
2819 Make_Identifier (Comp_Loc, Name_uInit),
2820 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2821 Typ,
2822 In_Init_Proc => True,
2823 Enclos_Type => Rec_Type,
2824 Discr_Map => Discr_Map);
2825
2826 Clean_Task_Names (Typ, Proc_Id);
2827
2828 -- Simple initialization
2829
2830 elsif Component_Needs_Simple_Initialization (Typ) then
2831 Actions :=
2832 Build_Assignment
2833 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
2834
2835 -- Nothing needed for this case
2836
2837 else
2838 Actions := No_List;
2839 end if;
2840
2841 if Present (Checks) then
2842 if Chars (Id) = Name_uParent then
2843 Append_List_To (Parent_Stmts, Checks);
2844 else
2845 Append_List_To (Stmts, Checks);
2846 end if;
2847 end if;
2848
2849 if Present (Actions) then
2850 if Chars (Id) = Name_uParent then
2851 Append_List_To (Parent_Stmts, Actions);
2852
2853 else
2854 Append_List_To (Stmts, Actions);
2855
2856 -- Preserve initialization state in the current counter
2857
2858 if Needs_Finalization (Typ) then
2859 if No (Counter_Id) then
2860 Make_Counter (Comp_Loc);
2861 end if;
2862
2863 Increment_Counter (Comp_Loc);
2864 end if;
2865 end if;
2866 end if;
2867 end if;
2868
2869 Next_Non_Pragma (Decl);
2870 end loop;
2871
2872 -- The parent field must be initialized first because variable
2873 -- size components of the parent affect the location of all the
2874 -- new components.
2875
2876 Prepend_List_To (Stmts, Parent_Stmts);
2877
2878 -- Set up tasks and protected object support. This needs to be done
2879 -- before any component with a per-object access discriminant
2880 -- constraint, or any variant part (which may contain such
2881 -- components) is initialized, because the initialization of these
2882 -- components may reference the enclosing concurrent object.
2883
2884 -- For a task record type, add the task create call and calls to bind
2885 -- any interrupt (signal) entries.
2886
2887 if Is_Task_Record_Type (Rec_Type) then
2888
2889 -- In the case of the restricted run time the ATCB has already
2890 -- been preallocated.
2891
2892 if Restricted_Profile then
2893 Append_To (Stmts,
2894 Make_Assignment_Statement (Loc,
2895 Name =>
2896 Make_Selected_Component (Loc,
2897 Prefix => Make_Identifier (Loc, Name_uInit),
2898 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2899 Expression =>
2900 Make_Attribute_Reference (Loc,
2901 Prefix =>
2902 Make_Selected_Component (Loc,
2903 Prefix => Make_Identifier (Loc, Name_uInit),
2904 Selector_Name => Make_Identifier (Loc, Name_uATCB)),
2905 Attribute_Name => Name_Unchecked_Access)));
2906 end if;
2907
2908 Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
2909
2910 declare
2911 Task_Type : constant Entity_Id :=
2912 Corresponding_Concurrent_Type (Rec_Type);
2913 Task_Decl : constant Node_Id := Parent (Task_Type);
2914 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
2915 Decl_Loc : Source_Ptr;
2916 Ent : Entity_Id;
2917 Vis_Decl : Node_Id;
2918
2919 begin
2920 if Present (Task_Def) then
2921 Vis_Decl := First (Visible_Declarations (Task_Def));
2922 while Present (Vis_Decl) loop
2923 Decl_Loc := Sloc (Vis_Decl);
2924
2925 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
2926 if Get_Attribute_Id (Chars (Vis_Decl)) =
2927 Attribute_Address
2928 then
2929 Ent := Entity (Name (Vis_Decl));
2930
2931 if Ekind (Ent) = E_Entry then
2932 Append_To (Stmts,
2933 Make_Procedure_Call_Statement (Decl_Loc,
2934 Name =>
2935 New_Occurrence_Of (RTE (
2936 RE_Bind_Interrupt_To_Entry), Decl_Loc),
2937 Parameter_Associations => New_List (
2938 Make_Selected_Component (Decl_Loc,
2939 Prefix =>
2940 Make_Identifier (Decl_Loc, Name_uInit),
2941 Selector_Name =>
2942 Make_Identifier
2943 (Decl_Loc, Name_uTask_Id)),
2944 Entry_Index_Expression
2945 (Decl_Loc, Ent, Empty, Task_Type),
2946 Expression (Vis_Decl))));
2947 end if;
2948 end if;
2949 end if;
2950
2951 Next (Vis_Decl);
2952 end loop;
2953 end if;
2954 end;
2955 end if;
2956
2957 -- For a protected type, add statements generated by
2958 -- Make_Initialize_Protection.
2959
2960 if Is_Protected_Record_Type (Rec_Type) then
2961 Append_List_To (Stmts,
2962 Make_Initialize_Protection (Rec_Type));
2963 end if;
2964
2965 -- Second pass: components with per-object constraints
2966
2967 if Has_POC then
2968 Decl := First_Non_Pragma (Component_Items (Comp_List));
2969 while Present (Decl) loop
2970 Comp_Loc := Sloc (Decl);
2971 Id := Defining_Identifier (Decl);
2972 Typ := Etype (Id);
2973
2974 if Has_Access_Constraint (Id)
2975 and then No (Expression (Decl))
2976 then
2977 if Has_Non_Null_Base_Init_Proc (Typ) then
2978 Append_List_To (Stmts,
2979 Build_Initialization_Call (Comp_Loc,
2980 Make_Selected_Component (Comp_Loc,
2981 Prefix =>
2982 Make_Identifier (Comp_Loc, Name_uInit),
2983 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2984 Typ,
2985 In_Init_Proc => True,
2986 Enclos_Type => Rec_Type,
2987 Discr_Map => Discr_Map));
2988
2989 Clean_Task_Names (Typ, Proc_Id);
2990
2991 -- Preserve initialization state in the current counter
2992
2993 if Needs_Finalization (Typ) then
2994 if No (Counter_Id) then
2995 Make_Counter (Comp_Loc);
2996 end if;
2997
2998 Increment_Counter (Comp_Loc);
2999 end if;
3000
3001 elsif Component_Needs_Simple_Initialization (Typ) then
3002 Append_List_To (Stmts,
3003 Build_Assignment
3004 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
3005 end if;
3006 end if;
3007
3008 Next_Non_Pragma (Decl);
3009 end loop;
3010 end if;
3011
3012 -- Process the variant part
3013
3014 if Present (Variant_Part (Comp_List)) then
3015 declare
3016 Variant_Alts : constant List_Id := New_List;
3017 Var_Loc : Source_Ptr;
3018 Variant : Node_Id;
3019
3020 begin
3021 Variant :=
3022 First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3023 while Present (Variant) loop
3024 Var_Loc := Sloc (Variant);
3025 Append_To (Variant_Alts,
3026 Make_Case_Statement_Alternative (Var_Loc,
3027 Discrete_Choices =>
3028 New_Copy_List (Discrete_Choices (Variant)),
3029 Statements =>
3030 Build_Init_Statements (Component_List (Variant))));
3031 Next_Non_Pragma (Variant);
3032 end loop;
3033
3034 -- The expression of the case statement which is a reference
3035 -- to one of the discriminants is replaced by the appropriate
3036 -- formal parameter of the initialization procedure.
3037
3038 Append_To (Stmts,
3039 Make_Case_Statement (Var_Loc,
3040 Expression =>
3041 New_Occurrence_Of (Discriminal (
3042 Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
3043 Alternatives => Variant_Alts));
3044 end;
3045 end if;
3046
3047 -- If no initializations when generated for component declarations
3048 -- corresponding to this Stmts, append a null statement to Stmts to
3049 -- to make it a valid Ada tree.
3050
3051 if Is_Empty_List (Stmts) then
3052 Append (Make_Null_Statement (Loc), Stmts);
3053 end if;
3054
3055 return Stmts;
3056
3057 exception
3058 when RE_Not_Available =>
3059 return Empty_List;
3060 end Build_Init_Statements;
3061
3062 -------------------------
3063 -- Build_Record_Checks --
3064 -------------------------
3065
3066 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
3067 Subtype_Mark_Id : Entity_Id;
3068
3069 procedure Constrain_Array
3070 (SI : Node_Id;
3071 Check_List : List_Id);
3072 -- Apply a list of index constraints to an unconstrained array type.
3073 -- The first parameter is the entity for the resulting subtype.
3074 -- Check_List is a list to which the check actions are appended.
3075
3076 ---------------------
3077 -- Constrain_Array --
3078 ---------------------
3079
3080 procedure Constrain_Array
3081 (SI : Node_Id;
3082 Check_List : List_Id)
3083 is
3084 C : constant Node_Id := Constraint (SI);
3085 Number_Of_Constraints : Nat := 0;
3086 Index : Node_Id;
3087 S, T : Entity_Id;
3088
3089 procedure Constrain_Index
3090 (Index : Node_Id;
3091 S : Node_Id;
3092 Check_List : List_Id);
3093 -- Process an index constraint in a constrained array declaration.
3094 -- The constraint can be either a subtype name or a range with or
3095 -- without an explicit subtype mark. Index is the corresponding
3096 -- index of the unconstrained array. S is the range expression.
3097 -- Check_List is a list to which the check actions are appended.
3098
3099 ---------------------
3100 -- Constrain_Index --
3101 ---------------------
3102
3103 procedure Constrain_Index
3104 (Index : Node_Id;
3105 S : Node_Id;
3106 Check_List : List_Id)
3107 is
3108 T : constant Entity_Id := Etype (Index);
3109
3110 begin
3111 if Nkind (S) = N_Range then
3112 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
3113 end if;
3114 end Constrain_Index;
3115
3116 -- Start of processing for Constrain_Array
3117
3118 begin
3119 T := Entity (Subtype_Mark (SI));
3120
3121 if Is_Access_Type (T) then
3122 T := Designated_Type (T);
3123 end if;
3124
3125 S := First (Constraints (C));
3126 while Present (S) loop
3127 Number_Of_Constraints := Number_Of_Constraints + 1;
3128 Next (S);
3129 end loop;
3130
3131 -- In either case, the index constraint must provide a discrete
3132 -- range for each index of the array type and the type of each
3133 -- discrete range must be the same as that of the corresponding
3134 -- index. (RM 3.6.1)
3135
3136 S := First (Constraints (C));
3137 Index := First_Index (T);
3138 Analyze (Index);
3139
3140 -- Apply constraints to each index type
3141
3142 for J in 1 .. Number_Of_Constraints loop
3143 Constrain_Index (Index, S, Check_List);
3144 Next (Index);
3145 Next (S);
3146 end loop;
3147 end Constrain_Array;
3148
3149 -- Start of processing for Build_Record_Checks
3150
3151 begin
3152 if Nkind (S) = N_Subtype_Indication then
3153 Find_Type (Subtype_Mark (S));
3154 Subtype_Mark_Id := Entity (Subtype_Mark (S));
3155
3156 -- Remaining processing depends on type
3157
3158 case Ekind (Subtype_Mark_Id) is
3159
3160 when Array_Kind =>
3161 Constrain_Array (S, Check_List);
3162
3163 when others =>
3164 null;
3165 end case;
3166 end if;
3167 end Build_Record_Checks;
3168
3169 -------------------------------------------
3170 -- Component_Needs_Simple_Initialization --
3171 -------------------------------------------
3172
3173 function Component_Needs_Simple_Initialization
3174 (T : Entity_Id) return Boolean
3175 is
3176 begin
3177 return
3178 Needs_Simple_Initialization (T)
3179 and then not Is_RTE (T, RE_Tag)
3180
3181 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
3182
3183 and then not Is_RTE (T, RE_Interface_Tag);
3184 end Component_Needs_Simple_Initialization;
3185
3186 --------------------------------------
3187 -- Parent_Subtype_Renaming_Discrims --
3188 --------------------------------------
3189
3190 function Parent_Subtype_Renaming_Discrims return Boolean is
3191 De : Entity_Id;
3192 Dp : Entity_Id;
3193
3194 begin
3195 if Base_Type (Rec_Ent) /= Rec_Ent then
3196 return False;
3197 end if;
3198
3199 if Etype (Rec_Ent) = Rec_Ent
3200 or else not Has_Discriminants (Rec_Ent)
3201 or else Is_Constrained (Rec_Ent)
3202 or else Is_Tagged_Type (Rec_Ent)
3203 then
3204 return False;
3205 end if;
3206
3207 -- If there are no explicit stored discriminants we have inherited
3208 -- the root type discriminants so far, so no renamings occurred.
3209
3210 if First_Discriminant (Rec_Ent) =
3211 First_Stored_Discriminant (Rec_Ent)
3212 then
3213 return False;
3214 end if;
3215
3216 -- Check if we have done some trivial renaming of the parent
3217 -- discriminants, i.e. something like
3218 --
3219 -- type DT (X1, X2: int) is new PT (X1, X2);
3220
3221 De := First_Discriminant (Rec_Ent);
3222 Dp := First_Discriminant (Etype (Rec_Ent));
3223 while Present (De) loop
3224 pragma Assert (Present (Dp));
3225
3226 if Corresponding_Discriminant (De) /= Dp then
3227 return True;
3228 end if;
3229
3230 Next_Discriminant (De);
3231 Next_Discriminant (Dp);
3232 end loop;
3233
3234 return Present (Dp);
3235 end Parent_Subtype_Renaming_Discrims;
3236
3237 ------------------------
3238 -- Requires_Init_Proc --
3239 ------------------------
3240
3241 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3242 Comp_Decl : Node_Id;
3243 Id : Entity_Id;
3244 Typ : Entity_Id;
3245
3246 begin
3247 -- Definitely do not need one if specifically suppressed
3248
3249 if Initialization_Suppressed (Rec_Id) then
3250 return False;
3251 end if;
3252
3253 -- If it is a type derived from a type with unknown discriminants,
3254 -- we cannot build an initialization procedure for it.
3255
3256 if Has_Unknown_Discriminants (Rec_Id)
3257 or else Has_Unknown_Discriminants (Etype (Rec_Id))
3258 then
3259 return False;
3260 end if;
3261
3262 -- Otherwise we need to generate an initialization procedure if
3263 -- Is_CPP_Class is False and at least one of the following applies:
3264
3265 -- 1. Discriminants are present, since they need to be initialized
3266 -- with the appropriate discriminant constraint expressions.
3267 -- However, the discriminant of an unchecked union does not
3268 -- count, since the discriminant is not present.
3269
3270 -- 2. The type is a tagged type, since the implicit Tag component
3271 -- needs to be initialized with a pointer to the dispatch table.
3272
3273 -- 3. The type contains tasks
3274
3275 -- 4. One or more components has an initial value
3276
3277 -- 5. One or more components is for a type which itself requires
3278 -- an initialization procedure.
3279
3280 -- 6. One or more components is a type that requires simple
3281 -- initialization (see Needs_Simple_Initialization), except
3282 -- that types Tag and Interface_Tag are excluded, since fields
3283 -- of these types are initialized by other means.
3284
3285 -- 7. The type is the record type built for a task type (since at
3286 -- the very least, Create_Task must be called)
3287
3288 -- 8. The type is the record type built for a protected type (since
3289 -- at least Initialize_Protection must be called)
3290
3291 -- 9. The type is marked as a public entity. The reason we add this
3292 -- case (even if none of the above apply) is to properly handle
3293 -- Initialize_Scalars. If a package is compiled without an IS
3294 -- pragma, and the client is compiled with an IS pragma, then
3295 -- the client will think an initialization procedure is present
3296 -- and call it, when in fact no such procedure is required, but
3297 -- since the call is generated, there had better be a routine
3298 -- at the other end of the call, even if it does nothing).
3299
3300 -- Note: the reason we exclude the CPP_Class case is because in this
3301 -- case the initialization is performed by the C++ constructors, and
3302 -- the IP is built by Set_CPP_Constructors.
3303
3304 if Is_CPP_Class (Rec_Id) then
3305 return False;
3306
3307 elsif Is_Interface (Rec_Id) then
3308 return False;
3309
3310 elsif (Has_Discriminants (Rec_Id)
3311 and then not Is_Unchecked_Union (Rec_Id))
3312 or else Is_Tagged_Type (Rec_Id)
3313 or else Is_Concurrent_Record_Type (Rec_Id)
3314 or else Has_Task (Rec_Id)
3315 then
3316 return True;
3317 end if;
3318
3319 Id := First_Component (Rec_Id);
3320 while Present (Id) loop
3321 Comp_Decl := Parent (Id);
3322 Typ := Etype (Id);
3323
3324 if Present (Expression (Comp_Decl))
3325 or else Has_Non_Null_Base_Init_Proc (Typ)
3326 or else Component_Needs_Simple_Initialization (Typ)
3327 then
3328 return True;
3329 end if;
3330
3331 Next_Component (Id);
3332 end loop;
3333
3334 -- As explained above, a record initialization procedure is needed
3335 -- for public types in case Initialize_Scalars applies to a client.
3336 -- However, such a procedure is not needed in the case where either
3337 -- of restrictions No_Initialize_Scalars or No_Default_Initialization
3338 -- applies. No_Initialize_Scalars excludes the possibility of using
3339 -- Initialize_Scalars in any partition, and No_Default_Initialization
3340 -- implies that no initialization should ever be done for objects of
3341 -- the type, so is incompatible with Initialize_Scalars.
3342
3343 if not Restriction_Active (No_Initialize_Scalars)
3344 and then not Restriction_Active (No_Default_Initialization)
3345 and then Is_Public (Rec_Id)
3346 then
3347 return True;
3348 end if;
3349
3350 return False;
3351 end Requires_Init_Proc;
3352
3353 -- Start of processing for Build_Record_Init_Proc
3354
3355 begin
3356 Rec_Type := Defining_Identifier (N);
3357
3358 -- This may be full declaration of a private type, in which case
3359 -- the visible entity is a record, and the private entity has been
3360 -- exchanged with it in the private part of the current package.
3361 -- The initialization procedure is built for the record type, which
3362 -- is retrievable from the private entity.
3363
3364 if Is_Incomplete_Or_Private_Type (Rec_Type) then
3365 Rec_Type := Underlying_Type (Rec_Type);
3366 end if;
3367
3368 -- If we have a variant record with restriction No_Implicit_Conditionals
3369 -- in effect, then we skip building the procedure. This is safe because
3370 -- if we can see the restriction, so can any caller, calls to initialize
3371 -- such records are not allowed for variant records if this restriction
3372 -- is active.
3373
3374 if Has_Variant_Part (Rec_Type)
3375 and then Restriction_Active (No_Implicit_Conditionals)
3376 then
3377 return;
3378 end if;
3379
3380 -- If there are discriminants, build the discriminant map to replace
3381 -- discriminants by their discriminals in complex bound expressions.
3382 -- These only arise for the corresponding records of synchronized types.
3383
3384 if Is_Concurrent_Record_Type (Rec_Type)
3385 and then Has_Discriminants (Rec_Type)
3386 then
3387 declare
3388 Disc : Entity_Id;
3389 begin
3390 Disc := First_Discriminant (Rec_Type);
3391 while Present (Disc) loop
3392 Append_Elmt (Disc, Discr_Map);
3393 Append_Elmt (Discriminal (Disc), Discr_Map);
3394 Next_Discriminant (Disc);
3395 end loop;
3396 end;
3397 end if;
3398
3399 -- Derived types that have no type extension can use the initialization
3400 -- procedure of their parent and do not need a procedure of their own.
3401 -- This is only correct if there are no representation clauses for the
3402 -- type or its parent, and if the parent has in fact been frozen so
3403 -- that its initialization procedure exists.
3404
3405 if Is_Derived_Type (Rec_Type)
3406 and then not Is_Tagged_Type (Rec_Type)
3407 and then not Is_Unchecked_Union (Rec_Type)
3408 and then not Has_New_Non_Standard_Rep (Rec_Type)
3409 and then not Parent_Subtype_Renaming_Discrims
3410 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
3411 then
3412 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
3413
3414 -- Otherwise if we need an initialization procedure, then build one,
3415 -- mark it as public and inlinable and as having a completion.
3416
3417 elsif Requires_Init_Proc (Rec_Type)
3418 or else Is_Unchecked_Union (Rec_Type)
3419 then
3420 Proc_Id :=
3421 Make_Defining_Identifier (Loc,
3422 Chars => Make_Init_Proc_Name (Rec_Type));
3423
3424 -- If No_Default_Initialization restriction is active, then we don't
3425 -- want to build an init_proc, but we need to mark that an init_proc
3426 -- would be needed if this restriction was not active (so that we can
3427 -- detect attempts to call it), so set a dummy init_proc in place.
3428
3429 if Restriction_Active (No_Default_Initialization) then
3430 Set_Init_Proc (Rec_Type, Proc_Id);
3431 return;
3432 end if;
3433
3434 Build_Offset_To_Top_Functions;
3435 Build_CPP_Init_Procedure;
3436 Build_Init_Procedure;
3437
3438 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
3439 Set_Is_Internal (Proc_Id);
3440 Set_Has_Completion (Proc_Id);
3441
3442 if not Debug_Generated_Code then
3443 Set_Debug_Info_Off (Proc_Id);
3444 end if;
3445
3446 Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
3447
3448 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
3449 -- needed and may generate early references to non frozen types
3450 -- since we expand aggregate much more systematically.
3451
3452 if Modify_Tree_For_C then
3453 return;
3454 end if;
3455
3456 declare
3457 Agg : constant Node_Id :=
3458 Build_Equivalent_Record_Aggregate (Rec_Type);
3459
3460 procedure Collect_Itypes (Comp : Node_Id);
3461 -- Generate references to itypes in the aggregate, because
3462 -- the first use of the aggregate may be in a nested scope.
3463
3464 --------------------
3465 -- Collect_Itypes --
3466 --------------------
3467
3468 procedure Collect_Itypes (Comp : Node_Id) is
3469 Ref : Node_Id;
3470 Sub_Aggr : Node_Id;
3471 Typ : constant Entity_Id := Etype (Comp);
3472
3473 begin
3474 if Is_Array_Type (Typ) and then Is_Itype (Typ) then
3475 Ref := Make_Itype_Reference (Loc);
3476 Set_Itype (Ref, Typ);
3477 Append_Freeze_Action (Rec_Type, Ref);
3478
3479 Ref := Make_Itype_Reference (Loc);
3480 Set_Itype (Ref, Etype (First_Index (Typ)));
3481 Append_Freeze_Action (Rec_Type, Ref);
3482
3483 -- Recurse on nested arrays
3484
3485 Sub_Aggr := First (Expressions (Comp));
3486 while Present (Sub_Aggr) loop
3487 Collect_Itypes (Sub_Aggr);
3488 Next (Sub_Aggr);
3489 end loop;
3490 end if;
3491 end Collect_Itypes;
3492
3493 begin
3494 -- If there is a static initialization aggregate for the type,
3495 -- generate itype references for the types of its (sub)components,
3496 -- to prevent out-of-scope errors in the resulting tree.
3497 -- The aggregate may have been rewritten as a Raise node, in which
3498 -- case there are no relevant itypes.
3499
3500 if Present (Agg) and then Nkind (Agg) = N_Aggregate then
3501 Set_Static_Initialization (Proc_Id, Agg);
3502
3503 declare
3504 Comp : Node_Id;
3505 begin
3506 Comp := First (Component_Associations (Agg));
3507 while Present (Comp) loop
3508 Collect_Itypes (Expression (Comp));
3509 Next (Comp);
3510 end loop;
3511 end;
3512 end if;
3513 end;
3514 end if;
3515 end Build_Record_Init_Proc;
3516
3517 ----------------------------
3518 -- Build_Slice_Assignment --
3519 ----------------------------
3520
3521 -- Generates the following subprogram:
3522
3523 -- procedure Assign
3524 -- (Source, Target : Array_Type,
3525 -- Left_Lo, Left_Hi : Index;
3526 -- Right_Lo, Right_Hi : Index;
3527 -- Rev : Boolean)
3528 -- is
3529 -- Li1 : Index;
3530 -- Ri1 : Index;
3531
3532 -- begin
3533
3534 -- if Left_Hi < Left_Lo then
3535 -- return;
3536 -- end if;
3537
3538 -- if Rev then
3539 -- Li1 := Left_Hi;
3540 -- Ri1 := Right_Hi;
3541 -- else
3542 -- Li1 := Left_Lo;
3543 -- Ri1 := Right_Lo;
3544 -- end if;
3545
3546 -- loop
3547 -- Target (Li1) := Source (Ri1);
3548
3549 -- if Rev then
3550 -- exit when Li1 = Left_Lo;
3551 -- Li1 := Index'pred (Li1);
3552 -- Ri1 := Index'pred (Ri1);
3553 -- else
3554 -- exit when Li1 = Left_Hi;
3555 -- Li1 := Index'succ (Li1);
3556 -- Ri1 := Index'succ (Ri1);
3557 -- end if;
3558 -- end loop;
3559 -- end Assign;
3560
3561 procedure Build_Slice_Assignment (Typ : Entity_Id) is
3562 Loc : constant Source_Ptr := Sloc (Typ);
3563 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
3564
3565 Larray : constant Entity_Id := Make_Temporary (Loc, 'A');
3566 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R');
3567 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L');
3568 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L');
3569 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R');
3570 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R');
3571 Rev : constant Entity_Id := Make_Temporary (Loc, 'D');
3572 -- Formal parameters of procedure
3573
3574 Proc_Name : constant Entity_Id :=
3575 Make_Defining_Identifier (Loc,
3576 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
3577
3578 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L');
3579 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R');
3580 -- Subscripts for left and right sides
3581
3582 Decls : List_Id;
3583 Loops : Node_Id;
3584 Stats : List_Id;
3585
3586 begin
3587 -- Build declarations for indexes
3588
3589 Decls := New_List;
3590
3591 Append_To (Decls,
3592 Make_Object_Declaration (Loc,
3593 Defining_Identifier => Lnn,
3594 Object_Definition =>
3595 New_Occurrence_Of (Index, Loc)));
3596
3597 Append_To (Decls,
3598 Make_Object_Declaration (Loc,
3599 Defining_Identifier => Rnn,
3600 Object_Definition =>
3601 New_Occurrence_Of (Index, Loc)));
3602
3603 Stats := New_List;
3604
3605 -- Build test for empty slice case
3606
3607 Append_To (Stats,
3608 Make_If_Statement (Loc,
3609 Condition =>
3610 Make_Op_Lt (Loc,
3611 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
3612 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
3613 Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
3614
3615 -- Build initializations for indexes
3616
3617 declare
3618 F_Init : constant List_Id := New_List;
3619 B_Init : constant List_Id := New_List;
3620
3621 begin
3622 Append_To (F_Init,
3623 Make_Assignment_Statement (Loc,
3624 Name => New_Occurrence_Of (Lnn, Loc),
3625 Expression => New_Occurrence_Of (Left_Lo, Loc)));
3626
3627 Append_To (F_Init,
3628 Make_Assignment_Statement (Loc,
3629 Name => New_Occurrence_Of (Rnn, Loc),
3630 Expression => New_Occurrence_Of (Right_Lo, Loc)));
3631
3632 Append_To (B_Init,
3633 Make_Assignment_Statement (Loc,
3634 Name => New_Occurrence_Of (Lnn, Loc),
3635 Expression => New_Occurrence_Of (Left_Hi, Loc)));
3636
3637 Append_To (B_Init,
3638 Make_Assignment_Statement (Loc,
3639 Name => New_Occurrence_Of (Rnn, Loc),
3640 Expression => New_Occurrence_Of (Right_Hi, Loc)));
3641
3642 Append_To (Stats,
3643 Make_If_Statement (Loc,
3644 Condition => New_Occurrence_Of (Rev, Loc),
3645 Then_Statements => B_Init,
3646 Else_Statements => F_Init));
3647 end;
3648
3649 -- Now construct the assignment statement
3650
3651 Loops :=
3652 Make_Loop_Statement (Loc,
3653 Statements => New_List (
3654 Make_Assignment_Statement (Loc,
3655 Name =>
3656 Make_Indexed_Component (Loc,
3657 Prefix => New_Occurrence_Of (Larray, Loc),
3658 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
3659 Expression =>
3660 Make_Indexed_Component (Loc,
3661 Prefix => New_Occurrence_Of (Rarray, Loc),
3662 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
3663 End_Label => Empty);
3664
3665 -- Build the exit condition and increment/decrement statements
3666
3667 declare
3668 F_Ass : constant List_Id := New_List;
3669 B_Ass : constant List_Id := New_List;
3670
3671 begin
3672 Append_To (F_Ass,
3673 Make_Exit_Statement (Loc,
3674 Condition =>
3675 Make_Op_Eq (Loc,
3676 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3677 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
3678
3679 Append_To (F_Ass,
3680 Make_Assignment_Statement (Loc,
3681 Name => New_Occurrence_Of (Lnn, Loc),
3682 Expression =>
3683 Make_Attribute_Reference (Loc,
3684 Prefix =>
3685 New_Occurrence_Of (Index, Loc),
3686 Attribute_Name => Name_Succ,
3687 Expressions => New_List (
3688 New_Occurrence_Of (Lnn, Loc)))));
3689
3690 Append_To (F_Ass,
3691 Make_Assignment_Statement (Loc,
3692 Name => New_Occurrence_Of (Rnn, Loc),
3693 Expression =>
3694 Make_Attribute_Reference (Loc,
3695 Prefix =>
3696 New_Occurrence_Of (Index, Loc),
3697 Attribute_Name => Name_Succ,
3698 Expressions => New_List (
3699 New_Occurrence_Of (Rnn, Loc)))));
3700
3701 Append_To (B_Ass,
3702 Make_Exit_Statement (Loc,
3703 Condition =>
3704 Make_Op_Eq (Loc,
3705 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3706 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
3707
3708 Append_To (B_Ass,
3709 Make_Assignment_Statement (Loc,
3710 Name => New_Occurrence_Of (Lnn, Loc),
3711 Expression =>
3712 Make_Attribute_Reference (Loc,
3713 Prefix =>
3714 New_Occurrence_Of (Index, Loc),
3715 Attribute_Name => Name_Pred,
3716 Expressions => New_List (
3717 New_Occurrence_Of (Lnn, Loc)))));
3718
3719 Append_To (B_Ass,
3720 Make_Assignment_Statement (Loc,
3721 Name => New_Occurrence_Of (Rnn, Loc),
3722 Expression =>
3723 Make_Attribute_Reference (Loc,
3724 Prefix =>
3725 New_Occurrence_Of (Index, Loc),
3726 Attribute_Name => Name_Pred,
3727 Expressions => New_List (
3728 New_Occurrence_Of (Rnn, Loc)))));
3729
3730 Append_To (Statements (Loops),
3731 Make_If_Statement (Loc,
3732 Condition => New_Occurrence_Of (Rev, Loc),
3733 Then_Statements => B_Ass,
3734 Else_Statements => F_Ass));
3735 end;
3736
3737 Append_To (Stats, Loops);
3738
3739 declare
3740 Spec : Node_Id;
3741 Formals : List_Id := New_List;
3742
3743 begin
3744 Formals := New_List (
3745 Make_Parameter_Specification (Loc,
3746 Defining_Identifier => Larray,
3747 Out_Present => True,
3748 Parameter_Type =>
3749 New_Occurrence_Of (Base_Type (Typ), Loc)),
3750
3751 Make_Parameter_Specification (Loc,
3752 Defining_Identifier => Rarray,
3753 Parameter_Type =>
3754 New_Occurrence_Of (Base_Type (Typ), Loc)),
3755
3756 Make_Parameter_Specification (Loc,
3757 Defining_Identifier => Left_Lo,
3758 Parameter_Type =>
3759 New_Occurrence_Of (Index, Loc)),
3760
3761 Make_Parameter_Specification (Loc,
3762 Defining_Identifier => Left_Hi,
3763 Parameter_Type =>
3764 New_Occurrence_Of (Index, Loc)),
3765
3766 Make_Parameter_Specification (Loc,
3767 Defining_Identifier => Right_Lo,
3768 Parameter_Type =>
3769 New_Occurrence_Of (Index, Loc)),
3770
3771 Make_Parameter_Specification (Loc,
3772 Defining_Identifier => Right_Hi,
3773 Parameter_Type =>
3774 New_Occurrence_Of (Index, Loc)));
3775
3776 Append_To (Formals,
3777 Make_Parameter_Specification (Loc,
3778 Defining_Identifier => Rev,
3779 Parameter_Type =>
3780 New_Occurrence_Of (Standard_Boolean, Loc)));
3781
3782 Spec :=
3783 Make_Procedure_Specification (Loc,
3784 Defining_Unit_Name => Proc_Name,
3785 Parameter_Specifications => Formals);
3786
3787 Discard_Node (
3788 Make_Subprogram_Body (Loc,
3789 Specification => Spec,
3790 Declarations => Decls,
3791 Handled_Statement_Sequence =>
3792 Make_Handled_Sequence_Of_Statements (Loc,
3793 Statements => Stats)));
3794 end;
3795
3796 Set_TSS (Typ, Proc_Name);
3797 Set_Is_Pure (Proc_Name);
3798 end Build_Slice_Assignment;
3799
3800 -----------------------------
3801 -- Build_Untagged_Equality --
3802 -----------------------------
3803
3804 procedure Build_Untagged_Equality (Typ : Entity_Id) is
3805 Build_Eq : Boolean;
3806 Comp : Entity_Id;
3807 Decl : Node_Id;
3808 Op : Entity_Id;
3809 Prim : Elmt_Id;
3810 Eq_Op : Entity_Id;
3811
3812 function User_Defined_Eq (T : Entity_Id) return Entity_Id;
3813 -- Check whether the type T has a user-defined primitive equality. If so
3814 -- return it, else return Empty. If true for a component of Typ, we have
3815 -- to build the primitive equality for it.
3816
3817 ---------------------
3818 -- User_Defined_Eq --
3819 ---------------------
3820
3821 function User_Defined_Eq (T : Entity_Id) return Entity_Id is
3822 Prim : Elmt_Id;
3823 Op : Entity_Id;
3824
3825 begin
3826 Op := TSS (T, TSS_Composite_Equality);
3827
3828 if Present (Op) then
3829 return Op;
3830 end if;
3831
3832 Prim := First_Elmt (Collect_Primitive_Operations (T));
3833 while Present (Prim) loop
3834 Op := Node (Prim);
3835
3836 if Chars (Op) = Name_Op_Eq
3837 and then Etype (Op) = Standard_Boolean
3838 and then Etype (First_Formal (Op)) = T
3839 and then Etype (Next_Formal (First_Formal (Op))) = T
3840 then
3841 return Op;
3842 end if;
3843
3844 Next_Elmt (Prim);
3845 end loop;
3846
3847 return Empty;
3848 end User_Defined_Eq;
3849
3850 -- Start of processing for Build_Untagged_Equality
3851
3852 begin
3853 -- If a record component has a primitive equality operation, we must
3854 -- build the corresponding one for the current type.
3855
3856 Build_Eq := False;
3857 Comp := First_Component (Typ);
3858 while Present (Comp) loop
3859 if Is_Record_Type (Etype (Comp))
3860 and then Present (User_Defined_Eq (Etype (Comp)))
3861 then
3862 Build_Eq := True;
3863 end if;
3864
3865 Next_Component (Comp);
3866 end loop;
3867
3868 -- If there is a user-defined equality for the type, we do not create
3869 -- the implicit one.
3870
3871 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
3872 Eq_Op := Empty;
3873 while Present (Prim) loop
3874 if Chars (Node (Prim)) = Name_Op_Eq
3875 and then Comes_From_Source (Node (Prim))
3876
3877 -- Don't we also need to check formal types and return type as in
3878 -- User_Defined_Eq above???
3879
3880 then
3881 Eq_Op := Node (Prim);
3882 Build_Eq := False;
3883 exit;
3884 end if;
3885
3886 Next_Elmt (Prim);
3887 end loop;
3888
3889 -- If the type is derived, inherit the operation, if present, from the
3890 -- parent type. It may have been declared after the type derivation. If
3891 -- the parent type itself is derived, it may have inherited an operation
3892 -- that has itself been overridden, so update its alias and related
3893 -- flags. Ditto for inequality.
3894
3895 if No (Eq_Op) and then Is_Derived_Type (Typ) then
3896 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
3897 while Present (Prim) loop
3898 if Chars (Node (Prim)) = Name_Op_Eq then
3899 Copy_TSS (Node (Prim), Typ);
3900 Build_Eq := False;
3901
3902 declare
3903 Op : constant Entity_Id := User_Defined_Eq (Typ);
3904 Eq_Op : constant Entity_Id := Node (Prim);
3905 NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
3906
3907 begin
3908 if Present (Op) then
3909 Set_Alias (Op, Eq_Op);
3910 Set_Is_Abstract_Subprogram
3911 (Op, Is_Abstract_Subprogram (Eq_Op));
3912
3913 if Chars (Next_Entity (Op)) = Name_Op_Ne then
3914 Set_Is_Abstract_Subprogram
3915 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
3916 end if;
3917 end if;
3918 end;
3919
3920 exit;
3921 end if;
3922
3923 Next_Elmt (Prim);
3924 end loop;
3925 end if;
3926
3927 -- If not inherited and not user-defined, build body as for a type with
3928 -- tagged components.
3929
3930 if Build_Eq then
3931 Decl :=
3932 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
3933 Op := Defining_Entity (Decl);
3934 Set_TSS (Typ, Op);
3935 Set_Is_Pure (Op);
3936
3937 if Is_Library_Level_Entity (Typ) then
3938 Set_Is_Public (Op);
3939 end if;
3940 end if;
3941 end Build_Untagged_Equality;
3942
3943 -----------------------------------
3944 -- Build_Variant_Record_Equality --
3945 -----------------------------------
3946
3947 -- Generates:
3948
3949 -- function _Equality (X, Y : T) return Boolean is
3950 -- begin
3951 -- -- Compare discriminants
3952
3953 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
3954 -- return False;
3955 -- end if;
3956
3957 -- -- Compare components
3958
3959 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
3960 -- return False;
3961 -- end if;
3962
3963 -- -- Compare variant part
3964
3965 -- case X.D1 is
3966 -- when V1 =>
3967 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
3968 -- return False;
3969 -- end if;
3970 -- ...
3971 -- when Vn =>
3972 -- if X.Cn /= Y.Cn or else ... then
3973 -- return False;
3974 -- end if;
3975 -- end case;
3976
3977 -- return True;
3978 -- end _Equality;
3979
3980 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
3981 Loc : constant Source_Ptr := Sloc (Typ);
3982
3983 F : constant Entity_Id :=
3984 Make_Defining_Identifier (Loc,
3985 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
3986
3987 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
3988 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
3989
3990 Def : constant Node_Id := Parent (Typ);
3991 Comps : constant Node_Id := Component_List (Type_Definition (Def));
3992 Stmts : constant List_Id := New_List;
3993 Pspecs : constant List_Id := New_List;
3994
3995 begin
3996 -- If we have a variant record with restriction No_Implicit_Conditionals
3997 -- in effect, then we skip building the procedure. This is safe because
3998 -- if we can see the restriction, so can any caller, calls to equality
3999 -- test routines are not allowed for variant records if this restriction
4000 -- is active.
4001
4002 if Restriction_Active (No_Implicit_Conditionals) then
4003 return;
4004 end if;
4005
4006 -- Derived Unchecked_Union types no longer inherit the equality function
4007 -- of their parent.
4008
4009 if Is_Derived_Type (Typ)
4010 and then not Is_Unchecked_Union (Typ)
4011 and then not Has_New_Non_Standard_Rep (Typ)
4012 then
4013 declare
4014 Parent_Eq : constant Entity_Id :=
4015 TSS (Root_Type (Typ), TSS_Composite_Equality);
4016 begin
4017 if Present (Parent_Eq) then
4018 Copy_TSS (Parent_Eq, Typ);
4019 return;
4020 end if;
4021 end;
4022 end if;
4023
4024 Discard_Node (
4025 Make_Subprogram_Body (Loc,
4026 Specification =>
4027 Make_Function_Specification (Loc,
4028 Defining_Unit_Name => F,
4029 Parameter_Specifications => Pspecs,
4030 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
4031 Declarations => New_List,
4032 Handled_Statement_Sequence =>
4033 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
4034
4035 Append_To (Pspecs,
4036 Make_Parameter_Specification (Loc,
4037 Defining_Identifier => X,
4038 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4039
4040 Append_To (Pspecs,
4041 Make_Parameter_Specification (Loc,
4042 Defining_Identifier => Y,
4043 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
4044
4045 -- Unchecked_Unions require additional machinery to support equality.
4046 -- Two extra parameters (A and B) are added to the equality function
4047 -- parameter list for each discriminant of the type, in order to
4048 -- capture the inferred values of the discriminants in equality calls.
4049 -- The names of the parameters match the names of the corresponding
4050 -- discriminant, with an added suffix.
4051
4052 if Is_Unchecked_Union (Typ) then
4053 declare
4054 Discr : Entity_Id;
4055 Discr_Type : Entity_Id;
4056 A, B : Entity_Id;
4057 New_Discrs : Elist_Id;
4058
4059 begin
4060 New_Discrs := New_Elmt_List;
4061
4062 Discr := First_Discriminant (Typ);
4063 while Present (Discr) loop
4064 Discr_Type := Etype (Discr);
4065 A := Make_Defining_Identifier (Loc,
4066 Chars => New_External_Name (Chars (Discr), 'A'));
4067
4068 B := Make_Defining_Identifier (Loc,
4069 Chars => New_External_Name (Chars (Discr), 'B'));
4070
4071 -- Add new parameters to the parameter list
4072
4073 Append_To (Pspecs,
4074 Make_Parameter_Specification (Loc,
4075 Defining_Identifier => A,
4076 Parameter_Type =>
4077 New_Occurrence_Of (Discr_Type, Loc)));
4078
4079 Append_To (Pspecs,
4080 Make_Parameter_Specification (Loc,
4081 Defining_Identifier => B,
4082 Parameter_Type =>
4083 New_Occurrence_Of (Discr_Type, Loc)));
4084
4085 Append_Elmt (A, New_Discrs);
4086
4087 -- Generate the following code to compare each of the inferred
4088 -- discriminants:
4089
4090 -- if a /= b then
4091 -- return False;
4092 -- end if;
4093
4094 Append_To (Stmts,
4095 Make_If_Statement (Loc,
4096 Condition =>
4097 Make_Op_Ne (Loc,
4098 Left_Opnd => New_Occurrence_Of (A, Loc),
4099 Right_Opnd => New_Occurrence_Of (B, Loc)),
4100 Then_Statements => New_List (
4101 Make_Simple_Return_Statement (Loc,
4102 Expression =>
4103 New_Occurrence_Of (Standard_False, Loc)))));
4104 Next_Discriminant (Discr);
4105 end loop;
4106
4107 -- Generate component-by-component comparison. Note that we must
4108 -- propagate the inferred discriminants formals to act as
4109 -- the case statement switch. Their value is added when an
4110 -- equality call on unchecked unions is expanded.
4111
4112 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs));
4113 end;
4114
4115 -- Normal case (not unchecked union)
4116
4117 else
4118 Append_To (Stmts,
4119 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
4120 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
4121 end if;
4122
4123 Append_To (Stmts,
4124 Make_Simple_Return_Statement (Loc,
4125 Expression => New_Occurrence_Of (Standard_True, Loc)));
4126
4127 Set_TSS (Typ, F);
4128 Set_Is_Pure (F);
4129
4130 if not Debug_Generated_Code then
4131 Set_Debug_Info_Off (F);
4132 end if;
4133 end Build_Variant_Record_Equality;
4134
4135 -----------------------------
4136 -- Check_Stream_Attributes --
4137 -----------------------------
4138
4139 procedure Check_Stream_Attributes (Typ : Entity_Id) is
4140 Comp : Entity_Id;
4141 Par_Read : constant Boolean :=
4142 Stream_Attribute_Available (Typ, TSS_Stream_Read)
4143 and then not Has_Specified_Stream_Read (Typ);
4144 Par_Write : constant Boolean :=
4145 Stream_Attribute_Available (Typ, TSS_Stream_Write)
4146 and then not Has_Specified_Stream_Write (Typ);
4147
4148 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
4149 -- Check that Comp has a user-specified Nam stream attribute
4150
4151 ----------------
4152 -- Check_Attr --
4153 ----------------
4154
4155 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
4156 begin
4157 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
4158 Error_Msg_Name_1 := Nam;
4159 Error_Msg_N
4160 ("|component& in limited extension must have% attribute", Comp);
4161 end if;
4162 end Check_Attr;
4163
4164 -- Start of processing for Check_Stream_Attributes
4165
4166 begin
4167 if Par_Read or else Par_Write then
4168 Comp := First_Component (Typ);
4169 while Present (Comp) loop
4170 if Comes_From_Source (Comp)
4171 and then Original_Record_Component (Comp) = Comp
4172 and then Is_Limited_Type (Etype (Comp))
4173 then
4174 if Par_Read then
4175 Check_Attr (Name_Read, TSS_Stream_Read);
4176 end if;
4177
4178 if Par_Write then
4179 Check_Attr (Name_Write, TSS_Stream_Write);
4180 end if;
4181 end if;
4182
4183 Next_Component (Comp);
4184 end loop;
4185 end if;
4186 end Check_Stream_Attributes;
4187
4188 ----------------------
4189 -- Clean_Task_Names --
4190 ----------------------
4191
4192 procedure Clean_Task_Names
4193 (Typ : Entity_Id;
4194 Proc_Id : Entity_Id)
4195 is
4196 begin
4197 if Has_Task (Typ)
4198 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4199 and then not Global_Discard_Names
4200 and then Tagged_Type_Expansion
4201 then
4202 Set_Uses_Sec_Stack (Proc_Id);
4203 end if;
4204 end Clean_Task_Names;
4205
4206 ------------------------------
4207 -- Expand_Freeze_Array_Type --
4208 ------------------------------
4209
4210 procedure Expand_Freeze_Array_Type (N : Node_Id) is
4211 Typ : constant Entity_Id := Entity (N);
4212 Base : constant Entity_Id := Base_Type (Typ);
4213 Comp_Typ : constant Entity_Id := Component_Type (Typ);
4214
4215 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4216
4217 begin
4218 -- Ensure that all freezing activities are properly flagged as Ghost
4219
4220 Set_Ghost_Mode_From_Entity (Typ);
4221
4222 if not Is_Bit_Packed_Array (Typ) then
4223
4224 -- If the component contains tasks, so does the array type. This may
4225 -- not be indicated in the array type because the component may have
4226 -- been a private type at the point of definition. Same if component
4227 -- type is controlled or contains protected objects.
4228
4229 Propagate_Concurrent_Flags (Base, Comp_Typ);
4230 Set_Has_Controlled_Component
4231 (Base, Has_Controlled_Component (Comp_Typ)
4232 or else Is_Controlled (Comp_Typ));
4233
4234 if No (Init_Proc (Base)) then
4235
4236 -- If this is an anonymous array created for a declaration with
4237 -- an initial value, its init_proc will never be called. The
4238 -- initial value itself may have been expanded into assignments,
4239 -- in which case the object declaration is carries the
4240 -- No_Initialization flag.
4241
4242 if Is_Itype (Base)
4243 and then Nkind (Associated_Node_For_Itype (Base)) =
4244 N_Object_Declaration
4245 and then
4246 (Present (Expression (Associated_Node_For_Itype (Base)))
4247 or else No_Initialization (Associated_Node_For_Itype (Base)))
4248 then
4249 null;
4250
4251 -- We do not need an init proc for string or wide [wide] string,
4252 -- since the only time these need initialization in normalize or
4253 -- initialize scalars mode, and these types are treated specially
4254 -- and do not need initialization procedures.
4255
4256 elsif Is_Standard_String_Type (Base) then
4257 null;
4258
4259 -- Otherwise we have to build an init proc for the subtype
4260
4261 else
4262 Build_Array_Init_Proc (Base, N);
4263 end if;
4264 end if;
4265
4266 if Typ = Base and then Has_Controlled_Component (Base) then
4267 Build_Controlling_Procs (Base);
4268
4269 if not Is_Limited_Type (Comp_Typ)
4270 and then Number_Dimensions (Typ) = 1
4271 then
4272 Build_Slice_Assignment (Typ);
4273 end if;
4274 end if;
4275
4276 -- For packed case, default initialization, except if the component type
4277 -- is itself a packed structure with an initialization procedure, or
4278 -- initialize/normalize scalars active, and we have a base type, or the
4279 -- type is public, because in that case a client might specify
4280 -- Normalize_Scalars and there better be a public Init_Proc for it.
4281
4282 elsif (Present (Init_Proc (Component_Type (Base)))
4283 and then No (Base_Init_Proc (Base)))
4284 or else (Init_Or_Norm_Scalars and then Base = Typ)
4285 or else Is_Public (Typ)
4286 then
4287 Build_Array_Init_Proc (Base, N);
4288 end if;
4289
4290 Ghost_Mode := Save_Ghost_Mode;
4291 end Expand_Freeze_Array_Type;
4292
4293 -----------------------------------
4294 -- Expand_Freeze_Class_Wide_Type --
4295 -----------------------------------
4296
4297 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
4298 function Is_C_Derivation (Typ : Entity_Id) return Boolean;
4299 -- Given a type, determine whether it is derived from a C or C++ root
4300
4301 ---------------------
4302 -- Is_C_Derivation --
4303 ---------------------
4304
4305 function Is_C_Derivation (Typ : Entity_Id) return Boolean is
4306 T : Entity_Id;
4307
4308 begin
4309 T := Typ;
4310 loop
4311 if Is_CPP_Class (T)
4312 or else Convention (T) = Convention_C
4313 or else Convention (T) = Convention_CPP
4314 then
4315 return True;
4316 end if;
4317
4318 exit when T = Etype (T);
4319
4320 T := Etype (T);
4321 end loop;
4322
4323 return False;
4324 end Is_C_Derivation;
4325
4326 -- Local variables
4327
4328 Typ : constant Entity_Id := Entity (N);
4329 Root : constant Entity_Id := Root_Type (Typ);
4330
4331 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4332
4333 -- Start of processing for Expand_Freeze_Class_Wide_Type
4334
4335 begin
4336 -- Certain run-time configurations and targets do not provide support
4337 -- for controlled types.
4338
4339 if Restriction_Active (No_Finalization) then
4340 return;
4341
4342 -- Do not create TSS routine Finalize_Address when dispatching calls are
4343 -- disabled since the core of the routine is a dispatching call.
4344
4345 elsif Restriction_Active (No_Dispatching_Calls) then
4346 return;
4347
4348 -- Do not create TSS routine Finalize_Address for concurrent class-wide
4349 -- types. Ignore C, C++, CIL and Java types since it is assumed that the
4350 -- non-Ada side will handle their destruction.
4351
4352 elsif Is_Concurrent_Type (Root)
4353 or else Is_C_Derivation (Root)
4354 or else Convention (Typ) = Convention_CPP
4355 then
4356 return;
4357
4358 -- Do not create TSS routine Finalize_Address when compiling in CodePeer
4359 -- mode since the routine contains an Unchecked_Conversion.
4360
4361 elsif CodePeer_Mode then
4362 return;
4363 end if;
4364
4365 -- Ensure that all freezing activities are properly flagged as Ghost
4366
4367 Set_Ghost_Mode_From_Entity (Typ);
4368
4369 -- Create the body of TSS primitive Finalize_Address. This automatically
4370 -- sets the TSS entry for the class-wide type.
4371
4372 Make_Finalize_Address_Body (Typ);
4373 Ghost_Mode := Save_Ghost_Mode;
4374 end Expand_Freeze_Class_Wide_Type;
4375
4376 ------------------------------------
4377 -- Expand_Freeze_Enumeration_Type --
4378 ------------------------------------
4379
4380 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
4381 Typ : constant Entity_Id := Entity (N);
4382 Loc : constant Source_Ptr := Sloc (Typ);
4383
4384 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4385
4386 Arr : Entity_Id;
4387 Ent : Entity_Id;
4388 Fent : Entity_Id;
4389 Is_Contiguous : Boolean;
4390 Ityp : Entity_Id;
4391 Last_Repval : Uint;
4392 Lst : List_Id;
4393 Num : Nat;
4394 Pos_Expr : Node_Id;
4395
4396 Func : Entity_Id;
4397 pragma Warnings (Off, Func);
4398
4399 begin
4400 -- Ensure that all freezing activities are properly flagged as Ghost
4401
4402 Set_Ghost_Mode_From_Entity (Typ);
4403
4404 -- Various optimizations possible if given representation is contiguous
4405
4406 Is_Contiguous := True;
4407
4408 Ent := First_Literal (Typ);
4409 Last_Repval := Enumeration_Rep (Ent);
4410
4411 Next_Literal (Ent);
4412 while Present (Ent) loop
4413 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4414 Is_Contiguous := False;
4415 exit;
4416 else
4417 Last_Repval := Enumeration_Rep (Ent);
4418 end if;
4419
4420 Next_Literal (Ent);
4421 end loop;
4422
4423 if Is_Contiguous then
4424 Set_Has_Contiguous_Rep (Typ);
4425 Ent := First_Literal (Typ);
4426 Num := 1;
4427 Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
4428
4429 else
4430 -- Build list of literal references
4431
4432 Lst := New_List;
4433 Num := 0;
4434
4435 Ent := First_Literal (Typ);
4436 while Present (Ent) loop
4437 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
4438 Num := Num + 1;
4439 Next_Literal (Ent);
4440 end loop;
4441 end if;
4442
4443 -- Now build an array declaration
4444
4445 -- typA : array (Natural range 0 .. num - 1) of ctype :=
4446 -- (v, v, v, v, v, ....)
4447
4448 -- where ctype is the corresponding integer type. If the representation
4449 -- is contiguous, we only keep the first literal, which provides the
4450 -- offset for Pos_To_Rep computations.
4451
4452 Arr :=
4453 Make_Defining_Identifier (Loc,
4454 Chars => New_External_Name (Chars (Typ), 'A'));
4455
4456 Append_Freeze_Action (Typ,
4457 Make_Object_Declaration (Loc,
4458 Defining_Identifier => Arr,
4459 Constant_Present => True,
4460
4461 Object_Definition =>
4462 Make_Constrained_Array_Definition (Loc,
4463 Discrete_Subtype_Definitions => New_List (
4464 Make_Subtype_Indication (Loc,
4465 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
4466 Constraint =>
4467 Make_Range_Constraint (Loc,
4468 Range_Expression =>
4469 Make_Range (Loc,
4470 Low_Bound =>
4471 Make_Integer_Literal (Loc, 0),
4472 High_Bound =>
4473 Make_Integer_Literal (Loc, Num - 1))))),
4474
4475 Component_Definition =>
4476 Make_Component_Definition (Loc,
4477 Aliased_Present => False,
4478 Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
4479
4480 Expression =>
4481 Make_Aggregate (Loc,
4482 Expressions => Lst)));
4483
4484 Set_Enum_Pos_To_Rep (Typ, Arr);
4485
4486 -- Now we build the function that converts representation values to
4487 -- position values. This function has the form:
4488
4489 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4490 -- begin
4491 -- case ityp!(A) is
4492 -- when enum-lit'Enum_Rep => return posval;
4493 -- when enum-lit'Enum_Rep => return posval;
4494 -- ...
4495 -- when others =>
4496 -- [raise Constraint_Error when F "invalid data"]
4497 -- return -1;
4498 -- end case;
4499 -- end;
4500
4501 -- Note: the F parameter determines whether the others case (no valid
4502 -- representation) raises Constraint_Error or returns a unique value
4503 -- of minus one. The latter case is used, e.g. in 'Valid code.
4504
4505 -- Note: the reason we use Enum_Rep values in the case here is to avoid
4506 -- the code generator making inappropriate assumptions about the range
4507 -- of the values in the case where the value is invalid. ityp is a
4508 -- signed or unsigned integer type of appropriate width.
4509
4510 -- Note: if exceptions are not supported, then we suppress the raise
4511 -- and return -1 unconditionally (this is an erroneous program in any
4512 -- case and there is no obligation to raise Constraint_Error here). We
4513 -- also do this if pragma Restrictions (No_Exceptions) is active.
4514
4515 -- Is this right??? What about No_Exception_Propagation???
4516
4517 -- Representations are signed
4518
4519 if Enumeration_Rep (First_Literal (Typ)) < 0 then
4520
4521 -- The underlying type is signed. Reset the Is_Unsigned_Type
4522 -- explicitly, because it might have been inherited from
4523 -- parent type.
4524
4525 Set_Is_Unsigned_Type (Typ, False);
4526
4527 if Esize (Typ) <= Standard_Integer_Size then
4528 Ityp := Standard_Integer;
4529 else
4530 Ityp := Universal_Integer;
4531 end if;
4532
4533 -- Representations are unsigned
4534
4535 else
4536 if Esize (Typ) <= Standard_Integer_Size then
4537 Ityp := RTE (RE_Unsigned);
4538 else
4539 Ityp := RTE (RE_Long_Long_Unsigned);
4540 end if;
4541 end if;
4542
4543 -- The body of the function is a case statement. First collect case
4544 -- alternatives, or optimize the contiguous case.
4545
4546 Lst := New_List;
4547
4548 -- If representation is contiguous, Pos is computed by subtracting
4549 -- the representation of the first literal.
4550
4551 if Is_Contiguous then
4552 Ent := First_Literal (Typ);
4553
4554 if Enumeration_Rep (Ent) = Last_Repval then
4555
4556 -- Another special case: for a single literal, Pos is zero
4557
4558 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4559
4560 else
4561 Pos_Expr :=
4562 Convert_To (Standard_Integer,
4563 Make_Op_Subtract (Loc,
4564 Left_Opnd =>
4565 Unchecked_Convert_To
4566 (Ityp, Make_Identifier (Loc, Name_uA)),
4567 Right_Opnd =>
4568 Make_Integer_Literal (Loc,
4569 Intval => Enumeration_Rep (First_Literal (Typ)))));
4570 end if;
4571
4572 Append_To (Lst,
4573 Make_Case_Statement_Alternative (Loc,
4574 Discrete_Choices => New_List (
4575 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4576 Low_Bound =>
4577 Make_Integer_Literal (Loc,
4578 Intval => Enumeration_Rep (Ent)),
4579 High_Bound =>
4580 Make_Integer_Literal (Loc, Intval => Last_Repval))),
4581
4582 Statements => New_List (
4583 Make_Simple_Return_Statement (Loc,
4584 Expression => Pos_Expr))));
4585
4586 else
4587 Ent := First_Literal (Typ);
4588 while Present (Ent) loop
4589 Append_To (Lst,
4590 Make_Case_Statement_Alternative (Loc,
4591 Discrete_Choices => New_List (
4592 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4593 Intval => Enumeration_Rep (Ent))),
4594
4595 Statements => New_List (
4596 Make_Simple_Return_Statement (Loc,
4597 Expression =>
4598 Make_Integer_Literal (Loc,
4599 Intval => Enumeration_Pos (Ent))))));
4600
4601 Next_Literal (Ent);
4602 end loop;
4603 end if;
4604
4605 -- In normal mode, add the others clause with the test.
4606 -- If Predicates_Ignored is True, validity checks do not apply to
4607 -- the subtype.
4608
4609 if not No_Exception_Handlers_Set
4610 and then not Predicates_Ignored (Typ)
4611 then
4612 Append_To (Lst,
4613 Make_Case_Statement_Alternative (Loc,
4614 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4615 Statements => New_List (
4616 Make_Raise_Constraint_Error (Loc,
4617 Condition => Make_Identifier (Loc, Name_uF),
4618 Reason => CE_Invalid_Data),
4619 Make_Simple_Return_Statement (Loc,
4620 Expression => Make_Integer_Literal (Loc, -1)))));
4621
4622 -- If either of the restrictions No_Exceptions_Handlers/Propagation is
4623 -- active then return -1 (we cannot usefully raise Constraint_Error in
4624 -- this case). See description above for further details.
4625
4626 else
4627 Append_To (Lst,
4628 Make_Case_Statement_Alternative (Loc,
4629 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4630 Statements => New_List (
4631 Make_Simple_Return_Statement (Loc,
4632 Expression => Make_Integer_Literal (Loc, -1)))));
4633 end if;
4634
4635 -- Now we can build the function body
4636
4637 Fent :=
4638 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4639
4640 Func :=
4641 Make_Subprogram_Body (Loc,
4642 Specification =>
4643 Make_Function_Specification (Loc,
4644 Defining_Unit_Name => Fent,
4645 Parameter_Specifications => New_List (
4646 Make_Parameter_Specification (Loc,
4647 Defining_Identifier =>
4648 Make_Defining_Identifier (Loc, Name_uA),
4649 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
4650 Make_Parameter_Specification (Loc,
4651 Defining_Identifier =>
4652 Make_Defining_Identifier (Loc, Name_uF),
4653 Parameter_Type =>
4654 New_Occurrence_Of (Standard_Boolean, Loc))),
4655
4656 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
4657
4658 Declarations => Empty_List,
4659
4660 Handled_Statement_Sequence =>
4661 Make_Handled_Sequence_Of_Statements (Loc,
4662 Statements => New_List (
4663 Make_Case_Statement (Loc,
4664 Expression =>
4665 Unchecked_Convert_To
4666 (Ityp, Make_Identifier (Loc, Name_uA)),
4667 Alternatives => Lst))));
4668
4669 Set_TSS (Typ, Fent);
4670
4671 -- Set Pure flag (it will be reset if the current context is not Pure).
4672 -- We also pretend there was a pragma Pure_Function so that for purposes
4673 -- of optimization and constant-folding, we will consider the function
4674 -- Pure even if we are not in a Pure context).
4675
4676 Set_Is_Pure (Fent);
4677 Set_Has_Pragma_Pure_Function (Fent);
4678
4679 -- Unless we are in -gnatD mode, where we are debugging generated code,
4680 -- this is an internal entity for which we don't need debug info.
4681
4682 if not Debug_Generated_Code then
4683 Set_Debug_Info_Off (Fent);
4684 end if;
4685
4686 Ghost_Mode := Save_Ghost_Mode;
4687
4688 exception
4689 when RE_Not_Available =>
4690 Ghost_Mode := Save_Ghost_Mode;
4691 return;
4692 end Expand_Freeze_Enumeration_Type;
4693
4694 -------------------------------
4695 -- Expand_Freeze_Record_Type --
4696 -------------------------------
4697
4698 procedure Expand_Freeze_Record_Type (N : Node_Id) is
4699 Typ : constant Node_Id := Entity (N);
4700 Typ_Decl : constant Node_Id := Parent (Typ);
4701
4702 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4703
4704 Comp : Entity_Id;
4705 Comp_Typ : Entity_Id;
4706 Predef_List : List_Id;
4707
4708 Wrapper_Decl_List : List_Id := No_List;
4709 Wrapper_Body_List : List_Id := No_List;
4710
4711 Renamed_Eq : Node_Id := Empty;
4712 -- Defining unit name for the predefined equality function in the case
4713 -- where the type has a primitive operation that is a renaming of
4714 -- predefined equality (but only if there is also an overriding
4715 -- user-defined equality function). Used to pass this entity from
4716 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
4717
4718 -- Start of processing for Expand_Freeze_Record_Type
4719
4720 begin
4721 -- Ensure that all freezing activities are properly flagged as Ghost
4722
4723 Set_Ghost_Mode_From_Entity (Typ);
4724
4725 -- Build discriminant checking functions if not a derived type (for
4726 -- derived types that are not tagged types, always use the discriminant
4727 -- checking functions of the parent type). However, for untagged types
4728 -- the derivation may have taken place before the parent was frozen, so
4729 -- we copy explicitly the discriminant checking functions from the
4730 -- parent into the components of the derived type.
4731
4732 if not Is_Derived_Type (Typ)
4733 or else Has_New_Non_Standard_Rep (Typ)
4734 or else Is_Tagged_Type (Typ)
4735 then
4736 Build_Discr_Checking_Funcs (Typ_Decl);
4737
4738 elsif Is_Derived_Type (Typ)
4739 and then not Is_Tagged_Type (Typ)
4740
4741 -- If we have a derived Unchecked_Union, we do not inherit the
4742 -- discriminant checking functions from the parent type since the
4743 -- discriminants are non existent.
4744
4745 and then not Is_Unchecked_Union (Typ)
4746 and then Has_Discriminants (Typ)
4747 then
4748 declare
4749 Old_Comp : Entity_Id;
4750
4751 begin
4752 Old_Comp :=
4753 First_Component (Base_Type (Underlying_Type (Etype (Typ))));
4754 Comp := First_Component (Typ);
4755 while Present (Comp) loop
4756 if Ekind (Comp) = E_Component
4757 and then Chars (Comp) = Chars (Old_Comp)
4758 then
4759 Set_Discriminant_Checking_Func
4760 (Comp, Discriminant_Checking_Func (Old_Comp));
4761 end if;
4762
4763 Next_Component (Old_Comp);
4764 Next_Component (Comp);
4765 end loop;
4766 end;
4767 end if;
4768
4769 if Is_Derived_Type (Typ)
4770 and then Is_Limited_Type (Typ)
4771 and then Is_Tagged_Type (Typ)
4772 then
4773 Check_Stream_Attributes (Typ);
4774 end if;
4775
4776 -- Update task, protected, and controlled component flags, because some
4777 -- of the component types may have been private at the point of the
4778 -- record declaration. Detect anonymous access-to-controlled components.
4779
4780 Comp := First_Component (Typ);
4781 while Present (Comp) loop
4782 Comp_Typ := Etype (Comp);
4783
4784 Propagate_Concurrent_Flags (Typ, Comp_Typ);
4785
4786 -- Do not set Has_Controlled_Component on a class-wide equivalent
4787 -- type. See Make_CW_Equivalent_Type.
4788
4789 if not Is_Class_Wide_Equivalent_Type (Typ)
4790 and then
4791 (Has_Controlled_Component (Comp_Typ)
4792 or else (Chars (Comp) /= Name_uParent
4793 and then (Is_Controlled_Active (Comp_Typ))))
4794 then
4795 Set_Has_Controlled_Component (Typ);
4796 end if;
4797
4798 Next_Component (Comp);
4799 end loop;
4800
4801 -- Handle constructors of untagged CPP_Class types
4802
4803 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
4804 Set_CPP_Constructors (Typ);
4805 end if;
4806
4807 -- Creation of the Dispatch Table. Note that a Dispatch Table is built
4808 -- for regular tagged types as well as for Ada types deriving from a C++
4809 -- Class, but not for tagged types directly corresponding to C++ classes
4810 -- In the later case we assume that it is created in the C++ side and we
4811 -- just use it.
4812
4813 if Is_Tagged_Type (Typ) then
4814
4815 -- Add the _Tag component
4816
4817 if Underlying_Type (Etype (Typ)) = Typ then
4818 Expand_Tagged_Root (Typ);
4819 end if;
4820
4821 if Is_CPP_Class (Typ) then
4822 Set_All_DT_Position (Typ);
4823
4824 -- Create the tag entities with a minimum decoration
4825
4826 if Tagged_Type_Expansion then
4827 Append_Freeze_Actions (Typ, Make_Tags (Typ));
4828 end if;
4829
4830 Set_CPP_Constructors (Typ);
4831
4832 else
4833 if not Building_Static_DT (Typ) then
4834
4835 -- Usually inherited primitives are not delayed but the first
4836 -- Ada extension of a CPP_Class is an exception since the
4837 -- address of the inherited subprogram has to be inserted in
4838 -- the new Ada Dispatch Table and this is a freezing action.
4839
4840 -- Similarly, if this is an inherited operation whose parent is
4841 -- not frozen yet, it is not in the DT of the parent, and we
4842 -- generate an explicit freeze node for the inherited operation
4843 -- so it is properly inserted in the DT of the current type.
4844
4845 declare
4846 Elmt : Elmt_Id;
4847 Subp : Entity_Id;
4848
4849 begin
4850 Elmt := First_Elmt (Primitive_Operations (Typ));
4851 while Present (Elmt) loop
4852 Subp := Node (Elmt);
4853
4854 if Present (Alias (Subp)) then
4855 if Is_CPP_Class (Etype (Typ)) then
4856 Set_Has_Delayed_Freeze (Subp);
4857
4858 elsif Has_Delayed_Freeze (Alias (Subp))
4859 and then not Is_Frozen (Alias (Subp))
4860 then
4861 Set_Is_Frozen (Subp, False);
4862 Set_Has_Delayed_Freeze (Subp);
4863 end if;
4864 end if;
4865
4866 Next_Elmt (Elmt);
4867 end loop;
4868 end;
4869 end if;
4870
4871 -- Unfreeze momentarily the type to add the predefined primitives
4872 -- operations. The reason we unfreeze is so that these predefined
4873 -- operations will indeed end up as primitive operations (which
4874 -- must be before the freeze point).
4875
4876 Set_Is_Frozen (Typ, False);
4877
4878 -- Do not add the spec of predefined primitives in case of
4879 -- CPP tagged type derivations that have convention CPP.
4880
4881 if Is_CPP_Class (Root_Type (Typ))
4882 and then Convention (Typ) = Convention_CPP
4883 then
4884 null;
4885
4886 -- Do not add the spec of the predefined primitives if we are
4887 -- compiling under restriction No_Dispatching_Calls.
4888
4889 elsif not Restriction_Active (No_Dispatching_Calls) then
4890 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
4891 Insert_List_Before_And_Analyze (N, Predef_List);
4892 end if;
4893
4894 -- Ada 2005 (AI-391): For a nonabstract null extension, create
4895 -- wrapper functions for each nonoverridden inherited function
4896 -- with a controlling result of the type. The wrapper for such
4897 -- a function returns an extension aggregate that invokes the
4898 -- parent function.
4899
4900 if Ada_Version >= Ada_2005
4901 and then not Is_Abstract_Type (Typ)
4902 and then Is_Null_Extension (Typ)
4903 then
4904 Make_Controlling_Function_Wrappers
4905 (Typ, Wrapper_Decl_List, Wrapper_Body_List);
4906 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
4907 end if;
4908
4909 -- Ada 2005 (AI-251): For a nonabstract type extension, build
4910 -- null procedure declarations for each set of homographic null
4911 -- procedures that are inherited from interface types but not
4912 -- overridden. This is done to ensure that the dispatch table
4913 -- entry associated with such null primitives are properly filled.
4914
4915 if Ada_Version >= Ada_2005
4916 and then Etype (Typ) /= Typ
4917 and then not Is_Abstract_Type (Typ)
4918 and then Has_Interfaces (Typ)
4919 then
4920 Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
4921 end if;
4922
4923 Set_Is_Frozen (Typ);
4924
4925 if not Is_Derived_Type (Typ)
4926 or else Is_Tagged_Type (Etype (Typ))
4927 then
4928 Set_All_DT_Position (Typ);
4929
4930 -- If this is a type derived from an untagged private type whose
4931 -- full view is tagged, the type is marked tagged for layout
4932 -- reasons, but it has no dispatch table.
4933
4934 elsif Is_Derived_Type (Typ)
4935 and then Is_Private_Type (Etype (Typ))
4936 and then not Is_Tagged_Type (Etype (Typ))
4937 then
4938 return;
4939 end if;
4940
4941 -- Create and decorate the tags. Suppress their creation when
4942 -- not Tagged_Type_Expansion because the dispatching mechanism is
4943 -- handled internally by the virtual target.
4944
4945 if Tagged_Type_Expansion then
4946 Append_Freeze_Actions (Typ, Make_Tags (Typ));
4947
4948 -- Generate dispatch table of locally defined tagged type.
4949 -- Dispatch tables of library level tagged types are built
4950 -- later (see Analyze_Declarations).
4951
4952 if not Building_Static_DT (Typ) then
4953 Append_Freeze_Actions (Typ, Make_DT (Typ));
4954 end if;
4955 end if;
4956
4957 -- If the type has unknown discriminants, propagate dispatching
4958 -- information to its underlying record view, which does not get
4959 -- its own dispatch table.
4960
4961 if Is_Derived_Type (Typ)
4962 and then Has_Unknown_Discriminants (Typ)
4963 and then Present (Underlying_Record_View (Typ))
4964 then
4965 declare
4966 Rep : constant Entity_Id := Underlying_Record_View (Typ);
4967 begin
4968 Set_Access_Disp_Table
4969 (Rep, Access_Disp_Table (Typ));
4970 Set_Dispatch_Table_Wrappers
4971 (Rep, Dispatch_Table_Wrappers (Typ));
4972 Set_Direct_Primitive_Operations
4973 (Rep, Direct_Primitive_Operations (Typ));
4974 end;
4975 end if;
4976
4977 -- Make sure that the primitives Initialize, Adjust and Finalize
4978 -- are Frozen before other TSS subprograms. We don't want them
4979 -- Frozen inside.
4980
4981 if Is_Controlled (Typ) then
4982 if not Is_Limited_Type (Typ) then
4983 Append_Freeze_Actions (Typ,
4984 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
4985 end if;
4986
4987 Append_Freeze_Actions (Typ,
4988 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
4989
4990 Append_Freeze_Actions (Typ,
4991 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
4992 end if;
4993
4994 -- Freeze rest of primitive operations. There is no need to handle
4995 -- the predefined primitives if we are compiling under restriction
4996 -- No_Dispatching_Calls.
4997
4998 if not Restriction_Active (No_Dispatching_Calls) then
4999 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
5000 end if;
5001 end if;
5002
5003 -- In the untagged case, ever since Ada 83 an equality function must
5004 -- be provided for variant records that are not unchecked unions.
5005 -- In Ada 2012 the equality function composes, and thus must be built
5006 -- explicitly just as for tagged records.
5007
5008 elsif Has_Discriminants (Typ)
5009 and then not Is_Limited_Type (Typ)
5010 then
5011 declare
5012 Comps : constant Node_Id :=
5013 Component_List (Type_Definition (Typ_Decl));
5014 begin
5015 if Present (Comps)
5016 and then Present (Variant_Part (Comps))
5017 then
5018 Build_Variant_Record_Equality (Typ);
5019 end if;
5020 end;
5021
5022 -- Otherwise create primitive equality operation (AI05-0123)
5023
5024 -- This is done unconditionally to ensure that tools can be linked
5025 -- properly with user programs compiled with older language versions.
5026 -- In addition, this is needed because "=" composes for bounded strings
5027 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
5028
5029 elsif Comes_From_Source (Typ)
5030 and then Convention (Typ) = Convention_Ada
5031 and then not Is_Limited_Type (Typ)
5032 then
5033 Build_Untagged_Equality (Typ);
5034 end if;
5035
5036 -- Before building the record initialization procedure, if we are
5037 -- dealing with a concurrent record value type, then we must go through
5038 -- the discriminants, exchanging discriminals between the concurrent
5039 -- type and the concurrent record value type. See the section "Handling
5040 -- of Discriminants" in the Einfo spec for details.
5041
5042 if Is_Concurrent_Record_Type (Typ)
5043 and then Has_Discriminants (Typ)
5044 then
5045 declare
5046 Ctyp : constant Entity_Id :=
5047 Corresponding_Concurrent_Type (Typ);
5048 Conc_Discr : Entity_Id;
5049 Rec_Discr : Entity_Id;
5050 Temp : Entity_Id;
5051
5052 begin
5053 Conc_Discr := First_Discriminant (Ctyp);
5054 Rec_Discr := First_Discriminant (Typ);
5055 while Present (Conc_Discr) loop
5056 Temp := Discriminal (Conc_Discr);
5057 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5058 Set_Discriminal (Rec_Discr, Temp);
5059
5060 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5061 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5062
5063 Next_Discriminant (Conc_Discr);
5064 Next_Discriminant (Rec_Discr);
5065 end loop;
5066 end;
5067 end if;
5068
5069 if Has_Controlled_Component (Typ) then
5070 Build_Controlling_Procs (Typ);
5071 end if;
5072
5073 Adjust_Discriminants (Typ);
5074
5075 -- Do not need init for interfaces on virtual targets since they're
5076 -- abstract.
5077
5078 if Tagged_Type_Expansion or else not Is_Interface (Typ) then
5079 Build_Record_Init_Proc (Typ_Decl, Typ);
5080 end if;
5081
5082 -- For tagged type that are not interfaces, build bodies of primitive
5083 -- operations. Note: do this after building the record initialization
5084 -- procedure, since the primitive operations may need the initialization
5085 -- routine. There is no need to add predefined primitives of interfaces
5086 -- because all their predefined primitives are abstract.
5087
5088 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
5089
5090 -- Do not add the body of predefined primitives in case of CPP tagged
5091 -- type derivations that have convention CPP.
5092
5093 if Is_CPP_Class (Root_Type (Typ))
5094 and then Convention (Typ) = Convention_CPP
5095 then
5096 null;
5097
5098 -- Do not add the body of the predefined primitives if we are
5099 -- compiling under restriction No_Dispatching_Calls or if we are
5100 -- compiling a CPP tagged type.
5101
5102 elsif not Restriction_Active (No_Dispatching_Calls) then
5103
5104 -- Create the body of TSS primitive Finalize_Address. This must
5105 -- be done before the bodies of all predefined primitives are
5106 -- created. If Typ is limited, Stream_Input and Stream_Read may
5107 -- produce build-in-place allocations and for those the expander
5108 -- needs Finalize_Address.
5109
5110 Make_Finalize_Address_Body (Typ);
5111 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
5112 Append_Freeze_Actions (Typ, Predef_List);
5113 end if;
5114
5115 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5116 -- inherited functions, then add their bodies to the freeze actions.
5117
5118 if Present (Wrapper_Body_List) then
5119 Append_Freeze_Actions (Typ, Wrapper_Body_List);
5120 end if;
5121
5122 -- Create extra formals for the primitive operations of the type.
5123 -- This must be done before analyzing the body of the initialization
5124 -- procedure, because a self-referential type might call one of these
5125 -- primitives in the body of the init_proc itself.
5126
5127 declare
5128 Elmt : Elmt_Id;
5129 Subp : Entity_Id;
5130
5131 begin
5132 Elmt := First_Elmt (Primitive_Operations (Typ));
5133 while Present (Elmt) loop
5134 Subp := Node (Elmt);
5135 if not Has_Foreign_Convention (Subp)
5136 and then not Is_Predefined_Dispatching_Operation (Subp)
5137 then
5138 Create_Extra_Formals (Subp);
5139 end if;
5140
5141 Next_Elmt (Elmt);
5142 end loop;
5143 end;
5144 end if;
5145
5146 Ghost_Mode := Save_Ghost_Mode;
5147 end Expand_Freeze_Record_Type;
5148
5149 ------------------------------------
5150 -- Expand_N_Full_Type_Declaration --
5151 ------------------------------------
5152
5153 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
5154 procedure Build_Master (Ptr_Typ : Entity_Id);
5155 -- Create the master associated with Ptr_Typ
5156
5157 ------------------
5158 -- Build_Master --
5159 ------------------
5160
5161 procedure Build_Master (Ptr_Typ : Entity_Id) is
5162 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
5163
5164 begin
5165 -- If the designated type is an incomplete view coming from a
5166 -- limited-with'ed package, we need to use the nonlimited view in
5167 -- case it has tasks.
5168
5169 if Ekind (Desig_Typ) in Incomplete_Kind
5170 and then Present (Non_Limited_View (Desig_Typ))
5171 then
5172 Desig_Typ := Non_Limited_View (Desig_Typ);
5173 end if;
5174
5175 -- Anonymous access types are created for the components of the
5176 -- record parameter for an entry declaration. No master is created
5177 -- for such a type.
5178
5179 if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
5180 Build_Master_Entity (Ptr_Typ);
5181 Build_Master_Renaming (Ptr_Typ);
5182
5183 -- Create a class-wide master because a Master_Id must be generated
5184 -- for access-to-limited-class-wide types whose root may be extended
5185 -- with task components.
5186
5187 -- Note: This code covers access-to-limited-interfaces because they
5188 -- can be used to reference tasks implementing them.
5189
5190 elsif Is_Limited_Class_Wide_Type (Desig_Typ)
5191 and then Tasking_Allowed
5192 then
5193 Build_Class_Wide_Master (Ptr_Typ);
5194 end if;
5195 end Build_Master;
5196
5197 -- Local declarations
5198
5199 Def_Id : constant Entity_Id := Defining_Identifier (N);
5200 B_Id : constant Entity_Id := Base_Type (Def_Id);
5201 FN : Node_Id;
5202 Par_Id : Entity_Id;
5203
5204 -- Start of processing for Expand_N_Full_Type_Declaration
5205
5206 begin
5207 if Is_Access_Type (Def_Id) then
5208 Build_Master (Def_Id);
5209
5210 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
5211 Expand_Access_Protected_Subprogram_Type (N);
5212 end if;
5213
5214 -- Array of anonymous access-to-task pointers
5215
5216 elsif Ada_Version >= Ada_2005
5217 and then Is_Array_Type (Def_Id)
5218 and then Is_Access_Type (Component_Type (Def_Id))
5219 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
5220 then
5221 Build_Master (Component_Type (Def_Id));
5222
5223 elsif Has_Task (Def_Id) then
5224 Expand_Previous_Access_Type (Def_Id);
5225
5226 -- Check the components of a record type or array of records for
5227 -- anonymous access-to-task pointers.
5228
5229 elsif Ada_Version >= Ada_2005
5230 and then (Is_Record_Type (Def_Id)
5231 or else
5232 (Is_Array_Type (Def_Id)
5233 and then Is_Record_Type (Component_Type (Def_Id))))
5234 then
5235 declare
5236 Comp : Entity_Id;
5237 First : Boolean;
5238 M_Id : Entity_Id;
5239 Typ : Entity_Id;
5240
5241 begin
5242 if Is_Array_Type (Def_Id) then
5243 Comp := First_Entity (Component_Type (Def_Id));
5244 else
5245 Comp := First_Entity (Def_Id);
5246 end if;
5247
5248 -- Examine all components looking for anonymous access-to-task
5249 -- types.
5250
5251 First := True;
5252 while Present (Comp) loop
5253 Typ := Etype (Comp);
5254
5255 if Ekind (Typ) = E_Anonymous_Access_Type
5256 and then Has_Task (Available_View (Designated_Type (Typ)))
5257 and then No (Master_Id (Typ))
5258 then
5259 -- Ensure that the record or array type have a _master
5260
5261 if First then
5262 Build_Master_Entity (Def_Id);
5263 Build_Master_Renaming (Typ);
5264 M_Id := Master_Id (Typ);
5265
5266 First := False;
5267
5268 -- Reuse the same master to service any additional types
5269
5270 else
5271 Set_Master_Id (Typ, M_Id);
5272 end if;
5273 end if;
5274
5275 Next_Entity (Comp);
5276 end loop;
5277 end;
5278 end if;
5279
5280 Par_Id := Etype (B_Id);
5281
5282 -- The parent type is private then we need to inherit any TSS operations
5283 -- from the full view.
5284
5285 if Ekind (Par_Id) in Private_Kind
5286 and then Present (Full_View (Par_Id))
5287 then
5288 Par_Id := Base_Type (Full_View (Par_Id));
5289 end if;
5290
5291 if Nkind (Type_Definition (Original_Node (N))) =
5292 N_Derived_Type_Definition
5293 and then not Is_Tagged_Type (Def_Id)
5294 and then Present (Freeze_Node (Par_Id))
5295 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
5296 then
5297 Ensure_Freeze_Node (B_Id);
5298 FN := Freeze_Node (B_Id);
5299
5300 if No (TSS_Elist (FN)) then
5301 Set_TSS_Elist (FN, New_Elmt_List);
5302 end if;
5303
5304 declare
5305 T_E : constant Elist_Id := TSS_Elist (FN);
5306 Elmt : Elmt_Id;
5307
5308 begin
5309 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
5310 while Present (Elmt) loop
5311 if Chars (Node (Elmt)) /= Name_uInit then
5312 Append_Elmt (Node (Elmt), T_E);
5313 end if;
5314
5315 Next_Elmt (Elmt);
5316 end loop;
5317
5318 -- If the derived type itself is private with a full view, then
5319 -- associate the full view with the inherited TSS_Elist as well.
5320
5321 if Ekind (B_Id) in Private_Kind
5322 and then Present (Full_View (B_Id))
5323 then
5324 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
5325 Set_TSS_Elist
5326 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
5327 end if;
5328 end;
5329 end if;
5330 end Expand_N_Full_Type_Declaration;
5331
5332 ---------------------------------
5333 -- Expand_N_Object_Declaration --
5334 ---------------------------------
5335
5336 procedure Expand_N_Object_Declaration (N : Node_Id) is
5337 Loc : constant Source_Ptr := Sloc (N);
5338 Def_Id : constant Entity_Id := Defining_Identifier (N);
5339 Expr : constant Node_Id := Expression (N);
5340 Obj_Def : constant Node_Id := Object_Definition (N);
5341 Typ : constant Entity_Id := Etype (Def_Id);
5342 Base_Typ : constant Entity_Id := Base_Type (Typ);
5343 Expr_Q : Node_Id;
5344
5345 function Build_Equivalent_Aggregate return Boolean;
5346 -- If the object has a constrained discriminated type and no initial
5347 -- value, it may be possible to build an equivalent aggregate instead,
5348 -- and prevent an actual call to the initialization procedure.
5349
5350 procedure Default_Initialize_Object (After : Node_Id);
5351 -- Generate all default initialization actions for object Def_Id. Any
5352 -- new code is inserted after node After.
5353
5354 function Rewrite_As_Renaming return Boolean;
5355 -- Indicate whether to rewrite a declaration with initialization into an
5356 -- object renaming declaration (see below).
5357
5358 --------------------------------
5359 -- Build_Equivalent_Aggregate --
5360 --------------------------------
5361
5362 function Build_Equivalent_Aggregate return Boolean is
5363 Aggr : Node_Id;
5364 Comp : Entity_Id;
5365 Discr : Elmt_Id;
5366 Full_Type : Entity_Id;
5367
5368 begin
5369 Full_Type := Typ;
5370
5371 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
5372 Full_Type := Full_View (Typ);
5373 end if;
5374
5375 -- Only perform this transformation if Elaboration_Code is forbidden
5376 -- or undesirable, and if this is a global entity of a constrained
5377 -- record type.
5378
5379 -- If Initialize_Scalars might be active this transformation cannot
5380 -- be performed either, because it will lead to different semantics
5381 -- or because elaboration code will in fact be created.
5382
5383 if Ekind (Full_Type) /= E_Record_Subtype
5384 or else not Has_Discriminants (Full_Type)
5385 or else not Is_Constrained (Full_Type)
5386 or else Is_Controlled (Full_Type)
5387 or else Is_Limited_Type (Full_Type)
5388 or else not Restriction_Active (No_Initialize_Scalars)
5389 then
5390 return False;
5391 end if;
5392
5393 if Ekind (Current_Scope) = E_Package
5394 and then
5395 (Restriction_Active (No_Elaboration_Code)
5396 or else Is_Preelaborated (Current_Scope))
5397 then
5398 -- Building a static aggregate is possible if the discriminants
5399 -- have static values and the other components have static
5400 -- defaults or none.
5401
5402 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5403 while Present (Discr) loop
5404 if not Is_OK_Static_Expression (Node (Discr)) then
5405 return False;
5406 end if;
5407
5408 Next_Elmt (Discr);
5409 end loop;
5410
5411 -- Check that initialized components are OK, and that non-
5412 -- initialized components do not require a call to their own
5413 -- initialization procedure.
5414
5415 Comp := First_Component (Full_Type);
5416 while Present (Comp) loop
5417 if Ekind (Comp) = E_Component
5418 and then Present (Expression (Parent (Comp)))
5419 and then
5420 not Is_OK_Static_Expression (Expression (Parent (Comp)))
5421 then
5422 return False;
5423
5424 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
5425 return False;
5426
5427 end if;
5428
5429 Next_Component (Comp);
5430 end loop;
5431
5432 -- Everything is static, assemble the aggregate, discriminant
5433 -- values first.
5434
5435 Aggr :=
5436 Make_Aggregate (Loc,
5437 Expressions => New_List,
5438 Component_Associations => New_List);
5439
5440 Discr := First_Elmt (Discriminant_Constraint (Full_Type));
5441 while Present (Discr) loop
5442 Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
5443 Next_Elmt (Discr);
5444 end loop;
5445
5446 -- Now collect values of initialized components
5447
5448 Comp := First_Component (Full_Type);
5449 while Present (Comp) loop
5450 if Ekind (Comp) = E_Component
5451 and then Present (Expression (Parent (Comp)))
5452 then
5453 Append_To (Component_Associations (Aggr),
5454 Make_Component_Association (Loc,
5455 Choices => New_List (New_Occurrence_Of (Comp, Loc)),
5456 Expression => New_Copy_Tree
5457 (Expression (Parent (Comp)))));
5458 end if;
5459
5460 Next_Component (Comp);
5461 end loop;
5462
5463 -- Finally, box-initialize remaining components
5464
5465 Append_To (Component_Associations (Aggr),
5466 Make_Component_Association (Loc,
5467 Choices => New_List (Make_Others_Choice (Loc)),
5468 Expression => Empty));
5469 Set_Box_Present (Last (Component_Associations (Aggr)));
5470 Set_Expression (N, Aggr);
5471
5472 if Typ /= Full_Type then
5473 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
5474 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
5475 Analyze_And_Resolve (Aggr, Typ);
5476 else
5477 Analyze_And_Resolve (Aggr, Full_Type);
5478 end if;
5479
5480 return True;
5481
5482 else
5483 return False;
5484 end if;
5485 end Build_Equivalent_Aggregate;
5486
5487 -------------------------------
5488 -- Default_Initialize_Object --
5489 -------------------------------
5490
5491 procedure Default_Initialize_Object (After : Node_Id) is
5492 function New_Object_Reference return Node_Id;
5493 -- Return a new reference to Def_Id with attributes Assignment_OK and
5494 -- Must_Not_Freeze already set.
5495
5496 --------------------------
5497 -- New_Object_Reference --
5498 --------------------------
5499
5500 function New_Object_Reference return Node_Id is
5501 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
5502
5503 begin
5504 -- The call to the type init proc or [Deep_]Finalize must not
5505 -- freeze the related object as the call is internally generated.
5506 -- This way legal rep clauses that apply to the object will not be
5507 -- flagged. Note that the initialization call may be removed if
5508 -- pragma Import is encountered or moved to the freeze actions of
5509 -- the object because of an address clause.
5510
5511 Set_Assignment_OK (Obj_Ref);
5512 Set_Must_Not_Freeze (Obj_Ref);
5513
5514 return Obj_Ref;
5515 end New_Object_Reference;
5516
5517 -- Local variables
5518
5519 Exceptions_OK : constant Boolean :=
5520 not Restriction_Active (No_Exception_Propagation);
5521
5522 Abrt_Blk : Node_Id;
5523 Abrt_Blk_Id : Entity_Id;
5524 Abrt_HSS : Node_Id;
5525 Aggr_Init : Node_Id;
5526 AUD : Entity_Id;
5527 Comp_Init : List_Id := No_List;
5528 Fin_Call : Node_Id;
5529 Init_Stmts : List_Id := No_List;
5530 Obj_Init : Node_Id := Empty;
5531 Obj_Ref : Node_Id;
5532
5533 -- Start of processing for Default_Initialize_Object
5534
5535 begin
5536 -- Default initialization is suppressed for objects that are already
5537 -- known to be imported (i.e. whose declaration specifies the Import
5538 -- aspect). Note that for objects with a pragma Import, we generate
5539 -- initialization here, and then remove it downstream when processing
5540 -- the pragma. It is also suppressed for variables for which a pragma
5541 -- Suppress_Initialization has been explicitly given
5542
5543 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
5544 return;
5545 end if;
5546
5547 -- The expansion performed by this routine is as follows:
5548
5549 -- begin
5550 -- Abort_Defer;
5551 -- Type_Init_Proc (Obj);
5552
5553 -- begin
5554 -- [Deep_]Initialize (Obj);
5555
5556 -- exception
5557 -- when others =>
5558 -- [Deep_]Finalize (Obj, Self => False);
5559 -- raise;
5560 -- end;
5561 -- at end
5562 -- Abort_Undefer_Direct;
5563 -- end;
5564
5565 -- Initialize the components of the object
5566
5567 if Has_Non_Null_Base_Init_Proc (Typ)
5568 and then not No_Initialization (N)
5569 and then not Initialization_Suppressed (Typ)
5570 then
5571 -- Do not initialize the components if No_Default_Initialization
5572 -- applies as the actual restriction check will occur later
5573 -- when the object is frozen as it is not known yet whether the
5574 -- object is imported or not.
5575
5576 if not Restriction_Active (No_Default_Initialization) then
5577
5578 -- If the values of the components are compile-time known, use
5579 -- their prebuilt aggregate form directly.
5580
5581 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
5582
5583 if Present (Aggr_Init) then
5584 Set_Expression
5585 (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
5586
5587 -- If type has discriminants, try to build an equivalent
5588 -- aggregate using discriminant values from the declaration.
5589 -- This is a useful optimization, in particular if restriction
5590 -- No_Elaboration_Code is active.
5591
5592 elsif Build_Equivalent_Aggregate then
5593 null;
5594
5595 -- Otherwise invoke the type init proc, generate:
5596 -- Type_Init_Proc (Obj);
5597
5598 else
5599 Obj_Ref := New_Object_Reference;
5600
5601 if Comes_From_Source (Def_Id) then
5602 Initialization_Warning (Obj_Ref);
5603 end if;
5604
5605 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
5606 end if;
5607 end if;
5608
5609 -- Provide a default value if the object needs simple initialization
5610 -- and does not already have an initial value. A generated temporary
5611 -- does not require initialization because it will be assigned later.
5612
5613 elsif Needs_Simple_Initialization
5614 (Typ, Initialize_Scalars
5615 and then No (Following_Address_Clause (N)))
5616 and then not Is_Internal (Def_Id)
5617 and then not Has_Init_Expression (N)
5618 then
5619 Set_No_Initialization (N, False);
5620 Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
5621 Analyze_And_Resolve (Expression (N), Typ);
5622 end if;
5623
5624 -- Initialize the object, generate:
5625 -- [Deep_]Initialize (Obj);
5626
5627 if Needs_Finalization (Typ) and then not No_Initialization (N) then
5628 Obj_Init :=
5629 Make_Init_Call
5630 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
5631 Typ => Typ);
5632 end if;
5633
5634 -- Build a special finalization block when both the object and its
5635 -- controlled components are to be initialized. The block finalizes
5636 -- the components if the object initialization fails. Generate:
5637
5638 -- begin
5639 -- <Obj_Init>
5640
5641 -- exception
5642 -- when others =>
5643 -- <Fin_Call>
5644 -- raise;
5645 -- end;
5646
5647 if Has_Controlled_Component (Typ)
5648 and then Present (Comp_Init)
5649 and then Present (Obj_Init)
5650 and then Exceptions_OK
5651 then
5652 Init_Stmts := Comp_Init;
5653
5654 Fin_Call :=
5655 Make_Final_Call
5656 (Obj_Ref => New_Object_Reference,
5657 Typ => Typ,
5658 Skip_Self => True);
5659
5660 if Present (Fin_Call) then
5661
5662 -- Do not emit warnings related to the elaboration order when a
5663 -- controlled object is declared before the body of Finalize is
5664 -- seen.
5665
5666 Set_No_Elaboration_Check (Fin_Call);
5667
5668 Append_To (Init_Stmts,
5669 Make_Block_Statement (Loc,
5670 Declarations => No_List,
5671
5672 Handled_Statement_Sequence =>
5673 Make_Handled_Sequence_Of_Statements (Loc,
5674 Statements => New_List (Obj_Init),
5675
5676 Exception_Handlers => New_List (
5677 Make_Exception_Handler (Loc,
5678 Exception_Choices => New_List (
5679 Make_Others_Choice (Loc)),
5680
5681 Statements => New_List (
5682 Fin_Call,
5683 Make_Raise_Statement (Loc)))))));
5684 end if;
5685
5686 -- Otherwise finalization is not required, the initialization calls
5687 -- are passed to the abort block building circuitry, generate:
5688
5689 -- Type_Init_Proc (Obj);
5690 -- [Deep_]Initialize (Obj);
5691
5692 else
5693 if Present (Comp_Init) then
5694 Init_Stmts := Comp_Init;
5695 end if;
5696
5697 if Present (Obj_Init) then
5698 if No (Init_Stmts) then
5699 Init_Stmts := New_List;
5700 end if;
5701
5702 Append_To (Init_Stmts, Obj_Init);
5703 end if;
5704 end if;
5705
5706 -- Build an abort block to protect the initialization calls
5707
5708 if Abort_Allowed
5709 and then Present (Comp_Init)
5710 and then Present (Obj_Init)
5711 then
5712 -- Generate:
5713 -- Abort_Defer;
5714
5715 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
5716
5717 -- When exceptions are propagated, abort deferral must take place
5718 -- in the presence of initialization or finalization exceptions.
5719 -- Generate:
5720
5721 -- begin
5722 -- Abort_Defer;
5723 -- <Init_Stmts>
5724 -- at end
5725 -- Abort_Undefer_Direct;
5726 -- end;
5727
5728 if Exceptions_OK then
5729 AUD := RTE (RE_Abort_Undefer_Direct);
5730
5731 Abrt_HSS :=
5732 Make_Handled_Sequence_Of_Statements (Loc,
5733 Statements => Init_Stmts,
5734 At_End_Proc => New_Occurrence_Of (AUD, Loc));
5735
5736 Abrt_Blk :=
5737 Make_Block_Statement (Loc,
5738 Handled_Statement_Sequence => Abrt_HSS);
5739
5740 Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
5741 Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
5742
5743 -- Present the Abort_Undefer_Direct function to the backend so
5744 -- that it can inline the call to the function.
5745
5746 Add_Inlined_Body (AUD, N);
5747
5748 Init_Stmts := New_List (Abrt_Blk);
5749
5750 -- Otherwise exceptions are not propagated. Generate:
5751
5752 -- Abort_Defer;
5753 -- <Init_Stmts>
5754 -- Abort_Undefer;
5755
5756 else
5757 Append_To (Init_Stmts,
5758 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5759 end if;
5760 end if;
5761
5762 -- Insert the whole initialization sequence into the tree. If the
5763 -- object has a delayed freeze, as will be the case when it has
5764 -- aspect specifications, the initialization sequence is part of
5765 -- the freeze actions.
5766
5767 if Present (Init_Stmts) then
5768 if Has_Delayed_Freeze (Def_Id) then
5769 Append_Freeze_Actions (Def_Id, Init_Stmts);
5770 else
5771 Insert_Actions_After (After, Init_Stmts);
5772 end if;
5773 end if;
5774 end Default_Initialize_Object;
5775
5776 -------------------------
5777 -- Rewrite_As_Renaming --
5778 -------------------------
5779
5780 function Rewrite_As_Renaming return Boolean is
5781 begin
5782 -- If the object declaration appears in the form
5783
5784 -- Obj : Ctrl_Typ := Func (...);
5785
5786 -- where Ctrl_Typ is controlled but not immutably limited type, then
5787 -- the expansion of the function call should use a dereference of the
5788 -- result to reference the value on the secondary stack.
5789
5790 -- Obj : Ctrl_Typ renames Func (...).all;
5791
5792 -- As a result, the call avoids an extra copy. This an optimization,
5793 -- but it is required for passing ACATS tests in some cases where it
5794 -- would otherwise make two copies. The RM allows removing redunant
5795 -- Adjust/Finalize calls, but does not allow insertion of extra ones.
5796
5797 -- This part is disabled for now, because it breaks GPS builds
5798
5799 return (False -- ???
5800 and then Nkind (Expr_Q) = N_Explicit_Dereference
5801 and then not Comes_From_Source (Expr_Q)
5802 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
5803 and then Nkind (Object_Definition (N)) in N_Has_Entity
5804 and then (Needs_Finalization (Entity (Object_Definition (N)))))
5805
5806 -- If the initializing expression is for a variable with attribute
5807 -- OK_To_Rename set, then transform:
5808
5809 -- Obj : Typ := Expr;
5810
5811 -- into
5812
5813 -- Obj : Typ renames Expr;
5814
5815 -- provided that Obj is not aliased. The aliased case has to be
5816 -- excluded in general because Expr will not be aliased in
5817 -- general.
5818
5819 or else
5820 (not Aliased_Present (N)
5821 and then Is_Entity_Name (Expr_Q)
5822 and then Ekind (Entity (Expr_Q)) = E_Variable
5823 and then OK_To_Rename (Entity (Expr_Q))
5824 and then Is_Entity_Name (Obj_Def));
5825 end Rewrite_As_Renaming;
5826
5827 -- Local variables
5828
5829 Next_N : constant Node_Id := Next (N);
5830 Id_Ref : Node_Id;
5831 Tag_Assign : Node_Id;
5832
5833 Init_After : Node_Id := N;
5834 -- Node after which the initialization actions are to be inserted. This
5835 -- is normally N, except for the case of a shared passive variable, in
5836 -- which case the init proc call must be inserted only after the bodies
5837 -- of the shared variable procedures have been seen.
5838
5839 -- Start of processing for Expand_N_Object_Declaration
5840
5841 begin
5842 -- Don't do anything for deferred constants. All proper actions will be
5843 -- expanded during the full declaration.
5844
5845 if No (Expr) and Constant_Present (N) then
5846 return;
5847 end if;
5848
5849 -- The type of the object cannot be abstract. This is diagnosed at the
5850 -- point the object is frozen, which happens after the declaration is
5851 -- fully expanded, so simply return now.
5852
5853 if Is_Abstract_Type (Typ) then
5854 return;
5855 end if;
5856
5857 -- First we do special processing for objects of a tagged type where
5858 -- this is the point at which the type is frozen. The creation of the
5859 -- dispatch table and the initialization procedure have to be deferred
5860 -- to this point, since we reference previously declared primitive
5861 -- subprograms.
5862
5863 -- Force construction of dispatch tables of library level tagged types
5864
5865 if Tagged_Type_Expansion
5866 and then Static_Dispatch_Tables
5867 and then Is_Library_Level_Entity (Def_Id)
5868 and then Is_Library_Level_Tagged_Type (Base_Typ)
5869 and then Ekind_In (Base_Typ, E_Record_Type,
5870 E_Protected_Type,
5871 E_Task_Type)
5872 and then not Has_Dispatch_Table (Base_Typ)
5873 then
5874 declare
5875 New_Nodes : List_Id := No_List;
5876
5877 begin
5878 if Is_Concurrent_Type (Base_Typ) then
5879 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
5880 else
5881 New_Nodes := Make_DT (Base_Typ, N);
5882 end if;
5883
5884 if not Is_Empty_List (New_Nodes) then
5885 Insert_List_Before (N, New_Nodes);
5886 end if;
5887 end;
5888 end if;
5889
5890 -- Make shared memory routines for shared passive variable
5891
5892 if Is_Shared_Passive (Def_Id) then
5893 Init_After := Make_Shared_Var_Procs (N);
5894 end if;
5895
5896 -- If tasks being declared, make sure we have an activation chain
5897 -- defined for the tasks (has no effect if we already have one), and
5898 -- also that a Master variable is established and that the appropriate
5899 -- enclosing construct is established as a task master.
5900
5901 if Has_Task (Typ) then
5902 Build_Activation_Chain_Entity (N);
5903 Build_Master_Entity (Def_Id);
5904 end if;
5905
5906 -- Default initialization required, and no expression present
5907
5908 if No (Expr) then
5909
5910 -- If we have a type with a variant part, the initialization proc
5911 -- will contain implicit tests of the discriminant values, which
5912 -- counts as a violation of the restriction No_Implicit_Conditionals.
5913
5914 if Has_Variant_Part (Typ) then
5915 declare
5916 Msg : Boolean;
5917
5918 begin
5919 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
5920
5921 if Msg then
5922 Error_Msg_N
5923 ("\initialization of variant record tests discriminants",
5924 Obj_Def);
5925 return;
5926 end if;
5927 end;
5928 end if;
5929
5930 -- For the default initialization case, if we have a private type
5931 -- with invariants, and invariant checks are enabled, then insert an
5932 -- invariant check after the object declaration. Note that it is OK
5933 -- to clobber the object with an invalid value since if the exception
5934 -- is raised, then the object will go out of scope. In the case where
5935 -- an array object is initialized with an aggregate, the expression
5936 -- is removed. Check flag Has_Init_Expression to avoid generating a
5937 -- junk invariant check and flag No_Initialization to avoid checking
5938 -- an uninitialized object such as a compiler temporary used for an
5939 -- aggregate.
5940
5941 if Has_Invariants (Base_Typ)
5942 and then Present (Invariant_Procedure (Base_Typ))
5943 and then not Has_Init_Expression (N)
5944 and then not No_Initialization (N)
5945 then
5946 -- If entity has an address clause or aspect, make invariant
5947 -- call into a freeze action for the explicit freeze node for
5948 -- object. Otherwise insert invariant check after declaration.
5949
5950 if Present (Following_Address_Clause (N))
5951 or else Has_Aspect (Def_Id, Aspect_Address)
5952 then
5953 Ensure_Freeze_Node (Def_Id);
5954 Set_Has_Delayed_Freeze (Def_Id);
5955 Set_Is_Frozen (Def_Id, False);
5956
5957 if not Partial_View_Has_Unknown_Discr (Typ) then
5958 Append_Freeze_Action (Def_Id,
5959 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
5960 end if;
5961
5962 elsif not Partial_View_Has_Unknown_Discr (Typ) then
5963 Insert_After (N,
5964 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
5965 end if;
5966 end if;
5967
5968 Default_Initialize_Object (Init_After);
5969
5970 -- Generate attribute for Persistent_BSS if needed
5971
5972 if Persistent_BSS_Mode
5973 and then Comes_From_Source (N)
5974 and then Is_Potentially_Persistent_Type (Typ)
5975 and then not Has_Init_Expression (N)
5976 and then Is_Library_Level_Entity (Def_Id)
5977 then
5978 declare
5979 Prag : Node_Id;
5980 begin
5981 Prag :=
5982 Make_Linker_Section_Pragma
5983 (Def_Id, Sloc (N), ".persistent.bss");
5984 Insert_After (N, Prag);
5985 Analyze (Prag);
5986 end;
5987 end if;
5988
5989 -- If access type, then we know it is null if not initialized
5990
5991 if Is_Access_Type (Typ) then
5992 Set_Is_Known_Null (Def_Id);
5993 end if;
5994
5995 -- Explicit initialization present
5996
5997 else
5998 -- Obtain actual expression from qualified expression
5999
6000 if Nkind (Expr) = N_Qualified_Expression then
6001 Expr_Q := Expression (Expr);
6002 else
6003 Expr_Q := Expr;
6004 end if;
6005
6006 -- When we have the appropriate type of aggregate in the expression
6007 -- (it has been determined during analysis of the aggregate by
6008 -- setting the delay flag), let's perform in place assignment and
6009 -- thus avoid creating a temporary.
6010
6011 if Is_Delayed_Aggregate (Expr_Q) then
6012 Convert_Aggr_In_Object_Decl (N);
6013
6014 -- Ada 2005 (AI-318-02): If the initialization expression is a call
6015 -- to a build-in-place function, then access to the declared object
6016 -- must be passed to the function. Currently we limit such functions
6017 -- to those with constrained limited result subtypes, but eventually
6018 -- plan to expand the allowed forms of functions that are treated as
6019 -- build-in-place.
6020
6021 elsif Ada_Version >= Ada_2005
6022 and then Is_Build_In_Place_Function_Call (Expr_Q)
6023 then
6024 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
6025
6026 -- The previous call expands the expression initializing the
6027 -- built-in-place object into further code that will be analyzed
6028 -- later. No further expansion needed here.
6029
6030 return;
6031
6032 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
6033 -- class-wide interface object to ensure that we copy the full
6034 -- object, unless we are targetting a VM where interfaces are handled
6035 -- by VM itself. Note that if the root type of Typ is an ancestor of
6036 -- Expr's type, both types share the same dispatch table and there is
6037 -- no need to displace the pointer.
6038
6039 elsif Is_Interface (Typ)
6040
6041 -- Avoid never-ending recursion because if Equivalent_Type is set
6042 -- then we've done it already and must not do it again.
6043
6044 and then not
6045 (Nkind (Obj_Def) = N_Identifier
6046 and then Present (Equivalent_Type (Entity (Obj_Def))))
6047 then
6048 pragma Assert (Is_Class_Wide_Type (Typ));
6049
6050 -- If the object is a return object of an inherently limited type,
6051 -- which implies build-in-place treatment, bypass the special
6052 -- treatment of class-wide interface initialization below. In this
6053 -- case, the expansion of the return statement will take care of
6054 -- creating the object (via allocator) and initializing it.
6055
6056 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
6057 null;
6058
6059 elsif Tagged_Type_Expansion then
6060 declare
6061 Iface : constant Entity_Id := Root_Type (Typ);
6062 Expr_N : Node_Id := Expr;
6063 Expr_Typ : Entity_Id;
6064 New_Expr : Node_Id;
6065 Obj_Id : Entity_Id;
6066 Tag_Comp : Node_Id;
6067
6068 begin
6069 -- If the original node of the expression was a conversion
6070 -- to this specific class-wide interface type then restore
6071 -- the original node because we must copy the object before
6072 -- displacing the pointer to reference the secondary tag
6073 -- component. This code must be kept synchronized with the
6074 -- expansion done by routine Expand_Interface_Conversion
6075
6076 if not Comes_From_Source (Expr_N)
6077 and then Nkind (Expr_N) = N_Explicit_Dereference
6078 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
6079 and then Etype (Original_Node (Expr_N)) = Typ
6080 then
6081 Rewrite (Expr_N, Original_Node (Expression (N)));
6082 end if;
6083
6084 -- Avoid expansion of redundant interface conversion
6085
6086 if Is_Interface (Etype (Expr_N))
6087 and then Nkind (Expr_N) = N_Type_Conversion
6088 and then Etype (Expr_N) = Typ
6089 then
6090 Expr_N := Expression (Expr_N);
6091 Set_Expression (N, Expr_N);
6092 end if;
6093
6094 Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
6095 Expr_Typ := Base_Type (Etype (Expr_N));
6096
6097 if Is_Class_Wide_Type (Expr_Typ) then
6098 Expr_Typ := Root_Type (Expr_Typ);
6099 end if;
6100
6101 -- Replace
6102 -- CW : I'Class := Obj;
6103 -- by
6104 -- Tmp : T := Obj;
6105 -- type Ityp is not null access I'Class;
6106 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
6107
6108 if Comes_From_Source (Expr_N)
6109 and then Nkind (Expr_N) = N_Identifier
6110 and then not Is_Interface (Expr_Typ)
6111 and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
6112 and then (Expr_Typ = Etype (Expr_Typ)
6113 or else not
6114 Is_Variable_Size_Record (Etype (Expr_Typ)))
6115 then
6116 -- Copy the object
6117
6118 Insert_Action (N,
6119 Make_Object_Declaration (Loc,
6120 Defining_Identifier => Obj_Id,
6121 Object_Definition =>
6122 New_Occurrence_Of (Expr_Typ, Loc),
6123 Expression => Relocate_Node (Expr_N)));
6124
6125 -- Statically reference the tag associated with the
6126 -- interface
6127
6128 Tag_Comp :=
6129 Make_Selected_Component (Loc,
6130 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6131 Selector_Name =>
6132 New_Occurrence_Of
6133 (Find_Interface_Tag (Expr_Typ, Iface), Loc));
6134
6135 -- Replace
6136 -- IW : I'Class := Obj;
6137 -- by
6138 -- type Equiv_Record is record ... end record;
6139 -- implicit subtype CW is <Class_Wide_Subtype>;
6140 -- Tmp : CW := CW!(Obj);
6141 -- type Ityp is not null access I'Class;
6142 -- IW : I'Class renames
6143 -- Ityp!(Displace (Temp'Address, I'Tag)).all;
6144
6145 else
6146 -- Generate the equivalent record type and update the
6147 -- subtype indication to reference it.
6148
6149 Expand_Subtype_From_Expr
6150 (N => N,
6151 Unc_Type => Typ,
6152 Subtype_Indic => Obj_Def,
6153 Exp => Expr_N);
6154
6155 if not Is_Interface (Etype (Expr_N)) then
6156 New_Expr := Relocate_Node (Expr_N);
6157
6158 -- For interface types we use 'Address which displaces
6159 -- the pointer to the base of the object (if required)
6160
6161 else
6162 New_Expr :=
6163 Unchecked_Convert_To (Etype (Obj_Def),
6164 Make_Explicit_Dereference (Loc,
6165 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6166 Make_Attribute_Reference (Loc,
6167 Prefix => Relocate_Node (Expr_N),
6168 Attribute_Name => Name_Address))));
6169 end if;
6170
6171 -- Copy the object
6172
6173 if not Is_Limited_Record (Expr_Typ) then
6174 Insert_Action (N,
6175 Make_Object_Declaration (Loc,
6176 Defining_Identifier => Obj_Id,
6177 Object_Definition =>
6178 New_Occurrence_Of (Etype (Obj_Def), Loc),
6179 Expression => New_Expr));
6180
6181 -- Rename limited type object since they cannot be copied
6182 -- This case occurs when the initialization expression
6183 -- has been previously expanded into a temporary object.
6184
6185 else pragma Assert (not Comes_From_Source (Expr_Q));
6186 Insert_Action (N,
6187 Make_Object_Renaming_Declaration (Loc,
6188 Defining_Identifier => Obj_Id,
6189 Subtype_Mark =>
6190 New_Occurrence_Of (Etype (Obj_Def), Loc),
6191 Name =>
6192 Unchecked_Convert_To
6193 (Etype (Obj_Def), New_Expr)));
6194 end if;
6195
6196 -- Dynamically reference the tag associated with the
6197 -- interface.
6198
6199 Tag_Comp :=
6200 Make_Function_Call (Loc,
6201 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
6202 Parameter_Associations => New_List (
6203 Make_Attribute_Reference (Loc,
6204 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6205 Attribute_Name => Name_Address),
6206 New_Occurrence_Of
6207 (Node (First_Elmt (Access_Disp_Table (Iface))),
6208 Loc)));
6209 end if;
6210
6211 Rewrite (N,
6212 Make_Object_Renaming_Declaration (Loc,
6213 Defining_Identifier => Make_Temporary (Loc, 'D'),
6214 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
6215 Name =>
6216 Convert_Tag_To_Interface (Typ, Tag_Comp)));
6217
6218 -- If the original entity comes from source, then mark the
6219 -- new entity as needing debug information, even though it's
6220 -- defined by a generated renaming that does not come from
6221 -- source, so that Materialize_Entity will be set on the
6222 -- entity when Debug_Renaming_Declaration is called during
6223 -- analysis.
6224
6225 if Comes_From_Source (Def_Id) then
6226 Set_Debug_Info_Needed (Defining_Identifier (N));
6227 end if;
6228
6229 Analyze (N, Suppress => All_Checks);
6230
6231 -- Replace internal identifier of rewritten node by the
6232 -- identifier found in the sources. We also have to exchange
6233 -- entities containing their defining identifiers to ensure
6234 -- the correct replacement of the object declaration by this
6235 -- object renaming declaration because these identifiers
6236 -- were previously added by Enter_Name to the current scope.
6237 -- We must preserve the homonym chain of the source entity
6238 -- as well. We must also preserve the kind of the entity,
6239 -- which may be a constant. Preserve entity chain because
6240 -- itypes may have been generated already, and the full
6241 -- chain must be preserved for final freezing. Finally,
6242 -- preserve Comes_From_Source setting, so that debugging
6243 -- and cross-referencing information is properly kept, and
6244 -- preserve source location, to prevent spurious errors when
6245 -- entities are declared (they must have their own Sloc).
6246
6247 declare
6248 New_Id : constant Entity_Id := Defining_Identifier (N);
6249 Next_Temp : constant Entity_Id := Next_Entity (New_Id);
6250 S_Flag : constant Boolean :=
6251 Comes_From_Source (Def_Id);
6252
6253 begin
6254 Set_Next_Entity (New_Id, Next_Entity (Def_Id));
6255 Set_Next_Entity (Def_Id, Next_Temp);
6256
6257 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
6258 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
6259 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
6260 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
6261
6262 Set_Comes_From_Source (Def_Id, False);
6263 Exchange_Entities (Defining_Identifier (N), Def_Id);
6264 Set_Comes_From_Source (Def_Id, S_Flag);
6265 end;
6266 end;
6267 end if;
6268
6269 return;
6270
6271 -- Common case of explicit object initialization
6272
6273 else
6274 -- In most cases, we must check that the initial value meets any
6275 -- constraint imposed by the declared type. However, there is one
6276 -- very important exception to this rule. If the entity has an
6277 -- unconstrained nominal subtype, then it acquired its constraints
6278 -- from the expression in the first place, and not only does this
6279 -- mean that the constraint check is not needed, but an attempt to
6280 -- perform the constraint check can cause order of elaboration
6281 -- problems.
6282
6283 if not Is_Constr_Subt_For_U_Nominal (Typ) then
6284
6285 -- If this is an allocator for an aggregate that has been
6286 -- allocated in place, delay checks until assignments are
6287 -- made, because the discriminants are not initialized.
6288
6289 if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
6290 then
6291 null;
6292
6293 -- Otherwise apply a constraint check now if no prev error
6294
6295 elsif Nkind (Expr) /= N_Error then
6296 Apply_Constraint_Check (Expr, Typ);
6297
6298 -- Deal with possible range check
6299
6300 if Do_Range_Check (Expr) then
6301
6302 -- If assignment checks are suppressed, turn off flag
6303
6304 if Suppress_Assignment_Checks (N) then
6305 Set_Do_Range_Check (Expr, False);
6306
6307 -- Otherwise generate the range check
6308
6309 else
6310 Generate_Range_Check
6311 (Expr, Typ, CE_Range_Check_Failed);
6312 end if;
6313 end if;
6314 end if;
6315 end if;
6316
6317 -- If the type is controlled and not inherently limited, then
6318 -- the target is adjusted after the copy and attached to the
6319 -- finalization list. However, no adjustment is done in the case
6320 -- where the object was initialized by a call to a function whose
6321 -- result is built in place, since no copy occurred. (Eventually
6322 -- we plan to support in-place function results for some cases
6323 -- of nonlimited types. ???) Similarly, no adjustment is required
6324 -- if we are going to rewrite the object declaration into a
6325 -- renaming declaration.
6326
6327 if Needs_Finalization (Typ)
6328 and then not Is_Limited_View (Typ)
6329 and then not Rewrite_As_Renaming
6330 then
6331 Insert_Action_After (Init_After,
6332 Make_Adjust_Call (
6333 Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
6334 Typ => Base_Typ));
6335 end if;
6336
6337 -- For tagged types, when an init value is given, the tag has to
6338 -- be re-initialized separately in order to avoid the propagation
6339 -- of a wrong tag coming from a view conversion unless the type
6340 -- is class wide (in this case the tag comes from the init value).
6341 -- Suppress the tag assignment when not Tagged_Type_Expansion
6342 -- because tags are represented implicitly in objects. Ditto for
6343 -- types that are CPP_CLASS, and for initializations that are
6344 -- aggregates, because they have to have the right tag.
6345
6346 -- The re-assignment of the tag has to be done even if the object
6347 -- is a constant. The assignment must be analyzed after the
6348 -- declaration. If an address clause follows, this is handled as
6349 -- part of the freeze actions for the object, otherwise insert
6350 -- tag assignment here.
6351
6352 Tag_Assign := Make_Tag_Assignment (N);
6353
6354 if Present (Tag_Assign) then
6355 if Present (Following_Address_Clause (N)) then
6356 Ensure_Freeze_Node (Def_Id);
6357
6358 else
6359 Insert_Action_After (Init_After, Tag_Assign);
6360 end if;
6361
6362 -- Handle C++ constructor calls. Note that we do not check that
6363 -- Typ is a tagged type since the equivalent Ada type of a C++
6364 -- class that has no virtual methods is an untagged limited
6365 -- record type.
6366
6367 elsif Is_CPP_Constructor_Call (Expr) then
6368
6369 -- The call to the initialization procedure does NOT freeze the
6370 -- object being initialized.
6371
6372 Id_Ref := New_Occurrence_Of (Def_Id, Loc);
6373 Set_Must_Not_Freeze (Id_Ref);
6374 Set_Assignment_OK (Id_Ref);
6375
6376 Insert_Actions_After (Init_After,
6377 Build_Initialization_Call (Loc, Id_Ref, Typ,
6378 Constructor_Ref => Expr));
6379
6380 -- We remove here the original call to the constructor
6381 -- to avoid its management in the backend
6382
6383 Set_Expression (N, Empty);
6384 return;
6385
6386 -- Handle initialization of limited tagged types
6387
6388 elsif Is_Tagged_Type (Typ)
6389 and then Is_Class_Wide_Type (Typ)
6390 and then Is_Limited_Record (Typ)
6391 and then not Is_Limited_Interface (Typ)
6392 then
6393 -- Given that the type is limited we cannot perform a copy. If
6394 -- Expr_Q is the reference to a variable we mark the variable
6395 -- as OK_To_Rename to expand this declaration into a renaming
6396 -- declaration (see bellow).
6397
6398 if Is_Entity_Name (Expr_Q) then
6399 Set_OK_To_Rename (Entity (Expr_Q));
6400
6401 -- If we cannot convert the expression into a renaming we must
6402 -- consider it an internal error because the backend does not
6403 -- have support to handle it.
6404
6405 else
6406 pragma Assert (False);
6407 raise Program_Error;
6408 end if;
6409
6410 -- For discrete types, set the Is_Known_Valid flag if the
6411 -- initializing value is known to be valid. Only do this for
6412 -- source assignments, since otherwise we can end up turning
6413 -- on the known valid flag prematurely from inserted code.
6414
6415 elsif Comes_From_Source (N)
6416 and then Is_Discrete_Type (Typ)
6417 and then Expr_Known_Valid (Expr)
6418 then
6419 Set_Is_Known_Valid (Def_Id);
6420
6421 elsif Is_Access_Type (Typ) then
6422
6423 -- For access types set the Is_Known_Non_Null flag if the
6424 -- initializing value is known to be non-null. We can also set
6425 -- Can_Never_Be_Null if this is a constant.
6426
6427 if Known_Non_Null (Expr) then
6428 Set_Is_Known_Non_Null (Def_Id, True);
6429
6430 if Constant_Present (N) then
6431 Set_Can_Never_Be_Null (Def_Id);
6432 end if;
6433 end if;
6434 end if;
6435
6436 -- If validity checking on copies, validate initial expression.
6437 -- But skip this if declaration is for a generic type, since it
6438 -- makes no sense to validate generic types. Not clear if this
6439 -- can happen for legal programs, but it definitely can arise
6440 -- from previous instantiation errors.
6441
6442 if Validity_Checks_On
6443 and then Comes_From_Source (N)
6444 and then Validity_Check_Copies
6445 and then not Is_Generic_Type (Etype (Def_Id))
6446 then
6447 Ensure_Valid (Expr);
6448 Set_Is_Known_Valid (Def_Id);
6449 end if;
6450 end if;
6451
6452 -- Cases where the back end cannot handle the initialization directly
6453 -- In such cases, we expand an assignment that will be appropriately
6454 -- handled by Expand_N_Assignment_Statement.
6455
6456 -- The exclusion of the unconstrained case is wrong, but for now it
6457 -- is too much trouble ???
6458
6459 if (Is_Possibly_Unaligned_Slice (Expr)
6460 or else (Is_Possibly_Unaligned_Object (Expr)
6461 and then not Represented_As_Scalar (Etype (Expr))))
6462 and then not (Is_Array_Type (Etype (Expr))
6463 and then not Is_Constrained (Etype (Expr)))
6464 then
6465 declare
6466 Stat : constant Node_Id :=
6467 Make_Assignment_Statement (Loc,
6468 Name => New_Occurrence_Of (Def_Id, Loc),
6469 Expression => Relocate_Node (Expr));
6470 begin
6471 Set_Expression (N, Empty);
6472 Set_No_Initialization (N);
6473 Set_Assignment_OK (Name (Stat));
6474 Set_No_Ctrl_Actions (Stat);
6475 Insert_After_And_Analyze (Init_After, Stat);
6476 end;
6477 end if;
6478 end if;
6479
6480 if Nkind (Obj_Def) = N_Access_Definition
6481 and then not Is_Local_Anonymous_Access (Etype (Def_Id))
6482 then
6483 -- An Ada 2012 stand-alone object of an anonymous access type
6484
6485 declare
6486 Loc : constant Source_Ptr := Sloc (N);
6487
6488 Level : constant Entity_Id :=
6489 Make_Defining_Identifier (Sloc (N),
6490 Chars =>
6491 New_External_Name (Chars (Def_Id), Suffix => "L"));
6492
6493 Level_Expr : Node_Id;
6494 Level_Decl : Node_Id;
6495
6496 begin
6497 Set_Ekind (Level, Ekind (Def_Id));
6498 Set_Etype (Level, Standard_Natural);
6499 Set_Scope (Level, Scope (Def_Id));
6500
6501 if No (Expr) then
6502
6503 -- Set accessibility level of null
6504
6505 Level_Expr :=
6506 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
6507
6508 else
6509 Level_Expr := Dynamic_Accessibility_Level (Expr);
6510 end if;
6511
6512 Level_Decl :=
6513 Make_Object_Declaration (Loc,
6514 Defining_Identifier => Level,
6515 Object_Definition =>
6516 New_Occurrence_Of (Standard_Natural, Loc),
6517 Expression => Level_Expr,
6518 Constant_Present => Constant_Present (N),
6519 Has_Init_Expression => True);
6520
6521 Insert_Action_After (Init_After, Level_Decl);
6522
6523 Set_Extra_Accessibility (Def_Id, Level);
6524 end;
6525 end if;
6526
6527 -- If the object is default initialized and its type is subject to
6528 -- pragma Default_Initial_Condition, add a runtime check to verify
6529 -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
6530
6531 -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
6532
6533 -- Note that the check is generated for source objects only
6534
6535 if Comes_From_Source (Def_Id)
6536 and then (Has_Default_Init_Cond (Typ)
6537 or else Has_Inherited_Default_Init_Cond (Typ))
6538 and then not Has_Init_Expression (N)
6539 and then Present (Default_Init_Cond_Procedure (Typ))
6540 then
6541 declare
6542 DIC_Call : constant Node_Id :=
6543 Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
6544 begin
6545 if Present (Next_N) then
6546 Insert_Before_And_Analyze (Next_N, DIC_Call);
6547
6548 -- The object declaration is the last node in a declarative or a
6549 -- statement list.
6550
6551 else
6552 Append_To (List_Containing (N), DIC_Call);
6553 Analyze (DIC_Call);
6554 end if;
6555 end;
6556 end if;
6557
6558 -- Final transformation - turn the object declaration into a renaming
6559 -- if appropriate. If this is the completion of a deferred constant
6560 -- declaration, then this transformation generates what would be
6561 -- illegal code if written by hand, but that's OK.
6562
6563 if Present (Expr) then
6564 if Rewrite_As_Renaming then
6565 Rewrite (N,
6566 Make_Object_Renaming_Declaration (Loc,
6567 Defining_Identifier => Defining_Identifier (N),
6568 Subtype_Mark => Obj_Def,
6569 Name => Expr_Q));
6570
6571 -- We do not analyze this renaming declaration, because all its
6572 -- components have already been analyzed, and if we were to go
6573 -- ahead and analyze it, we would in effect be trying to generate
6574 -- another declaration of X, which won't do.
6575
6576 Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
6577 Set_Analyzed (N);
6578
6579 -- We do need to deal with debug issues for this renaming
6580
6581 -- First, if entity comes from source, then mark it as needing
6582 -- debug information, even though it is defined by a generated
6583 -- renaming that does not come from source.
6584
6585 if Comes_From_Source (Defining_Identifier (N)) then
6586 Set_Debug_Info_Needed (Defining_Identifier (N));
6587 end if;
6588
6589 -- Now call the routine to generate debug info for the renaming
6590
6591 declare
6592 Decl : constant Node_Id := Debug_Renaming_Declaration (N);
6593 begin
6594 if Present (Decl) then
6595 Insert_Action (N, Decl);
6596 end if;
6597 end;
6598 end if;
6599 end if;
6600
6601 -- Exception on library entity not available
6602
6603 exception
6604 when RE_Not_Available =>
6605 return;
6606 end Expand_N_Object_Declaration;
6607
6608 ---------------------------------
6609 -- Expand_N_Subtype_Indication --
6610 ---------------------------------
6611
6612 -- Add a check on the range of the subtype. The static case is partially
6613 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
6614 -- to check here for the static case in order to avoid generating
6615 -- extraneous expanded code. Also deal with validity checking.
6616
6617 procedure Expand_N_Subtype_Indication (N : Node_Id) is
6618 Ran : constant Node_Id := Range_Expression (Constraint (N));
6619 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
6620
6621 begin
6622 if Nkind (Constraint (N)) = N_Range_Constraint then
6623 Validity_Check_Range (Range_Expression (Constraint (N)));
6624 end if;
6625
6626 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
6627 Apply_Range_Check (Ran, Typ);
6628 end if;
6629 end Expand_N_Subtype_Indication;
6630
6631 ---------------------------
6632 -- Expand_N_Variant_Part --
6633 ---------------------------
6634
6635 -- Note: this procedure no longer has any effect. It used to be that we
6636 -- would replace the choices in the last variant by a when others, and
6637 -- also expanded static predicates in variant choices here, but both of
6638 -- those activities were being done too early, since we can't check the
6639 -- choices until the statically predicated subtypes are frozen, which can
6640 -- happen as late as the free point of the record, and we can't change the
6641 -- last choice to an others before checking the choices, which is now done
6642 -- at the freeze point of the record.
6643
6644 procedure Expand_N_Variant_Part (N : Node_Id) is
6645 begin
6646 null;
6647 end Expand_N_Variant_Part;
6648
6649 ---------------------------------
6650 -- Expand_Previous_Access_Type --
6651 ---------------------------------
6652
6653 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
6654 Ptr_Typ : Entity_Id;
6655
6656 begin
6657 -- Find all access types in the current scope whose designated type is
6658 -- Def_Id and build master renamings for them.
6659
6660 Ptr_Typ := First_Entity (Current_Scope);
6661 while Present (Ptr_Typ) loop
6662 if Is_Access_Type (Ptr_Typ)
6663 and then Designated_Type (Ptr_Typ) = Def_Id
6664 and then No (Master_Id (Ptr_Typ))
6665 then
6666 -- Ensure that the designated type has a master
6667
6668 Build_Master_Entity (Def_Id);
6669
6670 -- Private and incomplete types complicate the insertion of master
6671 -- renamings because the access type may precede the full view of
6672 -- the designated type. For this reason, the master renamings are
6673 -- inserted relative to the designated type.
6674
6675 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
6676 end if;
6677
6678 Next_Entity (Ptr_Typ);
6679 end loop;
6680 end Expand_Previous_Access_Type;
6681
6682 -----------------------------
6683 -- Expand_Record_Extension --
6684 -----------------------------
6685
6686 -- Add a field _parent at the beginning of the record extension. This is
6687 -- used to implement inheritance. Here are some examples of expansion:
6688
6689 -- 1. no discriminants
6690 -- type T2 is new T1 with null record;
6691 -- gives
6692 -- type T2 is new T1 with record
6693 -- _Parent : T1;
6694 -- end record;
6695
6696 -- 2. renamed discriminants
6697 -- type T2 (B, C : Int) is new T1 (A => B) with record
6698 -- _Parent : T1 (A => B);
6699 -- D : Int;
6700 -- end;
6701
6702 -- 3. inherited discriminants
6703 -- type T2 is new T1 with record -- discriminant A inherited
6704 -- _Parent : T1 (A);
6705 -- D : Int;
6706 -- end;
6707
6708 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
6709 Indic : constant Node_Id := Subtype_Indication (Def);
6710 Loc : constant Source_Ptr := Sloc (Def);
6711 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
6712 Par_Subtype : Entity_Id;
6713 Comp_List : Node_Id;
6714 Comp_Decl : Node_Id;
6715 Parent_N : Node_Id;
6716 D : Entity_Id;
6717 List_Constr : constant List_Id := New_List;
6718
6719 begin
6720 -- Expand_Record_Extension is called directly from the semantics, so
6721 -- we must check to see whether expansion is active before proceeding,
6722 -- because this affects the visibility of selected components in bodies
6723 -- of instances.
6724
6725 if not Expander_Active then
6726 return;
6727 end if;
6728
6729 -- This may be a derivation of an untagged private type whose full
6730 -- view is tagged, in which case the Derived_Type_Definition has no
6731 -- extension part. Build an empty one now.
6732
6733 if No (Rec_Ext_Part) then
6734 Rec_Ext_Part :=
6735 Make_Record_Definition (Loc,
6736 End_Label => Empty,
6737 Component_List => Empty,
6738 Null_Present => True);
6739
6740 Set_Record_Extension_Part (Def, Rec_Ext_Part);
6741 Mark_Rewrite_Insertion (Rec_Ext_Part);
6742 end if;
6743
6744 Comp_List := Component_List (Rec_Ext_Part);
6745
6746 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
6747
6748 -- If the derived type inherits its discriminants the type of the
6749 -- _parent field must be constrained by the inherited discriminants
6750
6751 if Has_Discriminants (T)
6752 and then Nkind (Indic) /= N_Subtype_Indication
6753 and then not Is_Constrained (Entity (Indic))
6754 then
6755 D := First_Discriminant (T);
6756 while Present (D) loop
6757 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
6758 Next_Discriminant (D);
6759 end loop;
6760
6761 Par_Subtype :=
6762 Process_Subtype (
6763 Make_Subtype_Indication (Loc,
6764 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
6765 Constraint =>
6766 Make_Index_Or_Discriminant_Constraint (Loc,
6767 Constraints => List_Constr)),
6768 Def);
6769
6770 -- Otherwise the original subtype_indication is just what is needed
6771
6772 else
6773 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
6774 end if;
6775
6776 Set_Parent_Subtype (T, Par_Subtype);
6777
6778 Comp_Decl :=
6779 Make_Component_Declaration (Loc,
6780 Defining_Identifier => Parent_N,
6781 Component_Definition =>
6782 Make_Component_Definition (Loc,
6783 Aliased_Present => False,
6784 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
6785
6786 if Null_Present (Rec_Ext_Part) then
6787 Set_Component_List (Rec_Ext_Part,
6788 Make_Component_List (Loc,
6789 Component_Items => New_List (Comp_Decl),
6790 Variant_Part => Empty,
6791 Null_Present => False));
6792 Set_Null_Present (Rec_Ext_Part, False);
6793
6794 elsif Null_Present (Comp_List)
6795 or else Is_Empty_List (Component_Items (Comp_List))
6796 then
6797 Set_Component_Items (Comp_List, New_List (Comp_Decl));
6798 Set_Null_Present (Comp_List, False);
6799
6800 else
6801 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
6802 end if;
6803
6804 Analyze (Comp_Decl);
6805 end Expand_Record_Extension;
6806
6807 ------------------------
6808 -- Expand_Tagged_Root --
6809 ------------------------
6810
6811 procedure Expand_Tagged_Root (T : Entity_Id) is
6812 Def : constant Node_Id := Type_Definition (Parent (T));
6813 Comp_List : Node_Id;
6814 Comp_Decl : Node_Id;
6815 Sloc_N : Source_Ptr;
6816
6817 begin
6818 if Null_Present (Def) then
6819 Set_Component_List (Def,
6820 Make_Component_List (Sloc (Def),
6821 Component_Items => Empty_List,
6822 Variant_Part => Empty,
6823 Null_Present => True));
6824 end if;
6825
6826 Comp_List := Component_List (Def);
6827
6828 if Null_Present (Comp_List)
6829 or else Is_Empty_List (Component_Items (Comp_List))
6830 then
6831 Sloc_N := Sloc (Comp_List);
6832 else
6833 Sloc_N := Sloc (First (Component_Items (Comp_List)));
6834 end if;
6835
6836 Comp_Decl :=
6837 Make_Component_Declaration (Sloc_N,
6838 Defining_Identifier => First_Tag_Component (T),
6839 Component_Definition =>
6840 Make_Component_Definition (Sloc_N,
6841 Aliased_Present => False,
6842 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
6843
6844 if Null_Present (Comp_List)
6845 or else Is_Empty_List (Component_Items (Comp_List))
6846 then
6847 Set_Component_Items (Comp_List, New_List (Comp_Decl));
6848 Set_Null_Present (Comp_List, False);
6849
6850 else
6851 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
6852 end if;
6853
6854 -- We don't Analyze the whole expansion because the tag component has
6855 -- already been analyzed previously. Here we just insure that the tree
6856 -- is coherent with the semantic decoration
6857
6858 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
6859
6860 exception
6861 when RE_Not_Available =>
6862 return;
6863 end Expand_Tagged_Root;
6864
6865 ------------------------------
6866 -- Freeze_Stream_Operations --
6867 ------------------------------
6868
6869 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
6870 Names : constant array (1 .. 4) of TSS_Name_Type :=
6871 (TSS_Stream_Input,
6872 TSS_Stream_Output,
6873 TSS_Stream_Read,
6874 TSS_Stream_Write);
6875 Stream_Op : Entity_Id;
6876
6877 begin
6878 -- Primitive operations of tagged types are frozen when the dispatch
6879 -- table is constructed.
6880
6881 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
6882 return;
6883 end if;
6884
6885 for J in Names'Range loop
6886 Stream_Op := TSS (Typ, Names (J));
6887
6888 if Present (Stream_Op)
6889 and then Is_Subprogram (Stream_Op)
6890 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
6891 N_Subprogram_Declaration
6892 and then not Is_Frozen (Stream_Op)
6893 then
6894 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
6895 end if;
6896 end loop;
6897 end Freeze_Stream_Operations;
6898
6899 -----------------
6900 -- Freeze_Type --
6901 -----------------
6902
6903 -- Full type declarations are expanded at the point at which the type is
6904 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
6905 -- declarations generated by the freezing (e.g. the procedure generated
6906 -- for initialization) are chained in the Actions field list of the freeze
6907 -- node using Append_Freeze_Actions.
6908
6909 function Freeze_Type (N : Node_Id) return Boolean is
6910 procedure Process_RACW_Types (Typ : Entity_Id);
6911 -- Validate and generate stubs for all RACW types associated with type
6912 -- Typ.
6913
6914 procedure Process_Pending_Access_Types (Typ : Entity_Id);
6915 -- Associate type Typ's Finalize_Address primitive with the finalization
6916 -- masters of pending access-to-Typ types.
6917
6918 ------------------------
6919 -- Process_RACW_Types --
6920 ------------------------
6921
6922 procedure Process_RACW_Types (Typ : Entity_Id) is
6923 List : constant Elist_Id := Access_Types_To_Process (N);
6924 E : Elmt_Id;
6925 Seen : Boolean := False;
6926
6927 begin
6928 if Present (List) then
6929 E := First_Elmt (List);
6930 while Present (E) loop
6931 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
6932 Validate_RACW_Primitives (Node (E));
6933 Seen := True;
6934 end if;
6935
6936 Next_Elmt (E);
6937 end loop;
6938 end if;
6939
6940 -- If there are RACWs designating this type, make stubs now
6941
6942 if Seen then
6943 Remote_Types_Tagged_Full_View_Encountered (Typ);
6944 end if;
6945 end Process_RACW_Types;
6946
6947 ----------------------------------
6948 -- Process_Pending_Access_Types --
6949 ----------------------------------
6950
6951 procedure Process_Pending_Access_Types (Typ : Entity_Id) is
6952 E : Elmt_Id;
6953
6954 begin
6955 -- Finalize_Address is not generated in CodePeer mode because the
6956 -- body contains address arithmetic. This processing is disabled.
6957
6958 if CodePeer_Mode then
6959 null;
6960
6961 -- Certain itypes are generated for contexts that cannot allocate
6962 -- objects and should not set primitive Finalize_Address.
6963
6964 elsif Is_Itype (Typ)
6965 and then Nkind (Associated_Node_For_Itype (Typ)) =
6966 N_Explicit_Dereference
6967 then
6968 null;
6969
6970 -- When an access type is declared after the incomplete view of a
6971 -- Taft-amendment type, the access type is considered pending in
6972 -- case the full view of the Taft-amendment type is controlled. If
6973 -- this is indeed the case, associate the Finalize_Address routine
6974 -- of the full view with the finalization masters of all pending
6975 -- access types. This scenario applies to anonymous access types as
6976 -- well.
6977
6978 elsif Needs_Finalization (Typ)
6979 and then Present (Pending_Access_Types (Typ))
6980 then
6981 E := First_Elmt (Pending_Access_Types (Typ));
6982 while Present (E) loop
6983
6984 -- Generate:
6985 -- Set_Finalize_Address
6986 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
6987
6988 Append_Freeze_Action (Typ,
6989 Make_Set_Finalize_Address_Call
6990 (Loc => Sloc (N),
6991 Ptr_Typ => Node (E)));
6992
6993 Next_Elmt (E);
6994 end loop;
6995 end if;
6996 end Process_Pending_Access_Types;
6997
6998 -- Local variables
6999
7000 Def_Id : constant Entity_Id := Entity (N);
7001 Result : Boolean := False;
7002
7003 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
7004
7005 -- Start of processing for Freeze_Type
7006
7007 begin
7008 -- The type being frozen may be subject to pragma Ghost. Set the mode
7009 -- now to ensure that any nodes generated during freezing are properly
7010 -- marked as Ghost.
7011
7012 Set_Ghost_Mode (N, Def_Id);
7013
7014 -- Process any remote access-to-class-wide types designating the type
7015 -- being frozen.
7016
7017 Process_RACW_Types (Def_Id);
7018
7019 -- Freeze processing for record types
7020
7021 if Is_Record_Type (Def_Id) then
7022 if Ekind (Def_Id) = E_Record_Type then
7023 Expand_Freeze_Record_Type (N);
7024 elsif Is_Class_Wide_Type (Def_Id) then
7025 Expand_Freeze_Class_Wide_Type (N);
7026 end if;
7027
7028 -- Freeze processing for array types
7029
7030 elsif Is_Array_Type (Def_Id) then
7031 Expand_Freeze_Array_Type (N);
7032
7033 -- Freeze processing for access types
7034
7035 -- For pool-specific access types, find out the pool object used for
7036 -- this type, needs actual expansion of it in some cases. Here are the
7037 -- different cases :
7038
7039 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
7040 -- ---> don't use any storage pool
7041
7042 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
7043 -- Expand:
7044 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
7045
7046 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7047 -- ---> Storage Pool is the specified one
7048
7049 -- See GNAT Pool packages in the Run-Time for more details
7050
7051 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
7052 declare
7053 Loc : constant Source_Ptr := Sloc (N);
7054 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
7055
7056 Freeze_Action_Typ : Entity_Id;
7057 Pool_Object : Entity_Id;
7058
7059 begin
7060 -- Case 1
7061
7062 -- Rep Clause "for Def_Id'Storage_Size use 0;"
7063 -- ---> don't use any storage pool
7064
7065 if No_Pool_Assigned (Def_Id) then
7066 null;
7067
7068 -- Case 2
7069
7070 -- Rep Clause : for Def_Id'Storage_Size use Expr.
7071 -- ---> Expand:
7072 -- Def_Id__Pool : Stack_Bounded_Pool
7073 -- (Expr, DT'Size, DT'Alignment);
7074
7075 elsif Has_Storage_Size_Clause (Def_Id) then
7076 declare
7077 DT_Align : Node_Id;
7078 DT_Size : Node_Id;
7079
7080 begin
7081 -- For unconstrained composite types we give a size of zero
7082 -- so that the pool knows that it needs a special algorithm
7083 -- for variable size object allocation.
7084
7085 if Is_Composite_Type (Desig_Type)
7086 and then not Is_Constrained (Desig_Type)
7087 then
7088 DT_Size := Make_Integer_Literal (Loc, 0);
7089 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
7090
7091 else
7092 DT_Size :=
7093 Make_Attribute_Reference (Loc,
7094 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7095 Attribute_Name => Name_Max_Size_In_Storage_Elements);
7096
7097 DT_Align :=
7098 Make_Attribute_Reference (Loc,
7099 Prefix => New_Occurrence_Of (Desig_Type, Loc),
7100 Attribute_Name => Name_Alignment);
7101 end if;
7102
7103 Pool_Object :=
7104 Make_Defining_Identifier (Loc,
7105 Chars => New_External_Name (Chars (Def_Id), 'P'));
7106
7107 -- We put the code associated with the pools in the entity
7108 -- that has the later freeze node, usually the access type
7109 -- but it can also be the designated_type; because the pool
7110 -- code requires both those types to be frozen
7111
7112 if Is_Frozen (Desig_Type)
7113 and then (No (Freeze_Node (Desig_Type))
7114 or else Analyzed (Freeze_Node (Desig_Type)))
7115 then
7116 Freeze_Action_Typ := Def_Id;
7117
7118 -- A Taft amendment type cannot get the freeze actions
7119 -- since the full view is not there.
7120
7121 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
7122 and then No (Full_View (Desig_Type))
7123 then
7124 Freeze_Action_Typ := Def_Id;
7125
7126 else
7127 Freeze_Action_Typ := Desig_Type;
7128 end if;
7129
7130 Append_Freeze_Action (Freeze_Action_Typ,
7131 Make_Object_Declaration (Loc,
7132 Defining_Identifier => Pool_Object,
7133 Object_Definition =>
7134 Make_Subtype_Indication (Loc,
7135 Subtype_Mark =>
7136 New_Occurrence_Of
7137 (RTE (RE_Stack_Bounded_Pool), Loc),
7138
7139 Constraint =>
7140 Make_Index_Or_Discriminant_Constraint (Loc,
7141 Constraints => New_List (
7142
7143 -- First discriminant is the Pool Size
7144
7145 New_Occurrence_Of (
7146 Storage_Size_Variable (Def_Id), Loc),
7147
7148 -- Second discriminant is the element size
7149
7150 DT_Size,
7151
7152 -- Third discriminant is the alignment
7153
7154 DT_Align)))));
7155 end;
7156
7157 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
7158
7159 -- Case 3
7160
7161 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
7162 -- ---> Storage Pool is the specified one
7163
7164 -- When compiling in Ada 2012 mode, ensure that the accessibility
7165 -- level of the subpool access type is not deeper than that of the
7166 -- pool_with_subpools.
7167
7168 elsif Ada_Version >= Ada_2012
7169 and then Present (Associated_Storage_Pool (Def_Id))
7170
7171 -- Omit this check for the case of a configurable run-time that
7172 -- does not provide package System.Storage_Pools.Subpools.
7173
7174 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools)
7175 then
7176 declare
7177 Loc : constant Source_Ptr := Sloc (Def_Id);
7178 Pool : constant Entity_Id :=
7179 Associated_Storage_Pool (Def_Id);
7180 RSPWS : constant Entity_Id :=
7181 RTE (RE_Root_Storage_Pool_With_Subpools);
7182
7183 begin
7184 -- It is known that the accessibility level of the access
7185 -- type is deeper than that of the pool.
7186
7187 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
7188 and then not Accessibility_Checks_Suppressed (Def_Id)
7189 and then not Accessibility_Checks_Suppressed (Pool)
7190 then
7191 -- Static case: the pool is known to be a descendant of
7192 -- Root_Storage_Pool_With_Subpools.
7193
7194 if Is_Ancestor (RSPWS, Etype (Pool)) then
7195 Error_Msg_N
7196 ("??subpool access type has deeper accessibility "
7197 & "level than pool", Def_Id);
7198
7199 Append_Freeze_Action (Def_Id,
7200 Make_Raise_Program_Error (Loc,
7201 Reason => PE_Accessibility_Check_Failed));
7202
7203 -- Dynamic case: when the pool is of a class-wide type,
7204 -- it may or may not support subpools depending on the
7205 -- path of derivation. Generate:
7206
7207 -- if Def_Id in RSPWS'Class then
7208 -- raise Program_Error;
7209 -- end if;
7210
7211 elsif Is_Class_Wide_Type (Etype (Pool)) then
7212 Append_Freeze_Action (Def_Id,
7213 Make_If_Statement (Loc,
7214 Condition =>
7215 Make_In (Loc,
7216 Left_Opnd => New_Occurrence_Of (Pool, Loc),
7217 Right_Opnd =>
7218 New_Occurrence_Of
7219 (Class_Wide_Type (RSPWS), Loc)),
7220
7221 Then_Statements => New_List (
7222 Make_Raise_Program_Error (Loc,
7223 Reason => PE_Accessibility_Check_Failed))));
7224 end if;
7225 end if;
7226 end;
7227 end if;
7228
7229 -- For access-to-controlled types (including class-wide types and
7230 -- Taft-amendment types, which potentially have controlled
7231 -- components), expand the list controller object that will store
7232 -- the dynamically allocated objects. Don't do this transformation
7233 -- for expander-generated access types, but do it for types that
7234 -- are the full view of types derived from other private types.
7235 -- Also suppress the list controller in the case of a designated
7236 -- type with convention Java, since this is used when binding to
7237 -- Java API specs, where there's no equivalent of a finalization
7238 -- list and we don't want to pull in the finalization support if
7239 -- not needed.
7240
7241 if not Comes_From_Source (Def_Id)
7242 and then not Has_Private_Declaration (Def_Id)
7243 then
7244 null;
7245
7246 -- An exception is made for types defined in the run-time because
7247 -- Ada.Tags.Tag itself is such a type and cannot afford this
7248 -- unnecessary overhead that would generates a loop in the
7249 -- expansion scheme. Another exception is if Restrictions
7250 -- (No_Finalization) is active, since then we know nothing is
7251 -- controlled.
7252
7253 elsif Restriction_Active (No_Finalization)
7254 or else In_Runtime (Def_Id)
7255 then
7256 null;
7257
7258 -- Create a finalization master for an access-to-controlled type
7259 -- or an access-to-incomplete type. It is assumed that the full
7260 -- view will be controlled.
7261
7262 elsif Needs_Finalization (Desig_Type)
7263 or else (Is_Incomplete_Type (Desig_Type)
7264 and then No (Full_View (Desig_Type)))
7265 then
7266 Build_Finalization_Master (Def_Id);
7267
7268 -- Create a finalization master when the designated type contains
7269 -- a private component. It is assumed that the full view will be
7270 -- controlled.
7271
7272 elsif Has_Private_Component (Desig_Type) then
7273 Build_Finalization_Master
7274 (Typ => Def_Id,
7275 For_Private => True,
7276 Context_Scope => Scope (Def_Id),
7277 Insertion_Node => Declaration_Node (Desig_Type));
7278 end if;
7279 end;
7280
7281 -- Freeze processing for enumeration types
7282
7283 elsif Ekind (Def_Id) = E_Enumeration_Type then
7284
7285 -- We only have something to do if we have a non-standard
7286 -- representation (i.e. at least one literal whose pos value
7287 -- is not the same as its representation)
7288
7289 if Has_Non_Standard_Rep (Def_Id) then
7290 Expand_Freeze_Enumeration_Type (N);
7291 end if;
7292
7293 -- Private types that are completed by a derivation from a private
7294 -- type have an internally generated full view, that needs to be
7295 -- frozen. This must be done explicitly because the two views share
7296 -- the freeze node, and the underlying full view is not visible when
7297 -- the freeze node is analyzed.
7298
7299 elsif Is_Private_Type (Def_Id)
7300 and then Is_Derived_Type (Def_Id)
7301 and then Present (Full_View (Def_Id))
7302 and then Is_Itype (Full_View (Def_Id))
7303 and then Has_Private_Declaration (Full_View (Def_Id))
7304 and then Freeze_Node (Full_View (Def_Id)) = N
7305 then
7306 Set_Entity (N, Full_View (Def_Id));
7307 Result := Freeze_Type (N);
7308 Set_Entity (N, Def_Id);
7309
7310 -- All other types require no expander action. There are such cases
7311 -- (e.g. task types and protected types). In such cases, the freeze
7312 -- nodes are there for use by Gigi.
7313
7314 end if;
7315
7316 -- Complete the initialization of all pending access types' finalization
7317 -- masters now that the designated type has been is frozen and primitive
7318 -- Finalize_Address generated.
7319
7320 Process_Pending_Access_Types (Def_Id);
7321 Freeze_Stream_Operations (N, Def_Id);
7322
7323 -- Generate the [spec and] body of the invariant procedure tasked with
7324 -- the runtime verification of all invariants that pertain to the type.
7325 -- This includes invariants on the partial and full view, inherited
7326 -- class-wide invariants from parent types or interfaces, and invariants
7327 -- on array elements or record components.
7328
7329 if Has_Invariants (Def_Id) then
7330 Build_Invariant_Procedure_Body (Def_Id);
7331 end if;
7332
7333 Ghost_Mode := Save_Ghost_Mode;
7334 return Result;
7335
7336 exception
7337 when RE_Not_Available =>
7338 Ghost_Mode := Save_Ghost_Mode;
7339 return False;
7340 end Freeze_Type;
7341
7342 -------------------------
7343 -- Get_Simple_Init_Val --
7344 -------------------------
7345
7346 function Get_Simple_Init_Val
7347 (T : Entity_Id;
7348 N : Node_Id;
7349 Size : Uint := No_Uint) return Node_Id
7350 is
7351 Loc : constant Source_Ptr := Sloc (N);
7352 Val : Node_Id;
7353 Result : Node_Id;
7354 Val_RE : RE_Id;
7355
7356 Size_To_Use : Uint;
7357 -- This is the size to be used for computation of the appropriate
7358 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
7359
7360 IV_Attribute : constant Boolean :=
7361 Nkind (N) = N_Attribute_Reference
7362 and then Attribute_Name (N) = Name_Invalid_Value;
7363
7364 Lo_Bound : Uint;
7365 Hi_Bound : Uint;
7366 -- These are the values computed by the procedure Check_Subtype_Bounds
7367
7368 procedure Check_Subtype_Bounds;
7369 -- This procedure examines the subtype T, and its ancestor subtypes and
7370 -- derived types to determine the best known information about the
7371 -- bounds of the subtype. After the call Lo_Bound is set either to
7372 -- No_Uint if no information can be determined, or to a value which
7373 -- represents a known low bound, i.e. a valid value of the subtype can
7374 -- not be less than this value. Hi_Bound is similarly set to a known
7375 -- high bound (valid value cannot be greater than this).
7376
7377 --------------------------
7378 -- Check_Subtype_Bounds --
7379 --------------------------
7380
7381 procedure Check_Subtype_Bounds is
7382 ST1 : Entity_Id;
7383 ST2 : Entity_Id;
7384 Lo : Node_Id;
7385 Hi : Node_Id;
7386 Loval : Uint;
7387 Hival : Uint;
7388
7389 begin
7390 Lo_Bound := No_Uint;
7391 Hi_Bound := No_Uint;
7392
7393 -- Loop to climb ancestor subtypes and derived types
7394
7395 ST1 := T;
7396 loop
7397 if not Is_Discrete_Type (ST1) then
7398 return;
7399 end if;
7400
7401 Lo := Type_Low_Bound (ST1);
7402 Hi := Type_High_Bound (ST1);
7403
7404 if Compile_Time_Known_Value (Lo) then
7405 Loval := Expr_Value (Lo);
7406
7407 if Lo_Bound = No_Uint or else Lo_Bound < Loval then
7408 Lo_Bound := Loval;
7409 end if;
7410 end if;
7411
7412 if Compile_Time_Known_Value (Hi) then
7413 Hival := Expr_Value (Hi);
7414
7415 if Hi_Bound = No_Uint or else Hi_Bound > Hival then
7416 Hi_Bound := Hival;
7417 end if;
7418 end if;
7419
7420 ST2 := Ancestor_Subtype (ST1);
7421
7422 if No (ST2) then
7423 ST2 := Etype (ST1);
7424 end if;
7425
7426 exit when ST1 = ST2;
7427 ST1 := ST2;
7428 end loop;
7429 end Check_Subtype_Bounds;
7430
7431 -- Start of processing for Get_Simple_Init_Val
7432
7433 begin
7434 -- For a private type, we should always have an underlying type (because
7435 -- this was already checked in Needs_Simple_Initialization). What we do
7436 -- is to get the value for the underlying type and then do an unchecked
7437 -- conversion to the private type.
7438
7439 if Is_Private_Type (T) then
7440 Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
7441
7442 -- A special case, if the underlying value is null, then qualify it
7443 -- with the underlying type, so that the null is properly typed.
7444 -- Similarly, if it is an aggregate it must be qualified, because an
7445 -- unchecked conversion does not provide a context for it.
7446
7447 if Nkind_In (Val, N_Null, N_Aggregate) then
7448 Val :=
7449 Make_Qualified_Expression (Loc,
7450 Subtype_Mark =>
7451 New_Occurrence_Of (Underlying_Type (T), Loc),
7452 Expression => Val);
7453 end if;
7454
7455 Result := Unchecked_Convert_To (T, Val);
7456
7457 -- Don't truncate result (important for Initialize/Normalize_Scalars)
7458
7459 if Nkind (Result) = N_Unchecked_Type_Conversion
7460 and then Is_Scalar_Type (Underlying_Type (T))
7461 then
7462 Set_No_Truncation (Result);
7463 end if;
7464
7465 return Result;
7466
7467 -- Scalars with Default_Value aspect. The first subtype may now be
7468 -- private, so retrieve value from underlying type.
7469
7470 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
7471 if Is_Private_Type (First_Subtype (T)) then
7472 return Unchecked_Convert_To (T,
7473 Default_Aspect_Value (Full_View (First_Subtype (T))));
7474 else
7475 return
7476 Convert_To (T, Default_Aspect_Value (First_Subtype (T)));
7477 end if;
7478
7479 -- Otherwise, for scalars, we must have normalize/initialize scalars
7480 -- case, or if the node N is an 'Invalid_Value attribute node.
7481
7482 elsif Is_Scalar_Type (T) then
7483 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
7484
7485 -- Compute size of object. If it is given by the caller, we can use
7486 -- it directly, otherwise we use Esize (T) as an estimate. As far as
7487 -- we know this covers all cases correctly.
7488
7489 if Size = No_Uint or else Size <= Uint_0 then
7490 Size_To_Use := UI_Max (Uint_1, Esize (T));
7491 else
7492 Size_To_Use := Size;
7493 end if;
7494
7495 -- Maximum size to use is 64 bits, since we will create values of
7496 -- type Unsigned_64 and the range must fit this type.
7497
7498 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
7499 Size_To_Use := Uint_64;
7500 end if;
7501
7502 -- Check known bounds of subtype
7503
7504 Check_Subtype_Bounds;
7505
7506 -- Processing for Normalize_Scalars case
7507
7508 if Normalize_Scalars and then not IV_Attribute then
7509
7510 -- If zero is invalid, it is a convenient value to use that is
7511 -- for sure an appropriate invalid value in all situations.
7512
7513 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7514 Val := Make_Integer_Literal (Loc, 0);
7515
7516 -- Cases where all one bits is the appropriate invalid value
7517
7518 -- For modular types, all 1 bits is either invalid or valid. If
7519 -- it is valid, then there is nothing that can be done since there
7520 -- are no invalid values (we ruled out zero already).
7521
7522 -- For signed integer types that have no negative values, either
7523 -- there is room for negative values, or there is not. If there
7524 -- is, then all 1-bits may be interpreted as minus one, which is
7525 -- certainly invalid. Alternatively it is treated as the largest
7526 -- positive value, in which case the observation for modular types
7527 -- still applies.
7528
7529 -- For float types, all 1-bits is a NaN (not a number), which is
7530 -- certainly an appropriately invalid value.
7531
7532 elsif Is_Unsigned_Type (T)
7533 or else Is_Floating_Point_Type (T)
7534 or else Is_Enumeration_Type (T)
7535 then
7536 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
7537
7538 -- Resolve as Unsigned_64, because the largest number we can
7539 -- generate is out of range of universal integer.
7540
7541 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
7542
7543 -- Case of signed types
7544
7545 else
7546 declare
7547 Signed_Size : constant Uint :=
7548 UI_Min (Uint_63, Size_To_Use - 1);
7549
7550 begin
7551 -- Normally we like to use the most negative number. The one
7552 -- exception is when this number is in the known subtype
7553 -- range and the largest positive number is not in the known
7554 -- subtype range.
7555
7556 -- For this exceptional case, use largest positive value
7557
7558 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
7559 and then Lo_Bound <= (-(2 ** Signed_Size))
7560 and then Hi_Bound < 2 ** Signed_Size
7561 then
7562 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
7563
7564 -- Normal case of largest negative value
7565
7566 else
7567 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
7568 end if;
7569 end;
7570 end if;
7571
7572 -- Here for Initialize_Scalars case (or Invalid_Value attribute used)
7573
7574 else
7575 -- For float types, use float values from System.Scalar_Values
7576
7577 if Is_Floating_Point_Type (T) then
7578 if Root_Type (T) = Standard_Short_Float then
7579 Val_RE := RE_IS_Isf;
7580 elsif Root_Type (T) = Standard_Float then
7581 Val_RE := RE_IS_Ifl;
7582 elsif Root_Type (T) = Standard_Long_Float then
7583 Val_RE := RE_IS_Ilf;
7584 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
7585 Val_RE := RE_IS_Ill;
7586 end if;
7587
7588 -- If zero is invalid, use zero values from System.Scalar_Values
7589
7590 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
7591 if Size_To_Use <= 8 then
7592 Val_RE := RE_IS_Iz1;
7593 elsif Size_To_Use <= 16 then
7594 Val_RE := RE_IS_Iz2;
7595 elsif Size_To_Use <= 32 then
7596 Val_RE := RE_IS_Iz4;
7597 else
7598 Val_RE := RE_IS_Iz8;
7599 end if;
7600
7601 -- For unsigned, use unsigned values from System.Scalar_Values
7602
7603 elsif Is_Unsigned_Type (T) then
7604 if Size_To_Use <= 8 then
7605 Val_RE := RE_IS_Iu1;
7606 elsif Size_To_Use <= 16 then
7607 Val_RE := RE_IS_Iu2;
7608 elsif Size_To_Use <= 32 then
7609 Val_RE := RE_IS_Iu4;
7610 else
7611 Val_RE := RE_IS_Iu8;
7612 end if;
7613
7614 -- For signed, use signed values from System.Scalar_Values
7615
7616 else
7617 if Size_To_Use <= 8 then
7618 Val_RE := RE_IS_Is1;
7619 elsif Size_To_Use <= 16 then
7620 Val_RE := RE_IS_Is2;
7621 elsif Size_To_Use <= 32 then
7622 Val_RE := RE_IS_Is4;
7623 else
7624 Val_RE := RE_IS_Is8;
7625 end if;
7626 end if;
7627
7628 Val := New_Occurrence_Of (RTE (Val_RE), Loc);
7629 end if;
7630
7631 -- The final expression is obtained by doing an unchecked conversion
7632 -- of this result to the base type of the required subtype. Use the
7633 -- base type to prevent the unchecked conversion from chopping bits,
7634 -- and then we set Kill_Range_Check to preserve the "bad" value.
7635
7636 Result := Unchecked_Convert_To (Base_Type (T), Val);
7637
7638 -- Ensure result is not truncated, since we want the "bad" bits, and
7639 -- also kill range check on result.
7640
7641 if Nkind (Result) = N_Unchecked_Type_Conversion then
7642 Set_No_Truncation (Result);
7643 Set_Kill_Range_Check (Result, True);
7644 end if;
7645
7646 return Result;
7647
7648 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
7649
7650 elsif Is_Standard_String_Type (T) then
7651 pragma Assert (Init_Or_Norm_Scalars);
7652
7653 return
7654 Make_Aggregate (Loc,
7655 Component_Associations => New_List (
7656 Make_Component_Association (Loc,
7657 Choices => New_List (
7658 Make_Others_Choice (Loc)),
7659 Expression =>
7660 Get_Simple_Init_Val
7661 (Component_Type (T), N, Esize (Root_Type (T))))));
7662
7663 -- Access type is initialized to null
7664
7665 elsif Is_Access_Type (T) then
7666 return Make_Null (Loc);
7667
7668 -- No other possibilities should arise, since we should only be calling
7669 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
7670 -- indicating one of the above cases held.
7671
7672 else
7673 raise Program_Error;
7674 end if;
7675
7676 exception
7677 when RE_Not_Available =>
7678 return Empty;
7679 end Get_Simple_Init_Val;
7680
7681 ------------------------------
7682 -- Has_New_Non_Standard_Rep --
7683 ------------------------------
7684
7685 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
7686 begin
7687 if not Is_Derived_Type (T) then
7688 return Has_Non_Standard_Rep (T)
7689 or else Has_Non_Standard_Rep (Root_Type (T));
7690
7691 -- If Has_Non_Standard_Rep is not set on the derived type, the
7692 -- representation is fully inherited.
7693
7694 elsif not Has_Non_Standard_Rep (T) then
7695 return False;
7696
7697 else
7698 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
7699
7700 -- May need a more precise check here: the First_Rep_Item may be a
7701 -- stream attribute, which does not affect the representation of the
7702 -- type ???
7703
7704 end if;
7705 end Has_New_Non_Standard_Rep;
7706
7707 ----------------------
7708 -- Inline_Init_Proc --
7709 ----------------------
7710
7711 function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
7712 begin
7713 -- The initialization proc of protected records is not worth inlining.
7714 -- In addition, when compiled for another unit for inlining purposes,
7715 -- it may make reference to entities that have not been elaborated yet.
7716 -- The initialization proc of records that need finalization contains
7717 -- a nested clean-up procedure that makes it impractical to inline as
7718 -- well, except for simple controlled types themselves. And similar
7719 -- considerations apply to task types.
7720
7721 if Is_Concurrent_Type (Typ) then
7722 return False;
7723
7724 elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
7725 return False;
7726
7727 elsif Has_Task (Typ) then
7728 return False;
7729
7730 else
7731 return True;
7732 end if;
7733 end Inline_Init_Proc;
7734
7735 ----------------
7736 -- In_Runtime --
7737 ----------------
7738
7739 function In_Runtime (E : Entity_Id) return Boolean is
7740 S1 : Entity_Id;
7741
7742 begin
7743 S1 := Scope (E);
7744 while Scope (S1) /= Standard_Standard loop
7745 S1 := Scope (S1);
7746 end loop;
7747
7748 return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
7749 end In_Runtime;
7750
7751 ----------------------------
7752 -- Initialization_Warning --
7753 ----------------------------
7754
7755 procedure Initialization_Warning (E : Entity_Id) is
7756 Warning_Needed : Boolean;
7757
7758 begin
7759 Warning_Needed := False;
7760
7761 if Ekind (Current_Scope) = E_Package
7762 and then Static_Elaboration_Desired (Current_Scope)
7763 then
7764 if Is_Type (E) then
7765 if Is_Record_Type (E) then
7766 if Has_Discriminants (E)
7767 or else Is_Limited_Type (E)
7768 or else Has_Non_Standard_Rep (E)
7769 then
7770 Warning_Needed := True;
7771
7772 else
7773 -- Verify that at least one component has an initialization
7774 -- expression. No need for a warning on a type if all its
7775 -- components have no initialization.
7776
7777 declare
7778 Comp : Entity_Id;
7779
7780 begin
7781 Comp := First_Component (E);
7782 while Present (Comp) loop
7783 if Ekind (Comp) = E_Discriminant
7784 or else
7785 (Nkind (Parent (Comp)) = N_Component_Declaration
7786 and then Present (Expression (Parent (Comp))))
7787 then
7788 Warning_Needed := True;
7789 exit;
7790 end if;
7791
7792 Next_Component (Comp);
7793 end loop;
7794 end;
7795 end if;
7796
7797 if Warning_Needed then
7798 Error_Msg_N
7799 ("Objects of the type cannot be initialized statically "
7800 & "by default??", Parent (E));
7801 end if;
7802 end if;
7803
7804 else
7805 Error_Msg_N ("Object cannot be initialized statically??", E);
7806 end if;
7807 end if;
7808 end Initialization_Warning;
7809
7810 ------------------
7811 -- Init_Formals --
7812 ------------------
7813
7814 function Init_Formals (Typ : Entity_Id) return List_Id is
7815 Loc : constant Source_Ptr := Sloc (Typ);
7816 Formals : List_Id;
7817
7818 begin
7819 -- First parameter is always _Init : in out typ. Note that we need this
7820 -- to be in/out because in the case of the task record value, there
7821 -- are default record fields (_Priority, _Size, -Task_Info) that may
7822 -- be referenced in the generated initialization routine.
7823
7824 Formals := New_List (
7825 Make_Parameter_Specification (Loc,
7826 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
7827 In_Present => True,
7828 Out_Present => True,
7829 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
7830
7831 -- For task record value, or type that contains tasks, add two more
7832 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
7833 -- We also add these parameters for the task record type case.
7834
7835 if Has_Task (Typ)
7836 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
7837 then
7838 Append_To (Formals,
7839 Make_Parameter_Specification (Loc,
7840 Defining_Identifier =>
7841 Make_Defining_Identifier (Loc, Name_uMaster),
7842 Parameter_Type =>
7843 New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
7844
7845 -- Add _Chain (not done for sequential elaboration policy, see
7846 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
7847
7848 if Partition_Elaboration_Policy /= 'S' then
7849 Append_To (Formals,
7850 Make_Parameter_Specification (Loc,
7851 Defining_Identifier =>
7852 Make_Defining_Identifier (Loc, Name_uChain),
7853 In_Present => True,
7854 Out_Present => True,
7855 Parameter_Type =>
7856 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)));
7857 end if;
7858
7859 Append_To (Formals,
7860 Make_Parameter_Specification (Loc,
7861 Defining_Identifier =>
7862 Make_Defining_Identifier (Loc, Name_uTask_Name),
7863 In_Present => True,
7864 Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
7865 end if;
7866
7867 return Formals;
7868
7869 exception
7870 when RE_Not_Available =>
7871 return Empty_List;
7872 end Init_Formals;
7873
7874 -------------------------
7875 -- Init_Secondary_Tags --
7876 -------------------------
7877
7878 procedure Init_Secondary_Tags
7879 (Typ : Entity_Id;
7880 Target : Node_Id;
7881 Stmts_List : List_Id;
7882 Fixed_Comps : Boolean := True;
7883 Variable_Comps : Boolean := True)
7884 is
7885 Loc : constant Source_Ptr := Sloc (Target);
7886
7887 -- Inherit the C++ tag of the secondary dispatch table of Typ associated
7888 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
7889
7890 procedure Initialize_Tag
7891 (Typ : Entity_Id;
7892 Iface : Entity_Id;
7893 Tag_Comp : Entity_Id;
7894 Iface_Tag : Node_Id);
7895 -- Initialize the tag of the secondary dispatch table of Typ associated
7896 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
7897 -- Compiling under the CPP full ABI compatibility mode, if the ancestor
7898 -- of Typ CPP tagged type we generate code to inherit the contents of
7899 -- the dispatch table directly from the ancestor.
7900
7901 --------------------
7902 -- Initialize_Tag --
7903 --------------------
7904
7905 procedure Initialize_Tag
7906 (Typ : Entity_Id;
7907 Iface : Entity_Id;
7908 Tag_Comp : Entity_Id;
7909 Iface_Tag : Node_Id)
7910 is
7911 Comp_Typ : Entity_Id;
7912 Offset_To_Top_Comp : Entity_Id := Empty;
7913
7914 begin
7915 -- Initialize pointer to secondary DT associated with the interface
7916
7917 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
7918 Append_To (Stmts_List,
7919 Make_Assignment_Statement (Loc,
7920 Name =>
7921 Make_Selected_Component (Loc,
7922 Prefix => New_Copy_Tree (Target),
7923 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
7924 Expression =>
7925 New_Occurrence_Of (Iface_Tag, Loc)));
7926 end if;
7927
7928 Comp_Typ := Scope (Tag_Comp);
7929
7930 -- Initialize the entries of the table of interfaces. We generate a
7931 -- different call when the parent of the type has variable size
7932 -- components.
7933
7934 if Comp_Typ /= Etype (Comp_Typ)
7935 and then Is_Variable_Size_Record (Etype (Comp_Typ))
7936 and then Chars (Tag_Comp) /= Name_uTag
7937 then
7938 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
7939
7940 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
7941 -- configurable run-time environment.
7942
7943 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
7944 Error_Msg_CRT
7945 ("variable size record with interface types", Typ);
7946 return;
7947 end if;
7948
7949 -- Generate:
7950 -- Set_Dynamic_Offset_To_Top
7951 -- (This => Init,
7952 -- Interface_T => Iface'Tag,
7953 -- Offset_Value => n,
7954 -- Offset_Func => Fn'Address)
7955
7956 Append_To (Stmts_List,
7957 Make_Procedure_Call_Statement (Loc,
7958 Name =>
7959 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
7960 Parameter_Associations => New_List (
7961 Make_Attribute_Reference (Loc,
7962 Prefix => New_Copy_Tree (Target),
7963 Attribute_Name => Name_Address),
7964
7965 Unchecked_Convert_To (RTE (RE_Tag),
7966 New_Occurrence_Of
7967 (Node (First_Elmt (Access_Disp_Table (Iface))),
7968 Loc)),
7969
7970 Unchecked_Convert_To
7971 (RTE (RE_Storage_Offset),
7972 Make_Attribute_Reference (Loc,
7973 Prefix =>
7974 Make_Selected_Component (Loc,
7975 Prefix => New_Copy_Tree (Target),
7976 Selector_Name =>
7977 New_Occurrence_Of (Tag_Comp, Loc)),
7978 Attribute_Name => Name_Position)),
7979
7980 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
7981 Make_Attribute_Reference (Loc,
7982 Prefix => New_Occurrence_Of
7983 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
7984 Attribute_Name => Name_Address)))));
7985
7986 -- In this case the next component stores the value of the offset
7987 -- to the top.
7988
7989 Offset_To_Top_Comp := Next_Entity (Tag_Comp);
7990 pragma Assert (Present (Offset_To_Top_Comp));
7991
7992 Append_To (Stmts_List,
7993 Make_Assignment_Statement (Loc,
7994 Name =>
7995 Make_Selected_Component (Loc,
7996 Prefix => New_Copy_Tree (Target),
7997 Selector_Name =>
7998 New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
7999
8000 Expression =>
8001 Make_Attribute_Reference (Loc,
8002 Prefix =>
8003 Make_Selected_Component (Loc,
8004 Prefix => New_Copy_Tree (Target),
8005 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
8006 Attribute_Name => Name_Position)));
8007
8008 -- Normal case: No discriminants in the parent type
8009
8010 else
8011 -- Don't need to set any value if this interface shares the
8012 -- primary dispatch table.
8013
8014 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
8015 Append_To (Stmts_List,
8016 Build_Set_Static_Offset_To_Top (Loc,
8017 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc),
8018 Offset_Value =>
8019 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8020 Make_Attribute_Reference (Loc,
8021 Prefix =>
8022 Make_Selected_Component (Loc,
8023 Prefix => New_Copy_Tree (Target),
8024 Selector_Name =>
8025 New_Occurrence_Of (Tag_Comp, Loc)),
8026 Attribute_Name => Name_Position))));
8027 end if;
8028
8029 -- Generate:
8030 -- Register_Interface_Offset
8031 -- (This => Init,
8032 -- Interface_T => Iface'Tag,
8033 -- Is_Constant => True,
8034 -- Offset_Value => n,
8035 -- Offset_Func => null);
8036
8037 if RTE_Available (RE_Register_Interface_Offset) then
8038 Append_To (Stmts_List,
8039 Make_Procedure_Call_Statement (Loc,
8040 Name =>
8041 New_Occurrence_Of
8042 (RTE (RE_Register_Interface_Offset), Loc),
8043 Parameter_Associations => New_List (
8044 Make_Attribute_Reference (Loc,
8045 Prefix => New_Copy_Tree (Target),
8046 Attribute_Name => Name_Address),
8047
8048 Unchecked_Convert_To (RTE (RE_Tag),
8049 New_Occurrence_Of
8050 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
8051
8052 New_Occurrence_Of (Standard_True, Loc),
8053
8054 Unchecked_Convert_To (RTE (RE_Storage_Offset),
8055 Make_Attribute_Reference (Loc,
8056 Prefix =>
8057 Make_Selected_Component (Loc,
8058 Prefix => New_Copy_Tree (Target),
8059 Selector_Name =>
8060 New_Occurrence_Of (Tag_Comp, Loc)),
8061 Attribute_Name => Name_Position)),
8062
8063 Make_Null (Loc))));
8064 end if;
8065 end if;
8066 end Initialize_Tag;
8067
8068 -- Local variables
8069
8070 Full_Typ : Entity_Id;
8071 Ifaces_List : Elist_Id;
8072 Ifaces_Comp_List : Elist_Id;
8073 Ifaces_Tag_List : Elist_Id;
8074 Iface_Elmt : Elmt_Id;
8075 Iface_Comp_Elmt : Elmt_Id;
8076 Iface_Tag_Elmt : Elmt_Id;
8077 Tag_Comp : Node_Id;
8078 In_Variable_Pos : Boolean;
8079
8080 -- Start of processing for Init_Secondary_Tags
8081
8082 begin
8083 -- Handle private types
8084
8085 if Present (Full_View (Typ)) then
8086 Full_Typ := Full_View (Typ);
8087 else
8088 Full_Typ := Typ;
8089 end if;
8090
8091 Collect_Interfaces_Info
8092 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
8093
8094 Iface_Elmt := First_Elmt (Ifaces_List);
8095 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
8096 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
8097 while Present (Iface_Elmt) loop
8098 Tag_Comp := Node (Iface_Comp_Elmt);
8099
8100 -- Check if parent of record type has variable size components
8101
8102 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
8103 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
8104
8105 -- If we are compiling under the CPP full ABI compatibility mode and
8106 -- the ancestor is a CPP_Pragma tagged type then we generate code to
8107 -- initialize the secondary tag components from tags that reference
8108 -- secondary tables filled with copy of parent slots.
8109
8110 if Is_CPP_Class (Root_Type (Full_Typ)) then
8111
8112 -- Reject interface components located at variable offset in
8113 -- C++ derivations. This is currently unsupported.
8114
8115 if not Fixed_Comps and then In_Variable_Pos then
8116
8117 -- Locate the first dynamic component of the record. Done to
8118 -- improve the text of the warning.
8119
8120 declare
8121 Comp : Entity_Id;
8122 Comp_Typ : Entity_Id;
8123
8124 begin
8125 Comp := First_Entity (Typ);
8126 while Present (Comp) loop
8127 Comp_Typ := Etype (Comp);
8128
8129 if Ekind (Comp) /= E_Discriminant
8130 and then not Is_Tag (Comp)
8131 then
8132 exit when
8133 (Is_Record_Type (Comp_Typ)
8134 and then
8135 Is_Variable_Size_Record (Base_Type (Comp_Typ)))
8136 or else
8137 (Is_Array_Type (Comp_Typ)
8138 and then Is_Variable_Size_Array (Comp_Typ));
8139 end if;
8140
8141 Next_Entity (Comp);
8142 end loop;
8143
8144 pragma Assert (Present (Comp));
8145 Error_Msg_Node_2 := Comp;
8146 Error_Msg_NE
8147 ("parent type & with dynamic component & cannot be parent"
8148 & " of 'C'P'P derivation if new interfaces are present",
8149 Typ, Scope (Original_Record_Component (Comp)));
8150
8151 Error_Msg_Sloc :=
8152 Sloc (Scope (Original_Record_Component (Comp)));
8153 Error_Msg_NE
8154 ("type derived from 'C'P'P type & defined #",
8155 Typ, Scope (Original_Record_Component (Comp)));
8156
8157 -- Avoid duplicated warnings
8158
8159 exit;
8160 end;
8161
8162 -- Initialize secondary tags
8163
8164 else
8165 Append_To (Stmts_List,
8166 Make_Assignment_Statement (Loc,
8167 Name =>
8168 Make_Selected_Component (Loc,
8169 Prefix => New_Copy_Tree (Target),
8170 Selector_Name =>
8171 New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)),
8172 Expression =>
8173 New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc)));
8174 end if;
8175
8176 -- Otherwise generate code to initialize the tag
8177
8178 else
8179 if (In_Variable_Pos and then Variable_Comps)
8180 or else (not In_Variable_Pos and then Fixed_Comps)
8181 then
8182 Initialize_Tag (Full_Typ,
8183 Iface => Node (Iface_Elmt),
8184 Tag_Comp => Tag_Comp,
8185 Iface_Tag => Node (Iface_Tag_Elmt));
8186 end if;
8187 end if;
8188
8189 Next_Elmt (Iface_Elmt);
8190 Next_Elmt (Iface_Comp_Elmt);
8191 Next_Elmt (Iface_Tag_Elmt);
8192 end loop;
8193 end Init_Secondary_Tags;
8194
8195 ------------------------
8196 -- Is_User_Defined_Eq --
8197 ------------------------
8198
8199 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
8200 begin
8201 return Chars (Prim) = Name_Op_Eq
8202 and then Etype (First_Formal (Prim)) =
8203 Etype (Next_Formal (First_Formal (Prim)))
8204 and then Base_Type (Etype (Prim)) = Standard_Boolean;
8205 end Is_User_Defined_Equality;
8206
8207 ----------------------------------------
8208 -- Make_Controlling_Function_Wrappers --
8209 ----------------------------------------
8210
8211 procedure Make_Controlling_Function_Wrappers
8212 (Tag_Typ : Entity_Id;
8213 Decl_List : out List_Id;
8214 Body_List : out List_Id)
8215 is
8216 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8217 Prim_Elmt : Elmt_Id;
8218 Subp : Entity_Id;
8219 Actual_List : List_Id;
8220 Formal_List : List_Id;
8221 Formal : Entity_Id;
8222 Par_Formal : Entity_Id;
8223 Formal_Node : Node_Id;
8224 Func_Body : Node_Id;
8225 Func_Decl : Node_Id;
8226 Func_Spec : Node_Id;
8227 Return_Stmt : Node_Id;
8228
8229 begin
8230 Decl_List := New_List;
8231 Body_List := New_List;
8232
8233 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8234 while Present (Prim_Elmt) loop
8235 Subp := Node (Prim_Elmt);
8236
8237 -- If a primitive function with a controlling result of the type has
8238 -- not been overridden by the user, then we must create a wrapper
8239 -- function here that effectively overrides it and invokes the
8240 -- (non-abstract) parent function. This can only occur for a null
8241 -- extension. Note that functions with anonymous controlling access
8242 -- results don't qualify and must be overridden. We also exclude
8243 -- Input attributes, since each type will have its own version of
8244 -- Input constructed by the expander. The test for Comes_From_Source
8245 -- is needed to distinguish inherited operations from renamings
8246 -- (which also have Alias set). We exclude internal entities with
8247 -- Interface_Alias to avoid generating duplicated wrappers since
8248 -- the primitive which covers the interface is also available in
8249 -- the list of primitive operations.
8250
8251 -- The function may be abstract, or require_Overriding may be set
8252 -- for it, because tests for null extensions may already have reset
8253 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
8254 -- set, functions that need wrappers are recognized by having an
8255 -- alias that returns the parent type.
8256
8257 if Comes_From_Source (Subp)
8258 or else No (Alias (Subp))
8259 or else Present (Interface_Alias (Subp))
8260 or else Ekind (Subp) /= E_Function
8261 or else not Has_Controlling_Result (Subp)
8262 or else Is_Access_Type (Etype (Subp))
8263 or else Is_Abstract_Subprogram (Alias (Subp))
8264 or else Is_TSS (Subp, TSS_Stream_Input)
8265 then
8266 goto Next_Prim;
8267
8268 elsif Is_Abstract_Subprogram (Subp)
8269 or else Requires_Overriding (Subp)
8270 or else
8271 (Is_Null_Extension (Etype (Subp))
8272 and then Etype (Alias (Subp)) /= Etype (Subp))
8273 then
8274 Formal_List := No_List;
8275 Formal := First_Formal (Subp);
8276
8277 if Present (Formal) then
8278 Formal_List := New_List;
8279
8280 while Present (Formal) loop
8281 Append
8282 (Make_Parameter_Specification
8283 (Loc,
8284 Defining_Identifier =>
8285 Make_Defining_Identifier (Sloc (Formal),
8286 Chars => Chars (Formal)),
8287 In_Present => In_Present (Parent (Formal)),
8288 Out_Present => Out_Present (Parent (Formal)),
8289 Null_Exclusion_Present =>
8290 Null_Exclusion_Present (Parent (Formal)),
8291 Parameter_Type =>
8292 New_Occurrence_Of (Etype (Formal), Loc),
8293 Expression =>
8294 New_Copy_Tree (Expression (Parent (Formal)))),
8295 Formal_List);
8296
8297 Next_Formal (Formal);
8298 end loop;
8299 end if;
8300
8301 Func_Spec :=
8302 Make_Function_Specification (Loc,
8303 Defining_Unit_Name =>
8304 Make_Defining_Identifier (Loc,
8305 Chars => Chars (Subp)),
8306 Parameter_Specifications => Formal_List,
8307 Result_Definition =>
8308 New_Occurrence_Of (Etype (Subp), Loc));
8309
8310 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
8311 Append_To (Decl_List, Func_Decl);
8312
8313 -- Build a wrapper body that calls the parent function. The body
8314 -- contains a single return statement that returns an extension
8315 -- aggregate whose ancestor part is a call to the parent function,
8316 -- passing the formals as actuals (with any controlling arguments
8317 -- converted to the types of the corresponding formals of the
8318 -- parent function, which might be anonymous access types), and
8319 -- having a null extension.
8320
8321 Formal := First_Formal (Subp);
8322 Par_Formal := First_Formal (Alias (Subp));
8323 Formal_Node := First (Formal_List);
8324
8325 if Present (Formal) then
8326 Actual_List := New_List;
8327 else
8328 Actual_List := No_List;
8329 end if;
8330
8331 while Present (Formal) loop
8332 if Is_Controlling_Formal (Formal) then
8333 Append_To (Actual_List,
8334 Make_Type_Conversion (Loc,
8335 Subtype_Mark =>
8336 New_Occurrence_Of (Etype (Par_Formal), Loc),
8337 Expression =>
8338 New_Occurrence_Of
8339 (Defining_Identifier (Formal_Node), Loc)));
8340 else
8341 Append_To
8342 (Actual_List,
8343 New_Occurrence_Of
8344 (Defining_Identifier (Formal_Node), Loc));
8345 end if;
8346
8347 Next_Formal (Formal);
8348 Next_Formal (Par_Formal);
8349 Next (Formal_Node);
8350 end loop;
8351
8352 Return_Stmt :=
8353 Make_Simple_Return_Statement (Loc,
8354 Expression =>
8355 Make_Extension_Aggregate (Loc,
8356 Ancestor_Part =>
8357 Make_Function_Call (Loc,
8358 Name =>
8359 New_Occurrence_Of (Alias (Subp), Loc),
8360 Parameter_Associations => Actual_List),
8361 Null_Record_Present => True));
8362
8363 Func_Body :=
8364 Make_Subprogram_Body (Loc,
8365 Specification => New_Copy_Tree (Func_Spec),
8366 Declarations => Empty_List,
8367 Handled_Statement_Sequence =>
8368 Make_Handled_Sequence_Of_Statements (Loc,
8369 Statements => New_List (Return_Stmt)));
8370
8371 Set_Defining_Unit_Name
8372 (Specification (Func_Body),
8373 Make_Defining_Identifier (Loc, Chars (Subp)));
8374
8375 Append_To (Body_List, Func_Body);
8376
8377 -- Replace the inherited function with the wrapper function in the
8378 -- primitive operations list. We add the minimum decoration needed
8379 -- to override interface primitives.
8380
8381 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
8382
8383 Override_Dispatching_Operation
8384 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
8385 Is_Wrapper => True);
8386 end if;
8387
8388 <<Next_Prim>>
8389 Next_Elmt (Prim_Elmt);
8390 end loop;
8391 end Make_Controlling_Function_Wrappers;
8392
8393 -------------------
8394 -- Make_Eq_Body --
8395 -------------------
8396
8397 function Make_Eq_Body
8398 (Typ : Entity_Id;
8399 Eq_Name : Name_Id) return Node_Id
8400 is
8401 Loc : constant Source_Ptr := Sloc (Parent (Typ));
8402 Decl : Node_Id;
8403 Def : constant Node_Id := Parent (Typ);
8404 Stmts : constant List_Id := New_List;
8405 Variant_Case : Boolean := Has_Discriminants (Typ);
8406 Comps : Node_Id := Empty;
8407 Typ_Def : Node_Id := Type_Definition (Def);
8408
8409 begin
8410 Decl :=
8411 Predef_Spec_Or_Body (Loc,
8412 Tag_Typ => Typ,
8413 Name => Eq_Name,
8414 Profile => New_List (
8415 Make_Parameter_Specification (Loc,
8416 Defining_Identifier =>
8417 Make_Defining_Identifier (Loc, Name_X),
8418 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8419
8420 Make_Parameter_Specification (Loc,
8421 Defining_Identifier =>
8422 Make_Defining_Identifier (Loc, Name_Y),
8423 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8424
8425 Ret_Type => Standard_Boolean,
8426 For_Body => True);
8427
8428 if Variant_Case then
8429 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8430 Typ_Def := Record_Extension_Part (Typ_Def);
8431 end if;
8432
8433 if Present (Typ_Def) then
8434 Comps := Component_List (Typ_Def);
8435 end if;
8436
8437 Variant_Case :=
8438 Present (Comps) and then Present (Variant_Part (Comps));
8439 end if;
8440
8441 if Variant_Case then
8442 Append_To (Stmts,
8443 Make_Eq_If (Typ, Discriminant_Specifications (Def)));
8444 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
8445 Append_To (Stmts,
8446 Make_Simple_Return_Statement (Loc,
8447 Expression => New_Occurrence_Of (Standard_True, Loc)));
8448
8449 else
8450 Append_To (Stmts,
8451 Make_Simple_Return_Statement (Loc,
8452 Expression =>
8453 Expand_Record_Equality
8454 (Typ,
8455 Typ => Typ,
8456 Lhs => Make_Identifier (Loc, Name_X),
8457 Rhs => Make_Identifier (Loc, Name_Y),
8458 Bodies => Declarations (Decl))));
8459 end if;
8460
8461 Set_Handled_Statement_Sequence
8462 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8463 return Decl;
8464 end Make_Eq_Body;
8465
8466 ------------------
8467 -- Make_Eq_Case --
8468 ------------------
8469
8470 -- <Make_Eq_If shared components>
8471
8472 -- case X.D1 is
8473 -- when V1 => <Make_Eq_Case> on subcomponents
8474 -- ...
8475 -- when Vn => <Make_Eq_Case> on subcomponents
8476 -- end case;
8477
8478 function Make_Eq_Case
8479 (E : Entity_Id;
8480 CL : Node_Id;
8481 Discrs : Elist_Id := New_Elmt_List) return List_Id
8482 is
8483 Loc : constant Source_Ptr := Sloc (E);
8484 Result : constant List_Id := New_List;
8485 Variant : Node_Id;
8486 Alt_List : List_Id;
8487
8488 function Corresponding_Formal (C : Node_Id) return Entity_Id;
8489 -- Given the discriminant that controls a given variant of an unchecked
8490 -- union, find the formal of the equality function that carries the
8491 -- inferred value of the discriminant.
8492
8493 function External_Name (E : Entity_Id) return Name_Id;
8494 -- The value of a given discriminant is conveyed in the corresponding
8495 -- formal parameter of the equality routine. The name of this formal
8496 -- parameter carries a one-character suffix which is removed here.
8497
8498 --------------------------
8499 -- Corresponding_Formal --
8500 --------------------------
8501
8502 function Corresponding_Formal (C : Node_Id) return Entity_Id is
8503 Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
8504 Elm : Elmt_Id;
8505
8506 begin
8507 Elm := First_Elmt (Discrs);
8508 while Present (Elm) loop
8509 if Chars (Discr) = External_Name (Node (Elm)) then
8510 return Node (Elm);
8511 end if;
8512
8513 Next_Elmt (Elm);
8514 end loop;
8515
8516 -- A formal of the proper name must be found
8517
8518 raise Program_Error;
8519 end Corresponding_Formal;
8520
8521 -------------------
8522 -- External_Name --
8523 -------------------
8524
8525 function External_Name (E : Entity_Id) return Name_Id is
8526 begin
8527 Get_Name_String (Chars (E));
8528 Name_Len := Name_Len - 1;
8529 return Name_Find;
8530 end External_Name;
8531
8532 -- Start of processing for Make_Eq_Case
8533
8534 begin
8535 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
8536
8537 if No (Variant_Part (CL)) then
8538 return Result;
8539 end if;
8540
8541 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
8542
8543 if No (Variant) then
8544 return Result;
8545 end if;
8546
8547 Alt_List := New_List;
8548 while Present (Variant) loop
8549 Append_To (Alt_List,
8550 Make_Case_Statement_Alternative (Loc,
8551 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
8552 Statements =>
8553 Make_Eq_Case (E, Component_List (Variant), Discrs)));
8554 Next_Non_Pragma (Variant);
8555 end loop;
8556
8557 -- If we have an Unchecked_Union, use one of the parameters of the
8558 -- enclosing equality routine that captures the discriminant, to use
8559 -- as the expression in the generated case statement.
8560
8561 if Is_Unchecked_Union (E) then
8562 Append_To (Result,
8563 Make_Case_Statement (Loc,
8564 Expression =>
8565 New_Occurrence_Of (Corresponding_Formal (CL), Loc),
8566 Alternatives => Alt_List));
8567
8568 else
8569 Append_To (Result,
8570 Make_Case_Statement (Loc,
8571 Expression =>
8572 Make_Selected_Component (Loc,
8573 Prefix => Make_Identifier (Loc, Name_X),
8574 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
8575 Alternatives => Alt_List));
8576 end if;
8577
8578 return Result;
8579 end Make_Eq_Case;
8580
8581 ----------------
8582 -- Make_Eq_If --
8583 ----------------
8584
8585 -- Generates:
8586
8587 -- if
8588 -- X.C1 /= Y.C1
8589 -- or else
8590 -- X.C2 /= Y.C2
8591 -- ...
8592 -- then
8593 -- return False;
8594 -- end if;
8595
8596 -- or a null statement if the list L is empty
8597
8598 function Make_Eq_If
8599 (E : Entity_Id;
8600 L : List_Id) return Node_Id
8601 is
8602 Loc : constant Source_Ptr := Sloc (E);
8603 C : Node_Id;
8604 Field_Name : Name_Id;
8605 Cond : Node_Id;
8606
8607 begin
8608 if No (L) then
8609 return Make_Null_Statement (Loc);
8610
8611 else
8612 Cond := Empty;
8613
8614 C := First_Non_Pragma (L);
8615 while Present (C) loop
8616 Field_Name := Chars (Defining_Identifier (C));
8617
8618 -- The tags must not be compared: they are not part of the value.
8619 -- Ditto for parent interfaces because their equality operator is
8620 -- abstract.
8621
8622 -- Note also that in the following, we use Make_Identifier for
8623 -- the component names. Use of New_Occurrence_Of to identify the
8624 -- components would be incorrect because the wrong entities for
8625 -- discriminants could be picked up in the private type case.
8626
8627 if Field_Name = Name_uParent
8628 and then Is_Interface (Etype (Defining_Identifier (C)))
8629 then
8630 null;
8631
8632 elsif Field_Name /= Name_uTag then
8633 Evolve_Or_Else (Cond,
8634 Make_Op_Ne (Loc,
8635 Left_Opnd =>
8636 Make_Selected_Component (Loc,
8637 Prefix => Make_Identifier (Loc, Name_X),
8638 Selector_Name => Make_Identifier (Loc, Field_Name)),
8639
8640 Right_Opnd =>
8641 Make_Selected_Component (Loc,
8642 Prefix => Make_Identifier (Loc, Name_Y),
8643 Selector_Name => Make_Identifier (Loc, Field_Name))));
8644 end if;
8645
8646 Next_Non_Pragma (C);
8647 end loop;
8648
8649 if No (Cond) then
8650 return Make_Null_Statement (Loc);
8651
8652 else
8653 return
8654 Make_Implicit_If_Statement (E,
8655 Condition => Cond,
8656 Then_Statements => New_List (
8657 Make_Simple_Return_Statement (Loc,
8658 Expression => New_Occurrence_Of (Standard_False, Loc))));
8659 end if;
8660 end if;
8661 end Make_Eq_If;
8662
8663 -------------------
8664 -- Make_Neq_Body --
8665 -------------------
8666
8667 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
8668
8669 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
8670 -- Returns true if Prim is a renaming of an unresolved predefined
8671 -- inequality operation.
8672
8673 --------------------------------
8674 -- Is_Predefined_Neq_Renaming --
8675 --------------------------------
8676
8677 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
8678 begin
8679 return Chars (Prim) /= Name_Op_Ne
8680 and then Present (Alias (Prim))
8681 and then Comes_From_Source (Prim)
8682 and then Is_Intrinsic_Subprogram (Alias (Prim))
8683 and then Chars (Alias (Prim)) = Name_Op_Ne;
8684 end Is_Predefined_Neq_Renaming;
8685
8686 -- Local variables
8687
8688 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
8689 Stmts : constant List_Id := New_List;
8690 Decl : Node_Id;
8691 Eq_Prim : Entity_Id;
8692 Left_Op : Entity_Id;
8693 Renaming_Prim : Entity_Id;
8694 Right_Op : Entity_Id;
8695 Target : Entity_Id;
8696
8697 -- Start of processing for Make_Neq_Body
8698
8699 begin
8700 -- For a call on a renaming of a dispatching subprogram that is
8701 -- overridden, if the overriding occurred before the renaming, then
8702 -- the body executed is that of the overriding declaration, even if the
8703 -- overriding declaration is not visible at the place of the renaming;
8704 -- otherwise, the inherited or predefined subprogram is called, see
8705 -- (RM 8.5.4(8))
8706
8707 -- Stage 1: Search for a renaming of the inequality primitive and also
8708 -- search for an overriding of the equality primitive located before the
8709 -- renaming declaration.
8710
8711 declare
8712 Elmt : Elmt_Id;
8713 Prim : Node_Id;
8714
8715 begin
8716 Eq_Prim := Empty;
8717 Renaming_Prim := Empty;
8718
8719 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8720 while Present (Elmt) loop
8721 Prim := Node (Elmt);
8722
8723 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
8724 if No (Renaming_Prim) then
8725 pragma Assert (No (Eq_Prim));
8726 Eq_Prim := Prim;
8727 end if;
8728
8729 elsif Is_Predefined_Neq_Renaming (Prim) then
8730 Renaming_Prim := Prim;
8731 end if;
8732
8733 Next_Elmt (Elmt);
8734 end loop;
8735 end;
8736
8737 -- No further action needed if no renaming was found
8738
8739 if No (Renaming_Prim) then
8740 return Empty;
8741 end if;
8742
8743 -- Stage 2: Replace the renaming declaration by a subprogram declaration
8744 -- (required to add its body)
8745
8746 Decl := Parent (Parent (Renaming_Prim));
8747 Rewrite (Decl,
8748 Make_Subprogram_Declaration (Loc,
8749 Specification => Specification (Decl)));
8750 Set_Analyzed (Decl);
8751
8752 -- Remove the decoration of intrinsic renaming subprogram
8753
8754 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
8755 Set_Convention (Renaming_Prim, Convention_Ada);
8756 Set_Alias (Renaming_Prim, Empty);
8757 Set_Has_Completion (Renaming_Prim, False);
8758
8759 -- Stage 3: Build the corresponding body
8760
8761 Left_Op := First_Formal (Renaming_Prim);
8762 Right_Op := Next_Formal (Left_Op);
8763
8764 Decl :=
8765 Predef_Spec_Or_Body (Loc,
8766 Tag_Typ => Tag_Typ,
8767 Name => Chars (Renaming_Prim),
8768 Profile => New_List (
8769 Make_Parameter_Specification (Loc,
8770 Defining_Identifier =>
8771 Make_Defining_Identifier (Loc, Chars (Left_Op)),
8772 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
8773
8774 Make_Parameter_Specification (Loc,
8775 Defining_Identifier =>
8776 Make_Defining_Identifier (Loc, Chars (Right_Op)),
8777 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
8778
8779 Ret_Type => Standard_Boolean,
8780 For_Body => True);
8781
8782 -- If the overriding of the equality primitive occurred before the
8783 -- renaming, then generate:
8784
8785 -- function <Neq_Name> (X : Y : Typ) return Boolean is
8786 -- begin
8787 -- return not Oeq (X, Y);
8788 -- end;
8789
8790 if Present (Eq_Prim) then
8791 Target := Eq_Prim;
8792
8793 -- Otherwise build a nested subprogram which performs the predefined
8794 -- evaluation of the equality operator. That is, generate:
8795
8796 -- function <Neq_Name> (X : Y : Typ) return Boolean is
8797 -- function Oeq (X : Y) return Boolean is
8798 -- begin
8799 -- <<body of default implementation>>
8800 -- end;
8801 -- begin
8802 -- return not Oeq (X, Y);
8803 -- end;
8804
8805 else
8806 declare
8807 Local_Subp : Node_Id;
8808 begin
8809 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
8810 Set_Declarations (Decl, New_List (Local_Subp));
8811 Target := Defining_Entity (Local_Subp);
8812 end;
8813 end if;
8814
8815 Append_To (Stmts,
8816 Make_Simple_Return_Statement (Loc,
8817 Expression =>
8818 Make_Op_Not (Loc,
8819 Make_Function_Call (Loc,
8820 Name => New_Occurrence_Of (Target, Loc),
8821 Parameter_Associations => New_List (
8822 Make_Identifier (Loc, Chars (Left_Op)),
8823 Make_Identifier (Loc, Chars (Right_Op)))))));
8824
8825 Set_Handled_Statement_Sequence
8826 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8827 return Decl;
8828 end Make_Neq_Body;
8829
8830 -------------------------------
8831 -- Make_Null_Procedure_Specs --
8832 -------------------------------
8833
8834 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
8835 Decl_List : constant List_Id := New_List;
8836 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8837 Formal : Entity_Id;
8838 Formal_List : List_Id;
8839 New_Param_Spec : Node_Id;
8840 Parent_Subp : Entity_Id;
8841 Prim_Elmt : Elmt_Id;
8842 Subp : Entity_Id;
8843
8844 begin
8845 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
8846 while Present (Prim_Elmt) loop
8847 Subp := Node (Prim_Elmt);
8848
8849 -- If a null procedure inherited from an interface has not been
8850 -- overridden, then we build a null procedure declaration to
8851 -- override the inherited procedure.
8852
8853 Parent_Subp := Alias (Subp);
8854
8855 if Present (Parent_Subp)
8856 and then Is_Null_Interface_Primitive (Parent_Subp)
8857 then
8858 Formal_List := No_List;
8859 Formal := First_Formal (Subp);
8860
8861 if Present (Formal) then
8862 Formal_List := New_List;
8863
8864 while Present (Formal) loop
8865
8866 -- Copy the parameter spec including default expressions
8867
8868 New_Param_Spec :=
8869 New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
8870
8871 -- Generate a new defining identifier for the new formal.
8872 -- required because New_Copy_Tree does not duplicate
8873 -- semantic fields (except itypes).
8874
8875 Set_Defining_Identifier (New_Param_Spec,
8876 Make_Defining_Identifier (Sloc (Formal),
8877 Chars => Chars (Formal)));
8878
8879 -- For controlling arguments we must change their
8880 -- parameter type to reference the tagged type (instead
8881 -- of the interface type)
8882
8883 if Is_Controlling_Formal (Formal) then
8884 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
8885 then
8886 Set_Parameter_Type (New_Param_Spec,
8887 New_Occurrence_Of (Tag_Typ, Loc));
8888
8889 else pragma Assert
8890 (Nkind (Parameter_Type (Parent (Formal))) =
8891 N_Access_Definition);
8892 Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
8893 New_Occurrence_Of (Tag_Typ, Loc));
8894 end if;
8895 end if;
8896
8897 Append (New_Param_Spec, Formal_List);
8898
8899 Next_Formal (Formal);
8900 end loop;
8901 end if;
8902
8903 Append_To (Decl_List,
8904 Make_Subprogram_Declaration (Loc,
8905 Make_Procedure_Specification (Loc,
8906 Defining_Unit_Name =>
8907 Make_Defining_Identifier (Loc, Chars (Subp)),
8908 Parameter_Specifications => Formal_List,
8909 Null_Present => True)));
8910 end if;
8911
8912 Next_Elmt (Prim_Elmt);
8913 end loop;
8914
8915 return Decl_List;
8916 end Make_Null_Procedure_Specs;
8917
8918 -------------------------------------
8919 -- Make_Predefined_Primitive_Specs --
8920 -------------------------------------
8921
8922 procedure Make_Predefined_Primitive_Specs
8923 (Tag_Typ : Entity_Id;
8924 Predef_List : out List_Id;
8925 Renamed_Eq : out Entity_Id)
8926 is
8927 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
8928 -- Returns true if Prim is a renaming of an unresolved predefined
8929 -- equality operation.
8930
8931 -------------------------------
8932 -- Is_Predefined_Eq_Renaming --
8933 -------------------------------
8934
8935 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
8936 begin
8937 return Chars (Prim) /= Name_Op_Eq
8938 and then Present (Alias (Prim))
8939 and then Comes_From_Source (Prim)
8940 and then Is_Intrinsic_Subprogram (Alias (Prim))
8941 and then Chars (Alias (Prim)) = Name_Op_Eq;
8942 end Is_Predefined_Eq_Renaming;
8943
8944 -- Local variables
8945
8946 Loc : constant Source_Ptr := Sloc (Tag_Typ);
8947 Res : constant List_Id := New_List;
8948 Eq_Name : Name_Id := Name_Op_Eq;
8949 Eq_Needed : Boolean;
8950 Eq_Spec : Node_Id;
8951 Prim : Elmt_Id;
8952
8953 Has_Predef_Eq_Renaming : Boolean := False;
8954 -- Set to True if Tag_Typ has a primitive that renames the predefined
8955 -- equality operator. Used to implement (RM 8-5-4(8)).
8956
8957 -- Start of processing for Make_Predefined_Primitive_Specs
8958
8959 begin
8960 Renamed_Eq := Empty;
8961
8962 -- Spec of _Size
8963
8964 Append_To (Res, Predef_Spec_Or_Body (Loc,
8965 Tag_Typ => Tag_Typ,
8966 Name => Name_uSize,
8967 Profile => New_List (
8968 Make_Parameter_Specification (Loc,
8969 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
8970 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
8971
8972 Ret_Type => Standard_Long_Long_Integer));
8973
8974 -- Specs for dispatching stream attributes
8975
8976 declare
8977 Stream_Op_TSS_Names :
8978 constant array (Integer range <>) of TSS_Name_Type :=
8979 (TSS_Stream_Read,
8980 TSS_Stream_Write,
8981 TSS_Stream_Input,
8982 TSS_Stream_Output);
8983
8984 begin
8985 for Op in Stream_Op_TSS_Names'Range loop
8986 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
8987 Append_To (Res,
8988 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
8989 Stream_Op_TSS_Names (Op)));
8990 end if;
8991 end loop;
8992 end;
8993
8994 -- Spec of "=" is expanded if the type is not limited and if a user
8995 -- defined "=" was not already declared for the non-full view of a
8996 -- private extension
8997
8998 if not Is_Limited_Type (Tag_Typ) then
8999 Eq_Needed := True;
9000 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9001 while Present (Prim) loop
9002
9003 -- If a primitive is encountered that renames the predefined
9004 -- equality operator before reaching any explicit equality
9005 -- primitive, then we still need to create a predefined equality
9006 -- function, because calls to it can occur via the renaming. A
9007 -- new name is created for the equality to avoid conflicting with
9008 -- any user-defined equality. (Note that this doesn't account for
9009 -- renamings of equality nested within subpackages???)
9010
9011 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9012 Has_Predef_Eq_Renaming := True;
9013 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
9014
9015 -- User-defined equality
9016
9017 elsif Is_User_Defined_Equality (Node (Prim)) then
9018 if No (Alias (Node (Prim)))
9019 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
9020 N_Subprogram_Renaming_Declaration
9021 then
9022 Eq_Needed := False;
9023 exit;
9024
9025 -- If the parent is not an interface type and has an abstract
9026 -- equality function explicitly defined in the sources, then
9027 -- the inherited equality is abstract as well, and no body can
9028 -- be created for it.
9029
9030 elsif not Is_Interface (Etype (Tag_Typ))
9031 and then Present (Alias (Node (Prim)))
9032 and then Comes_From_Source (Alias (Node (Prim)))
9033 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
9034 then
9035 Eq_Needed := False;
9036 exit;
9037
9038 -- If the type has an equality function corresponding with
9039 -- a primitive defined in an interface type, the inherited
9040 -- equality is abstract as well, and no body can be created
9041 -- for it.
9042
9043 elsif Present (Alias (Node (Prim)))
9044 and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
9045 and then
9046 Is_Interface
9047 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
9048 then
9049 Eq_Needed := False;
9050 exit;
9051 end if;
9052 end if;
9053
9054 Next_Elmt (Prim);
9055 end loop;
9056
9057 -- If a renaming of predefined equality was found but there was no
9058 -- user-defined equality (so Eq_Needed is still true), then set the
9059 -- name back to Name_Op_Eq. But in the case where a user-defined
9060 -- equality was located after such a renaming, then the predefined
9061 -- equality function is still needed, so Eq_Needed must be set back
9062 -- to True.
9063
9064 if Eq_Name /= Name_Op_Eq then
9065 if Eq_Needed then
9066 Eq_Name := Name_Op_Eq;
9067 else
9068 Eq_Needed := True;
9069 end if;
9070 end if;
9071
9072 if Eq_Needed then
9073 Eq_Spec := Predef_Spec_Or_Body (Loc,
9074 Tag_Typ => Tag_Typ,
9075 Name => Eq_Name,
9076 Profile => New_List (
9077 Make_Parameter_Specification (Loc,
9078 Defining_Identifier =>
9079 Make_Defining_Identifier (Loc, Name_X),
9080 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9081
9082 Make_Parameter_Specification (Loc,
9083 Defining_Identifier =>
9084 Make_Defining_Identifier (Loc, Name_Y),
9085 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9086 Ret_Type => Standard_Boolean);
9087 Append_To (Res, Eq_Spec);
9088
9089 if Has_Predef_Eq_Renaming then
9090 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
9091
9092 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9093 while Present (Prim) loop
9094
9095 -- Any renamings of equality that appeared before an
9096 -- overriding equality must be updated to refer to the
9097 -- entity for the predefined equality, otherwise calls via
9098 -- the renaming would get incorrectly resolved to call the
9099 -- user-defined equality function.
9100
9101 if Is_Predefined_Eq_Renaming (Node (Prim)) then
9102 Set_Alias (Node (Prim), Renamed_Eq);
9103
9104 -- Exit upon encountering a user-defined equality
9105
9106 elsif Chars (Node (Prim)) = Name_Op_Eq
9107 and then No (Alias (Node (Prim)))
9108 then
9109 exit;
9110 end if;
9111
9112 Next_Elmt (Prim);
9113 end loop;
9114 end if;
9115 end if;
9116
9117 -- Spec for dispatching assignment
9118
9119 Append_To (Res, Predef_Spec_Or_Body (Loc,
9120 Tag_Typ => Tag_Typ,
9121 Name => Name_uAssign,
9122 Profile => New_List (
9123 Make_Parameter_Specification (Loc,
9124 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9125 Out_Present => True,
9126 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9127
9128 Make_Parameter_Specification (Loc,
9129 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9130 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)))));
9131 end if;
9132
9133 -- Ada 2005: Generate declarations for the following primitive
9134 -- operations for limited interfaces and synchronized types that
9135 -- implement a limited interface.
9136
9137 -- Disp_Asynchronous_Select
9138 -- Disp_Conditional_Select
9139 -- Disp_Get_Prim_Op_Kind
9140 -- Disp_Get_Task_Id
9141 -- Disp_Requeue
9142 -- Disp_Timed_Select
9143
9144 -- Disable the generation of these bodies if No_Dispatching_Calls,
9145 -- Ravenscar or ZFP is active.
9146
9147 if Ada_Version >= Ada_2005
9148 and then not Restriction_Active (No_Dispatching_Calls)
9149 and then not Restriction_Active (No_Select_Statements)
9150 and then RTE_Available (RE_Select_Specific_Data)
9151 then
9152 -- These primitives are defined abstract in interface types
9153
9154 if Is_Interface (Tag_Typ)
9155 and then Is_Limited_Record (Tag_Typ)
9156 then
9157 Append_To (Res,
9158 Make_Abstract_Subprogram_Declaration (Loc,
9159 Specification =>
9160 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9161
9162 Append_To (Res,
9163 Make_Abstract_Subprogram_Declaration (Loc,
9164 Specification =>
9165 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9166
9167 Append_To (Res,
9168 Make_Abstract_Subprogram_Declaration (Loc,
9169 Specification =>
9170 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9171
9172 Append_To (Res,
9173 Make_Abstract_Subprogram_Declaration (Loc,
9174 Specification =>
9175 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9176
9177 Append_To (Res,
9178 Make_Abstract_Subprogram_Declaration (Loc,
9179 Specification =>
9180 Make_Disp_Requeue_Spec (Tag_Typ)));
9181
9182 Append_To (Res,
9183 Make_Abstract_Subprogram_Declaration (Loc,
9184 Specification =>
9185 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9186
9187 -- If ancestor is an interface type, declare non-abstract primitives
9188 -- to override the abstract primitives of the interface type.
9189
9190 -- In VM targets we define these primitives in all root tagged types
9191 -- that are not interface types. Done because in VM targets we don't
9192 -- have secondary dispatch tables and any derivation of Tag_Typ may
9193 -- cover limited interfaces (which always have these primitives since
9194 -- they may be ancestors of synchronized interface types).
9195
9196 elsif (not Is_Interface (Tag_Typ)
9197 and then Is_Interface (Etype (Tag_Typ))
9198 and then Is_Limited_Record (Etype (Tag_Typ)))
9199 or else
9200 (Is_Concurrent_Record_Type (Tag_Typ)
9201 and then Has_Interfaces (Tag_Typ))
9202 or else
9203 (not Tagged_Type_Expansion
9204 and then not Is_Interface (Tag_Typ)
9205 and then Tag_Typ = Root_Type (Tag_Typ))
9206 then
9207 Append_To (Res,
9208 Make_Subprogram_Declaration (Loc,
9209 Specification =>
9210 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
9211
9212 Append_To (Res,
9213 Make_Subprogram_Declaration (Loc,
9214 Specification =>
9215 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
9216
9217 Append_To (Res,
9218 Make_Subprogram_Declaration (Loc,
9219 Specification =>
9220 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
9221
9222 Append_To (Res,
9223 Make_Subprogram_Declaration (Loc,
9224 Specification =>
9225 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
9226
9227 Append_To (Res,
9228 Make_Subprogram_Declaration (Loc,
9229 Specification =>
9230 Make_Disp_Requeue_Spec (Tag_Typ)));
9231
9232 Append_To (Res,
9233 Make_Subprogram_Declaration (Loc,
9234 Specification =>
9235 Make_Disp_Timed_Select_Spec (Tag_Typ)));
9236 end if;
9237 end if;
9238
9239 -- All tagged types receive their own Deep_Adjust and Deep_Finalize
9240 -- regardless of whether they are controlled or may contain controlled
9241 -- components.
9242
9243 -- Do not generate the routines if finalization is disabled
9244
9245 if Restriction_Active (No_Finalization) then
9246 null;
9247
9248 else
9249 if not Is_Limited_Type (Tag_Typ) then
9250 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
9251 end if;
9252
9253 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
9254 end if;
9255
9256 Predef_List := Res;
9257 end Make_Predefined_Primitive_Specs;
9258
9259 -------------------------
9260 -- Make_Tag_Assignment --
9261 -------------------------
9262
9263 function Make_Tag_Assignment (N : Node_Id) return Node_Id is
9264 Loc : constant Source_Ptr := Sloc (N);
9265 Def_If : constant Entity_Id := Defining_Identifier (N);
9266 Expr : constant Node_Id := Expression (N);
9267 Typ : constant Entity_Id := Etype (Def_If);
9268 Full_Typ : constant Entity_Id := Underlying_Type (Typ);
9269 New_Ref : Node_Id;
9270
9271 begin
9272 -- This expansion activity is called during analysis, but cannot
9273 -- be applied in ASIS mode when other expansion is disabled.
9274
9275 if Is_Tagged_Type (Typ)
9276 and then not Is_Class_Wide_Type (Typ)
9277 and then not Is_CPP_Class (Typ)
9278 and then Tagged_Type_Expansion
9279 and then Nkind (Expr) /= N_Aggregate
9280 and then not ASIS_Mode
9281 and then (Nkind (Expr) /= N_Qualified_Expression
9282 or else Nkind (Expression (Expr)) /= N_Aggregate)
9283 then
9284 New_Ref :=
9285 Make_Selected_Component (Loc,
9286 Prefix => New_Occurrence_Of (Def_If, Loc),
9287 Selector_Name =>
9288 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
9289 Set_Assignment_OK (New_Ref);
9290
9291 return
9292 Make_Assignment_Statement (Loc,
9293 Name => New_Ref,
9294 Expression =>
9295 Unchecked_Convert_To (RTE (RE_Tag),
9296 New_Occurrence_Of (Node
9297 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
9298 else
9299 return Empty;
9300 end if;
9301 end Make_Tag_Assignment;
9302
9303 ---------------------------------
9304 -- Needs_Simple_Initialization --
9305 ---------------------------------
9306
9307 function Needs_Simple_Initialization
9308 (T : Entity_Id;
9309 Consider_IS : Boolean := True) return Boolean
9310 is
9311 Consider_IS_NS : constant Boolean :=
9312 Normalize_Scalars or (Initialize_Scalars and Consider_IS);
9313
9314 begin
9315 -- Never need initialization if it is suppressed
9316
9317 if Initialization_Suppressed (T) then
9318 return False;
9319 end if;
9320
9321 -- Check for private type, in which case test applies to the underlying
9322 -- type of the private type.
9323
9324 if Is_Private_Type (T) then
9325 declare
9326 RT : constant Entity_Id := Underlying_Type (T);
9327 begin
9328 if Present (RT) then
9329 return Needs_Simple_Initialization (RT);
9330 else
9331 return False;
9332 end if;
9333 end;
9334
9335 -- Scalar type with Default_Value aspect requires initialization
9336
9337 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
9338 return True;
9339
9340 -- Cases needing simple initialization are access types, and, if pragma
9341 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
9342 -- types.
9343
9344 elsif Is_Access_Type (T)
9345 or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
9346 then
9347 return True;
9348
9349 -- If Initialize/Normalize_Scalars is in effect, string objects also
9350 -- need initialization, unless they are created in the course of
9351 -- expanding an aggregate (since in the latter case they will be
9352 -- filled with appropriate initializing values before they are used).
9353
9354 elsif Consider_IS_NS
9355 and then Is_Standard_String_Type (T)
9356 and then
9357 (not Is_Itype (T)
9358 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
9359 then
9360 return True;
9361
9362 else
9363 return False;
9364 end if;
9365 end Needs_Simple_Initialization;
9366
9367 ----------------------
9368 -- Predef_Deep_Spec --
9369 ----------------------
9370
9371 function Predef_Deep_Spec
9372 (Loc : Source_Ptr;
9373 Tag_Typ : Entity_Id;
9374 Name : TSS_Name_Type;
9375 For_Body : Boolean := False) return Node_Id
9376 is
9377 Formals : List_Id;
9378
9379 begin
9380 -- V : in out Tag_Typ
9381
9382 Formals := New_List (
9383 Make_Parameter_Specification (Loc,
9384 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9385 In_Present => True,
9386 Out_Present => True,
9387 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)));
9388
9389 -- F : Boolean := True
9390
9391 if Name = TSS_Deep_Adjust
9392 or else Name = TSS_Deep_Finalize
9393 then
9394 Append_To (Formals,
9395 Make_Parameter_Specification (Loc,
9396 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9397 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9398 Expression => New_Occurrence_Of (Standard_True, Loc)));
9399 end if;
9400
9401 return
9402 Predef_Spec_Or_Body (Loc,
9403 Name => Make_TSS_Name (Tag_Typ, Name),
9404 Tag_Typ => Tag_Typ,
9405 Profile => Formals,
9406 For_Body => For_Body);
9407
9408 exception
9409 when RE_Not_Available =>
9410 return Empty;
9411 end Predef_Deep_Spec;
9412
9413 -------------------------
9414 -- Predef_Spec_Or_Body --
9415 -------------------------
9416
9417 function Predef_Spec_Or_Body
9418 (Loc : Source_Ptr;
9419 Tag_Typ : Entity_Id;
9420 Name : Name_Id;
9421 Profile : List_Id;
9422 Ret_Type : Entity_Id := Empty;
9423 For_Body : Boolean := False) return Node_Id
9424 is
9425 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
9426 Spec : Node_Id;
9427
9428 begin
9429 Set_Is_Public (Id, Is_Public (Tag_Typ));
9430
9431 -- The internal flag is set to mark these declarations because they have
9432 -- specific properties. First, they are primitives even if they are not
9433 -- defined in the type scope (the freezing point is not necessarily in
9434 -- the same scope). Second, the predefined equality can be overridden by
9435 -- a user-defined equality, no body will be generated in this case.
9436
9437 Set_Is_Internal (Id);
9438
9439 if not Debug_Generated_Code then
9440 Set_Debug_Info_Off (Id);
9441 end if;
9442
9443 if No (Ret_Type) then
9444 Spec :=
9445 Make_Procedure_Specification (Loc,
9446 Defining_Unit_Name => Id,
9447 Parameter_Specifications => Profile);
9448 else
9449 Spec :=
9450 Make_Function_Specification (Loc,
9451 Defining_Unit_Name => Id,
9452 Parameter_Specifications => Profile,
9453 Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
9454 end if;
9455
9456 if Is_Interface (Tag_Typ) then
9457 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9458
9459 -- If body case, return empty subprogram body. Note that this is ill-
9460 -- formed, because there is not even a null statement, and certainly not
9461 -- a return in the function case. The caller is expected to do surgery
9462 -- on the body to add the appropriate stuff.
9463
9464 elsif For_Body then
9465 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
9466
9467 -- For the case of an Input attribute predefined for an abstract type,
9468 -- generate an abstract specification. This will never be called, but we
9469 -- need the slot allocated in the dispatching table so that attributes
9470 -- typ'Class'Input and typ'Class'Output will work properly.
9471
9472 elsif Is_TSS (Name, TSS_Stream_Input)
9473 and then Is_Abstract_Type (Tag_Typ)
9474 then
9475 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
9476
9477 -- Normal spec case, where we return a subprogram declaration
9478
9479 else
9480 return Make_Subprogram_Declaration (Loc, Spec);
9481 end if;
9482 end Predef_Spec_Or_Body;
9483
9484 -----------------------------
9485 -- Predef_Stream_Attr_Spec --
9486 -----------------------------
9487
9488 function Predef_Stream_Attr_Spec
9489 (Loc : Source_Ptr;
9490 Tag_Typ : Entity_Id;
9491 Name : TSS_Name_Type;
9492 For_Body : Boolean := False) return Node_Id
9493 is
9494 Ret_Type : Entity_Id;
9495
9496 begin
9497 if Name = TSS_Stream_Input then
9498 Ret_Type := Tag_Typ;
9499 else
9500 Ret_Type := Empty;
9501 end if;
9502
9503 return
9504 Predef_Spec_Or_Body
9505 (Loc,
9506 Name => Make_TSS_Name (Tag_Typ, Name),
9507 Tag_Typ => Tag_Typ,
9508 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
9509 Ret_Type => Ret_Type,
9510 For_Body => For_Body);
9511 end Predef_Stream_Attr_Spec;
9512
9513 ---------------------------------
9514 -- Predefined_Primitive_Bodies --
9515 ---------------------------------
9516
9517 function Predefined_Primitive_Bodies
9518 (Tag_Typ : Entity_Id;
9519 Renamed_Eq : Entity_Id) return List_Id
9520 is
9521 Loc : constant Source_Ptr := Sloc (Tag_Typ);
9522 Res : constant List_Id := New_List;
9523 Decl : Node_Id;
9524 Prim : Elmt_Id;
9525 Eq_Needed : Boolean;
9526 Eq_Name : Name_Id;
9527 Ent : Entity_Id;
9528
9529 pragma Warnings (Off, Ent);
9530
9531 begin
9532 pragma Assert (not Is_Interface (Tag_Typ));
9533
9534 -- See if we have a predefined "=" operator
9535
9536 if Present (Renamed_Eq) then
9537 Eq_Needed := True;
9538 Eq_Name := Chars (Renamed_Eq);
9539
9540 -- If the parent is an interface type then it has defined all the
9541 -- predefined primitives abstract and we need to check if the type
9542 -- has some user defined "=" function which matches the profile of
9543 -- the Ada predefined equality operator to avoid generating it.
9544
9545 elsif Is_Interface (Etype (Tag_Typ)) then
9546 Eq_Needed := True;
9547 Eq_Name := Name_Op_Eq;
9548
9549 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9550 while Present (Prim) loop
9551 if Chars (Node (Prim)) = Name_Op_Eq
9552 and then not Is_Internal (Node (Prim))
9553 and then Present (First_Entity (Node (Prim)))
9554
9555 -- The predefined equality primitive must have exactly two
9556 -- formals whose type is this tagged type
9557
9558 and then Present (Last_Entity (Node (Prim)))
9559 and then Next_Entity (First_Entity (Node (Prim)))
9560 = Last_Entity (Node (Prim))
9561 and then Etype (First_Entity (Node (Prim))) = Tag_Typ
9562 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ
9563 then
9564 Eq_Needed := False;
9565 Eq_Name := No_Name;
9566 exit;
9567 end if;
9568
9569 Next_Elmt (Prim);
9570 end loop;
9571
9572 else
9573 Eq_Needed := False;
9574 Eq_Name := No_Name;
9575
9576 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9577 while Present (Prim) loop
9578 if Chars (Node (Prim)) = Name_Op_Eq
9579 and then Is_Internal (Node (Prim))
9580 then
9581 Eq_Needed := True;
9582 Eq_Name := Name_Op_Eq;
9583 exit;
9584 end if;
9585
9586 Next_Elmt (Prim);
9587 end loop;
9588 end if;
9589
9590 -- Body of _Size
9591
9592 Decl := Predef_Spec_Or_Body (Loc,
9593 Tag_Typ => Tag_Typ,
9594 Name => Name_uSize,
9595 Profile => New_List (
9596 Make_Parameter_Specification (Loc,
9597 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9598 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9599
9600 Ret_Type => Standard_Long_Long_Integer,
9601 For_Body => True);
9602
9603 Set_Handled_Statement_Sequence (Decl,
9604 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9605 Make_Simple_Return_Statement (Loc,
9606 Expression =>
9607 Make_Attribute_Reference (Loc,
9608 Prefix => Make_Identifier (Loc, Name_X),
9609 Attribute_Name => Name_Size)))));
9610
9611 Append_To (Res, Decl);
9612
9613 -- Bodies for Dispatching stream IO routines. We need these only for
9614 -- non-limited types (in the limited case there is no dispatching).
9615 -- We also skip them if dispatching or finalization are not available
9616 -- or if stream operations are prohibited by restriction No_Streams or
9617 -- from use of pragma/aspect No_Tagged_Streams.
9618
9619 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
9620 and then No (TSS (Tag_Typ, TSS_Stream_Read))
9621 then
9622 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
9623 Append_To (Res, Decl);
9624 end if;
9625
9626 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
9627 and then No (TSS (Tag_Typ, TSS_Stream_Write))
9628 then
9629 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
9630 Append_To (Res, Decl);
9631 end if;
9632
9633 -- Skip body of _Input for the abstract case, since the corresponding
9634 -- spec is abstract (see Predef_Spec_Or_Body).
9635
9636 if not Is_Abstract_Type (Tag_Typ)
9637 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
9638 and then No (TSS (Tag_Typ, TSS_Stream_Input))
9639 then
9640 Build_Record_Or_Elementary_Input_Function
9641 (Loc, Tag_Typ, Decl, Ent);
9642 Append_To (Res, Decl);
9643 end if;
9644
9645 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
9646 and then No (TSS (Tag_Typ, TSS_Stream_Output))
9647 then
9648 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
9649 Append_To (Res, Decl);
9650 end if;
9651
9652 -- Ada 2005: Generate bodies for the following primitive operations for
9653 -- limited interfaces and synchronized types that implement a limited
9654 -- interface.
9655
9656 -- disp_asynchronous_select
9657 -- disp_conditional_select
9658 -- disp_get_prim_op_kind
9659 -- disp_get_task_id
9660 -- disp_timed_select
9661
9662 -- The interface versions will have null bodies
9663
9664 -- Disable the generation of these bodies if No_Dispatching_Calls,
9665 -- Ravenscar or ZFP is active.
9666
9667 -- In VM targets we define these primitives in all root tagged types
9668 -- that are not interface types. Done because in VM targets we don't
9669 -- have secondary dispatch tables and any derivation of Tag_Typ may
9670 -- cover limited interfaces (which always have these primitives since
9671 -- they may be ancestors of synchronized interface types).
9672
9673 if Ada_Version >= Ada_2005
9674 and then not Is_Interface (Tag_Typ)
9675 and then
9676 ((Is_Interface (Etype (Tag_Typ))
9677 and then Is_Limited_Record (Etype (Tag_Typ)))
9678 or else
9679 (Is_Concurrent_Record_Type (Tag_Typ)
9680 and then Has_Interfaces (Tag_Typ))
9681 or else
9682 (not Tagged_Type_Expansion
9683 and then Tag_Typ = Root_Type (Tag_Typ)))
9684 and then not Restriction_Active (No_Dispatching_Calls)
9685 and then not Restriction_Active (No_Select_Statements)
9686 and then RTE_Available (RE_Select_Specific_Data)
9687 then
9688 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
9689 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
9690 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
9691 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
9692 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ));
9693 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
9694 end if;
9695
9696 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
9697
9698 -- Body for equality
9699
9700 if Eq_Needed then
9701 Decl := Make_Eq_Body (Tag_Typ, Eq_Name);
9702 Append_To (Res, Decl);
9703 end if;
9704
9705 -- Body for inequality (if required)
9706
9707 Decl := Make_Neq_Body (Tag_Typ);
9708
9709 if Present (Decl) then
9710 Append_To (Res, Decl);
9711 end if;
9712
9713 -- Body for dispatching assignment
9714
9715 Decl :=
9716 Predef_Spec_Or_Body (Loc,
9717 Tag_Typ => Tag_Typ,
9718 Name => Name_uAssign,
9719 Profile => New_List (
9720 Make_Parameter_Specification (Loc,
9721 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
9722 Out_Present => True,
9723 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
9724
9725 Make_Parameter_Specification (Loc,
9726 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
9727 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
9728 For_Body => True);
9729
9730 Set_Handled_Statement_Sequence (Decl,
9731 Make_Handled_Sequence_Of_Statements (Loc, New_List (
9732 Make_Assignment_Statement (Loc,
9733 Name => Make_Identifier (Loc, Name_X),
9734 Expression => Make_Identifier (Loc, Name_Y)))));
9735
9736 Append_To (Res, Decl);
9737 end if;
9738
9739 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for
9740 -- tagged types which do not contain controlled components.
9741
9742 -- Do not generate the routines if finalization is disabled
9743
9744 if Restriction_Active (No_Finalization) then
9745 null;
9746
9747 elsif not Has_Controlled_Component (Tag_Typ) then
9748 if not Is_Limited_Type (Tag_Typ) then
9749 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
9750
9751 if Is_Controlled (Tag_Typ) then
9752 Set_Handled_Statement_Sequence (Decl,
9753 Make_Handled_Sequence_Of_Statements (Loc,
9754 Statements => New_List (
9755 Make_Adjust_Call (
9756 Obj_Ref => Make_Identifier (Loc, Name_V),
9757 Typ => Tag_Typ))));
9758
9759 else
9760 Set_Handled_Statement_Sequence (Decl,
9761 Make_Handled_Sequence_Of_Statements (Loc,
9762 Statements => New_List (
9763 Make_Null_Statement (Loc))));
9764 end if;
9765
9766 Append_To (Res, Decl);
9767 end if;
9768
9769 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
9770
9771 if Is_Controlled (Tag_Typ) then
9772 Set_Handled_Statement_Sequence (Decl,
9773 Make_Handled_Sequence_Of_Statements (Loc,
9774 Statements => New_List (
9775 Make_Final_Call
9776 (Obj_Ref => Make_Identifier (Loc, Name_V),
9777 Typ => Tag_Typ))));
9778
9779 else
9780 Set_Handled_Statement_Sequence (Decl,
9781 Make_Handled_Sequence_Of_Statements (Loc,
9782 Statements => New_List (Make_Null_Statement (Loc))));
9783 end if;
9784
9785 Append_To (Res, Decl);
9786 end if;
9787
9788 return Res;
9789 end Predefined_Primitive_Bodies;
9790
9791 ---------------------------------
9792 -- Predefined_Primitive_Freeze --
9793 ---------------------------------
9794
9795 function Predefined_Primitive_Freeze
9796 (Tag_Typ : Entity_Id) return List_Id
9797 is
9798 Res : constant List_Id := New_List;
9799 Prim : Elmt_Id;
9800 Frnodes : List_Id;
9801
9802 begin
9803 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
9804 while Present (Prim) loop
9805 if Is_Predefined_Dispatching_Operation (Node (Prim)) then
9806 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ);
9807
9808 if Present (Frnodes) then
9809 Append_List_To (Res, Frnodes);
9810 end if;
9811 end if;
9812
9813 Next_Elmt (Prim);
9814 end loop;
9815
9816 return Res;
9817 end Predefined_Primitive_Freeze;
9818
9819 -------------------------
9820 -- Stream_Operation_OK --
9821 -------------------------
9822
9823 function Stream_Operation_OK
9824 (Typ : Entity_Id;
9825 Operation : TSS_Name_Type) return Boolean
9826 is
9827 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
9828
9829 begin
9830 -- Special case of a limited type extension: a default implementation
9831 -- of the stream attributes Read or Write exists if that attribute
9832 -- has been specified or is available for an ancestor type; a default
9833 -- implementation of the attribute Output (resp. Input) exists if the
9834 -- attribute has been specified or Write (resp. Read) is available for
9835 -- an ancestor type. The last condition only applies under Ada 2005.
9836
9837 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
9838 if Operation = TSS_Stream_Read then
9839 Has_Predefined_Or_Specified_Stream_Attribute :=
9840 Has_Specified_Stream_Read (Typ);
9841
9842 elsif Operation = TSS_Stream_Write then
9843 Has_Predefined_Or_Specified_Stream_Attribute :=
9844 Has_Specified_Stream_Write (Typ);
9845
9846 elsif Operation = TSS_Stream_Input then
9847 Has_Predefined_Or_Specified_Stream_Attribute :=
9848 Has_Specified_Stream_Input (Typ)
9849 or else
9850 (Ada_Version >= Ada_2005
9851 and then Stream_Operation_OK (Typ, TSS_Stream_Read));
9852
9853 elsif Operation = TSS_Stream_Output then
9854 Has_Predefined_Or_Specified_Stream_Attribute :=
9855 Has_Specified_Stream_Output (Typ)
9856 or else
9857 (Ada_Version >= Ada_2005
9858 and then Stream_Operation_OK (Typ, TSS_Stream_Write));
9859 end if;
9860
9861 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
9862
9863 if not Has_Predefined_Or_Specified_Stream_Attribute
9864 and then Is_Derived_Type (Typ)
9865 and then (Operation = TSS_Stream_Read
9866 or else Operation = TSS_Stream_Write)
9867 then
9868 Has_Predefined_Or_Specified_Stream_Attribute :=
9869 Present
9870 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
9871 end if;
9872 end if;
9873
9874 -- If the type is not limited, or else is limited but the attribute is
9875 -- explicitly specified or is predefined for the type, then return True,
9876 -- unless other conditions prevail, such as restrictions prohibiting
9877 -- streams or dispatching operations. We also return True for limited
9878 -- interfaces, because they may be extended by nonlimited types and
9879 -- permit inheritance in this case (addresses cases where an abstract
9880 -- extension doesn't get 'Input declared, as per comments below, but
9881 -- 'Class'Input must still be allowed). Note that attempts to apply
9882 -- stream attributes to a limited interface or its class-wide type
9883 -- (or limited extensions thereof) will still get properly rejected
9884 -- by Check_Stream_Attribute.
9885
9886 -- We exclude the Input operation from being a predefined subprogram in
9887 -- the case where the associated type is an abstract extension, because
9888 -- the attribute is not callable in that case, per 13.13.2(49/2). Also,
9889 -- we don't want an abstract version created because types derived from
9890 -- the abstract type may not even have Input available (for example if
9891 -- derived from a private view of the abstract type that doesn't have
9892 -- a visible Input).
9893
9894 -- Do not generate stream routines for type Finalization_Master because
9895 -- a master may never appear in types and therefore cannot be read or
9896 -- written.
9897
9898 return
9899 (not Is_Limited_Type (Typ)
9900 or else Is_Interface (Typ)
9901 or else Has_Predefined_Or_Specified_Stream_Attribute)
9902 and then
9903 (Operation /= TSS_Stream_Input
9904 or else not Is_Abstract_Type (Typ)
9905 or else not Is_Derived_Type (Typ))
9906 and then not Has_Unknown_Discriminants (Typ)
9907 and then not
9908 (Is_Interface (Typ)
9909 and then
9910 (Is_Task_Interface (Typ)
9911 or else Is_Protected_Interface (Typ)
9912 or else Is_Synchronized_Interface (Typ)))
9913 and then not Restriction_Active (No_Streams)
9914 and then not Restriction_Active (No_Dispatch)
9915 and then No (No_Tagged_Streams_Pragma (Typ))
9916 and then not No_Run_Time_Mode
9917 and then RTE_Available (RE_Tag)
9918 and then No (Type_Without_Stream_Operation (Typ))
9919 and then RTE_Available (RE_Root_Stream_Type)
9920 and then not Is_RTE (Typ, RE_Finalization_Master);
9921 end Stream_Operation_OK;
9922
9923 end Exp_Ch3;