Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 3                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Atree;    use Atree;

with Checks;   use Checks;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Exp_Aggr; use Exp_Aggr;

with Exp_Atag; use Exp_Atag;

with Exp_Ch4;  use Exp_Ch4;

with Exp_Ch6;  use Exp_Ch6;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Ch11; use Exp_Ch11;

with Exp_Dbug; use Exp_Dbug;

with Exp_Disp; use Exp_Disp;

with Exp_Dist; use Exp_Dist;

with Exp_Smem; use Exp_Smem;

with Exp_Strm; use Exp_Strm;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Freeze;   use Freeze;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Attr; use Sem_Attr;

with Sem_Cat;  use Sem_Cat;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Disp; use Sem_Disp;

with Sem_Eval; use Sem_Eval;

with Sem_Mech; use Sem_Mech;

with Sem_Res;  use Sem_Res;

with Sem_SCIL; use Sem_SCIL;

with Sem_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Stand;    use Stand;

with Snames;   use Snames;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Ttypes;   use Ttypes;

with Validsw;  use Validsw;

package body Exp_Ch3 is

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Adjust_Discriminants (Rtype : Entity_Id);

   --  This is used when freezing a record type. It attempts to construct

   --  more restrictive subtypes for discriminants so that the max size of

   --  the record can be calculated more accurately. See the body of this

   --  procedure for details.

   procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);

   --  Build initialization procedure for given array type. Nod is a node

   --  used for attachment of any actions required in its construction.

   --  It also supplies the source location used for the procedure.

   function Build_Discriminant_Formals

     (Rec_Id : Entity_Id;

      Use_Dl : Boolean) return List_Id;

   --  This function uses the discriminants of a type to build a list of

   --  formal parameters, used in Build_Init_Procedure among other places.

   --  If the flag Use_Dl is set, the list is built using the already

   --  defined discriminals of the type, as is the case for concurrent

   --  types with discriminants. Otherwise new identifiers are created,

   --  with the source names of the discriminants.

   function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;

   --  This function builds a static aggregate that can serve as the initial

   --  value for an array type whose bounds are static, and whose component

   --  type is a composite type that has a static equivalent aggregate.

   --  The equivalent array aggregate is used both for object initialization

   --  and for component initialization, when used in the following function.

   function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;

   --  This function builds a static aggregate that can serve as the initial

   --  value for a record type whose components are scalar and initialized

   --  with compile-time values, or arrays with similar initialization or

   --  defaults. When possible, initialization of an object of the type can

   --  be achieved by using a copy of the aggregate as an initial value, thus

   --  removing the implicit call that would otherwise constitute elaboration

   --  code.

   procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id);

   --  Build record initialization procedure. N is the type declaration

   --  node, and Rec_Ent is the corresponding entity for the record type.

   procedure Build_Slice_Assignment (Typ : Entity_Id);

   --  Build assignment procedure for one-dimensional arrays of controlled

   --  types. Other array and slice assignments are expanded in-line, but

   --  the code expansion for controlled components (when control actions

   --  are active) can lead to very large blocks that GCC3 handles poorly.

   procedure Build_Untagged_Equality (Typ : Entity_Id);

   --  AI05-0123: Equality on untagged records composes. This procedure

   --  builds the equality routine for an untagged record that has components

   --  of a record type that has user-defined primitive equality operations.

   --  The resulting operation is a TSS subprogram.

   procedure Build_Variant_Record_Equality (Typ  : Entity_Id);

   --  Create An Equality function for the non-tagged variant record 'Typ'

   --  and attach it to the TSS list

   procedure Check_Stream_Attributes (Typ : Entity_Id);

   --  Check that if a limited extension has a parent with user-defined stream

   --  attributes, and does not itself have user-defined stream-attributes,

   --  then any limited component of the extension also has the corresponding

   --  user-defined stream attributes.

   procedure Clean_Task_Names

     (Typ     : Entity_Id;

      Proc_Id : Entity_Id);

   --  If an initialization procedure includes calls to generate names

   --  for task subcomponents, indicate that secondary stack cleanup is

   --  needed after an initialization. Typ is the component type, and Proc_Id

   --  the initialization procedure for the enclosing composite type.

   procedure Expand_Tagged_Root (T : Entity_Id);

   --  Add a field _Tag at the beginning of the record. This field carries

   --  the value of the access to the Dispatch table. This procedure is only

   --  called on root type, the _Tag field being inherited by the descendants.

   procedure Expand_Freeze_Array_Type (N : Node_Id);

   --  Freeze an array type. Deals with building the initialization procedure,

   --  creating the packed array type for a packed array and also with the

   --  creation of the controlling procedures for the controlled case. The

   --  argument N is the N_Freeze_Entity node for the type.

   procedure Expand_Freeze_Class_Wide_Type (N : Node_Id);

   --  Freeze a class-wide type. Build routine Finalize_Address for the purpose

   --  of finalizing controlled derivations from the class-wide's root type.

   procedure Expand_Freeze_Enumeration_Type (N : Node_Id);

   --  Freeze enumeration type with non-standard representation. Builds the

   --  array and function needed to convert between enumeration pos and

   --  enumeration representation values. N is the N_Freeze_Entity node

   --  for the type.

   procedure Expand_Freeze_Record_Type (N : Node_Id);

   --  Freeze record type. Builds all necessary discriminant checking

   --  and other ancillary functions, and builds dispatch tables where

   --  needed. The argument N is the N_Freeze_Entity node. This processing

   --  applies only to E_Record_Type entities, not to class wide types,

   --  record subtypes, or private types.

   procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);

   --  Treat user-defined stream operations as renaming_as_body if the

   --  subprogram they rename is not frozen when the type is frozen.

   procedure Initialization_Warning (E : Entity_Id);

   --  If static elaboration of the package is requested, indicate

   --  when a type does meet the conditions for static initialization. If

   --  E is a type, it has components that have no static initialization.

   --  if E is an entity, its initial expression is not compile-time known.

   function Init_Formals (Typ : Entity_Id) return List_Id;

   --  This function builds the list of formals for an initialization routine.

   --  The first formal is always _Init with the given type. For task value

   --  record types and types containing tasks, three additional formals are

   --  added:

   --

   --    _Master    : Master_Id

   --    _Chain     : in out Activation_Chain

   --    _Task_Name : String

   --

   --  The caller must append additional entries for discriminants if required.

   function In_Runtime (E : Entity_Id) return Boolean;

   --  Check if E is defined in the RTL (in a child of Ada or System). Used

   --  to avoid to bring in the overhead of _Input, _Output for tagged types.

   function Is_Variable_Size_Array (E : Entity_Id) return Boolean;

   --  Returns true if E has variable size components

   function Is_Variable_Size_Record (E : Entity_Id) return Boolean;

   --  Returns true if E has variable size components

   function Make_Eq_Body

     (Typ     : Entity_Id;

      Eq_Name : Name_Id) return Node_Id;

   --  Build the body of a primitive equality operation for a tagged record

   --  type, or in Ada 2012 for any record type that has components with a

   --  user-defined equality. Factored out of Predefined_Primitive_Bodies.

   function Make_Eq_Case

     (E     : Entity_Id;

      CL    : Node_Id;

      Discr : Entity_Id := Empty) return List_Id;

   --  Building block for variant record equality. Defined to share the code

   --  between the tagged and non-tagged case. Given a Component_List node CL,

   --  it generates an 'if' followed by a 'case' statement that compares all

   --  components of local temporaries named X and Y (that are declared as

   --  formals at some upper level). E provides the Sloc to be used for the

   --  generated code. Discr is used as the case statement switch in the case

   --  of Unchecked_Union equality.

   function Make_Eq_If

     (E : Entity_Id;

      L : List_Id) return Node_Id;

   --  Building block for variant record equality. Defined to share the code

   --  between the tagged and non-tagged case. Given the list of components

   --  (or discriminants) L, it generates a return statement that compares all

   --  components of local temporaries named X and Y (that are declared as

   --  formals at some upper level). E provides the Sloc to be used for the

   --  generated code.

   procedure Make_Predefined_Primitive_Specs

     (Tag_Typ     : Entity_Id;

      Predef_List : out List_Id;

      Renamed_Eq  : out Entity_Id);

   --  Create a list with the specs of the predefined primitive operations.

   --  For tagged types that are interfaces all these primitives are defined

   --  abstract.

   --

   --  The following entries are present for all tagged types, and provide

   --  the results of the corresponding attribute applied to the object.

   --  Dispatching is required in general, since the result of the attribute

   --  will vary with the actual object subtype.

   --

   --     _size          provides result of 'Size attribute

   --     typSR          provides result of 'Read attribute

   --     typSW          provides result of 'Write attribute

   --     typSI          provides result of 'Input attribute

   --     typSO          provides result of 'Output attribute

   --

   --  The following entries are additionally present for non-limited tagged

   --  types, and implement additional dispatching operations for predefined

   --  operations:

   --

   --     _equality      implements "=" operator

   --     _assign        implements assignment operation

   --     typDF          implements deep finalization

   --     typDA          implements deep adjust

   --

   --  The latter two are empty procedures unless the type contains some

   --  controlled components that require finalization actions (the deep

   --  in the name refers to the fact that the action applies to components).

   --

   --  The list is returned in Predef_List. The Parameter Renamed_Eq either

   --  returns the value Empty, or else the defining unit name for the

   --  predefined equality function in the case where the type has a primitive

   --  operation that is a renaming of predefined equality (but only if there

   --  is also an overriding user-defined equality function). The returned

   --  Renamed_Eq will be passed to the corresponding parameter of

   --  Predefined_Primitive_Bodies.

   function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;

   --  returns True if there are representation clauses for type T that are not

   --  inherited. If the result is false, the init_proc and the discriminant

   --  checking functions of the parent can be reused by a derived type.

   procedure Make_Controlling_Function_Wrappers

     (Tag_Typ   : Entity_Id;

      Decl_List : out List_Id;

      Body_List : out List_Id);

   --  Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions

   --  associated with inherited functions with controlling results which

   --  are not overridden. The body of each wrapper function consists solely

   --  of a return statement whose expression is an extension aggregate

   --  invoking the inherited subprogram's parent subprogram and extended

   --  with a null association list.

   function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;

   --  Ada 2005 (AI-251): Makes specs for null procedures associated with any

   --  null procedures inherited from an interface type that have not been

   --  overridden. Only one null procedure will be created for a given set of

   --  inherited null procedures with homographic profiles.

   function Predef_Spec_Or_Body

     (Loc      : Source_Ptr;

      Tag_Typ  : Entity_Id;

      Name     : Name_Id;

      Profile  : List_Id;

      Ret_Type : Entity_Id := Empty;

      For_Body : Boolean   := False) return Node_Id;

   --  This function generates the appropriate expansion for a predefined

   --  primitive operation specified by its name, parameter profile and

   --  return type (Empty means this is a procedure). If For_Body is false,

   --  then the returned node is a subprogram declaration. If For_Body is

   --  true, then the returned node is a empty subprogram body containing

   --  no declarations and no statements.

   function Predef_Stream_Attr_Spec

     (Loc      : Source_Ptr;

      Tag_Typ  : Entity_Id;

      Name     : TSS_Name_Type;

      For_Body : Boolean := False) return Node_Id;

   --  Specialized version of Predef_Spec_Or_Body that apply to read, write,

   --  input and output attribute whose specs are constructed in Exp_Strm.

   function Predef_Deep_Spec

     (Loc      : Source_Ptr;

      Tag_Typ  : Entity_Id;

      Name     : TSS_Name_Type;

      For_Body : Boolean := False) return Node_Id;

   --  Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust

   --  and _deep_finalize

   function Predefined_Primitive_Bodies

     (Tag_Typ    : Entity_Id;

      Renamed_Eq : Entity_Id) return List_Id;

   --  Create the bodies of the predefined primitives that are described in

   --  Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote

   --  the defining unit name of the type's predefined equality as returned

   --  by Make_Predefined_Primitive_Specs.

   function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;

   --  Freeze entities of all predefined primitive operations. This is needed

   --  because the bodies of these operations do not normally do any freezing.

   function Stream_Operation_OK

     (Typ       : Entity_Id;

      Operation : TSS_Name_Type) return Boolean;

   --  Check whether the named stream operation must be emitted for a given

   --  type. The rules for inheritance of stream attributes by type extensions

   --  are enforced by this function. Furthermore, various restrictions prevent

   --  the generation of these operations, as a useful optimization or for

   --  certification purposes.

   --------------------------

   -- Adjust_Discriminants --

   --------------------------

   --  This procedure attempts to define subtypes for discriminants that are

   --  more restrictive than those declared. Such a replacement is possible if

   --  we can demonstrate that values outside the restricted range would cause

   --  constraint errors in any case. The advantage of restricting the

   --  discriminant types in this way is that the maximum size of the variant

   --  record can be calculated more conservatively.

   --  An example of a situation in which we can perform this type of

   --  restriction is the following:

   --    subtype B is range 1 .. 10;

   --    type Q is array (B range <>) of Integer;

   --    type V (N : Natural) is record

   --       C : Q (1 .. N);

   --    end record;

   --  In this situation, we can restrict the upper bound of N to 10, since

   --  any larger value would cause a constraint error in any case.

   --  There are many situations in which such restriction is possible, but

   --  for now, we just look for cases like the above, where the component

   --  in question is a one dimensional array whose upper bound is one of

   --  the record discriminants. Also the component must not be part of

   --  any variant part, since then the component does not always exist.

   procedure Adjust_Discriminants (Rtype : Entity_Id) is

      Loc   : constant Source_Ptr := Sloc (Rtype);

      Comp  : Entity_Id;

      Ctyp  : Entity_Id;

      Ityp  : Entity_Id;

      Lo    : Node_Id;

      Hi    : Node_Id;

      P     : Node_Id;

      Loval : Uint;

      Discr : Entity_Id;

      Dtyp  : Entity_Id;

      Dhi   : Node_Id;

      Dhiv  : Uint;

      Ahi   : Node_Id;

      Ahiv  : Uint;

      Tnn   : Entity_Id;

   begin

      Comp := First_Component (Rtype);

      while Present (Comp) loop

         --  If our parent is a variant, quit, we do not look at components

         --  that are in variant parts, because they may not always exist.

         P := Parent (Comp);   -- component declaration

         P := Parent (P);      -- component list

         exit when Nkind (Parent (P)) = N_Variant;

         --  We are looking for a one dimensional array type

         Ctyp := Etype (Comp);

         if not Is_Array_Type (Ctyp)

           or else Number_Dimensions (Ctyp) > 1

         then

            goto Continue;

         end if;

         --  The lower bound must be constant, and the upper bound is a

         --  discriminant (which is a discriminant of the current record).

         Ityp := Etype (First_Index (Ctyp));

         Lo := Type_Low_Bound (Ityp);

         Hi := Type_High_Bound (Ityp);

         if not Compile_Time_Known_Value (Lo)

           or else Nkind (Hi) /= N_Identifier

           or else No (Entity (Hi))

           or else Ekind (Entity (Hi)) /= E_Discriminant

         then

            goto Continue;

         end if;

         --  We have an array with appropriate bounds

         Loval := Expr_Value (Lo);

         Discr := Entity (Hi);

         Dtyp  := Etype (Discr);

         --  See if the discriminant has a known upper bound

         Dhi := Type_High_Bound (Dtyp);

         if not Compile_Time_Known_Value (Dhi) then

            goto Continue;

         end if;

         Dhiv := Expr_Value (Dhi);

         --  See if base type of component array has known upper bound

         Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));

         if not Compile_Time_Known_Value (Ahi) then

            goto Continue;

         end if;

         Ahiv := Expr_Value (Ahi);

         --  The condition for doing the restriction is that the high bound

         --  of the discriminant is greater than the low bound of the array,

         --  and is also greater than the high bound of the base type index.

         if Dhiv > Loval and then Dhiv > Ahiv then

            --  We can reset the upper bound of the discriminant type to

            --  whichever is larger, the low bound of the component, or

            --  the high bound of the base type array index.

            --  We build a subtype that is declared as

            --     subtype Tnn is discr_type range discr_type'First .. max;

            --  And insert this declaration into the tree. The type of the

            --  discriminant is then reset to this more restricted subtype.

            Tnn := Make_Temporary (Loc, 'T');

            Insert_Action (Declaration_Node (Rtype),

              Make_Subtype_Declaration (Loc,

                Defining_Identifier => Tnn,

                Subtype_Indication =>

                  Make_Subtype_Indication (Loc,

                    Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),

                    Constraint   =>

                      Make_Range_Constraint (Loc,

                        Range_Expression =>

                          Make_Range (Loc,

                            Low_Bound =>

                              Make_Attribute_Reference (Loc,

                                Attribute_Name => Name_First,

                                Prefix => New_Occurrence_Of (Dtyp, Loc)),

                            High_Bound =>

                              Make_Integer_Literal (Loc,

                                Intval => UI_Max (Loval, Ahiv)))))));

            Set_Etype (Discr, Tnn);

         end if;

      <<Continue>>

         Next_Component (Comp);

      end loop;

   end Adjust_Discriminants;

   ---------------------------

   -- Build_Array_Init_Proc --

   ---------------------------

   procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is

      Loc              : constant Source_Ptr := Sloc (Nod);

      Comp_Type        : constant Entity_Id  := Component_Type (A_Type);

      Body_Stmts       : List_Id;

      Has_Default_Init : Boolean;

      Index_List       : List_Id;

      Proc_Id          : Entity_Id;

      function Init_Component return List_Id;

      --  Create one statement to initialize one array component, designated

      --  by a full set of indexes.

      function Init_One_Dimension (N : Int) return List_Id;

      --  Create loop to initialize one dimension of the array. The single

      --  statement in the loop body initializes the inner dimensions if any,

      --  or else the single component. Note that this procedure is called

      --  recursively, with N being the dimension to be initialized. A call

      --  with N greater than the number of dimensions simply generates the

      --  component initialization, terminating the recursion.

      --------------------

      -- Init_Component --

      --------------------

      function Init_Component return List_Id is

         Comp : Node_Id;

      begin

         Comp :=

           Make_Indexed_Component (Loc,

             Prefix      => Make_Identifier (Loc, Name_uInit),

             Expressions => Index_List);

         if Has_Default_Aspect (A_Type) then

            Set_Assignment_OK (Comp);

            return New_List (

              Make_Assignment_Statement (Loc,

                Name       => Comp,

                Expression =>

                  Convert_To (Comp_Type,

                    Default_Aspect_Component_Value (First_Subtype (A_Type)))));

         elsif Needs_Simple_Initialization (Comp_Type) then

            Set_Assignment_OK (Comp);

            return New_List (

              Make_Assignment_Statement (Loc,

                Name       => Comp,

                Expression =>

                  Get_Simple_Init_Val

                    (Comp_Type, Nod, Component_Size (A_Type))));

         else

            Clean_Task_Names (Comp_Type, Proc_Id);

            return

              Build_Initialization_Call

                (Loc, Comp, Comp_Type,

                 In_Init_Proc => True,

                 Enclos_Type  => A_Type);

         end if;

      end Init_Component;

      ------------------------

      -- Init_One_Dimension --

      ------------------------

      function Init_One_Dimension (N : Int) return List_Id is

         Index : Entity_Id;

      begin

         --  If the component does not need initializing, then there is nothing

         --  to do here, so we return a null body. This occurs when generating

         --  the dummy Init_Proc needed for Initialize_Scalars processing.

         if not Has_Non_Null_Base_Init_Proc (Comp_Type)

           and then not Needs_Simple_Initialization (Comp_Type)

           and then not Has_Task (Comp_Type)

           and then not Has_Default_Aspect (A_Type)

         then

            return New_List (Make_Null_Statement (Loc));

         --  If all dimensions dealt with, we simply initialize the component

         elsif N > Number_Dimensions (A_Type) then

            return Init_Component;

         --  Here we generate the required loop

         else

            Index :=

              Make_Defining_Identifier (Loc, New_External_Name ('J', N));

            Append (New_Reference_To (Index, Loc), Index_List);

            return New_List (

              Make_Implicit_Loop_Statement (Nod,

                Identifier => Empty,

                Iteration_Scheme =>

                  Make_Iteration_Scheme (Loc,

                    Loop_Parameter_Specification =>

                      Make_Loop_Parameter_Specification (Loc,

                        Defining_Identifier => Index,

                        Discrete_Subtype_Definition =>

                          Make_Attribute_Reference (Loc,

                            Prefix => Make_Identifier (Loc, Name_uInit),

                            Attribute_Name  => Name_Range,

                            Expressions     => New_List (

                              Make_Integer_Literal (Loc, N))))),

                Statements =>  Init_One_Dimension (N + 1)));

         end if;

      end Init_One_Dimension;

   --  Start of processing for Build_Array_Init_Proc

   begin

      --  Nothing to generate in the following cases:

      --    1. Initialization is suppressed for the type

      --    2. The type is a value type, in the CIL sense.

      --    3. The type has CIL/JVM convention.

      --    4. An initialization already exists for the base type

      if Initialization_Suppressed (A_Type)

        or else Is_Value_Type (Comp_Type)

        or else Convention (A_Type) = Convention_CIL

        or else Convention (A_Type) = Convention_Java

        or else Present (Base_Init_Proc (A_Type))

      then

         return;

      end if;

      Index_List := New_List;

      --  We need an initialization procedure if any of the following is true:

      --    1. The component type has an initialization procedure

      --    2. The component type needs simple initialization

      --    3. Tasks are present

      --    4. The type is marked as a public entity

      --    5. The array type has a Default_Component_Value aspect

      --  The reason for the public entity test is to deal properly with the

      --  Initialize_Scalars pragma. This pragma can be set in the client and

      --  not in the declaring package, this means the client will make a call

      --  to the initialization procedure (because one of conditions 1-3 must

      --  apply in this case), and we must generate a procedure (even if it is

      --  null) to satisfy the call in this case.

      --  Exception: do not build an array init_proc for a type whose root

      --  type is Standard.String or Standard.Wide_[Wide_]String, since there

      --  is no place to put the code, and in any case we handle initialization

      --  of such types (in the Initialize_Scalars case, that's the only time

      --  the issue arises) in a special manner anyway which does not need an

      --  init_proc.

      Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)

                            or else Needs_Simple_Initialization (Comp_Type)

                            or else Has_Task (Comp_Type)

                            or else Has_Default_Aspect (A_Type);

      if Has_Default_Init

        or else (not Restriction_Active (No_Initialize_Scalars)

                  and then Is_Public (A_Type)

                  and then Root_Type (A_Type) /= Standard_String

                  and then Root_Type (A_Type) /= Standard_Wide_String

                  and then Root_Type (A_Type) /= Standard_Wide_Wide_String)

      then

         Proc_Id :=

           Make_Defining_Identifier (Loc,

             Chars => Make_Init_Proc_Name (A_Type));

         --  If No_Default_Initialization restriction is active, then we don't

         --  want to build an init_proc, but we need to mark that an init_proc

         --  would be needed if this restriction was not active (so that we can

         --  detect attempts to call it), so set a dummy init_proc in place.

         --  This is only done though when actual default initialization is

         --  needed (and not done when only Is_Public is True), since otherwise

         --  objects such as arrays of scalars could be wrongly flagged as

         --  violating the restriction.

         if Restriction_Active (No_Default_Initialization) then

            if Has_Default_Init then

               Set_Init_Proc (A_Type, Proc_Id);

            end if;

            return;

         end if;

         Body_Stmts := Init_One_Dimension (1);

         Discard_Node (

           Make_Subprogram_Body (Loc,

             Specification =>

               Make_Procedure_Specification (Loc,

                 Defining_Unit_Name => Proc_Id,

                 Parameter_Specifications => Init_Formals (A_Type)),

             Declarations => New_List,

             Handled_Statement_Sequence =>

               Make_Handled_Sequence_Of_Statements (Loc,

                 Statements => Body_Stmts)));

         Set_Ekind          (Proc_Id, E_Procedure);

         Set_Is_Public      (Proc_Id, Is_Public (A_Type));

         Set_Is_Internal    (Proc_Id);

         Set_Has_Completion (Proc_Id);

         if not Debug_Generated_Code then

            Set_Debug_Info_Off (Proc_Id);

         end if;

         --  Set inlined unless controlled stuff or tasks around, in which

         --  case we do not want to inline, because nested stuff may cause

         --  difficulties in inter-unit inlining, and furthermore there is

         --  in any case no point in inlining such complex init procs.

         if not Has_Task (Proc_Id)

           and then not Needs_Finalization (Proc_Id)

         then

            Set_Is_Inlined (Proc_Id);

         end if;

         --  Associate Init_Proc with type, and determine if the procedure

         --  is null (happens because of the Initialize_Scalars pragma case,

         --  where we have to generate a null procedure in case it is called

         --  by a client with Initialize_Scalars set). Such procedures have

         --  to be generated, but do not have to be called, so we mark them

         --  as null to suppress the call.

         Set_Init_Proc (A_Type, Proc_Id);

         if List_Length (Body_Stmts) = 1

           --  We must skip SCIL nodes because they may have been added to this

           --  list by Insert_Actions.

           and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement

         then

            Set_Is_Null_Init_Proc (Proc_Id);

         else

            --  Try to build a static aggregate to statically initialize

            --  objects of the type. This can only be done for constrained

            --  one-dimensional arrays with static bounds.

            Set_Static_Initialization

              (Proc_Id,

               Build_Equivalent_Array_Aggregate (First_Subtype (A_Type)));

         end if;

      end if;

   end Build_Array_Init_Proc;

   --------------------------------

   -- Build_Discr_Checking_Funcs --

   --------------------------------

   procedure Build_Discr_Checking_Funcs (N : Node_Id) is

      Rec_Id            : Entity_Id;

      Loc               : Source_Ptr;

      Enclosing_Func_Id : Entity_Id;

      Sequence          : Nat     := 1;

      Type_Def          : Node_Id;

      V                 : Node_Id;

      function Build_Case_Statement

        (Case_Id : Entity_Id;

         Variant : Node_Id) return Node_Id;

      --  Build a case statement containing only two alternatives. The first

      --  alternative corresponds exactly to the discrete choices given on the

      --  variant with contains the components that we are generating the

      --  checks for. If the discriminant is one of these return False. The

      --  second alternative is an OTHERS choice that will return True

      --  indicating the discriminant did not match.

      function Build_Dcheck_Function

        (Case_Id : Entity_Id;

         Variant : Node_Id) return Entity_Id;

      --  Build the discriminant checking function for a given variant

      procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);

      --  Builds the discriminant checking function for each variant of the

      --  given variant part of the record type.

      --------------------------

      -- Build_Case_Statement --

      --------------------------

      function Build_Case_Statement