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