OSDN Git Service

2012-05-19 Eric Botcazou <ebotcazou@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch3.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                              E X P _ C H 3                               --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Einfo;    use Einfo;
29 with Errout;   use Errout;
30 with Exp_Aggr; use Exp_Aggr;
31 with Exp_Atag; use Exp_Atag;
32 with Exp_Ch4;  use Exp_Ch4;
33 with Exp_Ch6;  use Exp_Ch6;
34 with Exp_Ch7;  use Exp_Ch7;
35 with Exp_Ch9;  use Exp_Ch9;
36 with Exp_Ch11; use Exp_Ch11;
37 with Exp_Dbug; use Exp_Dbug;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Smem; use Exp_Smem;
41 with Exp_Strm; use Exp_Strm;
42 with Exp_Tss;  use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze;   use Freeze;
45 with Namet;    use Namet;
46 with Nlists;   use Nlists;
47 with Nmake;    use Nmake;
48 with Opt;      use Opt;
49 with Restrict; use Restrict;
50 with Rident;   use Rident;
51 with Rtsfind;  use Rtsfind;
52 with Sem;      use Sem;
53 with Sem_Aux;  use Sem_Aux;
54 with Sem_Attr; use Sem_Attr;
55 with Sem_Cat;  use Sem_Cat;
56 with Sem_Ch3;  use Sem_Ch3;
57 with Sem_Ch6;  use Sem_Ch6;
58 with Sem_Ch8;  use Sem_Ch8;
59 with Sem_Disp; use Sem_Disp;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Mech; use Sem_Mech;
62 with Sem_Res;  use Sem_Res;
63 with Sem_SCIL; use Sem_SCIL;
64 with Sem_Type; use Sem_Type;
65 with Sem_Util; use Sem_Util;
66 with Sinfo;    use Sinfo;
67 with Stand;    use Stand;
68 with Snames;   use Snames;
69 with Targparm; use Targparm;
70 with Tbuild;   use Tbuild;
71 with Ttypes;   use Ttypes;
72 with Validsw;  use Validsw;
73
74 package body Exp_Ch3 is
75
76    -----------------------
77    -- Local Subprograms --
78    -----------------------
79
80    procedure Adjust_Discriminants (Rtype : Entity_Id);
81    --  This is used when freezing a record type. It attempts to construct
82    --  more restrictive subtypes for discriminants so that the max size of
83    --  the record can be calculated more accurately. See the body of this
84    --  procedure for details.
85
86    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
87    --  Build initialization procedure for given array type. Nod is a node
88    --  used for attachment of any actions required in its construction.
89    --  It also supplies the source location used for the procedure.
90
91    function Build_Discriminant_Formals
92      (Rec_Id : Entity_Id;
93       Use_Dl : Boolean) return List_Id;
94    --  This function uses the discriminants of a type to build a list of
95    --  formal parameters, used in Build_Init_Procedure among other places.
96    --  If the flag Use_Dl is set, the list is built using the already
97    --  defined discriminals of the type, as is the case for concurrent
98    --  types with discriminants. Otherwise new identifiers are created,
99    --  with the source names of the discriminants.
100
101    function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
102    --  This function builds a static aggregate that can serve as the initial
103    --  value for an array type whose bounds are static, and whose component
104    --  type is a composite type that has a static equivalent aggregate.
105    --  The equivalent array aggregate is used both for object initialization
106    --  and for component initialization, when used in the following function.
107
108    function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
109    --  This function builds a static aggregate that can serve as the initial
110    --  value for a record type whose components are scalar and initialized
111    --  with compile-time values, or arrays with similar initialization or
112    --  defaults. When possible, initialization of an object of the type can
113    --  be achieved by using a copy of the aggregate as an initial value, thus
114    --  removing the implicit call that would otherwise constitute elaboration
115    --  code.
116
117    procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);
118    --  Build record initialization procedure. N is the type declaration
119    --  node, and Rec_Ent is the corresponding entity for the record type.
120
121    procedure Build_Slice_Assignment (Typ : Entity_Id);
122    --  Build assignment procedure for one-dimensional arrays of controlled
123    --  types. Other array and slice assignments are expanded in-line, but
124    --  the code expansion for controlled components (when control actions
125    --  are active) can lead to very large blocks that GCC3 handles poorly.
126
127    procedure Build_Untagged_Equality (Typ : Entity_Id);
128    --  AI05-0123: Equality on untagged records composes. This procedure
129    --  builds the equality routine for an untagged record that has components
130    --  of a record type that has user-defined primitive equality operations.
131    --  The resulting operation is a TSS subprogram.
132
133    procedure Build_Variant_Record_Equality (Typ  : Entity_Id);
134    --  Create An Equality function for the non-tagged variant record 'Typ'
135    --  and attach it to the TSS list
136
137    procedure Check_Stream_Attributes (Typ : Entity_Id);
138    --  Check that if a limited extension has a parent with user-defined stream
139    --  attributes, and does not itself have user-defined stream-attributes,
140    --  then any limited component of the extension also has the corresponding
141    --  user-defined stream attributes.
142
143    procedure Clean_Task_Names
144      (Typ     : Entity_Id;
145       Proc_Id : Entity_Id);
146    --  If an initialization procedure includes calls to generate names
147    --  for task subcomponents, indicate that secondary stack cleanup is
148    --  needed after an initialization. Typ is the component type, and Proc_Id
149    --  the initialization procedure for the enclosing composite type.
150
151    procedure Expand_Tagged_Root (T : Entity_Id);
152    --  Add a field _Tag at the beginning of the record. This field carries
153    --  the value of the access to the Dispatch table. This procedure is only
154    --  called on root type, the _Tag field being inherited by the descendants.
155
156    procedure Expand_Freeze_Array_Type (N : Node_Id);
157    --  Freeze an array type. Deals with building the initialization procedure,
158    --  creating the packed array type for a packed array and also with the
159    --  creation of the controlling procedures for the controlled case. The
160    --  argument N is the N_Freeze_Entity node for the type.
161
162    procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);
163    --  Freeze a class-wide type. Build routine Finalize_Address for the purpose
164    --  of finalizing controlled derivations from the class-wide's root type.
165
166    procedure Expand_Freeze_Enumeration_Type (N : Node_Id);
167    --  Freeze enumeration type with non-standard representation. Builds the
168    --  array and function needed to convert between enumeration pos and
169    --  enumeration representation values. N is the N_Freeze_Entity node
170    --  for the type.
171
172    procedure Expand_Freeze_Record_Type (N : Node_Id);
173    --  Freeze record type. Builds all necessary discriminant checking
174    --  and other ancillary functions, and builds dispatch tables where
175    --  needed. The argument N is the N_Freeze_Entity node. This processing
176    --  applies only to E_Record_Type entities, not to class wide types,
177    --  record subtypes, or private types.
178
179    procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
180    --  Treat user-defined stream operations as renaming_as_body if the
181    --  subprogram they rename is not frozen when the type is frozen.
182
183    procedure Initialization_Warning (E : Entity_Id);
184    --  If static elaboration of the package is requested, indicate
185    --  when a type does meet the conditions for static initialization. If
186    --  E is a type, it has components that have no static initialization.
187    --  if E is an entity, its initial expression is not compile-time known.
188
189    function Init_Formals (Typ : Entity_Id) return List_Id;
190    --  This function builds the list of formals for an initialization routine.
191    --  The first formal is always _Init with the given type. For task value
192    --  record types and types containing tasks, three additional formals are
193    --  added:
194    --
195    --    _Master    : Master_Id
196    --    _Chain     : in out Activation_Chain
197    --    _Task_Name : String
198    --
199    --  The caller must append additional entries for discriminants if required.
200
201    function In_Runtime (E : Entity_Id) return Boolean;
202    --  Check if E is defined in the RTL (in a child of Ada or System). Used
203    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
204
205    function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
206    --  Returns true if E has variable size components
207
208    function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
209    --  Returns true if E has variable size components
210
211    function Make_Eq_Body
212      (Typ     : Entity_Id;
213       Eq_Name : Name_Id) return Node_Id;
214    --  Build the body of a primitive equality operation for a tagged record
215    --  type, or in Ada 2012 for any record type that has components with a
216    --  user-defined equality. Factored out of Predefined_Primitive_Bodies.
217
218    function Make_Eq_Case
219      (E     : Entity_Id;
220       CL    : Node_Id;
221       Discr : Entity_Id := Empty) return List_Id;
222    --  Building block for variant record equality. Defined to share the code
223    --  between the tagged and non-tagged case. Given a Component_List node CL,
224    --  it generates an 'if' followed by a 'case' statement that compares all
225    --  components of local temporaries named X and Y (that are declared as
226    --  formals at some upper level). E provides the Sloc to be used for the
227    --  generated code. Discr is used as the case statement switch in the case
228    --  of Unchecked_Union equality.
229
230    function Make_Eq_If
231      (E : Entity_Id;
232       L : List_Id) return Node_Id;
233    --  Building block for variant record equality. Defined to share the code
234    --  between the tagged and non-tagged case. Given the list of components
235    --  (or discriminants) L, it generates a return statement that compares all
236    --  components of local temporaries named X and Y (that are declared as
237    --  formals at some upper level). E provides the Sloc to be used for the
238    --  generated code.
239
240    procedure Make_Predefined_Primitive_Specs
241      (Tag_Typ     : Entity_Id;
242       Predef_List : out List_Id;
243       Renamed_Eq  : out Entity_Id);
244    --  Create a list with the specs of the predefined primitive operations.
245    --  For tagged types that are interfaces all these primitives are defined
246    --  abstract.
247    --
248    --  The following entries are present for all tagged types, and provide
249    --  the results of the corresponding attribute applied to the object.
250    --  Dispatching is required in general, since the result of the attribute
251    --  will vary with the actual object subtype.
252    --
253    --     _size          provides result of 'Size attribute
254    --     typSR          provides result of 'Read attribute
255    --     typSW          provides result of 'Write attribute
256    --     typSI          provides result of 'Input attribute
257    --     typSO          provides result of 'Output attribute
258    --
259    --  The following entries are additionally present for non-limited tagged
260    --  types, and implement additional dispatching operations for predefined
261    --  operations:
262    --
263    --     _equality      implements "=" operator
264    --     _assign        implements assignment operation
265    --     typDF          implements deep finalization
266    --     typDA          implements deep adjust
267    --
268    --  The latter two are empty procedures unless the type contains some
269    --  controlled components that require finalization actions (the deep
270    --  in the name refers to the fact that the action applies to components).
271    --
272    --  The list is returned in Predef_List. The Parameter Renamed_Eq either
273    --  returns the value Empty, or else the defining unit name for the
274    --  predefined equality function in the case where the type has a primitive
275    --  operation that is a renaming of predefined equality (but only if there
276    --  is also an overriding user-defined equality function). The returned
277    --  Renamed_Eq will be passed to the corresponding parameter of
278    --  Predefined_Primitive_Bodies.
279
280    function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
281    --  returns True if there are representation clauses for type T that are not
282    --  inherited. If the result is false, the init_proc and the discriminant
283    --  checking functions of the parent can be reused by a derived type.
284
285    procedure Make_Controlling_Function_Wrappers
286      (Tag_Typ   : Entity_Id;
287       Decl_List : out List_Id;
288       Body_List : out List_Id);
289    --  Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
290    --  associated with inherited functions with controlling results which
291    --  are not overridden. The body of each wrapper function consists solely
292    --  of a return statement whose expression is an extension aggregate
293    --  invoking the inherited subprogram's parent subprogram and extended
294    --  with a null association list.
295
296    function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
297    --  Ada 2005 (AI-251): Makes specs for null procedures associated with any
298    --  null procedures inherited from an interface type that have not been
299    --  overridden. Only one null procedure will be created for a given set of
300    --  inherited null procedures with homographic profiles.
301
302    function Predef_Spec_Or_Body
303      (Loc      : Source_Ptr;
304       Tag_Typ  : Entity_Id;
305       Name     : Name_Id;
306       Profile  : List_Id;
307       Ret_Type : Entity_Id := Empty;
308       For_Body : Boolean   := False) return Node_Id;
309    --  This function generates the appropriate expansion for a predefined
310    --  primitive operation specified by its name, parameter profile and
311    --  return type (Empty means this is a procedure). If For_Body is false,
312    --  then the returned node is a subprogram declaration. If For_Body is
313    --  true, then the returned node is a empty subprogram body containing
314    --  no declarations and no statements.
315
316    function Predef_Stream_Attr_Spec
317      (Loc      : Source_Ptr;
318       Tag_Typ  : Entity_Id;
319       Name     : TSS_Name_Type;
320       For_Body : Boolean := False) return Node_Id;
321    --  Specialized version of Predef_Spec_Or_Body that apply to read, write,
322    --  input and output attribute whose specs are constructed in Exp_Strm.
323
324    function Predef_Deep_Spec
325      (Loc      : Source_Ptr;
326       Tag_Typ  : Entity_Id;
327       Name     : TSS_Name_Type;
328       For_Body : Boolean := False) return Node_Id;
329    --  Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
330    --  and _deep_finalize
331
332    function Predefined_Primitive_Bodies
333      (Tag_Typ    : Entity_Id;
334       Renamed_Eq : Entity_Id) return List_Id;
335    --  Create the bodies of the predefined primitives that are described in
336    --  Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
337    --  the defining unit name of the type's predefined equality as returned
338    --  by Make_Predefined_Primitive_Specs.
339
340    function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
341    --  Freeze entities of all predefined primitive operations. This is needed
342    --  because the bodies of these operations do not normally do any freezing.
343
344    function Stream_Operation_OK
345      (Typ       : Entity_Id;
346       Operation : TSS_Name_Type) return Boolean;
347    --  Check whether the named stream operation must be emitted for a given
348    --  type. The rules for inheritance of stream attributes by type extensions
349    --  are enforced by this function. Furthermore, various restrictions prevent
350    --  the generation of these operations, as a useful optimization or for
351    --  certification purposes.
352
353    --------------------------
354    -- Adjust_Discriminants --
355    --------------------------
356
357    --  This procedure attempts to define subtypes for discriminants that are
358    --  more restrictive than those declared. Such a replacement is possible if
359    --  we can demonstrate that values outside the restricted range would cause
360    --  constraint errors in any case. The advantage of restricting the
361    --  discriminant types in this way is that the maximum size of the variant
362    --  record can be calculated more conservatively.
363
364    --  An example of a situation in which we can perform this type of
365    --  restriction is the following:
366
367    --    subtype B is range 1 .. 10;
368    --    type Q is array (B range <>) of Integer;
369
370    --    type V (N : Natural) is record
371    --       C : Q (1 .. N);
372    --    end record;
373
374    --  In this situation, we can restrict the upper bound of N to 10, since
375    --  any larger value would cause a constraint error in any case.
376
377    --  There are many situations in which such restriction is possible, but
378    --  for now, we just look for cases like the above, where the component
379    --  in question is a one dimensional array whose upper bound is one of
380    --  the record discriminants. Also the component must not be part of
381    --  any variant part, since then the component does not always exist.
382
383    procedure Adjust_Discriminants (Rtype : Entity_Id) is
384       Loc   : constant Source_Ptr := Sloc (Rtype);
385       Comp  : Entity_Id;
386       Ctyp  : Entity_Id;
387       Ityp  : Entity_Id;
388       Lo    : Node_Id;
389       Hi    : Node_Id;
390       P     : Node_Id;
391       Loval : Uint;
392       Discr : Entity_Id;
393       Dtyp  : Entity_Id;
394       Dhi   : Node_Id;
395       Dhiv  : Uint;
396       Ahi   : Node_Id;
397       Ahiv  : Uint;
398       Tnn   : Entity_Id;
399
400    begin
401       Comp := First_Component (Rtype);
402       while Present (Comp) loop
403
404          --  If our parent is a variant, quit, we do not look at components
405          --  that are in variant parts, because they may not always exist.
406
407          P := Parent (Comp);   -- component declaration
408          P := Parent (P);      -- component list
409
410          exit when Nkind (Parent (P)) = N_Variant;
411
412          --  We are looking for a one dimensional array type
413
414          Ctyp := Etype (Comp);
415
416          if not Is_Array_Type (Ctyp)
417            or else Number_Dimensions (Ctyp) > 1
418          then
419             goto Continue;
420          end if;
421
422          --  The lower bound must be constant, and the upper bound is a
423          --  discriminant (which is a discriminant of the current record).
424
425          Ityp := Etype (First_Index (Ctyp));
426          Lo := Type_Low_Bound (Ityp);
427          Hi := Type_High_Bound (Ityp);
428
429          if not Compile_Time_Known_Value (Lo)
430            or else Nkind (Hi) /= N_Identifier
431            or else No (Entity (Hi))
432            or else Ekind (Entity (Hi)) /= E_Discriminant
433          then
434             goto Continue;
435          end if;
436
437          --  We have an array with appropriate bounds
438
439          Loval := Expr_Value (Lo);
440          Discr := Entity (Hi);
441          Dtyp  := Etype (Discr);
442
443          --  See if the discriminant has a known upper bound
444
445          Dhi := Type_High_Bound (Dtyp);
446
447          if not Compile_Time_Known_Value (Dhi) then
448             goto Continue;
449          end if;
450
451          Dhiv := Expr_Value (Dhi);
452
453          --  See if base type of component array has known upper bound
454
455          Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
456
457          if not Compile_Time_Known_Value (Ahi) then
458             goto Continue;
459          end if;
460
461          Ahiv := Expr_Value (Ahi);
462
463          --  The condition for doing the restriction is that the high bound
464          --  of the discriminant is greater than the low bound of the array,
465          --  and is also greater than the high bound of the base type index.
466
467          if Dhiv > Loval and then Dhiv > Ahiv then
468
469             --  We can reset the upper bound of the discriminant type to
470             --  whichever is larger, the low bound of the component, or
471             --  the high bound of the base type array index.
472
473             --  We build a subtype that is declared as
474
475             --     subtype Tnn is discr_type range discr_type'First .. max;
476
477             --  And insert this declaration into the tree. The type of the
478             --  discriminant is then reset to this more restricted subtype.
479
480             Tnn := Make_Temporary (Loc, 'T');
481
482             Insert_Action (Declaration_Node (Rtype),
483               Make_Subtype_Declaration (Loc,
484                 Defining_Identifier => Tnn,
485                 Subtype_Indication =>
486                   Make_Subtype_Indication (Loc,
487                     Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
488                     Constraint   =>
489                       Make_Range_Constraint (Loc,
490                         Range_Expression =>
491                           Make_Range (Loc,
492                             Low_Bound =>
493                               Make_Attribute_Reference (Loc,
494                                 Attribute_Name => Name_First,
495                                 Prefix => New_Occurrence_Of (Dtyp, Loc)),
496                             High_Bound =>
497                               Make_Integer_Literal (Loc,
498                                 Intval => UI_Max (Loval, Ahiv)))))));
499
500             Set_Etype (Discr, Tnn);
501          end if;
502
503       <<Continue>>
504          Next_Component (Comp);
505       end loop;
506    end Adjust_Discriminants;
507
508    ---------------------------
509    -- Build_Array_Init_Proc --
510    ---------------------------
511
512    procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
513       Loc              : constant Source_Ptr := Sloc (Nod);
514       Comp_Type        : constant Entity_Id  := Component_Type (A_Type);
515       Body_Stmts       : List_Id;
516       Has_Default_Init : Boolean;
517       Index_List       : List_Id;
518       Proc_Id          : Entity_Id;
519
520       function Init_Component return List_Id;
521       --  Create one statement to initialize one array component, designated
522       --  by a full set of indexes.
523
524       function Init_One_Dimension (N : Int) return List_Id;
525       --  Create loop to initialize one dimension of the array. The single
526       --  statement in the loop body initializes the inner dimensions if any,
527       --  or else the single component. Note that this procedure is called
528       --  recursively, with N being the dimension to be initialized. A call
529       --  with N greater than the number of dimensions simply generates the
530       --  component initialization, terminating the recursion.
531
532       --------------------
533       -- Init_Component --
534       --------------------
535
536       function Init_Component return List_Id is
537          Comp : Node_Id;
538
539       begin
540          Comp :=
541            Make_Indexed_Component (Loc,
542              Prefix      => Make_Identifier (Loc, Name_uInit),
543              Expressions => Index_List);
544
545          if Has_Default_Aspect (A_Type) then
546             Set_Assignment_OK (Comp);
547             return New_List (
548               Make_Assignment_Statement (Loc,
549                 Name       => Comp,
550                 Expression =>
551                   Convert_To (Comp_Type,
552                     Default_Aspect_Component_Value (First_Subtype (A_Type)))));
553
554          elsif Needs_Simple_Initialization (Comp_Type) then
555             Set_Assignment_OK (Comp);
556             return New_List (
557               Make_Assignment_Statement (Loc,
558                 Name       => Comp,
559                 Expression =>
560                   Get_Simple_Init_Val
561                     (Comp_Type, Nod, Component_Size (A_Type))));
562
563          else
564             Clean_Task_Names (Comp_Type, Proc_Id);
565             return
566               Build_Initialization_Call
567                 (Loc, Comp, Comp_Type,
568                  In_Init_Proc => True,
569                  Enclos_Type  => A_Type);
570          end if;
571       end Init_Component;
572
573       ------------------------
574       -- Init_One_Dimension --
575       ------------------------
576
577       function Init_One_Dimension (N : Int) return List_Id is
578          Index : Entity_Id;
579
580       begin
581          --  If the component does not need initializing, then there is nothing
582          --  to do here, so we return a null body. This occurs when generating
583          --  the dummy Init_Proc needed for Initialize_Scalars processing.
584
585          if not Has_Non_Null_Base_Init_Proc (Comp_Type)
586            and then not Needs_Simple_Initialization (Comp_Type)
587            and then not Has_Task (Comp_Type)
588            and then not Has_Default_Aspect (A_Type)
589          then
590             return New_List (Make_Null_Statement (Loc));
591
592          --  If all dimensions dealt with, we simply initialize the component
593
594          elsif N > Number_Dimensions (A_Type) then
595             return Init_Component;
596
597          --  Here we generate the required loop
598
599          else
600             Index :=
601               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
602
603             Append (New_Reference_To (Index, Loc), Index_List);
604
605             return New_List (
606               Make_Implicit_Loop_Statement (Nod,
607                 Identifier => Empty,
608                 Iteration_Scheme =>
609                   Make_Iteration_Scheme (Loc,
610                     Loop_Parameter_Specification =>
611                       Make_Loop_Parameter_Specification (Loc,
612                         Defining_Identifier => Index,
613                         Discrete_Subtype_Definition =>
614                           Make_Attribute_Reference (Loc,
615                             Prefix => Make_Identifier (Loc, Name_uInit),
616                             Attribute_Name  => Name_Range,
617                             Expressions     => New_List (
618                               Make_Integer_Literal (Loc, N))))),
619                 Statements =>  Init_One_Dimension (N + 1)));
620          end if;
621       end Init_One_Dimension;
622
623    --  Start of processing for Build_Array_Init_Proc
624
625    begin
626       --  Nothing to generate in the following cases:
627
628       --    1. Initialization is suppressed for the type
629       --    2. The type is a value type, in the CIL sense.
630       --    3. The type has CIL/JVM convention.
631       --    4. An initialization already exists for the base type
632
633       if Initialization_Suppressed (A_Type)
634         or else Is_Value_Type (Comp_Type)
635         or else Convention (A_Type) = Convention_CIL
636         or else Convention (A_Type) = Convention_Java
637         or else Present (Base_Init_Proc (A_Type))
638       then
639          return;
640       end if;
641
642       Index_List := New_List;
643
644       --  We need an initialization procedure if any of the following is true:
645
646       --    1. The component type has an initialization procedure
647       --    2. The component type needs simple initialization
648       --    3. Tasks are present
649       --    4. The type is marked as a public entity
650       --    5. The array type has a Default_Component_Value aspect
651
652       --  The reason for the public entity test is to deal properly with the
653       --  Initialize_Scalars pragma. This pragma can be set in the client and
654       --  not in the declaring package, this means the client will make a call
655       --  to the initialization procedure (because one of conditions 1-3 must
656       --  apply in this case), and we must generate a procedure (even if it is
657       --  null) to satisfy the call in this case.
658
659       --  Exception: do not build an array init_proc for a type whose root
660       --  type is Standard.String or Standard.Wide_[Wide_]String, since there
661       --  is no place to put the code, and in any case we handle initialization
662       --  of such types (in the Initialize_Scalars case, that's the only time
663       --  the issue arises) in a special manner anyway which does not need an
664       --  init_proc.
665
666       Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
667                             or else Needs_Simple_Initialization (Comp_Type)
668                             or else Has_Task (Comp_Type)
669                             or else Has_Default_Aspect (A_Type);
670
671       if Has_Default_Init
672         or else (not Restriction_Active (No_Initialize_Scalars)
673                   and then Is_Public (A_Type)
674                   and then Root_Type (A_Type) /= Standard_String
675                   and then Root_Type (A_Type) /= Standard_Wide_String
676                   and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
677       then
678          Proc_Id :=
679            Make_Defining_Identifier (Loc,
680              Chars => Make_Init_Proc_Name (A_Type));
681
682          --  If No_Default_Initialization restriction is active, then we don't
683          --  want to build an init_proc, but we need to mark that an init_proc
684          --  would be needed if this restriction was not active (so that we can
685          --  detect attempts to call it), so set a dummy init_proc in place.
686          --  This is only done though when actual default initialization is
687          --  needed (and not done when only Is_Public is True), since otherwise
688          --  objects such as arrays of scalars could be wrongly flagged as
689          --  violating the restriction.
690
691          if Restriction_Active (No_Default_Initialization) then
692             if Has_Default_Init then
693                Set_Init_Proc (A_Type, Proc_Id);
694             end if;
695
696             return;
697          end if;
698
699          Body_Stmts := Init_One_Dimension (1);
700
701          Discard_Node (
702            Make_Subprogram_Body (Loc,
703              Specification =>
704                Make_Procedure_Specification (Loc,
705                  Defining_Unit_Name => Proc_Id,
706                  Parameter_Specifications => Init_Formals (A_Type)),
707              Declarations => New_List,
708              Handled_Statement_Sequence =>
709                Make_Handled_Sequence_Of_Statements (Loc,
710                  Statements => Body_Stmts)));
711
712          Set_Ekind          (Proc_Id, E_Procedure);
713          Set_Is_Public      (Proc_Id, Is_Public (A_Type));
714          Set_Is_Internal    (Proc_Id);
715          Set_Has_Completion (Proc_Id);
716
717          if not Debug_Generated_Code then
718             Set_Debug_Info_Off (Proc_Id);
719          end if;
720
721          --  Set inlined unless controlled stuff or tasks around, in which
722          --  case we do not want to inline, because nested stuff may cause
723          --  difficulties in inter-unit inlining, and furthermore there is
724          --  in any case no point in inlining such complex init procs.
725
726          if not Has_Task (Proc_Id)
727            and then not Needs_Finalization (Proc_Id)
728          then
729             Set_Is_Inlined (Proc_Id);
730          end if;
731
732          --  Associate Init_Proc with type, and determine if the procedure
733          --  is null (happens because of the Initialize_Scalars pragma case,
734          --  where we have to generate a null procedure in case it is called
735          --  by a client with Initialize_Scalars set). Such procedures have
736          --  to be generated, but do not have to be called, so we mark them
737          --  as null to suppress the call.
738
739          Set_Init_Proc (A_Type, Proc_Id);
740
741          if List_Length (Body_Stmts) = 1
742
743            --  We must skip SCIL nodes because they may have been added to this
744            --  list by Insert_Actions.
745
746            and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
747          then
748             Set_Is_Null_Init_Proc (Proc_Id);
749
750          else
751             --  Try to build a static aggregate to statically initialize
752             --  objects of the type. This can only be done for constrained
753             --  one-dimensional arrays with static bounds.
754
755             Set_Static_Initialization
756               (Proc_Id,
757                Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));
758          end if;
759       end if;
760    end Build_Array_Init_Proc;
761
762    --------------------------------
763    -- Build_Discr_Checking_Funcs --
764    --------------------------------
765
766    procedure Build_Discr_Checking_Funcs (N : Node_Id) is
767       Rec_Id            : Entity_Id;
768       Loc               : Source_Ptr;
769       Enclosing_Func_Id : Entity_Id;
770       Sequence          : Nat     := 1;
771       Type_Def          : Node_Id;
772       V                 : Node_Id;
773
774       function Build_Case_Statement
775         (Case_Id : Entity_Id;
776          Variant : Node_Id) return Node_Id;
777       --  Build a case statement containing only two alternatives. The first
778       --  alternative corresponds exactly to the discrete choices given on the
779       --  variant with contains the components that we are generating the
780       --  checks for. If the discriminant is one of these return False. The
781       --  second alternative is an OTHERS choice that will return True
782       --  indicating the discriminant did not match.
783
784       function Build_Dcheck_Function
785         (Case_Id : Entity_Id;
786          Variant : Node_Id) return Entity_Id;
787       --  Build the discriminant checking function for a given variant
788
789       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
790       --  Builds the discriminant checking function for each variant of the
791       --  given variant part of the record type.
792
793       --------------------------
794       -- Build_Case_Statement --
795       --------------------------
796
797       function Build_Case_Statement
798         (Case_Id : Entity_Id;
799          Variant : Node_Id) return Node_Id
800       is
801          Alt_List       : constant List_Id := New_List;
802          Actuals_List   : List_Id;
803          Case_Node      : Node_Id;
804          Case_Alt_Node  : Node_Id;
805          Choice         : Node_Id;
806          Choice_List    : List_Id;
807          D              : Entity_Id;
808          Return_Node    : Node_Id;
809
810       begin
811          Case_Node := New_Node (N_Case_Statement, Loc);
812
813          --  Replace the discriminant which controls the variant, with the name
814          --  of the formal of the checking function.
815
816          Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id)));
817
818          Choice := First (Discrete_Choices (Variant));
819
820          if Nkind (Choice) = N_Others_Choice then
821             Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
822          else
823             Choice_List := New_Copy_List (Discrete_Choices (Variant));
824          end if;
825
826          if not Is_Empty_List (Choice_List) then
827             Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
828             Set_Discrete_Choices (Case_Alt_Node, Choice_List);
829
830             --  In case this is a nested variant, we need to return the result
831             --  of the discriminant checking function for the immediately
832             --  enclosing variant.
833
834             if Present (Enclosing_Func_Id) then
835                Actuals_List := New_List;
836
837                D := First_Discriminant (Rec_Id);
838                while Present (D) loop
839                   Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
840                   Next_Discriminant (D);
841                end loop;
842
843                Return_Node :=
844                  Make_Simple_Return_Statement (Loc,
845                    Expression =>
846                      Make_Function_Call (Loc,
847                        Name =>
848                          New_Reference_To (Enclosing_Func_Id,  Loc),
849                        Parameter_Associations =>
850                          Actuals_List));
851
852             else
853                Return_Node :=
854                  Make_Simple_Return_Statement (Loc,
855                    Expression =>
856                      New_Reference_To (Standard_False, Loc));
857             end if;
858
859             Set_Statements (Case_Alt_Node, New_List (Return_Node));
860             Append (Case_Alt_Node, Alt_List);
861          end if;
862
863          Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
864          Choice_List := New_List (New_Node (N_Others_Choice, Loc));
865          Set_Discrete_Choices (Case_Alt_Node, Choice_List);
866
867          Return_Node :=
868            Make_Simple_Return_Statement (Loc,
869              Expression =>
870                New_Reference_To (Standard_True, Loc));
871
872          Set_Statements (Case_Alt_Node, New_List (Return_Node));
873          Append (Case_Alt_Node, Alt_List);
874
875          Set_Alternatives (Case_Node, Alt_List);
876          return Case_Node;
877       end Build_Case_Statement;
878
879       ---------------------------
880       -- Build_Dcheck_Function --
881       ---------------------------
882
883       function Build_Dcheck_Function
884         (Case_Id : Entity_Id;
885          Variant : Node_Id) return Entity_Id
886       is
887          Body_Node           : Node_Id;
888          Func_Id             : Entity_Id;
889          Parameter_List      : List_Id;
890          Spec_Node           : Node_Id;
891
892       begin
893          Body_Node := New_Node (N_Subprogram_Body, Loc);
894          Sequence := Sequence + 1;
895
896          Func_Id :=
897            Make_Defining_Identifier (Loc,
898              Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
899
900          Spec_Node := New_Node (N_Function_Specification, Loc);
901          Set_Defining_Unit_Name (Spec_Node, Func_Id);
902
903          Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
904
905          Set_Parameter_Specifications (Spec_Node, Parameter_List);
906          Set_Result_Definition (Spec_Node,
907                                 New_Reference_To (Standard_Boolean,  Loc));
908          Set_Specification (Body_Node, Spec_Node);
909          Set_Declarations (Body_Node, New_List);
910
911          Set_Handled_Statement_Sequence (Body_Node,
912            Make_Handled_Sequence_Of_Statements (Loc,
913              Statements => New_List (
914                Build_Case_Statement (Case_Id, Variant))));
915
916          Set_Ekind       (Func_Id, E_Function);
917          Set_Mechanism   (Func_Id, Default_Mechanism);
918          Set_Is_Inlined  (Func_Id, True);
919          Set_Is_Pure     (Func_Id, True);
920          Set_Is_Public   (Func_Id, Is_Public (Rec_Id));
921          Set_Is_Internal (Func_Id, True);
922
923          if not Debug_Generated_Code then
924             Set_Debug_Info_Off (Func_Id);
925          end if;
926
927          Analyze (Body_Node);
928
929          Append_Freeze_Action (Rec_Id, Body_Node);
930          Set_Dcheck_Function (Variant, Func_Id);
931          return Func_Id;
932       end Build_Dcheck_Function;
933
934       ----------------------------
935       -- Build_Dcheck_Functions --
936       ----------------------------
937
938       procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
939          Component_List_Node : Node_Id;
940          Decl                : Entity_Id;
941          Discr_Name          : Entity_Id;
942          Func_Id             : Entity_Id;
943          Variant             : Node_Id;
944          Saved_Enclosing_Func_Id : Entity_Id;
945
946       begin
947          --  Build the discriminant-checking function for each variant, and
948          --  label all components of that variant with the function's name.
949          --  We only Generate a discriminant-checking function when the
950          --  variant is not empty, to prevent the creation of dead code.
951          --  The exception to that is when Frontend_Layout_On_Target is set,
952          --  because the variant record size function generated in package
953          --  Layout needs to generate calls to all discriminant-checking
954          --  functions, including those for empty variants.
955
956          Discr_Name := Entity (Name (Variant_Part_Node));
957          Variant := First_Non_Pragma (Variants (Variant_Part_Node));
958
959          while Present (Variant) loop
960             Component_List_Node := Component_List (Variant);
961
962             if not Null_Present (Component_List_Node)
963               or else Frontend_Layout_On_Target
964             then
965                Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
966                Decl :=
967                  First_Non_Pragma (Component_Items (Component_List_Node));
968
969                while Present (Decl) loop
970                   Set_Discriminant_Checking_Func
971                     (Defining_Identifier (Decl), Func_Id);
972
973                   Next_Non_Pragma (Decl);
974                end loop;
975
976                if Present (Variant_Part (Component_List_Node)) then
977                   Saved_Enclosing_Func_Id := Enclosing_Func_Id;
978                   Enclosing_Func_Id := Func_Id;
979                   Build_Dcheck_Functions (Variant_Part (Component_List_Node));
980                   Enclosing_Func_Id := Saved_Enclosing_Func_Id;
981                end if;
982             end if;
983
984             Next_Non_Pragma (Variant);
985          end loop;
986       end Build_Dcheck_Functions;
987
988    --  Start of processing for Build_Discr_Checking_Funcs
989
990    begin
991       --  Only build if not done already
992
993       if not Discr_Check_Funcs_Built (N) then
994          Type_Def := Type_Definition (N);
995
996          if Nkind (Type_Def) = N_Record_Definition then
997             if No (Component_List (Type_Def)) then   -- null record.
998                return;
999             else
1000                V := Variant_Part (Component_List (Type_Def));
1001             end if;
1002
1003          else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
1004             if No (Component_List (Record_Extension_Part (Type_Def))) then
1005                return;
1006             else
1007                V := Variant_Part
1008                       (Component_List (Record_Extension_Part (Type_Def)));
1009             end if;
1010          end if;
1011
1012          Rec_Id := Defining_Identifier (N);
1013
1014          if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1015             Loc := Sloc (N);
1016             Enclosing_Func_Id := Empty;
1017             Build_Dcheck_Functions (V);
1018          end if;
1019
1020          Set_Discr_Check_Funcs_Built (N);
1021       end if;
1022    end Build_Discr_Checking_Funcs;
1023
1024    --------------------------------
1025    -- Build_Discriminant_Formals --
1026    --------------------------------
1027
1028    function Build_Discriminant_Formals
1029      (Rec_Id : Entity_Id;
1030       Use_Dl : Boolean) return List_Id
1031    is
1032       Loc             : Source_Ptr       := Sloc (Rec_Id);
1033       Parameter_List  : constant List_Id := New_List;
1034       D               : Entity_Id;
1035       Formal          : Entity_Id;
1036       Formal_Type     : Entity_Id;
1037       Param_Spec_Node : Node_Id;
1038
1039    begin
1040       if Has_Discriminants (Rec_Id) then
1041          D := First_Discriminant (Rec_Id);
1042          while Present (D) loop
1043             Loc := Sloc (D);
1044
1045             if Use_Dl then
1046                Formal := Discriminal (D);
1047                Formal_Type := Etype (Formal);
1048             else
1049                Formal := Make_Defining_Identifier (Loc, Chars (D));
1050                Formal_Type := Etype (D);
1051             end if;
1052
1053             Param_Spec_Node :=
1054               Make_Parameter_Specification (Loc,
1055                   Defining_Identifier => Formal,
1056                 Parameter_Type =>
1057                   New_Reference_To (Formal_Type, Loc));
1058             Append (Param_Spec_Node, Parameter_List);
1059             Next_Discriminant (D);
1060          end loop;
1061       end if;
1062
1063       return Parameter_List;
1064    end Build_Discriminant_Formals;
1065
1066    --------------------------------------
1067    -- Build_Equivalent_Array_Aggregate --
1068    --------------------------------------
1069
1070    function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is
1071       Loc        : constant Source_Ptr := Sloc (T);
1072       Comp_Type  : constant Entity_Id := Component_Type (T);
1073       Index_Type : constant Entity_Id := Etype (First_Index (T));
1074       Proc       : constant Entity_Id := Base_Init_Proc (T);
1075       Lo, Hi     : Node_Id;
1076       Aggr       : Node_Id;
1077       Expr       : Node_Id;
1078
1079    begin
1080       if not Is_Constrained (T)
1081         or else Number_Dimensions (T) > 1
1082         or else No (Proc)
1083       then
1084          Initialization_Warning (T);
1085          return Empty;
1086       end if;
1087
1088       Lo := Type_Low_Bound  (Index_Type);
1089       Hi := Type_High_Bound (Index_Type);
1090
1091       if not Compile_Time_Known_Value (Lo)
1092         or else not Compile_Time_Known_Value (Hi)
1093       then
1094          Initialization_Warning (T);
1095          return Empty;
1096       end if;
1097
1098       if Is_Record_Type (Comp_Type)
1099         and then Present (Base_Init_Proc (Comp_Type))
1100       then
1101          Expr := Static_Initialization (Base_Init_Proc (Comp_Type));
1102
1103          if No (Expr) then
1104             Initialization_Warning (T);
1105             return Empty;
1106          end if;
1107
1108       else
1109          Initialization_Warning (T);
1110          return Empty;
1111       end if;
1112
1113       Aggr := Make_Aggregate (Loc, No_List, New_List);
1114       Set_Etype (Aggr, T);
1115       Set_Aggregate_Bounds (Aggr,
1116         Make_Range (Loc,
1117           Low_Bound  => New_Copy (Lo),
1118           High_Bound => New_Copy (Hi)));
1119       Set_Parent (Aggr, Parent (Proc));
1120
1121       Append_To (Component_Associations (Aggr),
1122          Make_Component_Association (Loc,
1123               Choices =>
1124                  New_List (
1125                    Make_Range (Loc,
1126                      Low_Bound  => New_Copy (Lo),
1127                      High_Bound => New_Copy (Hi))),
1128               Expression => Expr));
1129
1130       if Static_Array_Aggregate (Aggr) then
1131          return Aggr;
1132       else
1133          Initialization_Warning (T);
1134          return Empty;
1135       end if;
1136    end Build_Equivalent_Array_Aggregate;
1137
1138    ---------------------------------------
1139    -- Build_Equivalent_Record_Aggregate --
1140    ---------------------------------------
1141
1142    function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is
1143       Agg       : Node_Id;
1144       Comp      : Entity_Id;
1145       Comp_Type : Entity_Id;
1146
1147       --  Start of processing for Build_Equivalent_Record_Aggregate
1148
1149    begin
1150       if not Is_Record_Type (T)
1151         or else Has_Discriminants (T)
1152         or else Is_Limited_Type (T)
1153         or else Has_Non_Standard_Rep (T)
1154       then
1155          Initialization_Warning (T);
1156          return Empty;
1157       end if;
1158
1159       Comp := First_Component (T);
1160
1161       --  A null record needs no warning
1162
1163       if No (Comp) then
1164          return Empty;
1165       end if;
1166
1167       while Present (Comp) loop
1168
1169          --  Array components are acceptable if initialized by a positional
1170          --  aggregate with static components.
1171
1172          if Is_Array_Type (Etype (Comp)) then
1173             Comp_Type := Component_Type (Etype (Comp));
1174
1175             if Nkind (Parent (Comp)) /= N_Component_Declaration
1176               or else No (Expression (Parent (Comp)))
1177               or else Nkind (Expression (Parent (Comp))) /= N_Aggregate
1178             then
1179                Initialization_Warning (T);
1180                return Empty;
1181
1182             elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
1183                and then
1184                  (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1185                    or else
1186                   not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
1187             then
1188                Initialization_Warning (T);
1189                return Empty;
1190
1191             elsif
1192               not Static_Array_Aggregate (Expression (Parent (Comp)))
1193             then
1194                Initialization_Warning (T);
1195                return Empty;
1196             end if;
1197
1198          elsif Is_Scalar_Type (Etype (Comp)) then
1199             Comp_Type := Etype (Comp);
1200
1201             if Nkind (Parent (Comp)) /= N_Component_Declaration
1202               or else No (Expression (Parent (Comp)))
1203               or else not Compile_Time_Known_Value (Expression (Parent (Comp)))
1204               or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
1205               or else not
1206                 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
1207             then
1208                Initialization_Warning (T);
1209                return Empty;
1210             end if;
1211
1212          --  For now, other types are excluded
1213
1214          else
1215             Initialization_Warning (T);
1216             return Empty;
1217          end if;
1218
1219          Next_Component (Comp);
1220       end loop;
1221
1222       --  All components have static initialization. Build positional aggregate
1223       --  from the given expressions or defaults.
1224
1225       Agg := Make_Aggregate (Sloc (T), New_List, New_List);
1226       Set_Parent (Agg, Parent (T));
1227
1228       Comp := First_Component (T);
1229       while Present (Comp) loop
1230          Append
1231            (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg));
1232          Next_Component (Comp);
1233       end loop;
1234
1235       Analyze_And_Resolve (Agg, T);
1236       return Agg;
1237    end Build_Equivalent_Record_Aggregate;
1238
1239    -------------------------------
1240    -- Build_Initialization_Call --
1241    -------------------------------
1242
1243    --  References to a discriminant inside the record type declaration can
1244    --  appear either in the subtype_indication to constrain a record or an
1245    --  array, or as part of a larger expression given for the initial value
1246    --  of a component. In both of these cases N appears in the record
1247    --  initialization procedure and needs to be replaced by the formal
1248    --  parameter of the initialization procedure which corresponds to that
1249    --  discriminant.
1250
1251    --  In the example below, references to discriminants D1 and D2 in proc_1
1252    --  are replaced by references to formals with the same name
1253    --  (discriminals)
1254
1255    --  A similar replacement is done for calls to any record initialization
1256    --  procedure for any components that are themselves of a record type.
1257
1258    --  type R (D1, D2 : Integer) is record
1259    --     X : Integer := F * D1;
1260    --     Y : Integer := F * D2;
1261    --  end record;
1262
1263    --  procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1264    --  begin
1265    --     Out_2.D1 := D1;
1266    --     Out_2.D2 := D2;
1267    --     Out_2.X := F * D1;
1268    --     Out_2.Y := F * D2;
1269    --  end;
1270
1271    function Build_Initialization_Call
1272      (Loc               : Source_Ptr;
1273       Id_Ref            : Node_Id;
1274       Typ               : Entity_Id;
1275       In_Init_Proc      : Boolean := False;
1276       Enclos_Type       : Entity_Id := Empty;
1277       Discr_Map         : Elist_Id := New_Elmt_List;
1278       With_Default_Init : Boolean := False;
1279       Constructor_Ref   : Node_Id := Empty) return List_Id
1280    is
1281       Res            : constant List_Id := New_List;
1282       Arg            : Node_Id;
1283       Args           : List_Id;
1284       Decls          : List_Id;
1285       Decl           : Node_Id;
1286       Discr          : Entity_Id;
1287       First_Arg      : Node_Id;
1288       Full_Init_Type : Entity_Id;
1289       Full_Type      : Entity_Id := Typ;
1290       Init_Type      : Entity_Id;
1291       Proc           : Entity_Id;
1292
1293    begin
1294       pragma Assert (Constructor_Ref = Empty
1295         or else Is_CPP_Constructor_Call (Constructor_Ref));
1296
1297       if No (Constructor_Ref) then
1298          Proc := Base_Init_Proc (Typ);
1299       else
1300          Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref)));
1301       end if;
1302
1303       pragma Assert (Present (Proc));
1304       Init_Type      := Etype (First_Formal (Proc));
1305       Full_Init_Type := Underlying_Type (Init_Type);
1306
1307       --  Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1308       --  is active (in which case we make the call anyway, since in the
1309       --  actual compiled client it may be non null).
1310       --  Also nothing to do for value types.
1311
1312       if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars)
1313         or else Is_Value_Type (Typ)
1314         or else
1315           (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ)))
1316       then
1317          return Empty_List;
1318       end if;
1319
1320       --  Go to full view if private type. In the case of successive
1321       --  private derivations, this can require more than one step.
1322
1323       while Is_Private_Type (Full_Type)
1324         and then Present (Full_View (Full_Type))
1325       loop
1326          Full_Type := Full_View (Full_Type);
1327       end loop;
1328
1329       --  If Typ is derived, the procedure is the initialization procedure for
1330       --  the root type. Wrap the argument in an conversion to make it type
1331       --  honest. Actually it isn't quite type honest, because there can be
1332       --  conflicts of views in the private type case. That is why we set
1333       --  Conversion_OK in the conversion node.
1334
1335       if (Is_Record_Type (Typ)
1336            or else Is_Array_Type (Typ)
1337            or else Is_Private_Type (Typ))
1338         and then Init_Type /= Base_Type (Typ)
1339       then
1340          First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1341          Set_Etype (First_Arg, Init_Type);
1342
1343       else
1344          First_Arg := Id_Ref;
1345       end if;
1346
1347       Args := New_List (Convert_Concurrent (First_Arg, Typ));
1348
1349       --  In the tasks case, add _Master as the value of the _Master parameter
1350       --  and _Chain as the value of the _Chain parameter. At the outer level,
1351       --  these will be variables holding the corresponding values obtained
1352       --  from GNARL. At inner levels, they will be the parameters passed down
1353       --  through the outer routines.
1354
1355       if Has_Task (Full_Type) then
1356          if Restriction_Active (No_Task_Hierarchy) then
1357             Append_To (Args,
1358               New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1359          else
1360             Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1361          end if;
1362
1363          Append_To (Args, Make_Identifier (Loc, Name_uChain));
1364
1365          --  Ada 2005 (AI-287): In case of default initialized components
1366          --  with tasks, we generate a null string actual parameter.
1367          --  This is just a workaround that must be improved later???
1368
1369          if With_Default_Init then
1370             Append_To (Args,
1371               Make_String_Literal (Loc,
1372                 Strval => ""));
1373
1374          else
1375             Decls :=
1376               Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1377             Decl  := Last (Decls);
1378
1379             Append_To (Args,
1380               New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1381             Append_List (Decls, Res);
1382          end if;
1383
1384       else
1385          Decls := No_List;
1386          Decl  := Empty;
1387       end if;
1388
1389       --  Add discriminant values if discriminants are present
1390
1391       if Has_Discriminants (Full_Init_Type) then
1392          Discr := First_Discriminant (Full_Init_Type);
1393
1394          while Present (Discr) loop
1395
1396             --  If this is a discriminated concurrent type, the init_proc
1397             --  for the corresponding record is being called. Use that type
1398             --  directly to find the discriminant value, to handle properly
1399             --  intervening renamed discriminants.
1400
1401             declare
1402                T : Entity_Id := Full_Type;
1403
1404             begin
1405                if Is_Protected_Type (T) then
1406                   T := Corresponding_Record_Type (T);
1407
1408                elsif Is_Private_Type (T)
1409                  and then Present (Underlying_Full_View (T))
1410                  and then Is_Protected_Type (Underlying_Full_View (T))
1411                then
1412                   T := Corresponding_Record_Type (Underlying_Full_View (T));
1413                end if;
1414
1415                Arg :=
1416                  Get_Discriminant_Value (
1417                    Discr,
1418                    T,
1419                    Discriminant_Constraint (Full_Type));
1420             end;
1421
1422             --  If the target has access discriminants, and is constrained by
1423             --  an access to the enclosing construct, i.e. a current instance,
1424             --  replace the reference to the type by a reference to the object.
1425
1426             if Nkind (Arg) = N_Attribute_Reference
1427               and then Is_Access_Type (Etype (Arg))
1428               and then Is_Entity_Name (Prefix (Arg))
1429               and then Is_Type (Entity (Prefix (Arg)))
1430             then
1431                Arg :=
1432                  Make_Attribute_Reference (Loc,
1433                    Prefix         => New_Copy (Prefix (Id_Ref)),
1434                    Attribute_Name => Name_Unrestricted_Access);
1435
1436             elsif In_Init_Proc then
1437
1438                --  Replace any possible references to the discriminant in the
1439                --  call to the record initialization procedure with references
1440                --  to the appropriate formal parameter.
1441
1442                if Nkind (Arg) = N_Identifier
1443                   and then Ekind (Entity (Arg)) = E_Discriminant
1444                then
1445                   Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc);
1446
1447                --  Otherwise make a copy of the default expression. Note that
1448                --  we use the current Sloc for this, because we do not want the
1449                --  call to appear to be at the declaration point. Within the
1450                --  expression, replace discriminants with their discriminals.
1451
1452                else
1453                   Arg :=
1454                     New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1455                end if;
1456
1457             else
1458                if Is_Constrained (Full_Type) then
1459                   Arg := Duplicate_Subexpr_No_Checks (Arg);
1460                else
1461                   --  The constraints come from the discriminant default exps,
1462                   --  they must be reevaluated, so we use New_Copy_Tree but we
1463                   --  ensure the proper Sloc (for any embedded calls).
1464
1465                   Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1466                end if;
1467             end if;
1468
1469             --  Ada 2005 (AI-287): In case of default initialized components,
1470             --  if the component is constrained with a discriminant of the
1471             --  enclosing type, we need to generate the corresponding selected
1472             --  component node to access the discriminant value. In other cases
1473             --  this is not required, either  because we are inside the init
1474             --  proc and we use the corresponding formal, or else because the
1475             --  component is constrained by an expression.
1476
1477             if With_Default_Init
1478               and then Nkind (Id_Ref) = N_Selected_Component
1479               and then Nkind (Arg) = N_Identifier
1480               and then Ekind (Entity (Arg)) = E_Discriminant
1481             then
1482                Append_To (Args,
1483                  Make_Selected_Component (Loc,
1484                    Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1485                    Selector_Name => Arg));
1486             else
1487                Append_To (Args, Arg);
1488             end if;
1489
1490             Next_Discriminant (Discr);
1491          end loop;
1492       end if;
1493
1494       --  If this is a call to initialize the parent component of a derived
1495       --  tagged type, indicate that the tag should not be set in the parent.
1496
1497       if Is_Tagged_Type (Full_Init_Type)
1498         and then not Is_CPP_Class (Full_Init_Type)
1499         and then Nkind (Id_Ref) = N_Selected_Component
1500         and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1501       then
1502          Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1503
1504       elsif Present (Constructor_Ref) then
1505          Append_List_To (Args,
1506            New_Copy_List (Parameter_Associations (Constructor_Ref)));
1507       end if;
1508
1509       Append_To (Res,
1510         Make_Procedure_Call_Statement (Loc,
1511           Name => New_Occurrence_Of (Proc, Loc),
1512           Parameter_Associations => Args));
1513
1514       if Needs_Finalization (Typ)
1515         and then Nkind (Id_Ref) = N_Selected_Component
1516       then
1517          if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1518             Append_To (Res,
1519               Make_Init_Call
1520                 (Obj_Ref => New_Copy_Tree (First_Arg),
1521                  Typ     => Typ));
1522          end if;
1523       end if;
1524
1525       return Res;
1526
1527    exception
1528       when RE_Not_Available =>
1529          return Empty_List;
1530    end Build_Initialization_Call;
1531
1532    ----------------------------
1533    -- Build_Record_Init_Proc --
1534    ----------------------------
1535
1536    procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is
1537       Decls     : constant List_Id  := New_List;
1538       Discr_Map : constant Elist_Id := New_Elmt_List;
1539       Loc       : constant Source_Ptr := Sloc (Rec_Ent);
1540       Counter   : Int := 0;
1541       Proc_Id   : Entity_Id;
1542       Rec_Type  : Entity_Id;
1543       Set_Tag   : Entity_Id := Empty;
1544
1545       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1546       --  Build an assignment statement which assigns the default expression
1547       --  to its corresponding record component if defined. The left hand side
1548       --  of the assignment is marked Assignment_OK so that initialization of
1549       --  limited private records works correctly. This routine may also build
1550       --  an adjustment call if the component is controlled.
1551
1552       procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1553       --  If the record has discriminants, add assignment statements to
1554       --  Statement_List to initialize the discriminant values from the
1555       --  arguments of the initialization procedure.
1556
1557       function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1558       --  Build a list representing a sequence of statements which initialize
1559       --  components of the given component list. This may involve building
1560       --  case statements for the variant parts. Append any locally declared
1561       --  objects on list Decls.
1562
1563       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1564       --  Given a non-tagged type-derivation that declares discriminants,
1565       --  such as
1566       --
1567       --  type R (R1, R2 : Integer) is record ... end record;
1568       --
1569       --  type D (D1 : Integer) is new R (1, D1);
1570       --
1571       --  we make the _init_proc of D be
1572       --
1573       --       procedure _init_proc (X : D; D1 : Integer) is
1574       --       begin
1575       --          _init_proc (R (X), 1, D1);
1576       --       end _init_proc;
1577       --
1578       --  This function builds the call statement in this _init_proc.
1579
1580       procedure Build_CPP_Init_Procedure;
1581       --  Build the tree corresponding to the procedure specification and body
1582       --  of the IC procedure that initializes the C++ part of the dispatch
1583       --  table of an Ada tagged type that is a derivation of a CPP type.
1584       --  Install it as the CPP_Init TSS.
1585
1586       procedure Build_Init_Procedure;
1587       --  Build the tree corresponding to the procedure specification and body
1588       --  of the initialization procedure and install it as the _init TSS.
1589
1590       procedure Build_Offset_To_Top_Functions;
1591       --  Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1592       --  and body of Offset_To_Top, a function used in conjuction with types
1593       --  having secondary dispatch tables.
1594
1595       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1596       --  Add range checks to components of discriminated records. S is a
1597       --  subtype indication of a record component. Check_List is a list
1598       --  to which the check actions are appended.
1599
1600       function Component_Needs_Simple_Initialization
1601         (T : Entity_Id) return Boolean;
1602       --  Determine if a component needs simple initialization, given its type
1603       --  T. This routine is the same as Needs_Simple_Initialization except for
1604       --  components of type Tag and Interface_Tag. These two access types do
1605       --  not require initialization since they are explicitly initialized by
1606       --  other means.
1607
1608       function Parent_Subtype_Renaming_Discrims return Boolean;
1609       --  Returns True for base types N that rename discriminants, else False
1610
1611       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1612       --  Determine whether a record initialization procedure needs to be
1613       --  generated for the given record type.
1614
1615       ----------------------
1616       -- Build_Assignment --
1617       ----------------------
1618
1619       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1620          N_Loc : constant Source_Ptr := Sloc (N);
1621          Typ   : constant Entity_Id := Underlying_Type (Etype (Id));
1622          Exp   : Node_Id := N;
1623          Kind  : Node_Kind := Nkind (N);
1624          Lhs   : Node_Id;
1625          Res   : List_Id;
1626
1627       begin
1628          Lhs :=
1629            Make_Selected_Component (N_Loc,
1630              Prefix        => Make_Identifier (Loc, Name_uInit),
1631              Selector_Name => New_Occurrence_Of (Id, N_Loc));
1632          Set_Assignment_OK (Lhs);
1633
1634          --  Case of an access attribute applied to the current instance.
1635          --  Replace the reference to the type by a reference to the actual
1636          --  object. (Note that this handles the case of the top level of
1637          --  the expression being given by such an attribute, but does not
1638          --  cover uses nested within an initial value expression. Nested
1639          --  uses are unlikely to occur in practice, but are theoretically
1640          --  possible.) It is not clear how to handle them without fully
1641          --  traversing the expression. ???
1642
1643          if Kind = N_Attribute_Reference
1644            and then (Attribute_Name (N) = Name_Unchecked_Access
1645                        or else
1646                      Attribute_Name (N) = Name_Unrestricted_Access)
1647            and then Is_Entity_Name (Prefix (N))
1648            and then Is_Type (Entity (Prefix (N)))
1649            and then Entity (Prefix (N)) = Rec_Type
1650          then
1651             Exp :=
1652               Make_Attribute_Reference (N_Loc,
1653                 Prefix         =>
1654                   Make_Identifier (N_Loc, Name_uInit),
1655                 Attribute_Name => Name_Unrestricted_Access);
1656          end if;
1657
1658          --  Take a copy of Exp to ensure that later copies of this component
1659          --  declaration in derived types see the original tree, not a node
1660          --  rewritten during expansion of the init_proc. If the copy contains
1661          --  itypes, the scope of the new itypes is the init_proc being built.
1662
1663          Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
1664
1665          Res := New_List (
1666            Make_Assignment_Statement (Loc,
1667              Name       => Lhs,
1668              Expression => Exp));
1669
1670          Set_No_Ctrl_Actions (First (Res));
1671
1672          --  Adjust the tag if tagged (because of possible view conversions).
1673          --  Suppress the tag adjustment when VM_Target because VM tags are
1674          --  represented implicitly in objects.
1675
1676          if Is_Tagged_Type (Typ)
1677            and then Tagged_Type_Expansion
1678          then
1679             Append_To (Res,
1680               Make_Assignment_Statement (N_Loc,
1681                 Name       =>
1682                   Make_Selected_Component (N_Loc,
1683                     Prefix        =>
1684                       New_Copy_Tree (Lhs, New_Scope => Proc_Id),
1685                     Selector_Name =>
1686                       New_Reference_To (First_Tag_Component (Typ), N_Loc)),
1687
1688                 Expression =>
1689                   Unchecked_Convert_To (RTE (RE_Tag),
1690                     New_Reference_To
1691                       (Node
1692                         (First_Elmt
1693                           (Access_Disp_Table (Underlying_Type (Typ)))),
1694                        N_Loc))));
1695          end if;
1696
1697          --  Adjust the component if controlled except if it is an aggregate
1698          --  that will be expanded inline.
1699
1700          if Kind = N_Qualified_Expression then
1701             Kind := Nkind (Expression (N));
1702          end if;
1703
1704          if Needs_Finalization (Typ)
1705            and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
1706            and then not Is_Immutably_Limited_Type (Typ)
1707          then
1708             Append_To (Res,
1709               Make_Adjust_Call
1710                 (Obj_Ref => New_Copy_Tree (Lhs),
1711                  Typ     => Etype (Id)));
1712          end if;
1713
1714          return Res;
1715
1716       exception
1717          when RE_Not_Available =>
1718             return Empty_List;
1719       end Build_Assignment;
1720
1721       ------------------------------------
1722       -- Build_Discriminant_Assignments --
1723       ------------------------------------
1724
1725       procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1726          Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1727          D         : Entity_Id;
1728          D_Loc     : Source_Ptr;
1729
1730       begin
1731          if Has_Discriminants (Rec_Type)
1732            and then not Is_Unchecked_Union (Rec_Type)
1733          then
1734             D := First_Discriminant (Rec_Type);
1735             while Present (D) loop
1736
1737                --  Don't generate the assignment for discriminants in derived
1738                --  tagged types if the discriminant is a renaming of some
1739                --  ancestor discriminant. This initialization will be done
1740                --  when initializing the _parent field of the derived record.
1741
1742                if Is_Tagged
1743                  and then Present (Corresponding_Discriminant (D))
1744                then
1745                   null;
1746
1747                else
1748                   D_Loc := Sloc (D);
1749                   Append_List_To (Statement_List,
1750                     Build_Assignment (D,
1751                       New_Reference_To (Discriminal (D), D_Loc)));
1752                end if;
1753
1754                Next_Discriminant (D);
1755             end loop;
1756          end if;
1757       end Build_Discriminant_Assignments;
1758
1759       --------------------------
1760       -- Build_Init_Call_Thru --
1761       --------------------------
1762
1763       function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1764          Parent_Proc : constant Entity_Id :=
1765                          Base_Init_Proc (Etype (Rec_Type));
1766
1767          Parent_Type : constant Entity_Id :=
1768                          Etype (First_Formal (Parent_Proc));
1769
1770          Uparent_Type : constant Entity_Id :=
1771                           Underlying_Type (Parent_Type);
1772
1773          First_Discr_Param : Node_Id;
1774
1775          Arg          : Node_Id;
1776          Args         : List_Id;
1777          First_Arg    : Node_Id;
1778          Parent_Discr : Entity_Id;
1779          Res          : List_Id;
1780
1781       begin
1782          --  First argument (_Init) is the object to be initialized.
1783          --  ??? not sure where to get a reasonable Loc for First_Arg
1784
1785          First_Arg :=
1786            OK_Convert_To (Parent_Type,
1787              New_Reference_To (Defining_Identifier (First (Parameters)), Loc));
1788
1789          Set_Etype (First_Arg, Parent_Type);
1790
1791          Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1792
1793          --  In the tasks case,
1794          --    add _Master as the value of the _Master parameter
1795          --    add _Chain as the value of the _Chain parameter.
1796          --    add _Task_Name as the value of the _Task_Name parameter.
1797          --  At the outer level, these will be variables holding the
1798          --  corresponding values obtained from GNARL or the expander.
1799          --
1800          --  At inner levels, they will be the parameters passed down through
1801          --  the outer routines.
1802
1803          First_Discr_Param := Next (First (Parameters));
1804
1805          if Has_Task (Rec_Type) then
1806             if Restriction_Active (No_Task_Hierarchy) then
1807                Append_To (Args,
1808                  New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
1809             else
1810                Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1811             end if;
1812
1813             Append_To (Args, Make_Identifier (Loc, Name_uChain));
1814             Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
1815             First_Discr_Param := Next (Next (Next (First_Discr_Param)));
1816          end if;
1817
1818          --  Append discriminant values
1819
1820          if Has_Discriminants (Uparent_Type) then
1821             pragma Assert (not Is_Tagged_Type (Uparent_Type));
1822
1823             Parent_Discr := First_Discriminant (Uparent_Type);
1824             while Present (Parent_Discr) loop
1825
1826                --  Get the initial value for this discriminant
1827                --  ??? needs to be cleaned up to use parent_Discr_Constr
1828                --  directly.
1829
1830                declare
1831                   Discr       : Entity_Id :=
1832                                   First_Stored_Discriminant (Uparent_Type);
1833
1834                   Discr_Value : Elmt_Id :=
1835                                   First_Elmt (Stored_Constraint (Rec_Type));
1836
1837                begin
1838                   while Original_Record_Component (Parent_Discr) /= Discr loop
1839                      Next_Stored_Discriminant (Discr);
1840                      Next_Elmt (Discr_Value);
1841                   end loop;
1842
1843                   Arg := Node (Discr_Value);
1844                end;
1845
1846                --  Append it to the list
1847
1848                if Nkind (Arg) = N_Identifier
1849                   and then Ekind (Entity (Arg)) = E_Discriminant
1850                then
1851                   Append_To (Args,
1852                     New_Reference_To (Discriminal (Entity (Arg)), Loc));
1853
1854                --  Case of access discriminants. We replace the reference
1855                --  to the type by a reference to the actual object.
1856
1857                --  Is above comment right??? Use of New_Copy below seems mighty
1858                --  suspicious ???
1859
1860                else
1861                   Append_To (Args, New_Copy (Arg));
1862                end if;
1863
1864                Next_Discriminant (Parent_Discr);
1865             end loop;
1866          end if;
1867
1868          Res :=
1869            New_List (
1870              Make_Procedure_Call_Statement (Loc,
1871                Name                   =>
1872                  New_Occurrence_Of (Parent_Proc, Loc),
1873                Parameter_Associations => Args));
1874
1875          return Res;
1876       end Build_Init_Call_Thru;
1877
1878       -----------------------------------
1879       -- Build_Offset_To_Top_Functions --
1880       -----------------------------------
1881
1882       procedure Build_Offset_To_Top_Functions is
1883
1884          procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
1885          --  Generate:
1886          --    function Fxx (O : Address) return Storage_Offset is
1887          --       type Acc is access all <Typ>;
1888          --    begin
1889          --       return Acc!(O).Iface_Comp'Position;
1890          --    end Fxx;
1891
1892          ----------------------------------
1893          -- Build_Offset_To_Top_Function --
1894          ----------------------------------
1895
1896          procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
1897             Body_Node : Node_Id;
1898             Func_Id   : Entity_Id;
1899             Spec_Node : Node_Id;
1900             Acc_Type  : Entity_Id;
1901
1902          begin
1903             Func_Id := Make_Temporary (Loc, 'F');
1904             Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
1905
1906             --  Generate
1907             --    function Fxx (O : in Rec_Typ) return Storage_Offset;
1908
1909             Spec_Node := New_Node (N_Function_Specification, Loc);
1910             Set_Defining_Unit_Name (Spec_Node, Func_Id);
1911             Set_Parameter_Specifications (Spec_Node, New_List (
1912               Make_Parameter_Specification (Loc,
1913                 Defining_Identifier =>
1914                   Make_Defining_Identifier (Loc, Name_uO),
1915                 In_Present          => True,
1916                 Parameter_Type      =>
1917                   New_Reference_To (RTE (RE_Address), Loc))));
1918             Set_Result_Definition (Spec_Node,
1919               New_Reference_To (RTE (RE_Storage_Offset), Loc));
1920
1921             --  Generate
1922             --    function Fxx (O : in Rec_Typ) return Storage_Offset is
1923             --    begin
1924             --       return O.Iface_Comp'Position;
1925             --    end Fxx;
1926
1927             Body_Node := New_Node (N_Subprogram_Body, Loc);
1928             Set_Specification (Body_Node, Spec_Node);
1929
1930             Acc_Type := Make_Temporary (Loc, 'T');
1931             Set_Declarations (Body_Node, New_List (
1932               Make_Full_Type_Declaration (Loc,
1933                 Defining_Identifier => Acc_Type,
1934                 Type_Definition     =>
1935                   Make_Access_To_Object_Definition (Loc,
1936                     All_Present            => True,
1937                     Null_Exclusion_Present => False,
1938                     Constant_Present       => False,
1939                     Subtype_Indication     =>
1940                       New_Reference_To (Rec_Type, Loc)))));
1941
1942             Set_Handled_Statement_Sequence (Body_Node,
1943               Make_Handled_Sequence_Of_Statements (Loc,
1944                 Statements     => New_List (
1945                   Make_Simple_Return_Statement (Loc,
1946                     Expression =>
1947                       Make_Attribute_Reference (Loc,
1948                         Prefix         =>
1949                           Make_Selected_Component (Loc,
1950                             Prefix        =>
1951                               Unchecked_Convert_To (Acc_Type,
1952                                 Make_Identifier (Loc, Name_uO)),
1953                             Selector_Name =>
1954                               New_Reference_To (Iface_Comp, Loc)),
1955                         Attribute_Name => Name_Position)))));
1956
1957             Set_Ekind       (Func_Id, E_Function);
1958             Set_Mechanism   (Func_Id, Default_Mechanism);
1959             Set_Is_Internal (Func_Id, True);
1960
1961             if not Debug_Generated_Code then
1962                Set_Debug_Info_Off (Func_Id);
1963             end if;
1964
1965             Analyze (Body_Node);
1966
1967             Append_Freeze_Action (Rec_Type, Body_Node);
1968          end Build_Offset_To_Top_Function;
1969
1970          --  Local variables
1971
1972          Iface_Comp       : Node_Id;
1973          Iface_Comp_Elmt  : Elmt_Id;
1974          Ifaces_Comp_List : Elist_Id;
1975
1976       --  Start of processing for Build_Offset_To_Top_Functions
1977
1978       begin
1979          --  Offset_To_Top_Functions are built only for derivations of types
1980          --  with discriminants that cover interface types.
1981          --  Nothing is needed either in case of virtual machines, since
1982          --  interfaces are handled directly by the VM.
1983
1984          if not Is_Tagged_Type (Rec_Type)
1985            or else Etype (Rec_Type) = Rec_Type
1986            or else not Has_Discriminants (Etype (Rec_Type))
1987            or else not Tagged_Type_Expansion
1988          then
1989             return;
1990          end if;
1991
1992          Collect_Interface_Components (Rec_Type, Ifaces_Comp_List);
1993
1994          --  For each interface type with secondary dispatch table we generate
1995          --  the Offset_To_Top_Functions (required to displace the pointer in
1996          --  interface conversions)
1997
1998          Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
1999          while Present (Iface_Comp_Elmt) loop
2000             Iface_Comp := Node (Iface_Comp_Elmt);
2001             pragma Assert (Is_Interface (Related_Type (Iface_Comp)));
2002
2003             --  If the interface is a parent of Rec_Type it shares the primary
2004             --  dispatch table and hence there is no need to build the function
2005
2006             if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
2007                                 Use_Full_View => True)
2008             then
2009                Build_Offset_To_Top_Function (Iface_Comp);
2010             end if;
2011
2012             Next_Elmt (Iface_Comp_Elmt);
2013          end loop;
2014       end Build_Offset_To_Top_Functions;
2015
2016       ------------------------------
2017       -- Build_CPP_Init_Procedure --
2018       ------------------------------
2019
2020       procedure Build_CPP_Init_Procedure is
2021          Body_Node         : Node_Id;
2022          Body_Stmts        : List_Id;
2023          Flag_Id           : Entity_Id;
2024          Flag_Decl         : Node_Id;
2025          Handled_Stmt_Node : Node_Id;
2026          Init_Tags_List    : List_Id;
2027          Proc_Id           : Entity_Id;
2028          Proc_Spec_Node    : Node_Id;
2029
2030       begin
2031          --  Check cases requiring no IC routine
2032
2033          if not Is_CPP_Class (Root_Type (Rec_Type))
2034            or else Is_CPP_Class (Rec_Type)
2035            or else CPP_Num_Prims (Rec_Type) = 0
2036            or else not Tagged_Type_Expansion
2037            or else No_Run_Time_Mode
2038          then
2039             return;
2040          end if;
2041
2042          --  Generate:
2043
2044          --     Flag : Boolean := False;
2045          --
2046          --     procedure Typ_IC is
2047          --     begin
2048          --        if not Flag then
2049          --           Copy C++ dispatch table slots from parent
2050          --           Update C++ slots of overridden primitives
2051          --        end if;
2052          --     end;
2053
2054          Flag_Id := Make_Temporary (Loc, 'F');
2055
2056          Flag_Decl :=
2057            Make_Object_Declaration (Loc,
2058              Defining_Identifier => Flag_Id,
2059              Object_Definition =>
2060                New_Reference_To (Standard_Boolean, Loc),
2061              Expression =>
2062                New_Reference_To (Standard_True, Loc));
2063
2064          Analyze (Flag_Decl);
2065          Append_Freeze_Action (Rec_Type, Flag_Decl);
2066
2067          Body_Stmts := New_List;
2068          Body_Node := New_Node (N_Subprogram_Body, Loc);
2069
2070          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2071
2072          Proc_Id :=
2073            Make_Defining_Identifier (Loc,
2074              Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
2075
2076          Set_Ekind       (Proc_Id, E_Procedure);
2077          Set_Is_Internal (Proc_Id);
2078
2079          Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2080
2081          Set_Parameter_Specifications (Proc_Spec_Node, New_List);
2082          Set_Specification (Body_Node, Proc_Spec_Node);
2083          Set_Declarations (Body_Node, New_List);
2084
2085          Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
2086
2087          Append_To (Init_Tags_List,
2088            Make_Assignment_Statement (Loc,
2089              Name =>
2090                New_Reference_To (Flag_Id, Loc),
2091              Expression =>
2092                New_Reference_To (Standard_False, Loc)));
2093
2094          Append_To (Body_Stmts,
2095            Make_If_Statement (Loc,
2096              Condition => New_Occurrence_Of (Flag_Id, Loc),
2097              Then_Statements => Init_Tags_List));
2098
2099          Handled_Stmt_Node :=
2100            New_Node (N_Handled_Sequence_Of_Statements, Loc);
2101          Set_Statements (Handled_Stmt_Node, Body_Stmts);
2102          Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2103          Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2104
2105          if not Debug_Generated_Code then
2106             Set_Debug_Info_Off (Proc_Id);
2107          end if;
2108
2109          --  Associate CPP_Init_Proc with type
2110
2111          Set_Init_Proc (Rec_Type, Proc_Id);
2112       end Build_CPP_Init_Procedure;
2113
2114       --------------------------
2115       -- Build_Init_Procedure --
2116       --------------------------
2117
2118       procedure Build_Init_Procedure is
2119          Body_Stmts            : List_Id;
2120          Body_Node             : Node_Id;
2121          Handled_Stmt_Node     : Node_Id;
2122          Init_Tags_List        : List_Id;
2123          Parameters            : List_Id;
2124          Proc_Spec_Node        : Node_Id;
2125          Record_Extension_Node : Node_Id;
2126
2127       begin
2128          Body_Stmts := New_List;
2129          Body_Node := New_Node (N_Subprogram_Body, Loc);
2130          Set_Ekind (Proc_Id, E_Procedure);
2131
2132          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
2133          Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
2134
2135          Parameters := Init_Formals (Rec_Type);
2136          Append_List_To (Parameters,
2137            Build_Discriminant_Formals (Rec_Type, True));
2138
2139          --  For tagged types, we add a flag to indicate whether the routine
2140          --  is called to initialize a parent component in the init_proc of
2141          --  a type extension. If the flag is false, we do not set the tag
2142          --  because it has been set already in the extension.
2143
2144          if Is_Tagged_Type (Rec_Type) then
2145             Set_Tag := Make_Temporary (Loc, 'P');
2146
2147             Append_To (Parameters,
2148               Make_Parameter_Specification (Loc,
2149                 Defining_Identifier => Set_Tag,
2150                 Parameter_Type =>
2151                   New_Occurrence_Of (Standard_Boolean, Loc),
2152                 Expression =>
2153                   New_Occurrence_Of (Standard_True, Loc)));
2154          end if;
2155
2156          Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
2157          Set_Specification (Body_Node, Proc_Spec_Node);
2158          Set_Declarations (Body_Node, Decls);
2159
2160          --  N is a Derived_Type_Definition that renames the parameters of the
2161          --  ancestor type. We initialize it by expanding our discriminants and
2162          --  call the ancestor _init_proc with a type-converted object.
2163
2164          if Parent_Subtype_Renaming_Discrims then
2165             Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
2166
2167          elsif Nkind (Type_Definition (N)) = N_Record_Definition then
2168             Build_Discriminant_Assignments (Body_Stmts);
2169
2170             if not Null_Present (Type_Definition (N)) then
2171                Append_List_To (Body_Stmts,
2172                  Build_Init_Statements (
2173                    Component_List (Type_Definition (N))));
2174             end if;
2175
2176          --  N is a Derived_Type_Definition with a possible non-empty
2177          --  extension. The initialization of a type extension consists in the
2178          --  initialization of the components in the extension.
2179
2180          else
2181             Build_Discriminant_Assignments (Body_Stmts);
2182
2183             Record_Extension_Node :=
2184               Record_Extension_Part (Type_Definition (N));
2185
2186             if not Null_Present (Record_Extension_Node) then
2187                declare
2188                   Stmts : constant List_Id :=
2189                             Build_Init_Statements (
2190                               Component_List (Record_Extension_Node));
2191
2192                begin
2193                   --  The parent field must be initialized first because
2194                   --  the offset of the new discriminants may depend on it
2195
2196                   Prepend_To (Body_Stmts, Remove_Head (Stmts));
2197                   Append_List_To (Body_Stmts, Stmts);
2198                end;
2199             end if;
2200          end if;
2201
2202          --  Add here the assignment to instantiate the Tag
2203
2204          --  The assignment corresponds to the code:
2205
2206          --     _Init._Tag := Typ'Tag;
2207
2208          --  Suppress the tag assignment when VM_Target because VM tags are
2209          --  represented implicitly in objects. It is also suppressed in case
2210          --  of CPP_Class types because in this case the tag is initialized in
2211          --  the C++ side.
2212
2213          if Is_Tagged_Type (Rec_Type)
2214            and then Tagged_Type_Expansion
2215            and then not No_Run_Time_Mode
2216          then
2217             --  Case 1: Ada tagged types with no CPP ancestor. Set the tags of
2218             --  the actual object and invoke the IP of the parent (in this
2219             --  order). The tag must be initialized before the call to the IP
2220             --  of the parent and the assignments to other components because
2221             --  the initial value of the components may depend on the tag (eg.
2222             --  through a dispatching operation on an access to the current
2223             --  type). The tag assignment is not done when initializing the
2224             --  parent component of a type extension, because in that case the
2225             --  tag is set in the extension.
2226
2227             if not Is_CPP_Class (Root_Type (Rec_Type)) then
2228
2229                --  Initialize the primary tag component
2230
2231                Init_Tags_List := New_List (
2232                  Make_Assignment_Statement (Loc,
2233                    Name =>
2234                      Make_Selected_Component (Loc,
2235                        Prefix        => Make_Identifier (Loc, Name_uInit),
2236                        Selector_Name =>
2237                          New_Reference_To
2238                            (First_Tag_Component (Rec_Type), Loc)),
2239                    Expression =>
2240                      New_Reference_To
2241                        (Node
2242                          (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2243
2244                --  Ada 2005 (AI-251): Initialize the secondary tags components
2245                --  located at fixed positions (tags whose position depends on
2246                --  variable size components are initialized later ---see below)
2247
2248                if Ada_Version >= Ada_2005
2249                  and then not Is_Interface (Rec_Type)
2250                  and then Has_Interfaces (Rec_Type)
2251                then
2252                   Init_Secondary_Tags
2253                     (Typ            => Rec_Type,
2254                      Target         => Make_Identifier (Loc, Name_uInit),
2255                      Stmts_List     => Init_Tags_List,
2256                      Fixed_Comps    => True,
2257                      Variable_Comps => False);
2258                end if;
2259
2260                Prepend_To (Body_Stmts,
2261                  Make_If_Statement (Loc,
2262                    Condition => New_Occurrence_Of (Set_Tag, Loc),
2263                    Then_Statements => Init_Tags_List));
2264
2265             --  Case 2: CPP type. The imported C++ constructor takes care of
2266             --  tags initialization. No action needed here because the IP
2267             --  is built by Set_CPP_Constructors; in this case the IP is a
2268             --  wrapper that invokes the C++ constructor and copies the C++
2269             --  tags locally. Done to inherit the C++ slots in Ada derivations
2270             --  (see case 3).
2271
2272             elsif Is_CPP_Class (Rec_Type) then
2273                pragma Assert (False);
2274                null;
2275
2276             --  Case 3: Combined hierarchy containing C++ types and Ada tagged
2277             --  type derivations. Derivations of imported C++ classes add a
2278             --  complication, because we cannot inhibit tag setting in the
2279             --  constructor for the parent. Hence we initialize the tag after
2280             --  the call to the parent IP (that is, in reverse order compared
2281             --  with pure Ada hierarchies ---see comment on case 1).
2282
2283             else
2284                --  Initialize the primary tag
2285
2286                Init_Tags_List := New_List (
2287                  Make_Assignment_Statement (Loc,
2288                    Name =>
2289                      Make_Selected_Component (Loc,
2290                        Prefix        => Make_Identifier (Loc, Name_uInit),
2291                        Selector_Name =>
2292                          New_Reference_To
2293                            (First_Tag_Component (Rec_Type), Loc)),
2294                    Expression =>
2295                      New_Reference_To
2296                        (Node
2297                          (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
2298
2299                --  Ada 2005 (AI-251): Initialize the secondary tags components
2300                --  located at fixed positions (tags whose position depends on
2301                --  variable size components are initialized later ---see below)
2302
2303                if Ada_Version >= Ada_2005
2304                  and then not Is_Interface (Rec_Type)
2305                  and then Has_Interfaces (Rec_Type)
2306                then
2307                   Init_Secondary_Tags
2308                     (Typ            => Rec_Type,
2309                      Target         => Make_Identifier (Loc, Name_uInit),
2310                      Stmts_List     => Init_Tags_List,
2311                      Fixed_Comps    => True,
2312                      Variable_Comps => False);
2313                end if;
2314
2315                --  Initialize the tag component after invocation of parent IP.
2316
2317                --  Generate:
2318                --     parent_IP(_init.parent); // Invokes the C++ constructor
2319                --     [ typIC; ]               // Inherit C++ slots from parent
2320                --     init_tags
2321
2322                declare
2323                   Ins_Nod : Node_Id;
2324
2325                begin
2326                   --  Search for the call to the IP of the parent. We assume
2327                   --  that the first init_proc call is for the parent.
2328
2329                   Ins_Nod := First (Body_Stmts);
2330                   while Present (Next (Ins_Nod))
2331                      and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
2332                                 or else not Is_Init_Proc (Name (Ins_Nod)))
2333                   loop
2334                      Next (Ins_Nod);
2335                   end loop;
2336
2337                   --  The IC routine copies the inherited slots of the C+ part
2338                   --  of the dispatch table from the parent and updates the
2339                   --  overridden C++ slots.
2340
2341                   if CPP_Num_Prims (Rec_Type) > 0 then
2342                      declare
2343                         Init_DT : Entity_Id;
2344                         New_Nod : Node_Id;
2345
2346                      begin
2347                         Init_DT := CPP_Init_Proc (Rec_Type);
2348                         pragma Assert (Present (Init_DT));
2349
2350                         New_Nod :=
2351                           Make_Procedure_Call_Statement (Loc,
2352                             New_Reference_To (Init_DT, Loc));
2353                         Insert_After (Ins_Nod, New_Nod);
2354
2355                         --  Update location of init tag statements
2356
2357                         Ins_Nod := New_Nod;
2358                      end;
2359                   end if;
2360
2361                   Insert_List_After (Ins_Nod, Init_Tags_List);
2362                end;
2363             end if;
2364
2365             --  Ada 2005 (AI-251): Initialize the secondary tag components
2366             --  located at variable positions. We delay the generation of this
2367             --  code until here because the value of the attribute 'Position
2368             --  applied to variable size components of the parent type that
2369             --  depend on discriminants is only safely read at runtime after
2370             --  the parent components have been initialized.
2371
2372             if Ada_Version >= Ada_2005
2373               and then not Is_Interface (Rec_Type)
2374               and then Has_Interfaces (Rec_Type)
2375               and then Has_Discriminants (Etype (Rec_Type))
2376               and then Is_Variable_Size_Record (Etype (Rec_Type))
2377             then
2378                Init_Tags_List := New_List;
2379
2380                Init_Secondary_Tags
2381                  (Typ            => Rec_Type,
2382                   Target         => Make_Identifier (Loc, Name_uInit),
2383                   Stmts_List     => Init_Tags_List,
2384                   Fixed_Comps    => False,
2385                   Variable_Comps => True);
2386
2387                if Is_Non_Empty_List (Init_Tags_List) then
2388                   Append_List_To (Body_Stmts, Init_Tags_List);
2389                end if;
2390             end if;
2391          end if;
2392
2393          Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2394          Set_Statements (Handled_Stmt_Node, Body_Stmts);
2395
2396          --  Generate:
2397          --    Local_DF_Id (_init, C1, ..., CN);
2398          --    raise;
2399
2400          if Counter > 0
2401            and then Needs_Finalization (Rec_Type)
2402            and then not Is_Abstract_Type (Rec_Type)
2403            and then not Restriction_Active (No_Exception_Propagation)
2404          then
2405             declare
2406                Local_DF_Id : Entity_Id;
2407
2408             begin
2409                --  Create a local version of Deep_Finalize which has indication
2410                --  of partial initialization state.
2411
2412                Local_DF_Id := Make_Temporary (Loc, 'F');
2413
2414                Append_To (Decls,
2415                  Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id));
2416
2417                Set_Exception_Handlers (Handled_Stmt_Node, New_List (
2418                  Make_Exception_Handler (Loc,
2419                    Exception_Choices => New_List (
2420                      Make_Others_Choice (Loc)),
2421
2422                    Statements => New_List (
2423                      Make_Procedure_Call_Statement (Loc,
2424                        Name =>
2425                          New_Reference_To (Local_DF_Id, Loc),
2426
2427                        Parameter_Associations => New_List (
2428                          Make_Identifier (Loc, Name_uInit),
2429                          New_Reference_To (Standard_False, Loc))),
2430
2431                      Make_Raise_Statement (Loc)))));
2432             end;
2433          else
2434             Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2435          end if;
2436
2437          Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2438
2439          if not Debug_Generated_Code then
2440             Set_Debug_Info_Off (Proc_Id);
2441          end if;
2442
2443          --  Associate Init_Proc with type, and determine if the procedure
2444          --  is null (happens because of the Initialize_Scalars pragma case,
2445          --  where we have to generate a null procedure in case it is called
2446          --  by a client with Initialize_Scalars set). Such procedures have
2447          --  to be generated, but do not have to be called, so we mark them
2448          --  as null to suppress the call.
2449
2450          Set_Init_Proc (Rec_Type, Proc_Id);
2451
2452          if List_Length (Body_Stmts) = 1
2453
2454            --  We must skip SCIL nodes because they may have been added to this
2455            --  list by Insert_Actions.
2456
2457            and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement
2458            and then VM_Target = No_VM
2459          then
2460             --  Even though the init proc may be null at this time it might get
2461             --  some stuff added to it later by the VM backend.
2462
2463             Set_Is_Null_Init_Proc (Proc_Id);
2464          end if;
2465       end Build_Init_Procedure;
2466
2467       ---------------------------
2468       -- Build_Init_Statements --
2469       ---------------------------
2470
2471       function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2472          Checks     : constant List_Id := New_List;
2473          Actions    : List_Id   := No_List;
2474          Comp_Loc   : Source_Ptr;
2475          Counter_Id : Entity_Id := Empty;
2476          Decl       : Node_Id;
2477          Has_POC    : Boolean;
2478          Id         : Entity_Id;
2479          Names      : Node_Id;
2480          Stmts      : List_Id;
2481          Typ        : Entity_Id;
2482
2483          procedure Increment_Counter (Loc : Source_Ptr);
2484          --  Generate an "increment by one" statement for the current counter
2485          --  and append it to the list Stmts.
2486
2487          procedure Make_Counter (Loc : Source_Ptr);
2488          --  Create a new counter for the current component list. The routine
2489          --  creates a new defining Id, adds an object declaration and sets
2490          --  the Id generator for the next variant.
2491
2492          -----------------------
2493          -- Increment_Counter --
2494          -----------------------
2495
2496          procedure Increment_Counter (Loc : Source_Ptr) is
2497          begin
2498             --  Generate:
2499             --    Counter := Counter + 1;
2500
2501             Append_To (Stmts,
2502               Make_Assignment_Statement (Loc,
2503                 Name       => New_Reference_To (Counter_Id, Loc),
2504                 Expression =>
2505                   Make_Op_Add (Loc,
2506                     Left_Opnd  => New_Reference_To (Counter_Id, Loc),
2507                     Right_Opnd => Make_Integer_Literal (Loc, 1))));
2508          end Increment_Counter;
2509
2510          ------------------
2511          -- Make_Counter --
2512          ------------------
2513
2514          procedure Make_Counter (Loc : Source_Ptr) is
2515          begin
2516             --  Increment the Id generator
2517
2518             Counter := Counter + 1;
2519
2520             --  Create the entity and declaration
2521
2522             Counter_Id :=
2523               Make_Defining_Identifier (Loc,
2524                 Chars => New_External_Name ('C', Counter));
2525
2526             --  Generate:
2527             --    Cnn : Integer := 0;
2528
2529             Append_To (Decls,
2530               Make_Object_Declaration (Loc,
2531                 Defining_Identifier => Counter_Id,
2532                 Object_Definition   =>
2533                   New_Reference_To (Standard_Integer, Loc),
2534                 Expression          =>
2535                   Make_Integer_Literal (Loc, 0)));
2536          end Make_Counter;
2537
2538       --  Start of processing for Build_Init_Statements
2539
2540       begin
2541          if Null_Present (Comp_List) then
2542             return New_List (Make_Null_Statement (Loc));
2543          end if;
2544
2545          Stmts := New_List;
2546
2547          --  Loop through visible declarations of task types and protected
2548          --  types moving any expanded code from the spec to the body of the
2549          --  init procedure.
2550
2551          if Is_Task_Record_Type (Rec_Type)
2552            or else Is_Protected_Record_Type (Rec_Type)
2553          then
2554             declare
2555                Decl : constant Node_Id :=
2556                         Parent (Corresponding_Concurrent_Type (Rec_Type));
2557                Def  : Node_Id;
2558                N1   : Node_Id;
2559                N2   : Node_Id;
2560
2561             begin
2562                if Is_Task_Record_Type (Rec_Type) then
2563                   Def := Task_Definition (Decl);
2564                else
2565                   Def := Protected_Definition (Decl);
2566                end if;
2567
2568                if Present (Def) then
2569                   N1 := First (Visible_Declarations (Def));
2570                   while Present (N1) loop
2571                      N2 := N1;
2572                      N1 := Next (N1);
2573
2574                      if Nkind (N2) in N_Statement_Other_Than_Procedure_Call
2575                        or else Nkind (N2) in N_Raise_xxx_Error
2576                        or else Nkind (N2) = N_Procedure_Call_Statement
2577                      then
2578                         Append_To (Stmts,
2579                           New_Copy_Tree (N2, New_Scope => Proc_Id));
2580                         Rewrite (N2, Make_Null_Statement (Sloc (N2)));
2581                         Analyze (N2);
2582                      end if;
2583                   end loop;
2584                end if;
2585             end;
2586          end if;
2587
2588          --  Loop through components, skipping pragmas, in 2 steps. The first
2589          --  step deals with regular components. The second step deals with
2590          --  components have per object constraints, and no explicit initia-
2591          --  lization.
2592
2593          Has_POC := False;
2594
2595          --  First pass : regular components
2596
2597          Decl := First_Non_Pragma (Component_Items (Comp_List));
2598          while Present (Decl) loop
2599             Comp_Loc := Sloc (Decl);
2600             Build_Record_Checks
2601               (Subtype_Indication (Component_Definition (Decl)), Checks);
2602
2603             Id  := Defining_Identifier (Decl);
2604             Typ := Etype (Id);
2605
2606             --  Leave any processing of per-object constrained component for
2607             --  the second pass.
2608
2609             if Has_Access_Constraint (Id)
2610               and then No (Expression (Decl))
2611             then
2612                Has_POC := True;
2613
2614             --  Regular component cases
2615
2616             else
2617                --  Explicit initialization
2618
2619                if Present (Expression (Decl)) then
2620                   if Is_CPP_Constructor_Call (Expression (Decl)) then
2621                      Actions :=
2622                        Build_Initialization_Call
2623                          (Comp_Loc,
2624                           Id_Ref          =>
2625                             Make_Selected_Component (Comp_Loc,
2626                               Prefix        =>
2627                                 Make_Identifier (Comp_Loc, Name_uInit),
2628                               Selector_Name =>
2629                                 New_Occurrence_Of (Id, Comp_Loc)),
2630                           Typ             => Typ,
2631                           In_Init_Proc    => True,
2632                           Enclos_Type     => Rec_Type,
2633                           Discr_Map       => Discr_Map,
2634                           Constructor_Ref => Expression (Decl));
2635                   else
2636                      Actions := Build_Assignment (Id, Expression (Decl));
2637                   end if;
2638
2639                --  Composite component with its own Init_Proc
2640
2641                elsif not Is_Interface (Typ)
2642                  and then Has_Non_Null_Base_Init_Proc (Typ)
2643                then
2644                   Actions :=
2645                     Build_Initialization_Call
2646                       (Comp_Loc,
2647                        Make_Selected_Component (Comp_Loc,
2648                          Prefix        =>
2649                            Make_Identifier (Comp_Loc, Name_uInit),
2650                          Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2651                        Typ,
2652                        In_Init_Proc => True,
2653                        Enclos_Type  => Rec_Type,
2654                        Discr_Map    => Discr_Map);
2655
2656                   Clean_Task_Names (Typ, Proc_Id);
2657
2658                --  Simple initialization
2659
2660                elsif Component_Needs_Simple_Initialization (Typ) then
2661                   Actions :=
2662                     Build_Assignment
2663                       (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
2664
2665                --  Nothing needed for this case
2666
2667                else
2668                   Actions := No_List;
2669                end if;
2670
2671                if Present (Checks) then
2672                   Append_List_To (Stmts, Checks);
2673                end if;
2674
2675                if Present (Actions) then
2676                   Append_List_To (Stmts, Actions);
2677
2678                   --  Preserve the initialization state in the current counter
2679
2680                   if Chars (Id) /= Name_uParent
2681                     and then Needs_Finalization (Typ)
2682                   then
2683                      if No (Counter_Id) then
2684                         Make_Counter (Comp_Loc);
2685                      end if;
2686
2687                      Increment_Counter (Comp_Loc);
2688                   end if;
2689                end if;
2690             end if;
2691
2692             Next_Non_Pragma (Decl);
2693          end loop;
2694
2695          --  Set up tasks and protected object support. This needs to be done
2696          --  before any component with a per-object access discriminant
2697          --  constraint, or any variant part (which may contain such
2698          --  components) is initialized, because the initialization of these
2699          --  components may reference the enclosing concurrent object.
2700
2701          --  For a task record type, add the task create call and calls to bind
2702          --  any interrupt (signal) entries.
2703
2704          if Is_Task_Record_Type (Rec_Type) then
2705
2706             --  In the case of the restricted run time the ATCB has already
2707             --  been preallocated.
2708
2709             if Restricted_Profile then
2710                Append_To (Stmts,
2711                  Make_Assignment_Statement (Loc,
2712                    Name       =>
2713                      Make_Selected_Component (Loc,
2714                        Prefix        => Make_Identifier (Loc, Name_uInit),
2715                        Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2716                    Expression =>
2717                      Make_Attribute_Reference (Loc,
2718                        Prefix         =>
2719                          Make_Selected_Component (Loc,
2720                            Prefix        => Make_Identifier (Loc, Name_uInit),
2721                            Selector_Name => Make_Identifier (Loc, Name_uATCB)),
2722                        Attribute_Name => Name_Unchecked_Access)));
2723             end if;
2724
2725             Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
2726
2727             --  Generate the statements which map a string entry name to a
2728             --  task entry index. Note that the task may not have entries.
2729
2730             if Entry_Names_OK then
2731                Names := Build_Entry_Names (Rec_Type);
2732
2733                if Present (Names) then
2734                   Append_To (Stmts, Names);
2735                end if;
2736             end if;
2737
2738             declare
2739                Task_Type : constant Entity_Id :=
2740                              Corresponding_Concurrent_Type (Rec_Type);
2741                Task_Decl : constant Node_Id := Parent (Task_Type);
2742                Task_Def  : constant Node_Id := Task_Definition (Task_Decl);
2743                Decl_Loc  : Source_Ptr;
2744                Ent       : Entity_Id;
2745                Vis_Decl  : Node_Id;
2746
2747             begin
2748                if Present (Task_Def) then
2749                   Vis_Decl := First (Visible_Declarations (Task_Def));
2750                   while Present (Vis_Decl) loop
2751                      Decl_Loc := Sloc (Vis_Decl);
2752
2753                      if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
2754                         if Get_Attribute_Id (Chars (Vis_Decl)) =
2755                                                        Attribute_Address
2756                         then
2757                            Ent := Entity (Name (Vis_Decl));
2758
2759                            if Ekind (Ent) = E_Entry then
2760                               Append_To (Stmts,
2761                                 Make_Procedure_Call_Statement (Decl_Loc,
2762                                   Name =>
2763                                     New_Reference_To (RTE (
2764                                       RE_Bind_Interrupt_To_Entry), Decl_Loc),
2765                                   Parameter_Associations => New_List (
2766                                     Make_Selected_Component (Decl_Loc,
2767                                       Prefix        =>
2768                                         Make_Identifier (Decl_Loc, Name_uInit),
2769                                       Selector_Name =>
2770                                         Make_Identifier
2771                                          (Decl_Loc, Name_uTask_Id)),
2772                                     Entry_Index_Expression
2773                                       (Decl_Loc, Ent, Empty, Task_Type),
2774                                     Expression (Vis_Decl))));
2775                            end if;
2776                         end if;
2777                      end if;
2778
2779                      Next (Vis_Decl);
2780                   end loop;
2781                end if;
2782             end;
2783          end if;
2784
2785          --  For a protected type, add statements generated by
2786          --  Make_Initialize_Protection.
2787
2788          if Is_Protected_Record_Type (Rec_Type) then
2789             Append_List_To (Stmts,
2790               Make_Initialize_Protection (Rec_Type));
2791
2792             --  Generate the statements which map a string entry name to a
2793             --  protected entry index. Note that the protected type may not
2794             --  have entries.
2795
2796             if Entry_Names_OK then
2797                Names := Build_Entry_Names (Rec_Type);
2798
2799                if Present (Names) then
2800                   Append_To (Stmts, Names);
2801                end if;
2802             end if;
2803          end if;
2804
2805          --  Second pass: components with per-object constraints
2806
2807          if Has_POC then
2808             Decl := First_Non_Pragma (Component_Items (Comp_List));
2809             while Present (Decl) loop
2810                Comp_Loc := Sloc (Decl);
2811                Id := Defining_Identifier (Decl);
2812                Typ := Etype (Id);
2813
2814                if Has_Access_Constraint (Id)
2815                  and then No (Expression (Decl))
2816                then
2817                   if Has_Non_Null_Base_Init_Proc (Typ) then
2818                      Append_List_To (Stmts,
2819                        Build_Initialization_Call (Comp_Loc,
2820                          Make_Selected_Component (Comp_Loc,
2821                            Prefix        =>
2822                              Make_Identifier (Comp_Loc, Name_uInit),
2823                            Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
2824                          Typ,
2825                          In_Init_Proc => True,
2826                          Enclos_Type  => Rec_Type,
2827                          Discr_Map    => Discr_Map));
2828
2829                      Clean_Task_Names (Typ, Proc_Id);
2830
2831                      --  Preserve the initialization state in the current
2832                      --  counter.
2833
2834                      if Needs_Finalization (Typ) then
2835                         if No (Counter_Id) then
2836                            Make_Counter (Comp_Loc);
2837                         end if;
2838
2839                         Increment_Counter (Comp_Loc);
2840                      end if;
2841
2842                   elsif Component_Needs_Simple_Initialization (Typ) then
2843                      Append_List_To (Stmts,
2844                        Build_Assignment
2845                          (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
2846                   end if;
2847                end if;
2848
2849                Next_Non_Pragma (Decl);
2850             end loop;
2851          end if;
2852
2853          --  Process the variant part
2854
2855          if Present (Variant_Part (Comp_List)) then
2856             declare
2857                Variant_Alts : constant List_Id := New_List;
2858                Var_Loc      : Source_Ptr;
2859                Variant      : Node_Id;
2860
2861             begin
2862                Variant :=
2863                  First_Non_Pragma (Variants (Variant_Part (Comp_List)));
2864                while Present (Variant) loop
2865                   Var_Loc := Sloc (Variant);
2866                   Append_To (Variant_Alts,
2867                     Make_Case_Statement_Alternative (Var_Loc,
2868                       Discrete_Choices =>
2869                         New_Copy_List (Discrete_Choices (Variant)),
2870                       Statements =>
2871                         Build_Init_Statements (Component_List (Variant))));
2872                   Next_Non_Pragma (Variant);
2873                end loop;
2874
2875                --  The expression of the case statement which is a reference
2876                --  to one of the discriminants is replaced by the appropriate
2877                --  formal parameter of the initialization procedure.
2878
2879                Append_To (Stmts,
2880                  Make_Case_Statement (Var_Loc,
2881                    Expression =>
2882                      New_Reference_To (Discriminal (
2883                        Entity (Name (Variant_Part (Comp_List)))), Var_Loc),
2884                    Alternatives => Variant_Alts));
2885             end;
2886          end if;
2887
2888          --  If no initializations when generated for component declarations
2889          --  corresponding to this Stmts, append a null statement to Stmts to
2890          --  to make it a valid Ada tree.
2891
2892          if Is_Empty_List (Stmts) then
2893             Append (New_Node (N_Null_Statement, Loc), Stmts);
2894          end if;
2895
2896          return Stmts;
2897
2898       exception
2899          when RE_Not_Available =>
2900          return Empty_List;
2901       end Build_Init_Statements;
2902
2903       -------------------------
2904       -- Build_Record_Checks --
2905       -------------------------
2906
2907       procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
2908          Subtype_Mark_Id : Entity_Id;
2909
2910          procedure Constrain_Array
2911            (SI         : Node_Id;
2912             Check_List : List_Id);
2913          --  Apply a list of index constraints to an unconstrained array type.
2914          --  The first parameter is the entity for the resulting subtype.
2915          --  Check_List is a list to which the check actions are appended.
2916
2917          ---------------------
2918          -- Constrain_Array --
2919          ---------------------
2920
2921          procedure Constrain_Array
2922            (SI         : Node_Id;
2923             Check_List : List_Id)
2924          is
2925             C                     : constant Node_Id := Constraint (SI);
2926             Number_Of_Constraints : Nat := 0;
2927             Index                 : Node_Id;
2928             S, T                  : Entity_Id;
2929
2930             procedure Constrain_Index
2931               (Index      : Node_Id;
2932                S          : Node_Id;
2933                Check_List : List_Id);
2934             --  Process an index constraint in a constrained array declaration.
2935             --  The constraint can be either a subtype name or a range with or
2936             --  without an explicit subtype mark. Index is the corresponding
2937             --  index of the unconstrained array. S is the range expression.
2938             --  Check_List is a list to which the check actions are appended.
2939
2940             ---------------------
2941             -- Constrain_Index --
2942             ---------------------
2943
2944             procedure Constrain_Index
2945               (Index        : Node_Id;
2946                S            : Node_Id;
2947                Check_List   : List_Id)
2948             is
2949                T : constant Entity_Id := Etype (Index);
2950
2951             begin
2952                if Nkind (S) = N_Range then
2953                   Process_Range_Expr_In_Decl (S, T, Check_List);
2954                end if;
2955             end Constrain_Index;
2956
2957          --  Start of processing for Constrain_Array
2958
2959          begin
2960             T := Entity (Subtype_Mark (SI));
2961
2962             if Ekind (T) in Access_Kind then
2963                T := Designated_Type (T);
2964             end if;
2965
2966             S := First (Constraints (C));
2967
2968             while Present (S) loop
2969                Number_Of_Constraints := Number_Of_Constraints + 1;
2970                Next (S);
2971             end loop;
2972
2973             --  In either case, the index constraint must provide a discrete
2974             --  range for each index of the array type and the type of each
2975             --  discrete range must be the same as that of the corresponding
2976             --  index. (RM 3.6.1)
2977
2978             S := First (Constraints (C));
2979             Index := First_Index (T);
2980             Analyze (Index);
2981
2982             --  Apply constraints to each index type
2983
2984             for J in 1 .. Number_Of_Constraints loop
2985                Constrain_Index (Index, S, Check_List);
2986                Next (Index);
2987                Next (S);
2988             end loop;
2989          end Constrain_Array;
2990
2991       --  Start of processing for Build_Record_Checks
2992
2993       begin
2994          if Nkind (S) = N_Subtype_Indication then
2995             Find_Type (Subtype_Mark (S));
2996             Subtype_Mark_Id := Entity (Subtype_Mark (S));
2997
2998             --  Remaining processing depends on type
2999
3000             case Ekind (Subtype_Mark_Id) is
3001
3002                when Array_Kind =>
3003                   Constrain_Array (S, Check_List);
3004
3005                when others =>
3006                   null;
3007             end case;
3008          end if;
3009       end Build_Record_Checks;
3010
3011       -------------------------------------------
3012       -- Component_Needs_Simple_Initialization --
3013       -------------------------------------------
3014
3015       function Component_Needs_Simple_Initialization
3016         (T : Entity_Id) return Boolean
3017       is
3018       begin
3019          return
3020            Needs_Simple_Initialization (T)
3021              and then not Is_RTE (T, RE_Tag)
3022
3023                --  Ada 2005 (AI-251): Check also the tag of abstract interfaces
3024
3025              and then not Is_RTE (T, RE_Interface_Tag);
3026       end Component_Needs_Simple_Initialization;
3027
3028       --------------------------------------
3029       -- Parent_Subtype_Renaming_Discrims --
3030       --------------------------------------
3031
3032       function Parent_Subtype_Renaming_Discrims return Boolean is
3033          De : Entity_Id;
3034          Dp : Entity_Id;
3035
3036       begin
3037          if Base_Type (Rec_Ent) /= Rec_Ent then
3038             return False;
3039          end if;
3040
3041          if Etype (Rec_Ent) = Rec_Ent
3042            or else not Has_Discriminants (Rec_Ent)
3043            or else Is_Constrained (Rec_Ent)
3044            or else Is_Tagged_Type (Rec_Ent)
3045          then
3046             return False;
3047          end if;
3048
3049          --  If there are no explicit stored discriminants we have inherited
3050          --  the root type discriminants so far, so no renamings occurred.
3051
3052          if First_Discriminant (Rec_Ent) =
3053               First_Stored_Discriminant (Rec_Ent)
3054          then
3055             return False;
3056          end if;
3057
3058          --  Check if we have done some trivial renaming of the parent
3059          --  discriminants, i.e. something like
3060          --
3061          --    type DT (X1, X2: int) is new PT (X1, X2);
3062
3063          De := First_Discriminant (Rec_Ent);
3064          Dp := First_Discriminant (Etype (Rec_Ent));
3065          while Present (De) loop
3066             pragma Assert (Present (Dp));
3067
3068             if Corresponding_Discriminant (De) /= Dp then
3069                return True;
3070             end if;
3071
3072             Next_Discriminant (De);
3073             Next_Discriminant (Dp);
3074          end loop;
3075
3076          return Present (Dp);
3077       end Parent_Subtype_Renaming_Discrims;
3078
3079       ------------------------
3080       -- Requires_Init_Proc --
3081       ------------------------
3082
3083       function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
3084          Comp_Decl : Node_Id;
3085          Id        : Entity_Id;
3086          Typ       : Entity_Id;
3087
3088       begin
3089          --  Definitely do not need one if specifically suppressed
3090
3091          if Initialization_Suppressed (Rec_Id) then
3092             return False;
3093          end if;
3094
3095          --  If it is a type derived from a type with unknown discriminants,
3096          --  we cannot build an initialization procedure for it.
3097
3098          if Has_Unknown_Discriminants (Rec_Id)
3099            or else Has_Unknown_Discriminants (Etype (Rec_Id))
3100          then
3101             return False;
3102          end if;
3103
3104          --  Otherwise we need to generate an initialization procedure if
3105          --  Is_CPP_Class is False and at least one of the following applies:
3106
3107          --  1. Discriminants are present, since they need to be initialized
3108          --     with the appropriate discriminant constraint expressions.
3109          --     However, the discriminant of an unchecked union does not
3110          --     count, since the discriminant is not present.
3111
3112          --  2. The type is a tagged type, since the implicit Tag component
3113          --     needs to be initialized with a pointer to the dispatch table.
3114
3115          --  3. The type contains tasks
3116
3117          --  4. One or more components has an initial value
3118
3119          --  5. One or more components is for a type which itself requires
3120          --     an initialization procedure.
3121
3122          --  6. One or more components is a type that requires simple
3123          --     initialization (see Needs_Simple_Initialization), except
3124          --     that types Tag and Interface_Tag are excluded, since fields
3125          --     of these types are initialized by other means.
3126
3127          --  7. The type is the record type built for a task type (since at
3128          --     the very least, Create_Task must be called)
3129
3130          --  8. The type is the record type built for a protected type (since
3131          --     at least Initialize_Protection must be called)
3132
3133          --  9. The type is marked as a public entity. The reason we add this
3134          --     case (even if none of the above apply) is to properly handle
3135          --     Initialize_Scalars. If a package is compiled without an IS
3136          --     pragma, and the client is compiled with an IS pragma, then
3137          --     the client will think an initialization procedure is present
3138          --     and call it, when in fact no such procedure is required, but
3139          --     since the call is generated, there had better be a routine
3140          --     at the other end of the call, even if it does nothing!)
3141
3142          --  Note: the reason we exclude the CPP_Class case is because in this
3143          --  case the initialization is performed by the C++ constructors, and
3144          --  the IP is built by Set_CPP_Constructors.
3145
3146          if Is_CPP_Class (Rec_Id) then
3147             return False;
3148
3149          elsif Is_Interface (Rec_Id) then
3150             return False;
3151
3152          elsif (Has_Discriminants (Rec_Id)
3153                   and then not Is_Unchecked_Union (Rec_Id))
3154            or else Is_Tagged_Type (Rec_Id)
3155            or else Is_Concurrent_Record_Type (Rec_Id)
3156            or else Has_Task (Rec_Id)
3157          then
3158             return True;
3159          end if;
3160
3161          Id := First_Component (Rec_Id);
3162          while Present (Id) loop
3163             Comp_Decl := Parent (Id);
3164             Typ := Etype (Id);
3165
3166             if Present (Expression (Comp_Decl))
3167               or else Has_Non_Null_Base_Init_Proc (Typ)
3168               or else Component_Needs_Simple_Initialization (Typ)
3169             then
3170                return True;
3171             end if;
3172
3173             Next_Component (Id);
3174          end loop;
3175
3176          --  As explained above, a record initialization procedure is needed
3177          --  for public types in case Initialize_Scalars applies to a client.
3178          --  However, such a procedure is not needed in the case where either
3179          --  of restrictions No_Initialize_Scalars or No_Default_Initialization
3180          --  applies. No_Initialize_Scalars excludes the possibility of using
3181          --  Initialize_Scalars in any partition, and No_Default_Initialization
3182          --  implies that no initialization should ever be done for objects of
3183          --  the type, so is incompatible with Initialize_Scalars.
3184
3185          if not Restriction_Active (No_Initialize_Scalars)
3186            and then not Restriction_Active (No_Default_Initialization)
3187            and then Is_Public (Rec_Id)
3188          then
3189             return True;
3190          end if;
3191
3192          return False;
3193       end Requires_Init_Proc;
3194
3195    --  Start of processing for Build_Record_Init_Proc
3196
3197    begin
3198       --  Check for value type, which means no initialization required