gcc/ada/gcc-interface/decl.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 D E C L                                  *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2010, 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 along with GCC; see the file COPYING3.  If not see        *
  19  * <http://www.gnu.org/licenses/>.                                          *
  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 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tm.h"
  30 #include "tree.h"
  31 #include "flags.h"
  32 #include "toplev.h"
  33 #include "ggc.h"
  34 #include "target.h"
  35 #include "expr.h"
  36 #include "tree-inline.h"
  37
  38 #include "ada.h"
  39 #include "types.h"
  40 #include "atree.h"
  41 #include "elists.h"
  42 #include "namet.h"
  43 #include "nlists.h"
  44 #include "repinfo.h"
  45 #include "snames.h"
  46 #include "stringt.h"
  47 #include "uintp.h"
  48 #include "fe.h"
  49 #include "sinfo.h"
  50 #include "einfo.h"
  51 #include "ada-tree.h"
  52 #include "gigi.h"
  53
  54 #ifndef MAX_FIXED_MODE_SIZE
  55 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
  56 #endif
  57
  58 /* Convention_Stdcall should be processed in a specific way on Windows targets
  59    only.  The macro below is a helper to avoid having to check for a Windows
  60    specific attribute throughout this unit.  */
  61
  62 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
  63 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
  64 #else
  65 #define Has_Stdcall_Convention(E) (0)
  66 #endif
  67
  68 /* Stack realignment for functions with foreign conventions is provided on a
  69    per back-end basis now, as it is handled by the prologue expanders and not
  70    as part of the function's body any more.  It might be requested by way of a
  71    dedicated function type attribute on the targets that support it.
  72
  73    We need a way to avoid setting the attribute on the targets that don't
  74    support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
  75
  76    It is defined on targets where the circuitry is available, and indicates
  77    whether the realignment is needed for 'main'.  We use this to decide for
  78    foreign subprograms as well.
  79
  80    It is not defined on targets where the circuitry is not implemented, and
  81    we just never set the attribute in these cases.
  82
  83    Whether it is defined on all targets that would need it in theory is
  84    not entirely clear.  We currently trust the base GCC settings for this
  85    purpose.  */
  86
  87 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
  88 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
  89 #endif
  90
  91 struct incomplete
  92 {
  93   struct incomplete *next;
  94   tree old_type;
  95   Entity_Id full_type;
  96 };
  97
  98 /* These variables are used to defer recursively expanding incomplete types
  99    while we are processing an array, a record or a subprogram type.  */
 100 static int defer_incomplete_level = 0;
 101 static struct incomplete *defer_incomplete_list;
 102
 103 /* This variable is used to delay expanding From_With_Type types until the
 104    end of the spec.  */
 105 static struct incomplete *defer_limited_with;
 106
 107 /* These variables are used to defer finalizing types.  The element of the
 108    list is the TYPE_DECL associated with the type.  */
 109 static int defer_finalize_level = 0;
 110 static VEC (tree,heap) *defer_finalize_list;
 111
 112 /* A hash table used to cache the result of annotate_value.  */
 113 static GTY ((if_marked ("tree_int_map_marked_p"),
 114              param_is (struct tree_int_map))) htab_t annotate_value_cache;
 115
 116 enum alias_set_op
 117 {
 118   ALIAS_SET_COPY,
 119   ALIAS_SET_SUBSET,
 120   ALIAS_SET_SUPERSET
 121 };
 122
 123 static void relate_alias_sets (tree, tree, enum alias_set_op);
 124
 125 static bool allocatable_size_p (tree, bool);
 126 static void prepend_one_attribute_to (struct attrib **,
 127                                       enum attr_type, tree, tree, Node_Id);
 128 static void prepend_attributes (Entity_Id, struct attrib **);
 129 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
 130 static bool is_variable_size (tree);
 131 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
 132 static tree make_packable_type (tree, bool);
 133 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
 134 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
 135                                bool *);
 136 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
 137 static bool same_discriminant_p (Entity_Id, Entity_Id);
 138 static bool array_type_has_nonaliased_component (tree, Entity_Id);
 139 static bool compile_time_known_address_p (Node_Id);
 140 static bool cannot_be_superflat_p (Node_Id);
 141 static bool constructor_address_p (tree);
 142 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
 143                                   bool, bool, bool, bool, bool);
 144 static Uint annotate_value (tree);
 145 static void annotate_rep (Entity_Id, tree);
 146 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
 147 static tree build_subst_list (Entity_Id, Entity_Id, bool);
 148 static tree build_variant_list (tree, tree, tree);
 149 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
 150 static void set_rm_size (Uint, tree, Entity_Id);
 151 static tree make_type_from_size (tree, tree, bool);
 152 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
 153 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
 154 static void check_ok_for_atomic (tree, Entity_Id, bool);
 155 static int compatible_signatures_p (tree, tree);
 156 static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
 157 static tree get_rep_part (tree);
 158 static tree get_variant_part (tree);
 159 static tree create_variant_part_from (tree, tree, tree, tree, tree);
 160 static void copy_and_substitute_in_size (tree, tree, tree);
 161 static void rest_of_type_decl_compilation_no_defer (tree);
 162 \f
 163 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
 164    entity, return the equivalent GCC tree for that entity (a ..._DECL node)
 165    and associate the ..._DECL node with the input GNAT defining identifier.
 166
 167    If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
 168    initial value (in GCC tree form).  This is optional for a variable.  For
 169    a renamed entity, GNU_EXPR gives the object being renamed.
 170
 171    DEFINITION is nonzero if this call is intended for a definition.  This is
 172    used for separate compilation where it is necessary to know whether an
 173    external declaration or a definition must be created if the GCC equivalent
 174    was not created previously.  The value of 1 is normally used for a nonzero
 175    DEFINITION, but a value of 2 is used in special circumstances, defined in
 176    the code.  */
 177
 178 tree
 179 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 180 {
 181   /* Contains the kind of the input GNAT node.  */
 182   const Entity_Kind kind = Ekind (gnat_entity);
 183   /* True if this is a type.  */
 184   const bool is_type = IN (kind, Type_Kind);
 185   /* True if debug info is requested for this entity.  */
 186   const bool debug_info_p = Needs_Debug_Info (gnat_entity);
 187   /* True if this entity is to be considered as imported.  */
 188   const bool imported_p
 189     = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
 190   /* For a type, contains the equivalent GNAT node to be used in gigi.  */
 191   Entity_Id gnat_equiv_type = Empty;
 192   /* Temporary used to walk the GNAT tree.  */
 193   Entity_Id gnat_temp;
 194   /* Contains the GCC DECL node which is equivalent to the input GNAT node.
 195      This node will be associated with the GNAT node by calling at the end
 196      of the `switch' statement.  */
 197   tree gnu_decl = NULL_TREE;
 198   /* Contains the GCC type to be used for the GCC node.  */
 199   tree gnu_type = NULL_TREE;
 200   /* Contains the GCC size tree to be used for the GCC node.  */
 201   tree gnu_size = NULL_TREE;
 202   /* Contains the GCC name to be used for the GCC node.  */
 203   tree gnu_entity_name;
 204   /* True if we have already saved gnu_decl as a GNAT association.  */
 205   bool saved = false;
 206   /* True if we incremented defer_incomplete_level.  */
 207   bool this_deferred = false;
 208   /* True if we incremented force_global.  */
 209   bool this_global = false;
 210   /* True if we should check to see if elaborated during processing.  */
 211   bool maybe_present = false;
 212   /* True if we made GNU_DECL and its type here.  */
 213   bool this_made_decl = false;
 214   /* Size and alignment of the GCC node, if meaningful.  */
 215   unsigned int esize = 0, align = 0;
 216   /* Contains the list of attributes directly attached to the entity.  */
 217   struct attrib *attr_list = NULL;
 218
 219   /* Since a use of an Itype is a definition, process it as such if it
 220      is not in a with'ed unit.  */
 221   if (!definition
 222       && is_type
 223       && Is_Itype (gnat_entity)
 224       && !present_gnu_tree (gnat_entity)
 225       && In_Extended_Main_Code_Unit (gnat_entity))
 226     {
 227       /* Ensure that we are in a subprogram mentioned in the Scope chain of
 228          this entity, our current scope is global, or we encountered a task
 229          or entry (where we can't currently accurately check scoping).  */
 230       if (!current_function_decl
 231           || DECL_ELABORATION_PROC_P (current_function_decl))
 232         {
 233           process_type (gnat_entity);
 234           return get_gnu_tree (gnat_entity);
 235         }
 236
 237       for (gnat_temp = Scope (gnat_entity);
 238            Present (gnat_temp);
 239            gnat_temp = Scope (gnat_temp))
 240         {
 241           if (Is_Type (gnat_temp))
 242             gnat_temp = Underlying_Type (gnat_temp);
 243
 244           if (Ekind (gnat_temp) == E_Subprogram_Body)
 245             gnat_temp
 246               = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
 247
 248           if (IN (Ekind (gnat_temp), Subprogram_Kind)
 249               && Present (Protected_Body_Subprogram (gnat_temp)))
 250             gnat_temp = Protected_Body_Subprogram (gnat_temp);
 251
 252           if (Ekind (gnat_temp) == E_Entry
 253               || Ekind (gnat_temp) == E_Entry_Family
 254               || Ekind (gnat_temp) == E_Task_Type
 255               || (IN (Ekind (gnat_temp), Subprogram_Kind)
 256                   && present_gnu_tree (gnat_temp)
 257                   && (current_function_decl
 258                       == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
 259             {
 260               process_type (gnat_entity);
 261               return get_gnu_tree (gnat_entity);
 262             }
 263         }
 264
 265       /* This abort means the Itype has an incorrect scope, i.e. that its
 266          scope does not correspond to the subprogram it is declared in.  */
 267       gcc_unreachable ();
 268     }
 269
 270   /* If we've already processed this entity, return what we got last time.
 271      If we are defining the node, we should not have already processed it.
 272      In that case, we will abort below when we try to save a new GCC tree
 273      for this object.  We also need to handle the case of getting a dummy
 274      type when a Full_View exists.  */
 275   if ((!definition || (is_type && imported_p))
 276       && present_gnu_tree (gnat_entity))
 277     {
 278       gnu_decl = get_gnu_tree (gnat_entity);
 279
 280       if (TREE_CODE (gnu_decl) == TYPE_DECL
 281           && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
 282           && IN (kind, Incomplete_Or_Private_Kind)
 283           && Present (Full_View (gnat_entity)))
 284         {
 285           gnu_decl
 286             = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
 287           save_gnu_tree (gnat_entity, NULL_TREE, false);
 288           save_gnu_tree (gnat_entity, gnu_decl, false);
 289         }
 290
 291       return gnu_decl;
 292     }
 293
 294   /* If this is a numeric or enumeral type, or an access type, a nonzero
 295      Esize must be specified unless it was specified by the programmer.  */
 296   gcc_assert (!Unknown_Esize (gnat_entity)
 297               || Has_Size_Clause (gnat_entity)
 298               || (!IN (kind, Numeric_Kind)
 299                   && !IN (kind, Enumeration_Kind)
 300                   && (!IN (kind, Access_Kind)
 301                       || kind == E_Access_Protected_Subprogram_Type
 302                       || kind == E_Anonymous_Access_Protected_Subprogram_Type
 303                       || kind == E_Access_Subtype)));
 304
 305   /* The RM size must be specified for all discrete and fixed-point types.  */
 306   gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
 307                 && Unknown_RM_Size (gnat_entity)));
 308
 309   /* If we get here, it means we have not yet done anything with this entity.
 310      If we are not defining it, it must be a type or an entity that is defined
 311      elsewhere or externally, otherwise we should have defined it already.  */
 312   gcc_assert (definition
 313               || type_annotate_only
 314               || is_type
 315               || kind == E_Discriminant
 316               || kind == E_Component
 317               || kind == E_Label
 318               || (kind == E_Constant && Present (Full_View (gnat_entity)))
 319               || Is_Public (gnat_entity));
 320
 321   /* Get the name of the entity and set up the line number and filename of
 322      the original definition for use in any decl we make.  */
 323   gnu_entity_name = get_entity_name (gnat_entity);
 324   Sloc_to_locus (Sloc (gnat_entity), &input_location);
 325
 326   /* For cases when we are not defining (i.e., we are referencing from
 327      another compilation unit) public entities, show we are at global level
 328      for the purpose of computing scopes.  Don't do this for components or
 329      discriminants since the relevant test is whether or not the record is
 330      being defined.  */
 331   if (!definition
 332       && kind != E_Component
 333       && kind != E_Discriminant
 334       && Is_Public (gnat_entity)
 335       && !Is_Statically_Allocated (gnat_entity))
 336     force_global++, this_global = true;
 337
 338   /* Handle any attributes directly attached to the entity.  */
 339   if (Has_Gigi_Rep_Item (gnat_entity))
 340     prepend_attributes (gnat_entity, &attr_list);
 341
 342   /* Do some common processing for types.  */
 343   if (is_type)
 344     {
 345       /* Compute the equivalent type to be used in gigi.  */
 346       gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
 347
 348       /* Machine_Attributes on types are expected to be propagated to
 349          subtypes.  The corresponding Gigi_Rep_Items are only attached
 350          to the first subtype though, so we handle the propagation here.  */
 351       if (Base_Type (gnat_entity) != gnat_entity
 352           && !Is_First_Subtype (gnat_entity)
 353           && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
 354         prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
 355                             &attr_list);
 356
 357       /* Compute a default value for the size of the type.  */
 358       if (Known_Esize (gnat_entity)
 359           && UI_Is_In_Int_Range (Esize (gnat_entity)))
 360         {
 361           unsigned int max_esize;
 362           esize = UI_To_Int (Esize (gnat_entity));
 363
 364           if (IN (kind, Float_Kind))
 365             max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
 366           else if (IN (kind, Access_Kind))
 367             max_esize = POINTER_SIZE * 2;
 368           else
 369             max_esize = LONG_LONG_TYPE_SIZE;
 370
 371           if (esize > max_esize)
 372            esize = max_esize;
 373         }
 374       else
 375         esize = LONG_LONG_TYPE_SIZE;
 376     }
 377
 378   switch (kind)
 379     {
 380     case E_Constant:
 381       /* If this is a use of a deferred constant without address clause,
 382          get its full definition.  */
 383       if (!definition
 384           && No (Address_Clause (gnat_entity))
 385           && Present (Full_View (gnat_entity)))
 386         {
 387           gnu_decl
 388             = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
 389           saved = true;
 390           break;
 391         }
 392
 393       /* If we have an external constant that we are not defining, get the
 394          expression that is was defined to represent.  We may throw that
 395          expression away later if it is not a constant.  Do not retrieve the
 396          expression if it is an aggregate or allocator, because in complex
 397          instantiation contexts it may not be expanded  */
 398       if (!definition
 399           && Present (Expression (Declaration_Node (gnat_entity)))
 400           && !No_Initialization (Declaration_Node (gnat_entity))
 401           && (Nkind (Expression (Declaration_Node (gnat_entity)))
 402               != N_Aggregate)
 403           && (Nkind (Expression (Declaration_Node (gnat_entity)))
 404               != N_Allocator))
 405         gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
 406
 407       /* Ignore deferred constant definitions without address clause since
 408          they are processed fully in the front-end.  If No_Initialization
 409          is set, this is not a deferred constant but a constant whose value
 410          is built manually.  And constants that are renamings are handled
 411          like variables.  */
 412       if (definition
 413           && !gnu_expr
 414           && No (Address_Clause (gnat_entity))
 415           && !No_Initialization (Declaration_Node (gnat_entity))
 416           && No (Renamed_Object (gnat_entity)))
 417         {
 418           gnu_decl = error_mark_node;
 419           saved = true;
 420           break;
 421         }
 422
 423       /* Ignore constant definitions already marked with the error node.  See
 424          the N_Object_Declaration case of gnat_to_gnu for the rationale.  */
 425       if (definition
 426           && gnu_expr
 427           && present_gnu_tree (gnat_entity)
 428           && get_gnu_tree (gnat_entity) == error_mark_node)
 429         {
 430           maybe_present = true;
 431           break;
 432         }
 433
 434       goto object;
 435
 436     case E_Exception:
 437       /* We used to special case VMS exceptions here to directly map them to
 438          their associated condition code.  Since this code had to be masked
 439          dynamically to strip off the severity bits, this caused trouble in
 440          the GCC/ZCX case because the "type" pointers we store in the tables
 441          have to be static.  We now don't special case here anymore, and let
 442          the regular processing take place, which leaves us with a regular
 443          exception data object for VMS exceptions too.  The condition code
 444          mapping is taken care of by the front end and the bitmasking by the
 445          runtime library.  */
 446       goto object;
 447
 448     case E_Discriminant:
 449     case E_Component:
 450       {
 451         /* The GNAT record where the component was defined.  */
 452         Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
 453
 454         /* If the variable is an inherited record component (in the case of
 455            extended record types), just return the inherited entity, which
 456            must be a FIELD_DECL.  Likewise for discriminants.
 457            For discriminants of untagged records which have explicit
 458            stored discriminants, return the entity for the corresponding
 459            stored discriminant.  Also use Original_Record_Component
 460            if the record has a private extension.  */
 461         if (Present (Original_Record_Component (gnat_entity))
 462             && Original_Record_Component (gnat_entity) != gnat_entity)
 463           {
 464             gnu_decl
 465               = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
 466                                     gnu_expr, definition);
 467             saved = true;
 468             break;
 469           }
 470
 471         /* If the enclosing record has explicit stored discriminants,
 472            then it is an untagged record.  If the Corresponding_Discriminant
 473            is not empty then this must be a renamed discriminant and its
 474            Original_Record_Component must point to the corresponding explicit
 475            stored discriminant (i.e. we should have taken the previous
 476            branch).  */
 477         else if (Present (Corresponding_Discriminant (gnat_entity))
 478                  && Is_Tagged_Type (gnat_record))
 479           {
 480             /* A tagged record has no explicit stored discriminants.  */
 481             gcc_assert (First_Discriminant (gnat_record)
 482                        == First_Stored_Discriminant (gnat_record));
 483             gnu_decl
 484               = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
 485                                     gnu_expr, definition);
 486             saved = true;
 487             break;
 488           }
 489
 490         else if (Present (CR_Discriminant (gnat_entity))
 491                  && type_annotate_only)
 492           {
 493             gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
 494                                            gnu_expr, definition);
 495             saved = true;
 496             break;
 497           }
 498
 499         /* If the enclosing record has explicit stored discriminants, then
 500            it is an untagged record.  If the Corresponding_Discriminant
 501            is not empty then this must be a renamed discriminant and its
 502            Original_Record_Component must point to the corresponding explicit
 503            stored discriminant (i.e. we should have taken the first
 504            branch).  */
 505         else if (Present (Corresponding_Discriminant (gnat_entity))
 506                  && (First_Discriminant (gnat_record)
 507                      != First_Stored_Discriminant (gnat_record)))
 508           gcc_unreachable ();
 509
 510         /* Otherwise, if we are not defining this and we have no GCC type
 511            for the containing record, make one for it.  Then we should
 512            have made our own equivalent.  */
 513         else if (!definition && !present_gnu_tree (gnat_record))
 514           {
 515             /* ??? If this is in a record whose scope is a protected
 516                type and we have an Original_Record_Component, use it.
 517                This is a workaround for major problems in protected type
 518                handling.  */
 519             Entity_Id Scop = Scope (Scope (gnat_entity));
 520             if ((Is_Protected_Type (Scop)
 521                  || (Is_Private_Type (Scop)
 522                      && Present (Full_View (Scop))
 523                      && Is_Protected_Type (Full_View (Scop))))
 524                 && Present (Original_Record_Component (gnat_entity)))
 525               {
 526                 gnu_decl
 527                   = gnat_to_gnu_entity (Original_Record_Component
 528                                         (gnat_entity),
 529                                         gnu_expr, 0);
 530                 saved = true;
 531                 break;
 532               }
 533
 534             gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
 535             gnu_decl = get_gnu_tree (gnat_entity);
 536             saved = true;
 537             break;
 538           }
 539
 540         else
 541           /* Here we have no GCC type and this is a reference rather than a
 542              definition.  This should never happen.  Most likely the cause is
 543              reference before declaration in the gnat tree for gnat_entity.  */
 544           gcc_unreachable ();
 545       }
 546
 547     case E_Loop_Parameter:
 548     case E_Out_Parameter:
 549     case E_Variable:
 550
 551       /* Simple variables, loop variables, Out parameters and exceptions.  */
 552     object:
 553       {
 554         bool const_flag
 555           = ((kind == E_Constant || kind == E_Variable)
 556              && Is_True_Constant (gnat_entity)
 557              && !Treat_As_Volatile (gnat_entity)
 558              && (((Nkind (Declaration_Node (gnat_entity))
 559                    == N_Object_Declaration)
 560                   && Present (Expression (Declaration_Node (gnat_entity))))
 561                  || Present (Renamed_Object (gnat_entity))));
 562         bool inner_const_flag = const_flag;
 563         bool static_p = Is_Statically_Allocated (gnat_entity);
 564         bool mutable_p = false;
 565         bool used_by_ref = false;
 566         tree gnu_ext_name = NULL_TREE;
 567         tree renamed_obj = NULL_TREE;
 568         tree gnu_object_size;
 569
 570         if (Present (Renamed_Object (gnat_entity)) && !definition)
 571           {
 572             if (kind == E_Exception)
 573               gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
 574                                              NULL_TREE, 0);
 575             else
 576               gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
 577           }
 578
 579         /* Get the type after elaborating the renamed object.  */
 580         gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
 581
 582         /* For a debug renaming declaration, build a pure debug entity.  */
 583         if (Present (Debug_Renaming_Link (gnat_entity)))
 584           {
 585             rtx addr;
 586             gnu_decl = build_decl (input_location,
 587                                    VAR_DECL, gnu_entity_name, gnu_type);
 588             /* The (MEM (CONST (0))) pattern is prescribed by STABS.  */
 589             if (global_bindings_p ())
 590               addr = gen_rtx_CONST (VOIDmode, const0_rtx);
 591             else
 592               addr = stack_pointer_rtx;
 593             SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
 594             gnat_pushdecl (gnu_decl, gnat_entity);
 595             break;
 596           }
 597
 598         /* If this is a loop variable, its type should be the base type.
 599            This is because the code for processing a loop determines whether
 600            a normal loop end test can be done by comparing the bounds of the
 601            loop against those of the base type, which is presumed to be the
 602            size used for computation.  But this is not correct when the size
 603            of the subtype is smaller than the type.  */
 604         if (kind == E_Loop_Parameter)
 605           gnu_type = get_base_type (gnu_type);
 606
 607         /* Reject non-renamed objects whose type is an unconstrained array or
 608            any object whose type is a dummy type or void.  */
 609         if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 610              && No (Renamed_Object (gnat_entity)))
 611             || TYPE_IS_DUMMY_P (gnu_type)
 612             || TREE_CODE (gnu_type) == VOID_TYPE)
 613           {
 614             gcc_assert (type_annotate_only);
 615             if (this_global)
 616               force_global--;
 617             return error_mark_node;
 618           }
 619
 620         /* If an alignment is specified, use it if valid.  Note that exceptions
 621            are objects but don't have an alignment.  We must do this before we
 622            validate the size, since the alignment can affect the size.  */
 623         if (kind != E_Exception && Known_Alignment (gnat_entity))
 624           {
 625             gcc_assert (Present (Alignment (gnat_entity)));
 626             align = validate_alignment (Alignment (gnat_entity), gnat_entity,
 627                                         TYPE_ALIGN (gnu_type));
 628
 629             /* No point in changing the type if there is an address clause
 630                as the final type of the object will be a reference type.  */
 631             if (Present (Address_Clause (gnat_entity)))
 632               align = 0;
 633             else
 634               gnu_type
 635                 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
 636                                   false, false, definition, true);
 637           }
 638
 639         /* If we are defining the object, see if it has a Size and validate it
 640            if so.  If we are not defining the object and a Size clause applies,
 641            simply retrieve the value.  We don't want to ignore the clause and
 642            it is expected to have been validated already.  Then get the new
 643            type, if any.  */
 644         if (definition)
 645           gnu_size = validate_size (Esize (gnat_entity), gnu_type,
 646                                     gnat_entity, VAR_DECL, false,
 647                                     Has_Size_Clause (gnat_entity));
 648         else if (Has_Size_Clause (gnat_entity))
 649           gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
 650
 651         if (gnu_size)
 652           {
 653             gnu_type
 654               = make_type_from_size (gnu_type, gnu_size,
 655                                      Has_Biased_Representation (gnat_entity));
 656
 657             if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
 658               gnu_size = NULL_TREE;
 659           }
 660
 661         /* If this object has self-referential size, it must be a record with
 662            a default discriminant.  We are supposed to allocate an object of
 663            the maximum size in this case, unless it is a constant with an
 664            initializing expression, in which case we can get the size from
 665            that.  Note that the resulting size may still be a variable, so
 666            this may end up with an indirect allocation.  */
 667         if (No (Renamed_Object (gnat_entity))
 668             && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
 669           {
 670             if (gnu_expr && kind == E_Constant)
 671               {
 672                 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
 673                 if (CONTAINS_PLACEHOLDER_P (size))
 674                   {
 675                     /* If the initializing expression is itself a constant,
 676                        despite having a nominal type with self-referential
 677                        size, we can get the size directly from it.  */
 678                     if (TREE_CODE (gnu_expr) == COMPONENT_REF
 679                         && TYPE_IS_PADDING_P
 680                            (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
 681                         && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
 682                         && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
 683                             || DECL_READONLY_ONCE_ELAB
 684                                (TREE_OPERAND (gnu_expr, 0))))
 685                       gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
 686                     else
 687                       gnu_size
 688                         = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
 689                   }
 690                 else
 691                   gnu_size = size;
 692               }
 693             /* We may have no GNU_EXPR because No_Initialization is
 694                set even though there's an Expression.  */
 695             else if (kind == E_Constant
 696                      && (Nkind (Declaration_Node (gnat_entity))
 697                          == N_Object_Declaration)
 698                      && Present (Expression (Declaration_Node (gnat_entity))))
 699               gnu_size
 700                 = TYPE_SIZE (gnat_to_gnu_type
 701                              (Etype
 702                               (Expression (Declaration_Node (gnat_entity)))));
 703             else
 704               {
 705                 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
 706                 mutable_p = true;
 707               }
 708           }
 709
 710         /* If the size is zero byte, make it one byte since some linkers have
 711            troubles with zero-sized objects.  If the object will have a
 712            template, that will make it nonzero so don't bother.  Also avoid
 713            doing that for an object renaming or an object with an address
 714            clause, as we would lose useful information on the view size
 715            (e.g. for null array slices) and we are not allocating the object
 716            here anyway.  */
 717         if (((gnu_size
 718               && integer_zerop (gnu_size)
 719               && !TREE_OVERFLOW (gnu_size))
 720              || (TYPE_SIZE (gnu_type)
 721                  && integer_zerop (TYPE_SIZE (gnu_type))
 722                  && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
 723             && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
 724                 || !Is_Array_Type (Etype (gnat_entity)))
 725             && No (Renamed_Object (gnat_entity))
 726             && No (Address_Clause (gnat_entity)))
 727           gnu_size = bitsize_unit_node;
 728
 729         /* If this is an object with no specified size and alignment, and
 730            if either it is atomic or we are not optimizing alignment for
 731            space and it is composite and not an exception, an Out parameter
 732            or a reference to another object, and the size of its type is a
 733            constant, set the alignment to the smallest one which is not
 734            smaller than the size, with an appropriate cap.  */
 735         if (!gnu_size && align == 0
 736             && (Is_Atomic (gnat_entity)
 737                 || (!Optimize_Alignment_Space (gnat_entity)
 738                     && kind != E_Exception
 739                     && kind != E_Out_Parameter
 740                     && Is_Composite_Type (Etype (gnat_entity))
 741                     && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
 742                     && !imported_p
 743                     && No (Renamed_Object (gnat_entity))
 744                     && No (Address_Clause (gnat_entity))))
 745             && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
 746           {
 747             /* No point in jumping through all the hoops needed in order
 748                to support BIGGEST_ALIGNMENT if we don't really have to.
 749                So we cap to the smallest alignment that corresponds to
 750                a known efficient memory access pattern of the target.  */
 751             unsigned int align_cap = Is_Atomic (gnat_entity)
 752                                      ? BIGGEST_ALIGNMENT
 753                                      : get_mode_alignment (ptr_mode);
 754
 755             if (!host_integerp (TYPE_SIZE (gnu_type), 1)
 756                 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
 757               align = align_cap;
 758             else
 759               align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
 760
 761             /* But make sure not to under-align the object.  */
 762             if (align <= TYPE_ALIGN (gnu_type))
 763               align = 0;
 764
 765             /* And honor the minimum valid atomic alignment, if any.  */
 766 #ifdef MINIMUM_ATOMIC_ALIGNMENT
 767             else if (align < MINIMUM_ATOMIC_ALIGNMENT)
 768               align = MINIMUM_ATOMIC_ALIGNMENT;
 769 #endif
 770           }
 771
 772         /* If the object is set to have atomic components, find the component
 773            type and validate it.
 774
 775            ??? Note that we ignore Has_Volatile_Components on objects; it's
 776            not at all clear what to do in that case.  */
 777         if (Has_Atomic_Components (gnat_entity))
 778           {
 779             tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
 780                               ? TREE_TYPE (gnu_type) : gnu_type);
 781
 782             while (TREE_CODE (gnu_inner) == ARRAY_TYPE
 783                    && TYPE_MULTI_ARRAY_P (gnu_inner))
 784               gnu_inner = TREE_TYPE (gnu_inner);
 785
 786             check_ok_for_atomic (gnu_inner, gnat_entity, true);
 787           }
 788
 789         /* Now check if the type of the object allows atomic access.  Note
 790            that we must test the type, even if this object has size and
 791            alignment to allow such access, because we will be going inside
 792            the padded record to assign to the object.  We could fix this by
 793            always copying via an intermediate value, but it's not clear it's
 794            worth the effort.  */
 795         if (Is_Atomic (gnat_entity))
 796           check_ok_for_atomic (gnu_type, gnat_entity, false);
 797
 798         /* If this is an aliased object with an unconstrained nominal subtype,
 799            make a type that includes the template.  */
 800         if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
 801             && Is_Array_Type (Etype (gnat_entity))
 802             && !type_annotate_only)
 803         {
 804           tree gnu_fat
 805             = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
 806
 807           gnu_type
 808             = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
 809                                               concat_name (gnu_entity_name,
 810                                                            "UNC"),
 811                                               debug_info_p);
 812         }
 813
 814 #ifdef MINIMUM_ATOMIC_ALIGNMENT
 815         /* If the size is a constant and no alignment is specified, force
 816            the alignment to be the minimum valid atomic alignment.  The
 817            restriction on constant size avoids problems with variable-size
 818            temporaries; if the size is variable, there's no issue with
 819            atomic access.  Also don't do this for a constant, since it isn't
 820            necessary and can interfere with constant replacement.  Finally,
 821            do not do it for Out parameters since that creates an
 822            size inconsistency with In parameters.  */
 823         if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
 824             && !FLOAT_TYPE_P (gnu_type)
 825             && !const_flag && No (Renamed_Object (gnat_entity))
 826             && !imported_p && No (Address_Clause (gnat_entity))
 827             && kind != E_Out_Parameter
 828             && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
 829                 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
 830           align = MINIMUM_ATOMIC_ALIGNMENT;
 831 #endif
 832
 833         /* Make a new type with the desired size and alignment, if needed.
 834            But do not take into account alignment promotions to compute the
 835            size of the object.  */
 836         gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
 837         if (gnu_size || align > 0)
 838           gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
 839                                      false, false, definition,
 840                                      gnu_size ? true : false);
 841
 842         /* If this is a renaming, avoid as much as possible to create a new
 843            object.  However, in several cases, creating it is required.
 844            This processing needs to be applied to the raw expression so
 845            as to make it more likely to rename the underlying object.  */
 846         if (Present (Renamed_Object (gnat_entity)))
 847           {
 848             bool create_normal_object = false;
 849
 850             /* If the renamed object had padding, strip off the reference
 851                to the inner object and reset our type.  */
 852             if ((TREE_CODE (gnu_expr) == COMPONENT_REF
 853                  && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
 854                 /* Strip useless conversions around the object.  */
 855                 || (TREE_CODE (gnu_expr) == NOP_EXPR
 856                     && gnat_types_compatible_p
 857                        (TREE_TYPE (gnu_expr),
 858                         TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
 859               {
 860                 gnu_expr = TREE_OPERAND (gnu_expr, 0);
 861                 gnu_type = TREE_TYPE (gnu_expr);
 862               }
 863
 864             /* Case 1: If this is a constant renaming stemming from a function
 865                call, treat it as a normal object whose initial value is what
 866                is being renamed.  RM 3.3 says that the result of evaluating a
 867                function call is a constant object.  As a consequence, it can
 868                be the inner object of a constant renaming.  In this case, the
 869                renaming must be fully instantiated, i.e. it cannot be a mere
 870                reference to (part of) an existing object.  */
 871             if (const_flag)
 872               {
 873                 tree inner_object = gnu_expr;
 874                 while (handled_component_p (inner_object))
 875                   inner_object = TREE_OPERAND (inner_object, 0);
 876                 if (TREE_CODE (inner_object) == CALL_EXPR)
 877                   create_normal_object = true;
 878               }
 879
 880             /* Otherwise, see if we can proceed with a stabilized version of
 881                the renamed entity or if we need to make a new object.  */
 882             if (!create_normal_object)
 883               {
 884                 tree maybe_stable_expr = NULL_TREE;
 885                 bool stable = false;
 886
 887                 /* Case 2: If the renaming entity need not be materialized and
 888                    the renamed expression is something we can stabilize, use
 889                    that for the renaming.  At the global level, we can only do
 890                    this if we know no SAVE_EXPRs need be made, because the
 891                    expression we return might be used in arbitrary conditional
 892                    branches so we must force the SAVE_EXPRs evaluation
 893                    immediately and this requires a function context.  */
 894                 if (!Materialize_Entity (gnat_entity)
 895                     && (!global_bindings_p ()
 896                         || (staticp (gnu_expr)
 897                             && !TREE_SIDE_EFFECTS (gnu_expr))))
 898                   {
 899                     maybe_stable_expr
 900                       = gnat_stabilize_reference (gnu_expr, true, &stable);
 901
 902                     if (stable)
 903                       {
 904                         /* ??? No DECL_EXPR is created so we need to mark
 905                            the expression manually lest it is shared.  */
 906                         if (global_bindings_p ())
 907                           MARK_VISITED (maybe_stable_expr);
 908                         gnu_decl = maybe_stable_expr;
 909                         save_gnu_tree (gnat_entity, gnu_decl, true);
 910                         saved = true;
 911                         annotate_object (gnat_entity, gnu_type, NULL_TREE,
 912                                          false);
 913                         break;
 914                       }
 915
 916                     /* The stabilization failed.  Keep maybe_stable_expr
 917                        untouched here to let the pointer case below know
 918                        about that failure.  */
 919                   }
 920
 921                 /* Case 3: If this is a constant renaming and creating a
 922                    new object is allowed and cheap, treat it as a normal
 923                    object whose initial value is what is being renamed.  */
 924                 if (const_flag
 925                     && !Is_Composite_Type
 926                         (Underlying_Type (Etype (gnat_entity))))
 927                   ;
 928
 929                 /* Case 4: Make this into a constant pointer to the object we
 930                    are to rename and attach the object to the pointer if it is
 931                    something we can stabilize.
 932
 933                    From the proper scope, attached objects will be referenced
 934                    directly instead of indirectly via the pointer to avoid
 935                    subtle aliasing problems with non-addressable entities.
 936                    They have to be stable because we must not evaluate the
 937                    variables in the expression every time the renaming is used.
 938                    The pointer is called a "renaming" pointer in this case.
 939
 940                    In the rare cases where we cannot stabilize the renamed
 941                    object, we just make a "bare" pointer, and the renamed
 942                    entity is always accessed indirectly through it.  */
 943                 else
 944                   {
 945                     gnu_type = build_reference_type (gnu_type);
 946                     inner_const_flag = TREE_READONLY (gnu_expr);
 947                     const_flag = true;
 948
 949                     /* If the previous attempt at stabilizing failed, there
 950                        is no point in trying again and we reuse the result
 951                        without attaching it to the pointer.  In this case it
 952                        will only be used as the initializing expression of
 953                        the pointer and thus needs no special treatment with
 954                        regard to multiple evaluations.  */
 955                     if (maybe_stable_expr)
 956                       ;
 957
 958                     /* Otherwise, try to stabilize and attach the expression
 959                        to the pointer if the stabilization succeeds.
 960
 961                        Note that this might introduce SAVE_EXPRs and we don't
 962                        check whether we're at the global level or not.  This
 963                        is fine since we are building a pointer initializer and
 964                        neither the pointer nor the initializing expression can
 965                        be accessed before the pointer elaboration has taken
 966                        place in a correct program.
 967
 968                        These SAVE_EXPRs will be evaluated at the right place
 969                        by either the evaluation of the initializer for the
 970                        non-global case or the elaboration code for the global
 971                        case, and will be attached to the elaboration procedure
 972                        in the latter case.  */
 973                     else
 974                      {
 975                         maybe_stable_expr
 976                           = gnat_stabilize_reference (gnu_expr, true, &stable);
 977
 978                         if (stable)
 979                           renamed_obj = maybe_stable_expr;
 980
 981                         /* Attaching is actually performed downstream, as soon
 982                            as we have a VAR_DECL for the pointer we make.  */
 983                       }
 984
 985                     gnu_expr = build_unary_op (ADDR_EXPR, gnu_type,
 986                                                maybe_stable_expr);
 987
 988                     gnu_size = NULL_TREE;
 989                     used_by_ref = true;
 990                   }
 991               }
 992           }
 993
 994         /* Make a volatile version of this object's type if we are to make
 995            the object volatile.  We also interpret 13.3(19) conservatively
 996            and disallow any optimizations for such a non-constant object.  */
 997         if ((Treat_As_Volatile (gnat_entity)
 998              || (!const_flag
 999                  && (Is_Exported (gnat_entity)
1000                      || Is_Imported (gnat_entity)
1001                      || Present (Address_Clause (gnat_entity)))))
1002             && !TYPE_VOLATILE (gnu_type))
1003           gnu_type = build_qualified_type (gnu_type,
1004                                            (TYPE_QUALS (gnu_type)
1005                                             | TYPE_QUAL_VOLATILE));
1006
1007         /* If we are defining an aliased object whose nominal subtype is
1008            unconstrained, the object is a record that contains both the
1009            template and the object.  If there is an initializer, it will
1010            have already been converted to the right type, but we need to
1011            create the template if there is no initializer.  */
1012         if (definition
1013             && !gnu_expr
1014             && TREE_CODE (gnu_type) == RECORD_TYPE
1015             && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1016                 /* Beware that padding might have been introduced above.  */
1017                 || (TYPE_PADDING_P (gnu_type)
1018                     && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1019                        == RECORD_TYPE
1020                     && TYPE_CONTAINS_TEMPLATE_P
1021                        (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1022           {
1023             tree template_field
1024               = TYPE_PADDING_P (gnu_type)
1025                 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1026                 : TYPE_FIELDS (gnu_type);
1027             gnu_expr
1028               = gnat_build_constructor
1029                 (gnu_type,
1030                  tree_cons
1031                  (template_field,
1032                   build_template (TREE_TYPE (template_field),
1033                                   TREE_TYPE (TREE_CHAIN (template_field)),
1034                                   NULL_TREE),
1035                   NULL_TREE));
1036           }
1037
1038         /* Convert the expression to the type of the object except in the
1039            case where the object's type is unconstrained or the object's type
1040            is a padded record whose field is of self-referential size.  In
1041            the former case, converting will generate unnecessary evaluations
1042            of the CONSTRUCTOR to compute the size and in the latter case, we
1043            want to only copy the actual data.  */
1044         if (gnu_expr
1045             && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1046             && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1047             && !(TYPE_IS_PADDING_P (gnu_type)
1048                  && CONTAINS_PLACEHOLDER_P
1049                     (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1050           gnu_expr = convert (gnu_type, gnu_expr);
1051
1052         /* If this is a pointer that doesn't have an initializing expression,
1053            initialize it to NULL, unless the object is imported.  */
1054         if (definition
1055             && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1056             && !gnu_expr
1057             && !Is_Imported (gnat_entity))
1058           gnu_expr = integer_zero_node;
1059
1060         /* If we are defining the object and it has an Address clause, we must
1061            either get the address expression from the saved GCC tree for the
1062            object if it has a Freeze node, or elaborate the address expression
1063            here since the front-end has guaranteed that the elaboration has no
1064            effects in this case.  */
1065         if (definition && Present (Address_Clause (gnat_entity)))
1066           {
1067             Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1068             tree gnu_address
1069               = present_gnu_tree (gnat_entity)
1070                 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1071
1072             save_gnu_tree (gnat_entity, NULL_TREE, false);
1073
1074             /* Ignore the size.  It's either meaningless or was handled
1075                above.  */
1076             gnu_size = NULL_TREE;
1077             /* Convert the type of the object to a reference type that can
1078                alias everything as per 13.3(19).  */
1079             gnu_type
1080               = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1081             gnu_address = convert (gnu_type, gnu_address);
1082             used_by_ref = true;
1083             const_flag
1084               = !Is_Public (gnat_entity)
1085                 || compile_time_known_address_p (gnat_expr);
1086
1087             /* If this is a deferred constant, the initializer is attached to
1088                the full view.  */
1089             if (kind == E_Constant && Present (Full_View (gnat_entity)))
1090               gnu_expr
1091                 = gnat_to_gnu
1092                     (Expression (Declaration_Node (Full_View (gnat_entity))));
1093
1094             /* If we don't have an initializing expression for the underlying
1095                variable, the initializing expression for the pointer is the
1096                specified address.  Otherwise, we have to make a COMPOUND_EXPR
1097                to assign both the address and the initial value.  */
1098             if (!gnu_expr)
1099               gnu_expr = gnu_address;
1100             else
1101               gnu_expr
1102                 = build2 (COMPOUND_EXPR, gnu_type,
1103                           build_binary_op
1104                           (MODIFY_EXPR, NULL_TREE,
1105                            build_unary_op (INDIRECT_REF, NULL_TREE,
1106                                            gnu_address),
1107                            gnu_expr),
1108                           gnu_address);
1109           }
1110
1111         /* If it has an address clause and we are not defining it, mark it
1112            as an indirect object.  Likewise for Stdcall objects that are
1113            imported.  */
1114         if ((!definition && Present (Address_Clause (gnat_entity)))
1115             || (Is_Imported (gnat_entity)
1116                 && Has_Stdcall_Convention (gnat_entity)))
1117           {
1118             /* Convert the type of the object to a reference type that can
1119                alias everything as per 13.3(19).  */
1120             gnu_type
1121               = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1122             gnu_size = NULL_TREE;
1123
1124             /* No point in taking the address of an initializing expression
1125                that isn't going to be used.  */
1126             gnu_expr = NULL_TREE;
1127
1128             /* If it has an address clause whose value is known at compile
1129                time, make the object a CONST_DECL.  This will avoid a
1130                useless dereference.  */
1131             if (Present (Address_Clause (gnat_entity)))
1132               {
1133                 Node_Id gnat_address
1134                   = Expression (Address_Clause (gnat_entity));
1135
1136                 if (compile_time_known_address_p (gnat_address))
1137                   {
1138                     gnu_expr = gnat_to_gnu (gnat_address);
1139                     const_flag = true;
1140                   }
1141               }
1142
1143             used_by_ref = true;
1144           }
1145
1146         /* If we are at top level and this object is of variable size,
1147            make the actual type a hidden pointer to the real type and
1148            make the initializer be a memory allocation and initialization.
1149            Likewise for objects we aren't defining (presumed to be
1150            external references from other packages), but there we do
1151            not set up an initialization.
1152
1153            If the object's size overflows, make an allocator too, so that
1154            Storage_Error gets raised.  Note that we will never free
1155            such memory, so we presume it never will get allocated.  */
1156         if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1157                                  global_bindings_p ()
1158                                  || !definition
1159                                  || static_p)
1160             || (gnu_size && !allocatable_size_p (gnu_size,
1161                                                  global_bindings_p ()
1162                                                  || !definition
1163                                                  || static_p)))
1164           {
1165             gnu_type = build_reference_type (gnu_type);
1166             gnu_size = NULL_TREE;
1167             used_by_ref = true;
1168             const_flag = true;
1169
1170             /* In case this was a aliased object whose nominal subtype is
1171                unconstrained, the pointer above will be a thin pointer and
1172                build_allocator will automatically make the template.
1173
1174                If we have a template initializer only (that we made above),
1175                pretend there is none and rely on what build_allocator creates
1176                again anyway.  Otherwise (if we have a full initializer), get
1177                the data part and feed that to build_allocator.
1178
1179                If we are elaborating a mutable object, tell build_allocator to
1180                ignore a possibly simpler size from the initializer, if any, as
1181                we must allocate the maximum possible size in this case.  */
1182             if (definition)
1183               {
1184                 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1185
1186                 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1187                     && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1188                   {
1189                     gnu_alloc_type
1190                       = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1191
1192                     if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1193                         && 1 == VEC_length (constructor_elt,
1194                                             CONSTRUCTOR_ELTS (gnu_expr)))
1195                       gnu_expr = 0;
1196                     else
1197                       gnu_expr
1198                         = build_component_ref
1199                             (gnu_expr, NULL_TREE,
1200                              TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1201                              false);
1202                   }
1203
1204                 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1205                     && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1206                     && !Is_Imported (gnat_entity))
1207                   post_error ("?Storage_Error will be raised at run-time!",
1208                               gnat_entity);
1209
1210                 gnu_expr
1211                   = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1212                                      Empty, Empty, gnat_entity, mutable_p);
1213               }
1214             else
1215               {
1216                 gnu_expr = NULL_TREE;
1217                 const_flag = false;
1218               }
1219           }
1220
1221         /* If this object would go into the stack and has an alignment larger
1222            than the largest stack alignment the back-end can honor, resort to
1223            a variable of "aligning type".  */
1224         if (!global_bindings_p () && !static_p && definition
1225             && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1226           {
1227             /* Create the new variable.  No need for extra room before the
1228                aligned field as this is in automatic storage.  */
1229             tree gnu_new_type
1230               = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1231                                     TYPE_SIZE_UNIT (gnu_type),
1232                                     BIGGEST_ALIGNMENT, 0);
1233             tree gnu_new_var
1234               = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1235                                  NULL_TREE, gnu_new_type, NULL_TREE, false,
1236                                  false, false, false, NULL, gnat_entity);
1237
1238             /* Initialize the aligned field if we have an initializer.  */
1239             if (gnu_expr)
1240               add_stmt_with_node
1241                 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1242                                   build_component_ref
1243                                   (gnu_new_var, NULL_TREE,
1244                                    TYPE_FIELDS (gnu_new_type), false),
1245                                   gnu_expr),
1246                  gnat_entity);
1247
1248             /* And setup this entity as a reference to the aligned field.  */
1249             gnu_type = build_reference_type (gnu_type);
1250             gnu_expr
1251               = build_unary_op
1252                 (ADDR_EXPR, gnu_type,
1253                  build_component_ref (gnu_new_var, NULL_TREE,
1254                                       TYPE_FIELDS (gnu_new_type), false));
1255
1256             gnu_size = NULL_TREE;
1257             used_by_ref = true;
1258             const_flag = true;
1259           }
1260
1261         if (const_flag)
1262           gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1263                                                       | TYPE_QUAL_CONST));
1264
1265         /* Convert the expression to the type of the object except in the
1266            case where the object's type is unconstrained or the object's type
1267            is a padded record whose field is of self-referential size.  In
1268            the former case, converting will generate unnecessary evaluations
1269            of the CONSTRUCTOR to compute the size and in the latter case, we
1270            want to only copy the actual data.  */
1271         if (gnu_expr
1272             && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1273             && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1274             && !(TYPE_IS_PADDING_P (gnu_type)
1275                  && CONTAINS_PLACEHOLDER_P
1276                     (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1277           gnu_expr = convert (gnu_type, gnu_expr);
1278
1279         /* If this name is external or there was a name specified, use it,
1280            unless this is a VMS exception object since this would conflict
1281            with the symbol we need to export in addition.  Don't use the
1282            Interface_Name if there is an address clause (see CD30005).  */
1283         if (!Is_VMS_Exception (gnat_entity)
1284             && ((Present (Interface_Name (gnat_entity))
1285                  && No (Address_Clause (gnat_entity)))
1286                 || (Is_Public (gnat_entity)
1287                     && (!Is_Imported (gnat_entity)
1288                         || Is_Exported (gnat_entity)))))
1289           gnu_ext_name = create_concat_name (gnat_entity, NULL);
1290
1291         /* If this is an aggregate constant initialized to a constant, force it
1292            to be statically allocated.  This saves an initialization copy.  */
1293         if (!static_p
1294             && const_flag
1295             && gnu_expr && TREE_CONSTANT (gnu_expr)
1296             && AGGREGATE_TYPE_P (gnu_type)
1297             && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1298             && !(TYPE_IS_PADDING_P (gnu_type)
1299                  && !host_integerp (TYPE_SIZE_UNIT
1300                                     (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1301           static_p = true;
1302
1303         /* Now create the variable or the constant and set various flags.  */
1304         gnu_decl
1305           = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1306                              gnu_expr, const_flag, Is_Public (gnat_entity),
1307                              imported_p || !definition, static_p, attr_list,
1308                              gnat_entity);
1309         DECL_BY_REF_P (gnu_decl) = used_by_ref;
1310         DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1311
1312         /* If we are defining an Out parameter and optimization isn't enabled,
1313            create a fake PARM_DECL for debugging purposes and make it point to
1314            the VAR_DECL.  Suppress debug info for the latter but make sure it
1315            will live on the stack so that it can be accessed from within the
1316            debugger through the PARM_DECL.  */
1317         if (kind == E_Out_Parameter && definition && !optimize && debug_info_p)
1318           {
1319             tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1320             gnat_pushdecl (param, gnat_entity);
1321             SET_DECL_VALUE_EXPR (param, gnu_decl);
1322             DECL_HAS_VALUE_EXPR_P (param) = 1;
1323             DECL_IGNORED_P (gnu_decl) = 1;
1324             TREE_ADDRESSABLE (gnu_decl) = 1;
1325           }
1326
1327         /* If this is a renaming pointer, attach the renamed object to it and
1328            register it if we are at top level.  */
1329         if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1330           {
1331             SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1332             if (global_bindings_p ())
1333               {
1334                 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1335                 record_global_renaming_pointer (gnu_decl);
1336               }
1337           }
1338
1339         /* If this is a constant and we are defining it or it generates a real
1340            symbol at the object level and we are referencing it, we may want
1341            or need to have a true variable to represent it:
1342              - if optimization isn't enabled, for debugging purposes,
1343              - if the constant is public and not overlaid on something else,
1344              - if its address is taken,
1345              - if either itself or its type is aliased.  */
1346         if (TREE_CODE (gnu_decl) == CONST_DECL
1347             && (definition || Sloc (gnat_entity) > Standard_Location)
1348             && ((!optimize && debug_info_p)
1349                 || (Is_Public (gnat_entity)
1350                     && No (Address_Clause (gnat_entity)))
1351                 || Address_Taken (gnat_entity)
1352                 || Is_Aliased (gnat_entity)
1353                 || Is_Aliased (Etype (gnat_entity))))
1354           {
1355             tree gnu_corr_var
1356               = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1357                                       gnu_expr, true, Is_Public (gnat_entity),
1358                                       !definition, static_p, attr_list,
1359                                       gnat_entity);
1360
1361             SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1362
1363             /* As debugging information will be generated for the variable,
1364                do not generate debugging information for the constant.  */
1365             if (debug_info_p)
1366               DECL_IGNORED_P (gnu_decl) = 1;
1367             else
1368               DECL_IGNORED_P (gnu_corr_var) = 1;
1369           }
1370
1371         /* If this is a constant, even if we don't need a true variable, we
1372            may need to avoid returning the initializer in every case.  That
1373            can happen for the address of a (constant) constructor because,
1374            upon dereferencing it, the constructor will be reinjected in the
1375            tree, which may not be valid in every case; see lvalue_required_p
1376            for more details.  */
1377         if (TREE_CODE (gnu_decl) == CONST_DECL)
1378           DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1379
1380         /* If this object is declared in a block that contains a block with an
1381            exception handler, and we aren't using the GCC exception mechanism,
1382            we must force this variable in memory in order to avoid an invalid
1383            optimization.  */
1384         if (Exception_Mechanism != Back_End_Exceptions
1385             && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1386           TREE_ADDRESSABLE (gnu_decl) = 1;
1387
1388         /* If we are defining an object with variable size or an object with
1389            fixed size that will be dynamically allocated, and we are using the
1390            setjmp/longjmp exception mechanism, update the setjmp buffer.  */
1391         if (definition
1392             && Exception_Mechanism == Setjmp_Longjmp
1393             && get_block_jmpbuf_decl ()
1394             && DECL_SIZE_UNIT (gnu_decl)
1395             && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1396                 || (flag_stack_check == GENERIC_STACK_CHECK
1397                     && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1398                                          STACK_CHECK_MAX_VAR_SIZE) > 0)))
1399           add_stmt_with_node (build_call_1_expr
1400                               (update_setjmp_buf_decl,
1401                                build_unary_op (ADDR_EXPR, NULL_TREE,
1402                                                get_block_jmpbuf_decl ())),
1403                               gnat_entity);
1404
1405         /* Back-annotate Esize and Alignment of the object if not already
1406            known.  Note that we pick the values of the type, not those of
1407            the object, to shield ourselves from low-level platform-dependent
1408            adjustments like alignment promotion.  This is both consistent with
1409            all the treatment above, where alignment and size are set on the
1410            type of the object and not on the object directly, and makes it
1411            possible to support all confirming representation clauses.  */
1412         annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1413                          used_by_ref);
1414       }
1415       break;
1416
1417     case E_Void:
1418       /* Return a TYPE_DECL for "void" that we previously made.  */
1419       gnu_decl = TYPE_NAME (void_type_node);
1420       break;
1421
1422     case E_Enumeration_Type:
1423       /* A special case: for the types Character and Wide_Character in
1424          Standard, we do not list all the literals.  So if the literals
1425          are not specified, make this an unsigned type.  */
1426       if (No (First_Literal (gnat_entity)))
1427         {
1428           gnu_type = make_unsigned_type (esize);
1429           TYPE_NAME (gnu_type) = gnu_entity_name;
1430
1431           /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1432              This is needed by the DWARF-2 back-end to distinguish between
1433              unsigned integer types and character types.  */
1434           TYPE_STRING_FLAG (gnu_type) = 1;
1435           break;
1436         }
1437
1438       {
1439         /* We have a list of enumeral constants in First_Literal.  We make a
1440            CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1441            be placed into TYPE_FIELDS.  Each node in the list is a TREE_LIST
1442            whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1443            value of the literal.  But when we have a regular boolean type, we
1444            simplify this a little by using a BOOLEAN_TYPE.  */
1445         bool is_boolean = Is_Boolean_Type (gnat_entity)
1446                           && !Has_Non_Standard_Rep (gnat_entity);
1447         tree gnu_literal_list = NULL_TREE;
1448         Entity_Id gnat_literal;
1449
1450         if (Is_Unsigned_Type (gnat_entity))
1451           gnu_type = make_unsigned_type (esize);
1452         else
1453           gnu_type = make_signed_type (esize);
1454
1455         TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1456
1457         for (gnat_literal = First_Literal (gnat_entity);
1458              Present (gnat_literal);
1459              gnat_literal = Next_Literal (gnat_literal))
1460           {
1461             tree gnu_value
1462               = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1463             tree gnu_literal
1464               = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1465                                  gnu_type, gnu_value, true, false, false,
1466                                  false, NULL, gnat_literal);
1467
1468             save_gnu_tree (gnat_literal, gnu_literal, false);
1469             gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1470                                           gnu_value, gnu_literal_list);
1471           }
1472
1473         if (!is_boolean)
1474           TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1475
1476         /* Note that the bounds are updated at the end of this function
1477            to avoid an infinite recursion since they refer to the type.  */
1478       }
1479       break;
1480
1481     case E_Signed_Integer_Type:
1482     case E_Ordinary_Fixed_Point_Type:
1483     case E_Decimal_Fixed_Point_Type:
1484       /* For integer types, just make a signed type the appropriate number
1485          of bits.  */
1486       gnu_type = make_signed_type (esize);
1487       break;
1488
1489     case E_Modular_Integer_Type:
1490       {
1491         /* For modular types, make the unsigned type of the proper number
1492            of bits and then set up the modulus, if required.  */
1493         tree gnu_modulus, gnu_high = NULL_TREE;
1494
1495         /* Packed array types are supposed to be subtypes only.  */
1496         gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1497
1498         gnu_type = make_unsigned_type (esize);
1499
1500         /* Get the modulus in this type.  If it overflows, assume it is because
1501            it is equal to 2**Esize.  Note that there is no overflow checking
1502            done on unsigned type, so we detect the overflow by looking for
1503            a modulus of zero, which is otherwise invalid.  */
1504         gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1505
1506         if (!integer_zerop (gnu_modulus))
1507           {
1508             TYPE_MODULAR_P (gnu_type) = 1;
1509             SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1510             gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1511                                     convert (gnu_type, integer_one_node));
1512           }
1513
1514         /* If the upper bound is not maximal, make an extra subtype.  */
1515         if (gnu_high
1516             && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1517           {
1518             tree gnu_subtype = make_unsigned_type (esize);
1519             SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1520             TREE_TYPE (gnu_subtype) = gnu_type;
1521             TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1522             TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1523             gnu_type = gnu_subtype;
1524           }
1525       }
1526       break;
1527
1528     case E_Signed_Integer_Subtype:
1529     case E_Enumeration_Subtype:
1530     case E_Modular_Integer_Subtype:
1531     case E_Ordinary_Fixed_Point_Subtype:
1532     case E_Decimal_Fixed_Point_Subtype:
1533
1534       /* For integral subtypes, we make a new INTEGER_TYPE.  Note that we do
1535          not want to call create_range_type since we would like each subtype
1536          node to be distinct.  ??? Historically this was in preparation for
1537          when memory aliasing is implemented, but that's obsolete now given
1538          the call to relate_alias_sets below.
1539
1540          The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1541          this fact is used by the arithmetic conversion functions.
1542
1543          We elaborate the Ancestor_Subtype if it is not in the current unit
1544          and one of our bounds is non-static.  We do this to ensure consistent
1545          naming in the case where several subtypes share the same bounds, by
1546          elaborating the first such subtype first, thus using its name.  */
1547
1548       if (!definition
1549           && Present (Ancestor_Subtype (gnat_entity))
1550           && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1551           && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1552               || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1553         gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1554
1555       /* Set the precision to the Esize except for bit-packed arrays.  */
1556       if (Is_Packed_Array_Type (gnat_entity)
1557           && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1558         esize = UI_To_Int (RM_Size (gnat_entity));
1559
1560       /* This should be an unsigned type if the base type is unsigned or
1561          if the lower bound is constant and non-negative or if the type
1562          is biased.  */
1563       if (Is_Unsigned_Type (Etype (gnat_entity))
1564           || Is_Unsigned_Type (gnat_entity)
1565           || Has_Biased_Representation (gnat_entity))
1566         gnu_type = make_unsigned_type (esize);
1567       else
1568         gnu_type = make_signed_type (esize);
1569       TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1570
1571       SET_TYPE_RM_MIN_VALUE
1572         (gnu_type,
1573          convert (TREE_TYPE (gnu_type),
1574                   elaborate_expression (Type_Low_Bound (gnat_entity),
1575                                         gnat_entity, get_identifier ("L"),
1576                                         definition, true,
1577                                         Needs_Debug_Info (gnat_entity))));
1578
1579       SET_TYPE_RM_MAX_VALUE
1580         (gnu_type,
1581          convert (TREE_TYPE (gnu_type),
1582                   elaborate_expression (Type_High_Bound (gnat_entity),
1583                                         gnat_entity, get_identifier ("U"),
1584                                         definition, true,
1585                                         Needs_Debug_Info (gnat_entity))));
1586
1587       /* One of the above calls might have caused us to be elaborated,
1588          so don't blow up if so.  */
1589       if (present_gnu_tree (gnat_entity))
1590         {
1591           maybe_present = true;
1592           break;
1593         }
1594
1595       TYPE_BIASED_REPRESENTATION_P (gnu_type)
1596         = Has_Biased_Representation (gnat_entity);
1597
1598       /* Attach the TYPE_STUB_DECL in case we have a parallel type.  */
1599       TYPE_STUB_DECL (gnu_type)
1600         = create_type_stub_decl (gnu_entity_name, gnu_type);
1601
1602       /* Inherit our alias set from what we're a subtype of.  Subtypes
1603          are not different types and a pointer can designate any instance
1604          within a subtype hierarchy.  */
1605       relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1606
1607       /* For a packed array, make the original array type a parallel type.  */
1608       if (debug_info_p
1609           && Is_Packed_Array_Type (gnat_entity)
1610           && present_gnu_tree (Original_Array_Type (gnat_entity)))
1611         add_parallel_type (TYPE_STUB_DECL (gnu_type),
1612                            gnat_to_gnu_type
1613                            (Original_Array_Type (gnat_entity)));
1614
1615       /* We have to handle clauses that under-align the type specially.  */
1616       if ((Present (Alignment_Clause (gnat_entity))
1617            || (Is_Packed_Array_Type (gnat_entity)
1618                && Present
1619                   (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1620           && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1621         {
1622           align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1623           if (align >= TYPE_ALIGN (gnu_type))
1624             align = 0;
1625         }
1626
1627       /* If the type we are dealing with represents a bit-packed array,
1628          we need to have the bits left justified on big-endian targets
1629          and right justified on little-endian targets.  We also need to
1630          ensure that when the value is read (e.g. for comparison of two
1631          such values), we only get the good bits, since the unused bits
1632          are uninitialized.  Both goals are accomplished by wrapping up
1633          the modular type in an enclosing record type.  */
1634       if (Is_Packed_Array_Type (gnat_entity)
1635           && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1636         {
1637           tree gnu_field_type, gnu_field;
1638
1639           /* Set the RM size before wrapping up the original type.  */
1640           SET_TYPE_RM_SIZE (gnu_type,
1641                             UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1642           TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1643
1644           /* Create a stripped-down declaration, mainly for debugging.  */
1645           create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1646                             debug_info_p, gnat_entity);
1647
1648           /* Now save it and build the enclosing record type.  */
1649           gnu_field_type = gnu_type;
1650
1651           gnu_type = make_node (RECORD_TYPE);
1652           TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1653           TYPE_PACKED (gnu_type) = 1;
1654           TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1655           TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1656           SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1657
1658           /* Propagate the alignment of the modular type to the record type,
1659              unless there is an alignment clause that under-aligns the type.
1660              This means that bit-packed arrays are given "ceil" alignment for
1661              their size by default, which may seem counter-intuitive but makes
1662              it possible to overlay them on modular types easily.  */
1663           TYPE_ALIGN (gnu_type)
1664             = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1665
1666           relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1667
1668           /* Don't notify the field as "addressable", since we won't be taking
1669              it's address and it would prevent create_field_decl from making a
1670              bitfield.  */
1671           gnu_field = create_field_decl (get_identifier ("OBJECT"),
1672                                          gnu_field_type, gnu_type, 1,
1673                                          NULL_TREE, bitsize_zero_node, 0);
1674
1675           /* Do not emit debug info until after the parallel type is added.  */
1676           finish_record_type (gnu_type, gnu_field, 2, false);
1677           compute_record_mode (gnu_type);
1678           TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1679
1680           if (debug_info_p)
1681             {
1682               /* Make the original array type a parallel type.  */
1683               if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1684                 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1685                                    gnat_to_gnu_type
1686                                    (Original_Array_Type (gnat_entity)));
1687
1688               rest_of_record_type_compilation (gnu_type);
1689             }
1690         }
1691
1692       /* If the type we are dealing with has got a smaller alignment than the
1693          natural one, we need to wrap it up in a record type and under-align
1694          the latter.  We reuse the padding machinery for this purpose.  */
1695       else if (align > 0)
1696         {
1697           tree gnu_field_type, gnu_field;
1698
1699           /* Set the RM size before wrapping up the type.  */
1700           SET_TYPE_RM_SIZE (gnu_type,
1701                             UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1702
1703           /* Create a stripped-down declaration, mainly for debugging.  */
1704           create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1705                             debug_info_p, gnat_entity);
1706
1707           /* Now save it and build the enclosing record type.  */
1708           gnu_field_type = gnu_type;
1709
1710           gnu_type = make_node (RECORD_TYPE);
1711           TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1712           TYPE_PACKED (gnu_type) = 1;
1713           TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1714           TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1715           SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1716           TYPE_ALIGN (gnu_type) = align;
1717           relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1718
1719           /* Don't notify the field as "addressable", since we won't be taking
1720              it's address and it would prevent create_field_decl from making a
1721              bitfield.  */
1722           gnu_field = create_field_decl (get_identifier ("F"),
1723                                          gnu_field_type, gnu_type, 1,
1724                                          NULL_TREE, bitsize_zero_node, 0);
1725
1726           finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1727           compute_record_mode (gnu_type);
1728           TYPE_PADDING_P (gnu_type) = 1;
1729         }
1730
1731       break;
1732
1733     case E_Floating_Point_Type:
1734       /* If this is a VAX floating-point type, use an integer of the proper
1735          size.  All the operations will be handled with ASM statements.  */
1736       if (Vax_Float (gnat_entity))
1737         {
1738           gnu_type = make_signed_type (esize);
1739           TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1740           SET_TYPE_DIGITS_VALUE (gnu_type,
1741                                  UI_To_gnu (Digits_Value (gnat_entity),
1742                                             sizetype));
1743           break;
1744         }
1745
1746       /* The type of the Low and High bounds can be our type if this is
1747          a type from Standard, so set them at the end of the function.  */
1748       gnu_type = make_node (REAL_TYPE);
1749       TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1750       layout_type (gnu_type);
1751       break;
1752
1753     case E_Floating_Point_Subtype:
1754       if (Vax_Float (gnat_entity))
1755         {
1756           gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1757           break;
1758         }
1759
1760       {
1761         if (!definition
1762             && Present (Ancestor_Subtype (gnat_entity))
1763             && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1764             && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1765                 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1766           gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1767                               gnu_expr, 0);
1768
1769         gnu_type = make_node (REAL_TYPE);
1770         TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1771         TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1772         TYPE_GCC_MIN_VALUE (gnu_type)
1773           = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1774         TYPE_GCC_MAX_VALUE (gnu_type)
1775           = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1776         layout_type (gnu_type);
1777
1778         SET_TYPE_RM_MIN_VALUE
1779           (gnu_type,
1780            convert (TREE_TYPE (gnu_type),
1781                     elaborate_expression (Type_Low_Bound (gnat_entity),
1782                                           gnat_entity, get_identifier ("L"),
1783                                           definition, true,
1784                                           Needs_Debug_Info (gnat_entity))));
1785
1786         SET_TYPE_RM_MAX_VALUE
1787           (gnu_type,
1788            convert (TREE_TYPE (gnu_type),
1789                     elaborate_expression (Type_High_Bound (gnat_entity),
1790                                           gnat_entity, get_identifier ("U"),
1791                                           definition, true,
1792                                           Needs_Debug_Info (gnat_entity))));
1793
1794         /* One of the above calls might have caused us to be elaborated,
1795            so don't blow up if so.  */
1796         if (present_gnu_tree (gnat_entity))
1797           {
1798             maybe_present = true;
1799             break;
1800           }
1801
1802         /* Inherit our alias set from what we're a subtype of, as for
1803            integer subtypes.  */
1804         relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1805       }
1806     break;
1807
1808       /* Array and String Types and Subtypes
1809
1810          Unconstrained array types are represented by E_Array_Type and
1811          constrained array types are represented by E_Array_Subtype.  There
1812          are no actual objects of an unconstrained array type; all we have
1813          are pointers to that type.
1814
1815          The following fields are defined on array types and subtypes:
1816
1817                 Component_Type     Component type of the array.
1818                 Number_Dimensions  Number of dimensions (an int).
1819                 First_Index        Type of first index.  */
1820
1821     case E_String_Type:
1822     case E_Array_Type:
1823       {
1824         Entity_Id gnat_index, gnat_name;
1825         const bool convention_fortran_p
1826           = (Convention (gnat_entity) == Convention_Fortran);
1827         const int ndim = Number_Dimensions (gnat_entity);
1828         tree gnu_template_fields = NULL_TREE;
1829         tree gnu_template_type = make_node (RECORD_TYPE);
1830         tree gnu_template_reference;
1831         tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1832         tree gnu_fat_type = make_node (RECORD_TYPE);
1833         tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
1834         tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
1835         tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
1836         int index;
1837
1838         TYPE_NAME (gnu_template_type)
1839           = create_concat_name (gnat_entity, "XUB");
1840
1841         /* Make a node for the array.  If we are not defining the array
1842            suppress expanding incomplete types.  */
1843         gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1844
1845         if (!definition)
1846           {
1847             defer_incomplete_level++;
1848             this_deferred = true;
1849           }
1850
1851         /* Build the fat pointer type.  Use a "void *" object instead of
1852            a pointer to the array type since we don't have the array type
1853            yet (it will reference the fat pointer via the bounds).  */
1854         tem = chainon (chainon (NULL_TREE,
1855                                 create_field_decl (get_identifier ("P_ARRAY"),
1856                                                    ptr_void_type_node,
1857                                                    gnu_fat_type, 0,
1858                                                    NULL_TREE, NULL_TREE, 0)),
1859                        create_field_decl (get_identifier ("P_BOUNDS"),
1860                                           gnu_ptr_template,
1861                                           gnu_fat_type, 0,
1862                                           NULL_TREE, NULL_TREE, 0));
1863
1864         /* Make sure we can put this into a register.  */
1865         TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1866
1867         /* Do not emit debug info for this record type since the types of its
1868            fields are still incomplete at this point.  */
1869         finish_record_type (gnu_fat_type, tem, 0, false);
1870         TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
1871
1872         /* Build a reference to the template from a PLACEHOLDER_EXPR that
1873            is the fat pointer.  This will be used to access the individual
1874            fields once we build them.  */
1875         tem = build3 (COMPONENT_REF, gnu_ptr_template,
1876                       build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1877                       TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1878         gnu_template_reference
1879           = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1880         TREE_READONLY (gnu_template_reference) = 1;
1881
1882         /* Now create the GCC type for each index and add the fields for that
1883            index to the template.  */
1884         for (index = (convention_fortran_p ? ndim - 1 : 0),
1885              gnat_index = First_Index (gnat_entity);
1886              0 <= index && index < ndim;
1887              index += (convention_fortran_p ? - 1 : 1),
1888              gnat_index = Next_Index (gnat_index))
1889           {
1890             char field_name[16];
1891             tree gnu_index_base_type
1892               = get_unpadded_type (Base_Type (Etype (gnat_index)));
1893             tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
1894             tree gnu_min, gnu_max, gnu_high;
1895
1896             /* Make the FIELD_DECLs for the low and high bounds of this
1897                type and then make extractions of these fields from the
1898                template.  */
1899             sprintf (field_name, "LB%d", index);
1900             gnu_lb_field = create_field_decl (get_identifier (field_name),
1901                                               gnu_index_base_type,
1902                                               gnu_template_type, 0,
1903                                               NULL_TREE, NULL_TREE, 0);
1904             Sloc_to_locus (Sloc (gnat_entity),
1905                            &DECL_SOURCE_LOCATION (gnu_lb_field));
1906
1907             field_name[0] = 'U';
1908             gnu_hb_field = create_field_decl (get_identifier (field_name),
1909                                               gnu_index_base_type,
1910                                               gnu_template_type, 0,
1911                                               NULL_TREE, NULL_TREE, 0);
1912             Sloc_to_locus (Sloc (gnat_entity),
1913                            &DECL_SOURCE_LOCATION (gnu_hb_field));
1914
1915             gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
1916
1917             /* We can't use build_component_ref here since the template type
1918                isn't complete yet.  */
1919             gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
1920                                    gnu_template_reference, gnu_lb_field,
1921                                    NULL_TREE);
1922             gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
1923                                    gnu_template_reference, gnu_hb_field,
1924                                    NULL_TREE);
1925             TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
1926
1927             gnu_min = convert (sizetype, gnu_orig_min);
1928             gnu_max = convert (sizetype, gnu_orig_max);
1929
1930             /* Compute the size of this dimension.  See the E_Array_Subtype
1931                case below for the rationale.  */
1932             gnu_high
1933               = build3 (COND_EXPR, sizetype,
1934                         build2 (GE_EXPR, boolean_type_node,
1935                                 gnu_orig_max, gnu_orig_min),
1936                         gnu_max,
1937                         size_binop (MINUS_EXPR, gnu_min, size_one_node));
1938
1939             /* Make a range type with the new range in the Ada base type.
1940                Then make an index type with the size range in sizetype.  */
1941             gnu_index_types[index]
1942               = create_index_type (gnu_min, gnu_high,
1943                                    create_range_type (gnu_index_base_type,
1944                                                       gnu_orig_min,
1945                                                       gnu_orig_max),
1946                                    gnat_entity);
1947
1948             /* Update the maximum size of the array in elements.  */
1949             if (gnu_max_size)
1950               {
1951                 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
1952                 tree gnu_min
1953                   = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
1954                 tree gnu_max
1955                   = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
1956                 tree gnu_this_max
1957                   = size_binop (MAX_EXPR,
1958                                 size_binop (PLUS_EXPR, size_one_node,
1959                                             size_binop (MINUS_EXPR,
1960                                                         gnu_max, gnu_min)),
1961                                 size_zero_node);
1962
1963                 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1964                     && TREE_OVERFLOW (gnu_this_max))
1965                   gnu_max_size = NULL_TREE;
1966                 else
1967                   gnu_max_size
1968                     = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1969               }
1970
1971             TYPE_NAME (gnu_index_types[index])
1972               = create_concat_name (gnat_entity, field_name);
1973           }
1974
1975         for (index = 0; index < ndim; index++)
1976           gnu_template_fields
1977             = chainon (gnu_template_fields, gnu_temp_fields[index]);
1978
1979         /* Install all the fields into the template.  */
1980         finish_record_type (gnu_template_type, gnu_template_fields, 0,
1981                             debug_info_p);
1982         TYPE_READONLY (gnu_template_type) = 1;
1983
1984         /* Now make the array of arrays and update the pointer to the array
1985            in the fat pointer.  Note that it is the first field.  */
1986         tem = gnat_to_gnu_component_type (gnat_entity, definition,
1987                                           debug_info_p);
1988
1989         /* If Component_Size is not already specified, annotate it with the
1990            size of the component.  */
1991         if (Unknown_Component_Size (gnat_entity))
1992           Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1993
1994         /* Compute the maximum size of the array in units and bits.  */
1995         if (gnu_max_size)
1996           {
1997             gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1998                                             TYPE_SIZE_UNIT (tem));
1999             gnu_max_size = size_binop (MULT_EXPR,
2000                                        convert (bitsizetype, gnu_max_size),
2001                                        TYPE_SIZE (tem));
2002           }
2003         else
2004           gnu_max_size_unit = NULL_TREE;
2005
2006         /* Now build the array type.  */
2007         for (index = ndim - 1; index >= 0; index--)
2008           {
2009             tem = build_array_type (tem, gnu_index_types[index]);
2010             TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2011             if (array_type_has_nonaliased_component (tem, gnat_entity))
2012               TYPE_NONALIASED_COMPONENT (tem) = 1;
2013           }
2014
2015         /* If an alignment is specified, use it if valid.  But ignore it
2016            for the original type of packed array types.  If the alignment
2017            was requested with an explicit alignment clause, state so.  */
2018         if (No (Packed_Array_Type (gnat_entity))
2019             && Known_Alignment (gnat_entity))
2020           {
2021             TYPE_ALIGN (tem)
2022               = validate_alignment (Alignment (gnat_entity), gnat_entity,
2023                                     TYPE_ALIGN (tem));
2024             if (Present (Alignment_Clause (gnat_entity)))
2025               TYPE_USER_ALIGN (tem) = 1;
2026           }
2027
2028         TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2029         TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2030
2031         /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2032            corresponding fat pointer.  */
2033         TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
2034           = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2035         SET_TYPE_MODE (gnu_type, BLKmode);
2036         TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2037         SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2038
2039         /* If the maximum size doesn't overflow, use it.  */
2040         if (gnu_max_size
2041             && TREE_CODE (gnu_max_size) == INTEGER_CST
2042             && !TREE_OVERFLOW (gnu_max_size)
2043             && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2044             && !TREE_OVERFLOW (gnu_max_size_unit))
2045           {
2046             TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2047                                           TYPE_SIZE (tem));
2048             TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2049                                                TYPE_SIZE_UNIT (tem));
2050           }
2051
2052         create_type_decl (create_concat_name (gnat_entity, "XUA"),
2053                           tem, NULL, !Comes_From_Source (gnat_entity),
2054                           debug_info_p, gnat_entity);
2055
2056         /* Give the fat pointer type a name.  If this is a packed type, tell
2057            the debugger how to interpret the underlying bits.  */
2058         if (Present (Packed_Array_Type (gnat_entity)))
2059           gnat_name = Packed_Array_Type (gnat_entity);
2060         else
2061           gnat_name = gnat_entity;
2062         create_type_decl (create_concat_name (gnat_name, "XUP"),
2063                           gnu_fat_type, NULL, true,
2064                           debug_info_p, gnat_entity);
2065
2066         /* Create the type to be used as what a thin pointer designates:
2067            a record type for the object and its template with the fields
2068            shifted to have the template at a negative offset.  */
2069         tem = build_unc_object_type (gnu_template_type, tem,
2070                                      create_concat_name (gnat_name, "XUT"),
2071                                      debug_info_p);
2072         shift_unc_components_for_thin_pointers (tem);
2073
2074         SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2075         TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2076       }
2077       break;
2078
2079     case E_String_Subtype:
2080     case E_Array_Subtype:
2081
2082       /* This is the actual data type for array variables.  Multidimensional
2083          arrays are implemented as arrays of arrays.  Note that arrays which
2084          have sparse enumeration subtypes as index components create sparse
2085          arrays, which is obviously space inefficient but so much easier to
2086          code for now.
2087
2088          Also note that the subtype never refers to the unconstrained array
2089          type, which is somewhat at variance with Ada semantics.
2090
2091          First check to see if this is simply a renaming of the array type.
2092          If so, the result is the array type.  */
2093
2094       gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2095       if (!Is_Constrained (gnat_entity))
2096         ;
2097       else
2098         {
2099           Entity_Id gnat_index, gnat_base_index;
2100           const bool convention_fortran_p
2101             = (Convention (gnat_entity) == Convention_Fortran);
2102           const int ndim = Number_Dimensions (gnat_entity);
2103           tree gnu_base_type = gnu_type;
2104           tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
2105           tree gnu_max_size = size_one_node, gnu_max_size_unit;
2106           bool need_index_type_struct = false;
2107           int index;
2108
2109           /* First create the GCC type for each index and find out whether
2110              special types are needed for debugging information.  */
2111           for (index = (convention_fortran_p ? ndim - 1 : 0),
2112                gnat_index = First_Index (gnat_entity),
2113                gnat_base_index
2114                  = First_Index (Implementation_Base_Type (gnat_entity));
2115                0 <= index && index < ndim;
2116                index += (convention_fortran_p ? - 1 : 1),
2117                gnat_index = Next_Index (gnat_index),
2118                gnat_base_index = Next_Index (gnat_base_index))
2119             {
2120               tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2121               tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2122               tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2123               tree gnu_min = convert (sizetype, gnu_orig_min);
2124               tree gnu_max = convert (sizetype, gnu_orig_max);
2125               tree gnu_base_index_type
2126                 = get_unpadded_type (Etype (gnat_base_index));
2127               tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2128               tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2129               tree gnu_high;
2130
2131               /* See if the base array type is already flat.  If it is, we
2132                  are probably compiling an ACATS test but it will cause the
2133                  code below to malfunction if we don't handle it specially.  */
2134               if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2135                   && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2136                   && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2137                 {
2138                   gnu_min = size_one_node;
2139                   gnu_max = size_zero_node;
2140                   gnu_high = gnu_max;
2141                 }
2142
2143               /* Similarly, if one of the values overflows in sizetype and the
2144                  range is null, use 1..0 for the sizetype bounds.  */
2145               else if (TREE_CODE (gnu_min) == INTEGER_CST
2146                        && TREE_CODE (gnu_max) == INTEGER_CST
2147                        && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2148                        && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2149                 {
2150                   gnu_min = size_one_node;
2151                   gnu_max = size_zero_node;
2152                   gnu_high = gnu_max;
2153                 }
2154
2155               /* If the minimum and maximum values both overflow in sizetype,
2156                  but the difference in the original type does not overflow in
2157                  sizetype, ignore the overflow indication.  */
2158               else if (TREE_CODE (gnu_min) == INTEGER_CST
2159                        && TREE_CODE (gnu_max) == INTEGER_CST
2160                        && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2161                        && !TREE_OVERFLOW
2162                            (convert (sizetype,
2163                                      fold_build2 (MINUS_EXPR, gnu_index_type,
2164                                                   gnu_orig_max,
2165                                                   gnu_orig_min))))
2166                 {
2167                   TREE_OVERFLOW (gnu_min) = 0;
2168                   TREE_OVERFLOW (gnu_max) = 0;
2169                   gnu_high = gnu_max;
2170                 }
2171
2172               /* Compute the size of this dimension in the general case.  We
2173                  need to provide GCC with an upper bound to use but have to
2174                  deal with the "superflat" case.  There are three ways to do
2175                  this.  If we can prove that the array can never be superflat,
2176                  we can just use the high bound of the index type.  */
2177               else if ((Nkind (gnat_index) == N_Range
2178                         && cannot_be_superflat_p (gnat_index))
2179                        /* Packed Array Types are never superflat.  */
2180                        || Is_Packed_Array_Type (gnat_entity))
2181                 gnu_high = gnu_max;
2182
2183               /* Otherwise, if the high bound is constant but the low bound is
2184                  not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2185                  lower bound.  Note that the comparison must be done in the
2186                  original type to avoid any overflow during the conversion.  */
2187               else if (TREE_CODE (gnu_max) == INTEGER_CST
2188                        && TREE_CODE (gnu_min) != INTEGER_CST)
2189                 {
2190                   gnu_high = gnu_max;
2191                   gnu_min
2192                     = build_cond_expr (sizetype,
2193                                        build_binary_op (GE_EXPR,
2194                                                         boolean_type_node,
2195                                                         gnu_orig_max,
2196                                                         gnu_orig_min),
2197                                        gnu_min,
2198                                        size_binop (PLUS_EXPR, gnu_max,
2199                                                    size_one_node));
2200                 }
2201
2202               /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2203                  in all the other cases.  Note that, here as well as above,
2204                  the condition used in the comparison must be equivalent to
2205                  the condition (length != 0).  This is relied upon in order
2206                  to optimize array comparisons in compare_arrays.  */
2207               else
2208                 gnu_high
2209                   = build_cond_expr (sizetype,
2210                                      build_binary_op (GE_EXPR,
2211                                                       boolean_type_node,
2212                                                       gnu_orig_max,
2213                                                       gnu_orig_min),
2214                                      gnu_max,
2215                                      size_binop (MINUS_EXPR, gnu_min,
2216                                                  size_one_node));
2217
2218               /* Reuse the index type for the range type.  Then make an index
2219                  type with the size range in sizetype.  */
2220               gnu_index_types[index]
2221                 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2222                                      gnat_entity);
2223
2224               /* Update the maximum size of the array in elements.  Here we
2225                  see if any constraint on the index type of the base type
2226                  can be used in the case of self-referential bound on the
2227                  index type of the subtype.  We look for a non-"infinite"
2228                  and non-self-referential bound from any type involved and
2229                  handle each bound separately.  */
2230               if (gnu_max_size)
2231                 {
2232                   tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2233                   tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2234                   tree gnu_base_index_base_type
2235                     = get_base_type (gnu_base_index_type);
2236                   tree gnu_base_base_min
2237                     = convert (sizetype,
2238                                TYPE_MIN_VALUE (gnu_base_index_base_type));
2239                   tree gnu_base_base_max
2240                     = convert (sizetype,
2241                                TYPE_MAX_VALUE (gnu_base_index_base_type));
2242
2243                   if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2244                       || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2245                            && !TREE_OVERFLOW (gnu_base_min)))
2246                     gnu_base_min = gnu_min;
2247
2248                   if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2249                       || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2250                            && !TREE_OVERFLOW (gnu_base_max)))
2251                     gnu_base_max = gnu_max;
2252
2253                   if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2254                        && TREE_OVERFLOW (gnu_base_min))
2255                       || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2256                       || (TREE_CODE (gnu_base_max) == INTEGER_CST
2257                           && TREE_OVERFLOW (gnu_base_max))
2258                       || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2259                     gnu_max_size = NULL_TREE;
2260                   else
2261                     {
2262                       tree gnu_this_max
2263                         = size_binop (MAX_EXPR,
2264                                       size_binop (PLUS_EXPR, size_one_node,
2265                                                   size_binop (MINUS_EXPR,
2266                                                               gnu_base_max,
2267                                                               gnu_base_min)),
2268                                       size_zero_node);
2269
2270                       if (TREE_CODE (gnu_this_max) == INTEGER_CST
2271                           && TREE_OVERFLOW (gnu_this_max))
2272                         gnu_max_size = NULL_TREE;
2273                       else
2274                         gnu_max_size
2275                           = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2276                     }
2277                 }
2278
2279               /* We need special types for debugging information to point to
2280                  the index types if they have variable bounds, are not integer
2281                  types, are biased or are wider than sizetype.  */
2282               if (!integer_onep (gnu_orig_min)
2283                   || TREE_CODE (gnu_orig_max) != INTEGER_CST
2284                   || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2285                   || (TREE_TYPE (gnu_index_type)
2286                       && TREE_CODE (TREE_TYPE (gnu_index_type))
2287                          != INTEGER_TYPE)
2288                   || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2289                   || compare_tree_int (rm_size (gnu_index_type),
2290                                        TYPE_PRECISION (sizetype)) > 0)
2291                 need_index_type_struct = true;
2292             }
2293
2294           /* Then flatten: create the array of arrays.  For an array type
2295              used to implement a packed array, get the component type from
2296              the original array type since the representation clauses that
2297              can affect it are on the latter.  */
2298           if (Is_Packed_Array_Type (gnat_entity)
2299               && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2300             {
2301               gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2302               for (index = ndim - 1; index >= 0; index--)
2303                 gnu_type = TREE_TYPE (gnu_type);
2304
2305               /* One of the above calls might have caused us to be elaborated,
2306                  so don't blow up if so.  */
2307               if (present_gnu_tree (gnat_entity))
2308                 {
2309                   maybe_present = true;
2310                   break;
2311                 }
2312             }
2313           else
2314             {
2315               gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2316                                                      debug_info_p);
2317
2318               /* One of the above calls might have caused us to be elaborated,
2319                  so don't blow up if so.  */
2320               if (present_gnu_tree (gnat_entity))
2321                 {
2322                   maybe_present = true;
2323                   break;
2324                 }
2325             }
2326
2327           /* Compute the maximum size of the array in units and bits.  */
2328           if (gnu_max_size)
2329             {
2330               gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2331                                               TYPE_SIZE_UNIT (gnu_type));
2332               gnu_max_size = size_binop (MULT_EXPR,
2333                                          convert (bitsizetype, gnu_max_size),
2334                                          TYPE_SIZE (gnu_type));
2335             }
2336           else
2337             gnu_max_size_unit = NULL_TREE;
2338
2339           /* Now build the array type.  */
2340           for (index = ndim - 1; index >= 0; index --)
2341             {
2342               gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
2343               TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2344               if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2345                 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2346             }
2347
2348           /* Attach the TYPE_STUB_DECL in case we have a parallel type.  */
2349           TYPE_STUB_DECL (gnu_type)
2350             = create_type_stub_decl (gnu_entity_name, gnu_type);
2351
2352           /* If we are at file level and this is a multi-dimensional array,
2353              we need to make a variable corresponding to the stride of the
2354              inner dimensions.   */
2355           if (global_bindings_p () && ndim > 1)
2356             {
2357               tree gnu_str_name = get_identifier ("ST");
2358               tree gnu_arr_type;
2359
2360               for (gnu_arr_type = TREE_TYPE (gnu_type);
2361                    TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2362                    gnu_arr_type = TREE_TYPE (gnu_arr_type),
2363                    gnu_str_name = concat_name (gnu_str_name, "ST"))
2364                 {
2365                   tree eltype = TREE_TYPE (gnu_arr_type);
2366
2367                   TYPE_SIZE (gnu_arr_type)
2368                     = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2369                                               gnat_entity, gnu_str_name,
2370                                               definition, false);
2371
2372                   /* ??? For now, store the size as a multiple of the
2373                      alignment of the element type in bytes so that we
2374                      can see the alignment from the tree.  */
2375                   TYPE_SIZE_UNIT (gnu_arr_type)
2376                     = build_binary_op
2377                       (MULT_EXPR, sizetype,
2378                        elaborate_expression_1
2379                        (build_binary_op (EXACT_DIV_EXPR, sizetype,
2380                                          TYPE_SIZE_UNIT (gnu_arr_type),
2381                                          size_int (TYPE_ALIGN (eltype)
2382                                                    / BITS_PER_UNIT)),
2383                         gnat_entity, concat_name (gnu_str_name, "A_U"),
2384                         definition, false),
2385                        size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2386
2387                   /* ??? create_type_decl is not invoked on the inner types so
2388                      the MULT_EXPR node built above will never be marked.  */
2389                   MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2390                 }
2391             }
2392
2393           /* If we need to write out a record type giving the names of the
2394              bounds for debugging purposes, do it now and make the record
2395              type a parallel type.  This is not needed for a packed array
2396              since the bounds are conveyed by the original array type.  */
2397           if (need_index_type_struct
2398               && debug_info_p
2399               && !Is_Packed_Array_Type (gnat_entity))
2400             {
2401               tree gnu_bound_rec = make_node (RECORD_TYPE);
2402               tree gnu_field_list = NULL_TREE;
2403               tree gnu_field;
2404
2405               TYPE_NAME (gnu_bound_rec)
2406                 = create_concat_name (gnat_entity, "XA");
2407
2408               for (index = ndim - 1; index >= 0; index--)
2409                 {
2410                   tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2411                   tree gnu_index_name = TYPE_NAME (gnu_index);
2412
2413                   if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2414                     gnu_index_name = DECL_NAME (gnu_index_name);
2415
2416                   /* Make sure to reference the types themselves, and not just
2417                      their names, as the debugger may fall back on them.  */
2418                   gnu_field = create_field_decl (gnu_index_name, gnu_index,
2419                                                  gnu_bound_rec,
2420                                                  0, NULL_TREE, NULL_TREE, 0);
2421                   TREE_CHAIN (gnu_field) = gnu_field_list;
2422                   gnu_field_list = gnu_field;
2423                 }
2424
2425               finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2426               add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2427             }
2428
2429           /* Otherwise, for a packed array, make the original array type a
2430              parallel type.  */
2431           else if (debug_info_p
2432                    && Is_Packed_Array_Type (gnat_entity)
2433                    && present_gnu_tree (Original_Array_Type (gnat_entity)))
2434             add_parallel_type (TYPE_STUB_DECL (gnu_type),
2435                                gnat_to_gnu_type
2436                                (Original_Array_Type (gnat_entity)));
2437
2438           TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2439           TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2440             = (Is_Packed_Array_Type (gnat_entity)
2441                && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2442
2443           /* If the size is self-referential and the maximum size doesn't
2444              overflow, use it.  */
2445           if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2446               && gnu_max_size
2447               && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2448                    && TREE_OVERFLOW (gnu_max_size))
2449               && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2450                    && TREE_OVERFLOW (gnu_max_size_unit)))
2451             {
2452               TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2453                                                  TYPE_SIZE (gnu_type));
2454               TYPE_SIZE_UNIT (gnu_type)
2455                 = size_binop (MIN_EXPR, gnu_max_size_unit,
2456                               TYPE_SIZE_UNIT (gnu_type));
2457             }
2458
2459           /* Set our alias set to that of our base type.  This gives all
2460              array subtypes the same alias set.  */
2461           relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2462
2463           /* If this is a packed type, make this type the same as the packed
2464              array type, but do some adjusting in the type first.  */
2465           if (Present (Packed_Array_Type (gnat_entity)))
2466             {
2467               Entity_Id gnat_index;
2468               tree gnu_inner;
2469
2470               /* First finish the type we had been making so that we output
2471                  debugging information for it.  */
2472               if (Treat_As_Volatile (gnat_entity))
2473                 gnu_type
2474                   = build_qualified_type (gnu_type,
2475                                           TYPE_QUALS (gnu_type)
2476                                           | TYPE_QUAL_VOLATILE);
2477
2478               /* Make it artificial only if the base type was artificial too.
2479                  That's sort of "morally" true and will make it possible for
2480                  the debugger to look it up by name in DWARF, which is needed
2481                  in order to decode the packed array type.  */
2482               gnu_decl
2483                 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2484                                     !Comes_From_Source (Etype (gnat_entity))
2485                                     && !Comes_From_Source (gnat_entity),
2486                                     debug_info_p, gnat_entity);
2487
2488               /* Save it as our equivalent in case the call below elaborates
2489                  this type again.  */
2490               save_gnu_tree (gnat_entity, gnu_decl, false);
2491
2492               gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2493                                              NULL_TREE, 0);
2494               this_made_decl = true;
2495               gnu_type = TREE_TYPE (gnu_decl);
2496               save_gnu_tree (gnat_entity, NULL_TREE, false);
2497
2498               gnu_inner = gnu_type;
2499               while (TREE_CODE (gnu_inner) == RECORD_TYPE
2500                      && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2501                          || TYPE_PADDING_P (gnu_inner)))
2502                 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2503
2504               /* We need to attach the index type to the type we just made so
2505                  that the actual bounds can later be put into a template.  */
2506               if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2507                    && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2508                   || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2509                       && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2510                 {
2511                   if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2512                     {
2513                       /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2514                          TYPE_MODULUS for modular types so we make an extra
2515                          subtype if necessary.  */
2516                       if (TYPE_MODULAR_P (gnu_inner))
2517                         {
2518                           tree gnu_subtype
2519                             = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2520                           TREE_TYPE (gnu_subtype) = gnu_inner;
2521                           TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2522                           SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2523                                                  TYPE_MIN_VALUE (gnu_inner));
2524                           SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2525                                                  TYPE_MAX_VALUE (gnu_inner));
2526                           gnu_inner = gnu_subtype;
2527                         }
2528
2529                       TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2530
2531 #ifdef ENABLE_CHECKING
2532                       /* Check for other cases of overloading.  */
2533                       gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2534 #endif
2535                     }
2536
2537                   for (gnat_index = First_Index (gnat_entity);
2538                        Present (gnat_index);
2539                        gnat_index = Next_Index (gnat_index))
2540                     SET_TYPE_ACTUAL_BOUNDS
2541                       (gnu_inner,
2542                        tree_cons (NULL_TREE,
2543                                   get_unpadded_type (Etype (gnat_index)),
2544                                   TYPE_ACTUAL_BOUNDS (gnu_inner)));
2545
2546                   if (Convention (gnat_entity) != Convention_Fortran)
2547                     SET_TYPE_ACTUAL_BOUNDS
2548                       (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2549
2550                   if (TREE_CODE (gnu_type) == RECORD_TYPE
2551                       && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2552                     TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2553                 }
2554             }
2555
2556           else
2557             /* Abort if packed array with no Packed_Array_Type field set.  */
2558             gcc_assert (!Is_Packed (gnat_entity));
2559         }
2560       break;
2561
2562     case E_String_Literal_Subtype:
2563       /* Create the type for a string literal.  */
2564       {
2565         Entity_Id gnat_full_type
2566           = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2567              && Present (Full_View (Etype (gnat_entity)))
2568              ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2569         tree gnu_string_type = get_unpadded_type (gnat_full_type);
2570         tree gnu_string_array_type
2571           = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2572         tree gnu_string_index_type
2573           = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2574                                       (TYPE_DOMAIN (gnu_string_array_type))));
2575         tree gnu_lower_bound
2576           = convert (gnu_string_index_type,
2577                      gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2578         int length = UI_To_Int (String_Literal_Length (gnat_entity));
2579         tree gnu_length = ssize_int (length - 1);
2580         tree gnu_upper_bound
2581           = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2582                              gnu_lower_bound,
2583                              convert (gnu_string_index_type, gnu_length));
2584         tree gnu_index_type
2585           = create_index_type (convert (sizetype, gnu_lower_bound),
2586                                convert (sizetype, gnu_upper_bound),
2587                                create_range_type (gnu_string_index_type,
2588                                                   gnu_lower_bound,
2589                                                   gnu_upper_bound),
2590                                gnat_entity);
2591
2592         gnu_type
2593           = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2594                               gnu_index_type);
2595         if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2596           TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2597         relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2598       }
2599       break;
2600
2601     /* Record Types and Subtypes
2602
2603        The following fields are defined on record types:
2604
2605                 Has_Discriminants       True if the record has discriminants
2606                 First_Discriminant      Points to head of list of discriminants
2607                 First_Entity            Points to head of list of fields
2608                 Is_Tagged_Type          True if the record is tagged
2609
2610        Implementation of Ada records and discriminated records:
2611
2612        A record type definition is transformed into the equivalent of a C
2613        struct definition.  The fields that are the discriminants which are
2614        found in the Full_Type_Declaration node and the elements of the
2615        Component_List found in the Record_Type_Definition node.  The
2616        Component_List can be a recursive structure since each Variant of
2617        the Variant_Part of the Component_List has a Component_List.
2618
2619        Processing of a record type definition comprises starting the list of
2620        field declarations here from the discriminants and the calling the
2621        function components_to_record to add the rest of the fields from the
2622        component list and return the gnu type node.  The function
2623        components_to_record will call itself recursively as it traverses
2624        the tree.  */
2625
2626     case E_Record_Type:
2627       if (Has_Complex_Representation (gnat_entity))
2628         {
2629           gnu_type
2630             = build_complex_type
2631               (get_unpadded_type
2632                (Etype (Defining_Entity
2633                        (First (Component_Items
2634                                (Component_List
2635                                 (Type_Definition
2636                                  (Declaration_Node (gnat_entity)))))))));
2637
2638           break;
2639         }
2640
2641       {
2642         Node_Id full_definition = Declaration_Node (gnat_entity);
2643         Node_Id record_definition = Type_Definition (full_definition);
2644         Entity_Id gnat_field;
2645         tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2646         /* Set PACKED in keeping with gnat_to_gnu_field.  */
2647         int packed
2648           = Is_Packed (gnat_entity)
2649             ? 1
2650             : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2651               ? -1
2652               : (Known_Alignment (gnat_entity)
2653                  || (Strict_Alignment (gnat_entity)
2654                      && Known_Static_Esize (gnat_entity)))
2655                 ? -2
2656                 : 0;
2657         bool has_discr = Has_Discriminants (gnat_entity);
2658         bool has_rep = Has_Specified_Layout (gnat_entity);
2659         bool all_rep = has_rep;
2660         bool is_extension
2661           = (Is_Tagged_Type (gnat_entity)
2662              && Nkind (record_definition) == N_Derived_Type_Definition);
2663         bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2664
2665         /* See if all fields have a rep clause.  Stop when we find one
2666            that doesn't.  */
2667         if (all_rep)
2668           for (gnat_field = First_Entity (gnat_entity);
2669                Present (gnat_field);
2670                gnat_field = Next_Entity (gnat_field))
2671             if ((Ekind (gnat_field) == E_Component
2672                  || Ekind (gnat_field) == E_Discriminant)
2673                 && No (Component_Clause (gnat_field)))
2674               {
2675                 all_rep = false;
2676                 break;
2677               }
2678
2679         /* If this is a record extension, go a level further to find the
2680            record definition.  Also, verify we have a Parent_Subtype.  */
2681         if (is_extension)
2682           {
2683             if (!type_annotate_only
2684                 || Present (Record_Extension_Part (record_definition)))
2685               record_definition = Record_Extension_Part (record_definition);
2686
2687             gcc_assert (type_annotate_only
2688                         || Present (Parent_Subtype (gnat_entity)));
2689           }
2690
2691         /* Make a node for the record.  If we are not defining the record,
2692            suppress expanding incomplete types.  */
2693         gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2694         TYPE_NAME (gnu_type) = gnu_entity_name;
2695         TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2696
2697         if (!definition)
2698           {
2699             defer_incomplete_level++;
2700             this_deferred = true;
2701           }
2702
2703         /* If both a size and rep clause was specified, put the size in
2704            the record type now so that it can get the proper mode.  */
2705         if (has_rep && Known_Esize (gnat_entity))
2706           TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2707
2708         /* Always set the alignment here so that it can be used to
2709            set the mode, if it is making the alignment stricter.  If
2710            it is invalid, it will be checked again below.  If this is to
2711            be Atomic, choose a default alignment of a word unless we know
2712            the size and it's smaller.  */
2713         if (Known_Alignment (gnat_entity))
2714           TYPE_ALIGN (gnu_type)
2715             = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2716         else if (Is_Atomic (gnat_entity))
2717           TYPE_ALIGN (gnu_type)
2718             = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2719         /* If a type needs strict alignment, the minimum size will be the
2720            type size instead of the RM size (see validate_size).  Cap the
2721            alignment, lest it causes this type size to become too large.  */
2722         else if (Strict_Alignment (gnat_entity)
2723                  && Known_Static_Esize (gnat_entity))
2724           {
2725             unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2726             unsigned int raw_align = raw_size & -raw_size;
2727             if (raw_align < BIGGEST_ALIGNMENT)
2728               TYPE_ALIGN (gnu_type) = raw_align;
2729           }
2730         else
2731           TYPE_ALIGN (gnu_type) = 0;
2732
2733         /* If we have a Parent_Subtype, make a field for the parent.  If
2734            this record has rep clauses, force the position to zero.  */
2735         if (Present (Parent_Subtype (gnat_entity)))
2736           {
2737             Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2738             tree gnu_parent;
2739
2740             /* A major complexity here is that the parent subtype will
2741                reference our discriminants in its Discriminant_Constraint
2742                list.  But those must reference the parent component of this
2743                record which is of the parent subtype we have not built yet!
2744                To break the circle we first build a dummy COMPONENT_REF which
2745                represents the "get to the parent" operation and initialize
2746                each of those discriminants to a COMPONENT_REF of the above
2747                dummy parent referencing the corresponding discriminant of the
2748                base type of the parent subtype.  */
2749             gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2750                                      build0 (PLACEHOLDER_EXPR, gnu_type),
2751                                      build_decl (input_location,
2752                                                  FIELD_DECL, NULL_TREE,
2753                                                  void_type_node),
2754                                      NULL_TREE);
2755
2756             if (has_discr)
2757               for (gnat_field = First_Stored_Discriminant (gnat_entity);
2758                    Present (gnat_field);
2759                    gnat_field = Next_Stored_Discriminant (gnat_field))
2760                 if (Present (Corresponding_Discriminant (gnat_field)))
2761                   {
2762                     tree gnu_field
2763                       = gnat_to_gnu_field_decl (Corresponding_Discriminant
2764                                                 (gnat_field));
2765                     save_gnu_tree
2766                       (gnat_field,
2767                        build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2768                                gnu_get_parent, gnu_field, NULL_TREE),
2769                        true);
2770                   }
2771
2772             /* Then we build the parent subtype.  If it has discriminants but
2773                the type itself has unknown discriminants, this means that it
2774                doesn't contain information about how the discriminants are
2775                derived from those of the ancestor type, so it cannot be used
2776                directly.  Instead it is built by cloning the parent subtype
2777                of the underlying record view of the type, for which the above
2778                derivation of discriminants has been made explicit.  */
2779             if (Has_Discriminants (gnat_parent)
2780                 && Has_Unknown_Discriminants (gnat_entity))
2781               {
2782                 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2783
2784                 /* If we are defining the type, the underlying record
2785                    view must already have been elaborated at this point.
2786                    Otherwise do it now as its parent subtype cannot be
2787                    technically elaborated on its own.  */
2788                 if (definition)
2789                   gcc_assert (present_gnu_tree (gnat_uview));
2790                 else
2791                   gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2792
2793                 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2794
2795                 /* Substitute the "get to the parent" of the type for that
2796                    of its underlying record view in the cloned type.  */
2797                 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2798                      Present (gnat_field);
2799                      gnat_field = Next_Stored_Discriminant (gnat_field))
2800                   if (Present (Corresponding_Discriminant (gnat_field)))
2801                     {
2802                       tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2803                       tree gnu_ref
2804                         = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2805                                   gnu_get_parent, gnu_field, NULL_TREE);
2806                       gnu_parent
2807                         = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2808                     }
2809               }
2810             else
2811               gnu_parent = gnat_to_gnu_type (gnat_parent);
2812
2813             /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2814                initially built.  The discriminants must reference the fields
2815                of the parent subtype and not those of its base type for the
2816                placeholder machinery to properly work.  */
2817             if (has_discr)
2818               {
2819                 /* The actual parent subtype is the full view.  */
2820                 if (IN (Ekind (gnat_parent), Private_Kind))
2821                   {
2822                     if (Present (Full_View (gnat_parent)))
2823                       gnat_parent = Full_View (gnat_parent);
2824                     else
2825                       gnat_parent = Underlying_Full_View (gnat_parent);
2826                   }
2827
2828                 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2829                      Present (gnat_field);
2830                      gnat_field = Next_Stored_Discriminant (gnat_field))
2831                   if (Present (Corresponding_Discriminant (gnat_field)))
2832                     {
2833                       Entity_Id field = Empty;
2834                       for (field = First_Stored_Discriminant (gnat_parent);
2835                            Present (field);
2836                            field = Next_Stored_Discriminant (field))
2837                         if (same_discriminant_p (gnat_field, field))
2838                           break;
2839                       gcc_assert (Present (field));
2840                       TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2841                         = gnat_to_gnu_field_decl (field);
2842                     }
2843               }
2844
2845             /* The "get to the parent" COMPONENT_REF must be given its
2846                proper type...  */
2847             TREE_TYPE (gnu_get_parent) = gnu_parent;
2848
2849             /* ...and reference the _Parent field of this record.  */
2850             gnu_field
2851               = create_field_decl (parent_name_id,
2852                                    gnu_parent, gnu_type, 0,
2853                                    has_rep
2854                                    ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2855                                    has_rep
2856                                    ? bitsize_zero_node : NULL_TREE, 1);
2857             DECL_INTERNAL_P (gnu_field) = 1;
2858             TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2859             TYPE_FIELDS (gnu_type) = gnu_field;
2860           }
2861
2862         /* Make the fields for the discriminants and put them into the record
2863            unless it's an Unchecked_Union.  */
2864         if (has_discr)
2865           for (gnat_field = First_Stored_Discriminant (gnat_entity);
2866                Present (gnat_field);
2867                gnat_field = Next_Stored_Discriminant (gnat_field))
2868             {
2869               /* If this is a record extension and this discriminant is the
2870                  renaming of another discriminant, we've handled it above.  */
2871               if (Present (Parent_Subtype (gnat_entity))
2872                   && Present (Corresponding_Discriminant (gnat_field)))
2873                 continue;
2874
2875               gnu_field
2876                 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
2877                                      debug_info_p);
2878
2879               /* Make an expression using a PLACEHOLDER_EXPR from the
2880                  FIELD_DECL node just created and link that with the
2881                  corresponding GNAT defining identifier.  */
2882               save_gnu_tree (gnat_field,
2883                              build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2884                                      build0 (PLACEHOLDER_EXPR, gnu_type),
2885                                      gnu_field, NULL_TREE),
2886                              true);
2887
2888               if (!is_unchecked_union)
2889                 {
2890                   TREE_CHAIN (gnu_field) = gnu_field_list;
2891                   gnu_field_list = gnu_field;
2892                 }
2893             }
2894
2895         /* Add the fields into the record type and finish it up.  */
2896         components_to_record (gnu_type, Component_List (record_definition),
2897                               gnu_field_list, packed, definition, NULL,
2898                               false, all_rep, is_unchecked_union,
2899                               debug_info_p, false);
2900
2901         /* If it is passed by reference, force BLKmode to ensure that objects
2902            of this type will always be put in memory.  */
2903         if (Is_By_Reference_Type (gnat_entity))
2904           SET_TYPE_MODE (gnu_type, BLKmode);
2905
2906         /* We used to remove the associations of the discriminants and _Parent
2907            for validity checking but we may need them if there's a Freeze_Node
2908            for a subtype used in this record.  */
2909         TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2910
2911         /* Fill in locations of fields.  */
2912         annotate_rep (gnat_entity, gnu_type);
2913
2914         /* If there are any entities in the chain corresponding to components
2915            that we did not elaborate, ensure we elaborate their types if they
2916            are Itypes.  */
2917         for (gnat_temp = First_Entity (gnat_entity);
2918              Present (gnat_temp);
2919              gnat_temp = Next_Entity (gnat_temp))
2920           if ((Ekind (gnat_temp) == E_Component
2921                || Ekind (gnat_temp) == E_Discriminant)
2922               && Is_Itype (Etype (gnat_temp))
2923               && !present_gnu_tree (gnat_temp))
2924             gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2925       }
2926       break;
2927
2928     case E_Class_Wide_Subtype:
2929       /* If an equivalent type is present, that is what we should use.
2930          Otherwise, fall through to handle this like a record subtype
2931          since it may have constraints.  */
2932       if (gnat_equiv_type != gnat_entity)
2933         {
2934           gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2935           maybe_present = true;
2936           break;
2937         }
2938
2939       /* ... fall through ... */
2940
2941     case E_Record_Subtype:
2942       /* If Cloned_Subtype is Present it means this record subtype has
2943          identical layout to that type or subtype and we should use
2944          that GCC type for this one.  The front end guarantees that
2945          the component list is shared.  */
2946       if (Present (Cloned_Subtype (gnat_entity)))
2947         {
2948           gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2949                                          NULL_TREE, 0);
2950           maybe_present = true;
2951           break;
2952         }
2953
2954       /* Otherwise, first ensure the base type is elaborated.  Then, if we are
2955          changing the type, make a new type with each field having the type of
2956          the field in the new subtype but the position computed by transforming
2957          every discriminant reference according to the constraints.  We don't
2958          see any difference between private and non-private type here since
2959          derivations from types should have been deferred until the completion
2960          of the private type.  */
2961       else
2962         {
2963           Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2964           tree gnu_base_type;
2965
2966           if (!definition)
2967             {
2968               defer_incomplete_level++;
2969               this_deferred = true;
2970             }
2971
2972           gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2973
2974           if (present_gnu_tree (gnat_entity))
2975             {
2976               maybe_present = true;
2977               break;
2978             }
2979
2980           /* When the subtype has discriminants and these discriminants affect
2981              the initial shape it has inherited, factor them in.  But for an
2982              Unchecked_Union (it must be an Itype), just return the type.
2983              We can't just test Is_Constrained because private subtypes without
2984              discriminants of types with discriminants with default expressions
2985              are Is_Constrained but aren't constrained!  */
2986           if (IN (Ekind (gnat_base_type), Record_Kind)
2987               && !Is_Unchecked_Union (gnat_base_type)
2988               && !Is_For_Access_Subtype (gnat_entity)
2989               && Is_Constrained (gnat_entity)
2990               && Has_Discriminants (gnat_entity)
2991               && Present (Discriminant_Constraint (gnat_entity))
2992               && Stored_Constraint (gnat_entity) != No_Elist)
2993             {
2994               tree gnu_subst_list
2995                 = build_subst_list (gnat_entity, gnat_base_type, definition);
2996               tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
2997               tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
2998               bool selected_variant = false;
2999               Entity_Id gnat_field;
3000
3001               gnu_type = make_node (RECORD_TYPE);
3002               TYPE_NAME (gnu_type) = gnu_entity_name;
3003
3004               /* Set the size, alignment and alias set of the new type to
3005                  match that of the old one, doing required substitutions.  */
3006               copy_and_substitute_in_size (gnu_type, gnu_base_type,
3007                                            gnu_subst_list);
3008
3009               if (TYPE_IS_PADDING_P (gnu_base_type))
3010                 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3011               else
3012                 gnu_unpad_base_type = gnu_base_type;
3013
3014               /* Look for a REP part in the base type.  */
3015               gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3016
3017               /* Look for a variant part in the base type.  */
3018               gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3019
3020               /* If there is a variant part, we must compute whether the
3021                  constraints statically select a particular variant.  If
3022                  so, we simply drop the qualified union and flatten the
3023                  list of fields.  Otherwise we'll build a new qualified
3024                  union for the variants that are still relevant.  */
3025               if (gnu_variant_part)
3026                 {
3027                   gnu_variant_list
3028                     = build_variant_list (TREE_TYPE (gnu_variant_part),
3029                                           gnu_subst_list, NULL_TREE);
3030
3031                   /* If all the qualifiers are unconditionally true, the
3032                      innermost variant is statically selected.  */
3033                   selected_variant = true;
3034                   for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3035                     if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
3036                       {
3037                         selected_variant = false;
3038                         break;
3039                       }
3040
3041                   /* Otherwise, create the new variants.  */
3042                   if (!selected_variant)
3043                     for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3044                       {
3045                         tree old_variant = TREE_PURPOSE (t);
3046                         tree new_variant = make_node (RECORD_TYPE);
3047                         TYPE_NAME (new_variant)
3048                           = DECL_NAME (TYPE_NAME (old_variant));
3049                         copy_and_substitute_in_size (new_variant, old_variant,
3050                                                      gnu_subst_list);
3051                         TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
3052                       }
3053                 }
3054               else
3055                 {
3056                   gnu_variant_list = NULL_TREE;
3057                   selected_variant = false;
3058                 }
3059
3060               gnu_pos_list
3061                 = build_position_list (gnu_unpad_base_type,
3062                                        gnu_variant_list && !selected_variant,
3063                                        size_zero_node, bitsize_zero_node,
3064                                        BIGGEST_ALIGNMENT, NULL_TREE);
3065
3066               for (gnat_field = First_Entity (gnat_entity);
3067                    Present (gnat_field);
3068                    gnat_field = Next_Entity (gnat_field))
3069                 if ((Ekind (gnat_field) == E_Component
3070                      || Ekind (gnat_field) == E_Discriminant)
3071                     && !(Present (Corresponding_Discriminant (gnat_field))
3072                          && Is_Tagged_Type (gnat_base_type))
3073                     && Underlying_Type (Scope (Original_Record_Component
3074                                                (gnat_field)))
3075                        == gnat_base_type)
3076                   {
3077                     Name_Id gnat_name = Chars (gnat_field);
3078                     Entity_Id gnat_old_field
3079                       = Original_Record_Component (gnat_field);
3080                     tree gnu_old_field
3081                       = gnat_to_gnu_field_decl (gnat_old_field);
3082                     tree gnu_context = DECL_CONTEXT (gnu_old_field);
3083                     tree gnu_field, gnu_field_type, gnu_size;
3084                     tree gnu_cont_type, gnu_last = NULL_TREE;
3085
3086                     /* If the type is the same, retrieve the GCC type from the
3087                        old field to take into account possible adjustments.  */
3088                     if (Etype (gnat_field) == Etype (gnat_old_field))
3089                       gnu_field_type = TREE_TYPE (gnu_old_field);
3090                     else
3091                       gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3092
3093                     /* If there was a component clause, the field types must be
3094                        the same for the type and subtype, so copy the data from
3095                        the old field to avoid recomputation here.  Also if the
3096                        field is justified modular and the optimization in
3097                        gnat_to_gnu_field was applied.  */
3098                     if (Present (Component_Clause (gnat_old_field))
3099                         || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3100                             && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3101                             && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3102                                == TREE_TYPE (gnu_old_field)))
3103                       {
3104                         gnu_size = DECL_SIZE (gnu_old_field);
3105                         gnu_field_type = TREE_TYPE (gnu_old_field);
3106                       }
3107
3108                     /* If the old field was packed and of constant size, we
3109                        have to get the old size here, as it might differ from
3110                        what the Etype conveys and the latter might overlap
3111                        onto the following field.  Try to arrange the type for
3112                        possible better packing along the way.  */
3113                     else if (DECL_PACKED (gnu_old_field)
3114                              && TREE_CODE (DECL_SIZE (gnu_old_field))
3115                                 == INTEGER_CST)
3116                       {
3117                         gnu_size = DECL_SIZE (gnu_old_field);
3118                         if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3119                             && !TYPE_FAT_POINTER_P (gnu_field_type)
3120                             && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3121                           gnu_field_type
3122                             = make_packable_type (gnu_field_type, true);
3123                       }
3124
3125                     else
3126                       gnu_size = TYPE_SIZE (gnu_field_type);
3127
3128                     /* If the context of the old field is the base type or its
3129                        REP part (if any), put the field directly in the new
3130                        type; otherwise look up the context in the variant list
3131                        and put the field either in the new type if there is a
3132                        selected variant or in one of the new variants.  */
3133                     if (gnu_context == gnu_unpad_base_type
3134                         || (gnu_rep_part
3135                             && gnu_context == TREE_TYPE (gnu_rep_part)))
3136                       gnu_cont_type = gnu_type;
3137                     else
3138                       {
3139                         t = purpose_member (gnu_context, gnu_variant_list);
3140                         if (t)
3141                           {
3142                             if (selected_variant)
3143                               gnu_cont_type = gnu_type;
3144                             else
3145                               gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
3146                           }
3147                         else
3148                           /* The front-end may pass us "ghost" components if
3149                              it fails to recognize that a constrained subtype
3150                              is statically constrained.  Discard them.  */
3151                           continue;
3152                       }
3153
3154                     /* Now create the new field modeled on the old one.  */
3155                     gnu_field
3156                       = create_field_decl_from (gnu_old_field, gnu_field_type,
3157                                                 gnu_cont_type, gnu_size,
3158                                                 gnu_pos_list, gnu_subst_list);
3159
3160                     /* Put it in one of the new variants directly.  */
3161                     if (gnu_cont_type != gnu_type)
3162                       {
3163                         TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3164                         TYPE_FIELDS (gnu_cont_type) = gnu_field;
3165                       }
3166
3167                     /* To match the layout crafted in components_to_record,
3168                        if this is the _Tag or _Parent field, put it before
3169                        any other fields.  */
3170                     else if (gnat_name == Name_uTag
3171                              || gnat_name == Name_uParent)
3172                       gnu_field_list = chainon (gnu_field_list, gnu_field);
3173
3174                     /* Similarly, if this is the _Controller field, put
3175                        it before the other fields except for the _Tag or
3176                        _Parent field.  */
3177                     else if (gnat_name == Name_uController && gnu_last)
3178                       {
3179                         TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
3180                         TREE_CHAIN (gnu_last) = gnu_field;
3181                       }
3182
3183                     /* Otherwise, if this is a regular field, put it after
3184                        the other fields.  */
3185                     else
3186                       {
3187                         TREE_CHAIN (gnu_field) = gnu_field_list;
3188                         gnu_field_list = gnu_field;
3189                         if (!gnu_last)
3190                           gnu_last = gnu_field;
3191                       }
3192
3193                     save_gnu_tree (gnat_field, gnu_field, false);
3194                   }
3195
3196               /* If there is a variant list and no selected variant, we need
3197                  to create the nest of variant parts from the old nest.  */
3198               if (gnu_variant_list && !selected_variant)
3199                 {
3200                   tree new_variant_part
3201                     = create_variant_part_from (gnu_variant_part,
3202                                                 gnu_variant_list, gnu_type,
3203                                                 gnu_pos_list, gnu_subst_list);
3204                   TREE_CHAIN (new_variant_part) = gnu_field_list;
3205                   gnu_field_list = new_variant_part;
3206                 }
3207
3208               /* Now go through the entities again looking for Itypes that
3209                  we have not elaborated but should (e.g., Etypes of fields
3210                  that have Original_Components).  */
3211               for (gnat_field = First_Entity (gnat_entity);
3212                    Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3213                 if ((Ekind (gnat_field) == E_Discriminant
3214                      || Ekind (gnat_field) == E_Component)
3215                     && !present_gnu_tree (Etype (gnat_field)))
3216                   gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3217
3218               /* Do not emit debug info for the type yet since we're going to
3219                  modify it below.  */
3220               gnu_field_list = nreverse (gnu_field_list);
3221               finish_record_type (gnu_type, gnu_field_list, 2, false);
3222
3223               /* See the E_Record_Type case for the rationale.  */
3224               if (Is_By_Reference_Type (gnat_entity))
3225                 SET_TYPE_MODE (gnu_type, BLKmode);
3226               else
3227                 compute_record_mode (gnu_type);
3228
3229               TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3230
3231               /* Fill in locations of fields.  */
3232               annotate_rep (gnat_entity, gnu_type);
3233
3234               /* If debugging information is being written for the type, write
3235                  a record that shows what we are a subtype of and also make a
3236                  variable that indicates our size, if still variable.  */
3237               if (debug_info_p)
3238                 {
3239                   tree gnu_subtype_marker = make_node (RECORD_TYPE);
3240                   tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3241                   tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3242
3243                   if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3244                     gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3245
3246                   TYPE_NAME (gnu_subtype_marker)
3247                     = create_concat_name (gnat_entity, "XVS");
3248                   finish_record_type (gnu_subtype_marker,
3249                                       create_field_decl (gnu_unpad_base_name,
3250                                                          build_reference_type
3251                                                          (gnu_unpad_base_type),
3252                                                          gnu_subtype_marker,
3253                                                          0, NULL_TREE,
3254                                                          NULL_TREE, 0),
3255                                       0, true);
3256
3257                   add_parallel_type (TYPE_STUB_DECL (gnu_type),
3258                                      gnu_subtype_marker);
3259
3260                   if (definition
3261                       && TREE_CODE (gnu_size_unit) != INTEGER_CST
3262                       && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3263                     TYPE_SIZE_UNIT (gnu_subtype_marker)
3264                       = create_var_decl (create_concat_name (gnat_entity,
3265                                                              "XVZ"),
3266                                          NULL_TREE, sizetype, gnu_size_unit,
3267                                          false, false, false, false, NULL,
3268                                          gnat_entity);
3269                 }
3270
3271               /* Now we can finalize it.  */
3272               rest_of_record_type_compilation (gnu_type);
3273             }
3274
3275           /* Otherwise, go down all the components in the new type and make
3276              them equivalent to those in the base type.  */
3277           else
3278             {
3279               gnu_type = gnu_base_type;
3280
3281               for (gnat_temp = First_Entity (gnat_entity);
3282                    Present (gnat_temp);
3283                    gnat_temp = Next_Entity (gnat_temp))
3284                 if ((Ekind (gnat_temp) == E_Discriminant
3285                      && !Is_Unchecked_Union (gnat_base_type))
3286                     || Ekind (gnat_temp) == E_Component)
3287                   save_gnu_tree (gnat_temp,
3288                                  gnat_to_gnu_field_decl
3289                                  (Original_Record_Component (gnat_temp)),
3290                                  false);
3291             }
3292         }
3293       break;
3294
3295     case E_Access_Subprogram_Type:
3296       /* Use the special descriptor type for dispatch tables if needed,
3297          that is to say for the Prim_Ptr of a-tags.ads and its clones.
3298          Note that we are only required to do so for static tables in
3299          order to be compatible with the C++ ABI, but Ada 2005 allows
3300          to extend library level tagged types at the local level so
3301          we do it in the non-static case as well.  */
3302       if (TARGET_VTABLE_USES_DESCRIPTORS
3303           && Is_Dispatch_Table_Entity (gnat_entity))
3304         {
3305             gnu_type = fdesc_type_node;
3306             gnu_size = TYPE_SIZE (gnu_type);
3307             break;
3308         }
3309
3310       /* ... fall through ... */
3311
3312     case E_Anonymous_Access_Subprogram_Type:
3313       /* If we are not defining this entity, and we have incomplete
3314          entities being processed above us, make a dummy type and
3315          fill it in later.  */
3316       if (!definition && defer_incomplete_level != 0)
3317         {
3318           struct incomplete *p
3319             = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3320
3321           gnu_type
3322             = build_pointer_type
3323               (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3324           gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3325                                        !Comes_From_Source (gnat_entity),
3326                                        debug_info_p, gnat_entity);
3327           this_made_decl = true;
3328           gnu_type = TREE_TYPE (gnu_decl);
3329           save_gnu_tree (gnat_entity, gnu_decl, false);
3330           saved = true;
3331
3332           p->old_type = TREE_TYPE (gnu_type);
3333           p->full_type = Directly_Designated_Type (gnat_entity);
3334           p->next = defer_incomplete_list;
3335           defer_incomplete_list = p;
3336           break;
3337         }
3338
3339       /* ... fall through ... */
3340
3341     case E_Allocator_Type:
3342     case E_Access_Type:
3343     case E_Access_Attribute_Type:
3344     case E_Anonymous_Access_Type:
3345     case E_General_Access_Type:
3346       {
3347         Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3348         Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3349         bool is_from_limited_with
3350           = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3351              && From_With_Type (gnat_desig_equiv));
3352
3353         /* Get the "full view" of this entity.  If this is an incomplete
3354            entity from a limited with, treat its non-limited view as the full
3355            view.  Otherwise, if this is an incomplete or private type, use the
3356            full view.  In the former case, we might point to a private type,
3357            in which case, we need its full view.  Also, we want to look at the
3358            actual type used for the representation, so this takes a total of
3359            three steps.  */
3360         Entity_Id gnat_desig_full_direct_first
3361           = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3362              : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3363                 ? Full_View (gnat_desig_equiv) : Empty));
3364         Entity_Id gnat_desig_full_direct
3365           = ((is_from_limited_with
3366               && Present (gnat_desig_full_direct_first)
3367               && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3368              ? Full_View (gnat_desig_full_direct_first)
3369              : gnat_desig_full_direct_first);
3370         Entity_Id gnat_desig_full
3371           = Gigi_Equivalent_Type (gnat_desig_full_direct);
3372
3373         /* This the type actually used to represent the designated type,
3374            either gnat_desig_full or gnat_desig_equiv.  */
3375         Entity_Id gnat_desig_rep;
3376
3377         /* True if this is a pointer to an unconstrained array.  */
3378         bool is_unconstrained_array;
3379
3380         /* We want to know if we'll be seeing the freeze node for any
3381            incomplete type we may be pointing to.  */
3382         bool in_main_unit
3383           = (Present (gnat_desig_full)
3384              ? In_Extended_Main_Code_Unit (gnat_desig_full)
3385              : In_Extended_Main_Code_Unit (gnat_desig_type));
3386
3387         /* True if we make a dummy type here.  */
3388         bool got_fat_p = false;
3389         /* True if the dummy is a fat pointer.  */
3390         bool made_dummy = false;
3391         tree gnu_desig_type = NULL_TREE;
3392         enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3393
3394         if (!targetm.valid_pointer_mode (p_mode))
3395           p_mode = ptr_mode;
3396
3397         /* If either the designated type or its full view is an unconstrained
3398            array subtype, replace it with the type it's a subtype of.  This
3399            avoids problems with multiple copies of unconstrained array types.
3400            Likewise, if the designated type is a subtype of an incomplete
3401            record type, use the parent type to avoid order of elaboration
3402            issues.  This can lose some code efficiency, but there is no
3403            alternative.  */
3404         if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3405             && ! Is_Constrained (gnat_desig_equiv))
3406           gnat_desig_equiv = Etype (gnat_desig_equiv);
3407         if (Present (gnat_desig_full)
3408             && ((Ekind (gnat_desig_full) == E_Array_Subtype
3409                  && ! Is_Constrained (gnat_desig_full))
3410                 || (Ekind (gnat_desig_full) == E_Record_Subtype
3411                     && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3412           gnat_desig_full = Etype (gnat_desig_full);
3413
3414         /* Now set the type that actually marks the representation of
3415            the designated type and also flag whether we have a unconstrained
3416            array.  */
3417         gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3418         is_unconstrained_array
3419           = (Is_Array_Type (gnat_desig_rep)
3420              && ! Is_Constrained (gnat_desig_rep));
3421
3422         /* If we are pointing to an incomplete type whose completion is an
3423            unconstrained array, make a fat pointer type.  The two types in our
3424            fields will be pointers to dummy nodes and will be replaced in
3425            update_pointer_to.  Similarly, if the type itself is a dummy type or
3426            an unconstrained array.  Also make a dummy TYPE_OBJECT_RECORD_TYPE
3427            in case we have any thin pointers to it.  */
3428         if (is_unconstrained_array
3429             && (Present (gnat_desig_full)
3430                 || (present_gnu_tree (gnat_desig_equiv)
3431                     && TYPE_IS_DUMMY_P (TREE_TYPE
3432                                         (get_gnu_tree (gnat_desig_equiv))))
3433                 || (No (gnat_desig_full) && ! in_main_unit
3434                     && defer_incomplete_level != 0
3435                     && ! present_gnu_tree (gnat_desig_equiv))
3436                 || (in_main_unit && is_from_limited_with
3437                     && Present (Freeze_Node (gnat_desig_rep)))))
3438           {
3439             tree gnu_old;
3440
3441             if (present_gnu_tree (gnat_desig_rep))
3442               gnu_old = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3443             else
3444               {
3445                 gnu_old = make_dummy_type (gnat_desig_rep);
3446
3447                 /* Show the dummy we get will be a fat pointer.  */
3448                 got_fat_p = made_dummy = true;
3449               }
3450
3451             /* If the call above got something that has a pointer, that
3452                pointer is our type.  This could have happened either
3453                because the type was elaborated or because somebody
3454                else executed the code below.  */
3455             gnu_type = TYPE_POINTER_TO (gnu_old);
3456             if (!gnu_type)
3457               {
3458                 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3459                 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3460                 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3461                 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3462                 tree fields;
3463
3464                 TYPE_NAME (gnu_template_type)
3465                   = create_concat_name (gnat_desig_equiv, "XUB");
3466                 TYPE_DUMMY_P (gnu_template_type) = 1;
3467
3468                 TYPE_NAME (gnu_array_type)
3469                   = create_concat_name (gnat_desig_equiv, "XUA");
3470                 TYPE_DUMMY_P (gnu_array_type) = 1;
3471
3472                 gnu_type = make_node (RECORD_TYPE);
3473                 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3474                 TYPE_POINTER_TO (gnu_old) = gnu_type;
3475
3476                 fields
3477                   = chainon (chainon (NULL_TREE,
3478                                       create_field_decl
3479                                       (get_identifier ("P_ARRAY"),
3480                                        gnu_ptr_array,
3481                                        gnu_type, 0, 0, 0, 0)),
3482                              create_field_decl (get_identifier ("P_BOUNDS"),
3483                                                 gnu_ptr_template,
3484                                                 gnu_type, 0, 0, 0, 0));
3485
3486                 /* Make sure we can place this into a register.  */
3487                 TYPE_ALIGN (gnu_type)
3488                   = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3489                 TYPE_FAT_POINTER_P (gnu_type) = 1;
3490
3491                 /* Do not emit debug info for this record type since the types
3492                    of its fields are incomplete.  */
3493                 finish_record_type (gnu_type, fields, 0, false);
3494
3495                 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3496                 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3497                   = create_concat_name (gnat_desig_equiv, "XUT");
3498                 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3499               }
3500           }
3501
3502         /* If we already know what the full type is, use it.  */
3503         else if (Present (gnat_desig_full)
3504                  && present_gnu_tree (gnat_desig_full))
3505           gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3506
3507         /* Get the type of the thing we are to point to and build a pointer
3508            to it.  If it is a reference to an incomplete or private type with a
3509            full view that is a record, make a dummy type node and get the
3510            actual type later when we have verified it is safe.  */
3511         else if ((! in_main_unit
3512                   && ! present_gnu_tree (gnat_desig_equiv)
3513                   && Present (gnat_desig_full)
3514                   && ! present_gnu_tree (gnat_desig_full)
3515                   && Is_Record_Type (gnat_desig_full))
3516                  /* Likewise if we are pointing to a record or array and we
3517                     are to defer elaborating incomplete types.  We do this
3518                     since this access type may be the full view of some
3519                     private type.  Note that the unconstrained array case is
3520                     handled above.  */
3521                  || ((! in_main_unit || imported_p)
3522                      && defer_incomplete_level != 0
3523                      && ! present_gnu_tree (gnat_desig_equiv)
3524                      && ((Is_Record_Type (gnat_desig_rep)
3525                           || Is_Array_Type (gnat_desig_rep))))
3526                  /* If this is a reference from a limited_with type back to our
3527                     main unit and there's a Freeze_Node for it, either we have
3528                     already processed the declaration and made the dummy type,
3529                     in which case we just reuse the latter, or we have not yet,
3530                     in which case we make the dummy type and it will be reused
3531                     when the declaration is processed.  In both cases, the
3532                     pointer eventually created below will be automatically
3533                     adjusted when the Freeze_Node is processed.  Note that the
3534                     unconstrained array case is handled above.  */
3535                  ||  (in_main_unit && is_from_limited_with
3536                       && Present (Freeze_Node (gnat_desig_rep))))
3537           {
3538             gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3539             made_dummy = true;
3540           }
3541
3542         /* Otherwise handle the case of a pointer to itself.  */
3543         else if (gnat_desig_equiv == gnat_entity)
3544           {
3545             gnu_type
3546               = build_pointer_type_for_mode (void_type_node, p_mode,
3547                                              No_Strict_Aliasing (gnat_entity));
3548             TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3549           }
3550
3551         /* If expansion is disabled, the equivalent type of a concurrent
3552            type is absent, so build a dummy pointer type.  */
3553         else if (type_annotate_only && No (gnat_desig_equiv))
3554           gnu_type = ptr_void_type_node;
3555
3556         /* Finally, handle the straightforward case where we can just
3557            elaborate our designated type and point to it.  */
3558         else
3559           gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3560
3561         /* It is possible that a call to gnat_to_gnu_type above resolved our
3562            type.  If so, just return it.  */
3563         if (present_gnu_tree (gnat_entity))
3564           {
3565             maybe_present = true;
3566             break;
3567           }
3568
3569         /* If we have a GCC type for the designated type, possibly modify it
3570            if we are pointing only to constant objects and then make a pointer
3571            to it.  Don't do this for unconstrained arrays.  */
3572         if (!gnu_type && gnu_desig_type)
3573           {
3574             if (Is_Access_Constant (gnat_entity)
3575                 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3576               {
3577                 gnu_desig_type
3578                   = build_qualified_type
3579                     (gnu_desig_type,
3580                      TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3581
3582                 /* Some extra processing is required if we are building a
3583                    pointer to an incomplete type (in the GCC sense).  We might
3584                    have such a type if we just made a dummy, or directly out
3585                    of the call to gnat_to_gnu_type above if we are processing
3586                    an access type for a record component designating the
3587                    record type itself.  */
3588                 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3589                   {
3590                     /* We must ensure that the pointer to variant we make will
3591                        be processed by update_pointer_to when the initial type
3592                        is completed.  Pretend we made a dummy and let further
3593                        processing act as usual.  */
3594                     made_dummy = true;
3595
3596                     /* We must ensure that update_pointer_to will not retrieve
3597                        the dummy variant when building a properly qualified
3598                        version of the complete type.  We take advantage of the
3599                        fact that get_qualified_type is requiring TYPE_NAMEs to
3600                        match to influence build_qualified_type and then also
3601                        update_pointer_to here.  */
3602                     TYPE_NAME (gnu_desig_type)
3603                       = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3604                   }
3605               }
3606
3607             gnu_type
3608               = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3609                                              No_Strict_Aliasing (gnat_entity));
3610           }
3611
3612         /* If we are not defining this object and we made a dummy pointer,
3613            save our current definition, evaluate the actual type, and replace
3614            the tentative type we made with the actual one.  If we are to defer
3615            actually looking up the actual type, make an entry in the
3616            deferred list.  If this is from a limited with, we have to defer
3617            to the end of the current spec in two cases: first if the
3618            designated type is in the current unit and second if the access
3619            type is.  */
3620         if ((! in_main_unit || is_from_limited_with) && made_dummy)
3621           {
3622             tree gnu_old_type
3623               = TYPE_IS_FAT_POINTER_P (gnu_type)
3624                 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3625
3626             if (esize == POINTER_SIZE
3627                 && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
3628               gnu_type
3629                 = build_pointer_type
3630                   (TYPE_OBJECT_RECORD_TYPE
3631                    (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3632
3633             gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3634                                          !Comes_From_Source (gnat_entity),
3635                                          debug_info_p, gnat_entity);
3636             this_made_decl = true;
3637             gnu_type = TREE_TYPE (gnu_decl);
3638             save_gnu_tree (gnat_entity, gnu_decl, false);
3639             saved = true;
3640
3641             if (defer_incomplete_level == 0
3642                 && ! (is_from_limited_with
3643                       && (in_main_unit
3644                           || In_Extended_Main_Code_Unit (gnat_entity))))
3645               update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3646                                  gnat_to_gnu_type (gnat_desig_equiv));
3647
3648               /* Note that the call to gnat_to_gnu_type here might have
3649                  updated gnu_old_type directly, in which case it is not a
3650                  dummy type any more when we get into update_pointer_to.
3651
3652                  This may happen for instance when the designated type is a
3653                  record type, because their elaboration starts with an
3654                  initial node from make_dummy_type, which may yield the same
3655                  node as the one we got.
3656
3657                  Besides, variants of this non-dummy type might have been
3658                  created along the way.  update_pointer_to is expected to
3659                  properly take care of those situations.  */
3660             else
3661               {
3662                 struct incomplete *p
3663                   = (struct incomplete *) xmalloc (sizeof
3664                                                    (struct incomplete));
3665                 struct incomplete **head
3666                   = (is_from_limited_with
3667                      && (in_main_unit
3668                          || In_Extended_Main_Code_Unit (gnat_entity))
3669                      ? &defer_limited_with : &defer_incomplete_list);
3670
3671                 p->old_type = gnu_old_type;
3672                 p->full_type = gnat_desig_equiv;
3673                 p->next = *head;
3674                 *head = p;
3675               }
3676           }
3677       }
3678       break;
3679
3680     case E_Access_Protected_Subprogram_Type:
3681     case E_Anonymous_Access_Protected_Subprogram_Type:
3682       if (type_annotate_only && No (gnat_equiv_type))
3683         gnu_type = ptr_void_type_node;
3684       else
3685         {
3686           /* The runtime representation is the equivalent type.  */
3687           gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3688           maybe_present = true;
3689         }
3690
3691       if (Is_Itype (Directly_Designated_Type (gnat_entity))
3692           && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3693           && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3694           && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3695         gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3696                             NULL_TREE, 0);
3697
3698       break;
3699
3700     case E_Access_Subtype:
3701
3702       /* We treat this as identical to its base type; any constraint is
3703          meaningful only to the front end.
3704
3705          The designated type must be elaborated as well, if it does
3706          not have its own freeze node.  Designated (sub)types created
3707          for constrained components of records with discriminants are
3708          not frozen by the front end and thus not elaborated by gigi,
3709          because their use may appear before the base type is frozen,
3710          and because it is not clear that they are needed anywhere in
3711          Gigi.  With the current model, there is no correct place where
3712          they could be elaborated.  */
3713
3714       gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3715       if (Is_Itype (Directly_Designated_Type (gnat_entity))
3716           && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3717           && Is_Frozen (Directly_Designated_Type (gnat_entity))
3718           && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3719         {
3720           /* If we are not defining this entity, and we have incomplete
3721              entities being processed above us, make a dummy type and
3722              elaborate it later.  */
3723           if (!definition && defer_incomplete_level != 0)
3724             {
3725               struct incomplete *p
3726                 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3727               tree gnu_ptr_type
3728                 = build_pointer_type
3729                   (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3730
3731               p->old_type = TREE_TYPE (gnu_ptr_type);
3732               p->full_type = Directly_Designated_Type (gnat_entity);
3733               p->next = defer_incomplete_list;
3734               defer_incomplete_list = p;
3735             }
3736           else if (!IN (Ekind (Base_Type
3737                               (Directly_Designated_Type (gnat_entity))),
3738                        Incomplete_Or_Private_Kind))
3739             gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3740                                 NULL_TREE, 0);
3741         }
3742
3743       maybe_present = true;
3744       break;
3745
3746     /* Subprogram Entities
3747
3748        The following access functions are defined for subprograms (functions
3749        or procedures):
3750
3751                 First_Formal    The first formal parameter.
3752                 Is_Imported     Indicates that the subprogram has appeared in
3753                                 an INTERFACE or IMPORT pragma.  For now we
3754                                 assume that the external language is C.
3755                 Is_Exported     Likewise but for an EXPORT pragma.
3756                 Is_Inlined      True if the subprogram is to be inlined.
3757
3758        In addition for function subprograms we have:
3759
3760                 Etype           Return type of the function.
3761
3762        Each parameter is first checked by calling must_pass_by_ref on its
3763        type to determine if it is passed by reference.  For parameters which
3764        are copied in, if they are Ada In Out or Out parameters, their return
3765        value becomes part of a record which becomes the return type of the
3766        function (C function - note that this applies only to Ada procedures
3767        so there is no Ada return type).  Additional code to store back the
3768        parameters will be generated on the caller side.  This transformation
3769        is done here, not in the front-end.
3770
3771        The intended result of the transformation can be seen from the
3772        equivalent source rewritings that follow:
3773
3774                                                 struct temp {int a,b};
3775        procedure P (A,B: In Out ...) is         temp P (int A,B)
3776        begin                                    {
3777          ..                                       ..
3778        end P;                                     return {A,B};
3779                                                 }
3780
3781                                                 temp t;
3782        P(X,Y);                                  t = P(X,Y);
3783                                                 X = t.a , Y = t.b;
3784
3785        For subprogram types we need to perform mainly the same conversions to
3786        GCC form that are needed for procedures and function declarations.  The
3787        only difference is that at the end, we make a type declaration instead
3788        of a function declaration.  */
3789
3790     case E_Subprogram_Type:
3791     case E_Function:
3792     case E_Procedure:
3793       {
3794         /* The first GCC parameter declaration (a PARM_DECL node).  The
3795            PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3796            actually is the head of this parameter list.  */
3797         tree gnu_param_list = NULL_TREE;
3798         /* Likewise for the stub associated with an exported procedure.  */
3799         tree gnu_stub_param_list = NULL_TREE;
3800         /* The type returned by a function.  If the subprogram is a procedure
3801            this type should be void_type_node.  */
3802         tree gnu_return_type = void_type_node;
3803         /* List of fields in return type of procedure with copy-in copy-out
3804            parameters.  */
3805         tree gnu_field_list = NULL_TREE;
3806         /* Non-null for subprograms containing parameters passed by copy-in
3807            copy-out (Ada In Out or Out parameters not passed by reference),
3808            in which case it is the list of nodes used to specify the values
3809            of the In Out/Out parameters that are returned as a record upon
3810            procedure return.  The TREE_PURPOSE of an element of this list is
3811            a field of the record and the TREE_VALUE is the PARM_DECL
3812            corresponding to that field.  This list will be saved in the
3813            TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create.  */
3814         tree gnu_cico_list = NULL_TREE;
3815         /* If an import pragma asks to map this subprogram to a GCC builtin,
3816            this is the builtin DECL node.  */
3817         tree gnu_builtin_decl = NULL_TREE;
3818         /* For the stub associated with an exported procedure.  */
3819         tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3820         tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3821         Entity_Id gnat_param;
3822         bool inline_flag = Is_Inlined (gnat_entity);
3823         bool public_flag = Is_Public (gnat_entity) || imported_p;
3824         bool extern_flag
3825           = (Is_Public (gnat_entity) && !definition) || imported_p;
3826
3827        /* The semantics of "pure" in Ada essentially matches that of "const"
3828           in the back-end.  In particular, both properties are orthogonal to
3829           the "nothrow" property if the EH circuitry is explicit in the
3830           internal representation of the back-end.  If we are to completely
3831           hide the EH circuitry from it, we need to declare that calls to pure
3832           Ada subprograms that can throw have side effects since they can
3833           trigger an "abnormal" transfer of control flow; thus they can be
3834           neither "const" nor "pure" in the back-end sense.  */
3835         bool const_flag
3836           = (Exception_Mechanism == Back_End_Exceptions
3837              && Is_Pure (gnat_entity));
3838
3839         bool volatile_flag = No_Return (gnat_entity);
3840         bool return_by_direct_ref_p = false;
3841         bool return_by_invisi_ref_p = false;
3842         bool return_unconstrained_p = false;
3843         bool has_copy_in_out = false;
3844         bool has_stub = false;
3845         int parmnum;
3846
3847         /* A parameter may refer to this type, so defer completion of any
3848            incomplete types.  */
3849         if (kind == E_Subprogram_Type && !definition)
3850           {
3851             defer_incomplete_level++;
3852             this_deferred = true;
3853           }
3854
3855         /* If the subprogram has an alias, it is probably inherited, so
3856            we can use the original one.  If the original "subprogram"
3857            is actually an enumeration literal, it may be the first use
3858            of its type, so we must elaborate that type now.  */
3859         if (Present (Alias (gnat_entity)))
3860           {
3861             if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3862               gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3863
3864             gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3865                                            gnu_expr, 0);
3866
3867             /* Elaborate any Itypes in the parameters of this entity.  */
3868             for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3869                  Present (gnat_temp);
3870                  gnat_temp = Next_Formal_With_Extras (gnat_temp))
3871               if (Is_Itype (Etype (gnat_temp)))
3872                 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3873
3874             break;
3875           }
3876
3877         /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3878            corresponding DECL node.
3879
3880            We still want the parameter associations to take place because the
3881            proper generation of calls depends on it (a GNAT parameter without
3882            a corresponding GCC tree has a very specific meaning), so we don't
3883            just break here.  */
3884         if (Convention (gnat_entity) == Convention_Intrinsic)
3885           gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3886
3887         /* ??? What if we don't find the builtin node above ? warn ? err ?
3888            In the current state we neither warn nor err, and calls will just
3889            be handled as for regular subprograms.  */
3890
3891         if (kind == E_Function || kind == E_Subprogram_Type)
3892           gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3893
3894         /* If this function returns by reference, make the actual return
3895            type of this function the pointer and mark the decl.  */
3896         if (Returns_By_Ref (gnat_entity))
3897           {
3898             gnu_return_type = build_pointer_type (gnu_return_type);
3899             return_by_direct_ref_p = true;
3900           }
3901
3902         /* If the Mechanism is By_Reference, ensure this function uses the
3903            target's by-invisible-reference mechanism, which may not be the
3904            same as above (e.g. it might be passing an extra parameter).
3905
3906            Prior to GCC 4, this was handled by just setting TREE_ADDRESSABLE
3907            on the result type.  Everything required to pass by invisible
3908            reference using the target's mechanism (e.g. an extra parameter)
3909            was handled at RTL expansion time.
3910
3911            This doesn't work with GCC 4 any more for several reasons.  First,
3912            the gimplification process might need to create temporaries of this
3913            type and the gimplifier ICEs on such attempts; that's why the flag
3914            is now set on the function type instead.  Second, the middle-end
3915            now also relies on a different attribute, DECL_BY_REFERENCE on the
3916            RESULT_DECL, and expects the by-invisible-reference-ness to be made
3917            explicit in the function body.  */
3918         else if (kind == E_Function && Mechanism (gnat_entity) == By_Reference)
3919           return_by_invisi_ref_p = true;
3920
3921         /* If we are supposed to return an unconstrained array, actually return
3922            a fat pointer and make a note of that.  */
3923         else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3924           {
3925             gnu_return_type = TREE_TYPE (gnu_return_type);
3926             return_unconstrained_p = true;
3927           }
3928
3929         /* If the type requires a transient scope, the result is allocated
3930            on the secondary stack, so the result type of the function is
3931            just a pointer.  */
3932         else if (Requires_Transient_Scope (Etype (gnat_entity)))
3933           {
3934             gnu_return_type = build_pointer_type (gnu_return_type);
3935             return_unconstrained_p = true;
3936           }
3937
3938         /* If the type is a padded type and the underlying type would not
3939            be passed by reference or this function has a foreign convention,
3940            return the underlying type.  */
3941         else if (TYPE_IS_PADDING_P (gnu_return_type)
3942                  && (!default_pass_by_ref (TREE_TYPE
3943                                            (TYPE_FIELDS (gnu_return_type)))
3944                      || Has_Foreign_Convention (gnat_entity)))
3945           gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3946
3947         /* If the return type is unconstrained, that means it must have a
3948            maximum size.  Use the padded type as the effective return type.
3949            And ensure the function uses the target's by-invisible-reference
3950            mechanism to avoid copying too much data when it returns.  */
3951         if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
3952           {
3953             gnu_return_type
3954               = maybe_pad_type (gnu_return_type,
3955                                 max_size (TYPE_SIZE (gnu_return_type), true),
3956                                 0, gnat_entity, false, false, false, true);
3957             return_by_invisi_ref_p = true;
3958           }
3959
3960         /* If the return type has a size that overflows, we cannot have
3961            a function that returns that type.  This usage doesn't make
3962            sense anyway, so give an error here.  */
3963         if (TYPE_SIZE_UNIT (gnu_return_type)
3964             && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3965             && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3966           {
3967             post_error ("cannot return type whose size overflows",
3968                         gnat_entity);
3969             gnu_return_type = copy_node (gnu_return_type);
3970             TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3971             TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3972             TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3973             TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3974           }
3975
3976         /* Look at all our parameters and get the type of
3977            each.  While doing this, build a copy-out structure if
3978            we need one.  */
3979
3980         /* Loop over the parameters and get their associated GCC tree.
3981            While doing this, build a copy-out structure if we need one.  */
3982         for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3983              Present (gnat_param);
3984              gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3985           {
3986             tree gnu_param_name = get_entity_name (gnat_param);
3987             tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3988             tree gnu_param, gnu_field;
3989             bool copy_in_copy_out = false;
3990             Mechanism_Type mech = Mechanism (gnat_param);
3991
3992             /* Builtins are expanded inline and there is no real call sequence
3993                involved.  So the type expected by the underlying expander is
3994                always the type of each argument "as is".  */
3995             if (gnu_builtin_decl)
3996               mech = By_Copy;
3997             /* Handle the first parameter of a valued procedure specially.  */
3998             else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3999               mech = By_Copy_Return;
4000             /* Otherwise, see if a Mechanism was supplied that forced this
4001                parameter to be passed one way or another.  */
4002             else if (mech == Default
4003                      || mech == By_Copy || mech == By_Reference)
4004               ;
4005             else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4006               mech = By_Descriptor;
4007
4008             else if (By_Short_Descriptor_Last <= mech &&
4009                      mech <= By_Short_Descriptor)
4010               mech = By_Short_Descriptor;
4011
4012             else if (mech > 0)
4013               {
4014                 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4015                     || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4016                     || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4017                                              mech))
4018                   mech = By_Reference;
4019                 else
4020                   mech = By_Copy;
4021               }
4022             else
4023               {
4024                 post_error ("unsupported mechanism for&", gnat_param);
4025                 mech = Default;
4026               }
4027
4028             gnu_param
4029               = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4030                                    Has_Foreign_Convention (gnat_entity),
4031                                    &copy_in_copy_out);
4032
4033             /* We are returned either a PARM_DECL or a type if no parameter
4034                needs to be passed; in either case, adjust the type.  */
4035             if (DECL_P (gnu_param))
4036               gnu_param_type = TREE_TYPE (gnu_param);
4037             else
4038               {
4039                 gnu_param_type = gnu_param;
4040                 gnu_param = NULL_TREE;
4041               }
4042
4043             if (gnu_param)
4044               {
4045                 /* If it's an exported subprogram, we build a parameter list
4046                    in parallel, in case we need to emit a stub for it.  */
4047                 if (Is_Exported (gnat_entity))
4048                   {
4049                     gnu_stub_param_list
4050                       = chainon (gnu_param, gnu_stub_param_list);
4051                     /* Change By_Descriptor parameter to By_Reference for
4052                        the internal version of an exported subprogram.  */
4053                     if (mech == By_Descriptor || mech == By_Short_Descriptor)
4054                       {
4055                         gnu_param
4056                           = gnat_to_gnu_param (gnat_param, By_Reference,
4057                                                gnat_entity, false,
4058                                                &copy_in_copy_out);
4059                         has_stub = true;
4060                       }
4061                     else
4062                       gnu_param = copy_node (gnu_param);
4063                   }
4064
4065                 gnu_param_list = chainon (gnu_param, gnu_param_list);
4066                 Sloc_to_locus (Sloc (gnat_param),
4067                                &DECL_SOURCE_LOCATION (gnu_param));
4068                 save_gnu_tree (gnat_param, gnu_param, false);
4069
4070                 /* If a parameter is a pointer, this function may modify
4071                    memory through it and thus shouldn't be considered
4072                    a const function.  Also, the memory may be modified
4073                    between two calls, so they can't be CSE'ed.  The latter
4074                    case also handles by-ref parameters.  */
4075                 if (POINTER_TYPE_P (gnu_param_type)
4076                     || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4077                   const_flag = false;
4078               }
4079
4080             if (copy_in_copy_out)
4081               {
4082                 if (!has_copy_in_out)
4083                   {
4084                     gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
4085                     gnu_return_type = make_node (RECORD_TYPE);
4086                     TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4087                     /* Set a default alignment to speed up accesses.  */
4088                     TYPE_ALIGN (gnu_return_type)
4089                       = get_mode_alignment (ptr_mode);
4090                     has_copy_in_out = true;
4091                   }
4092
4093                 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
4094                                                gnu_return_type, 0, 0, 0, 0);
4095                 Sloc_to_locus (Sloc (gnat_param),
4096                                &DECL_SOURCE_LOCATION (gnu_field));
4097                 TREE_CHAIN (gnu_field) = gnu_field_list;
4098                 gnu_field_list = gnu_field;
4099                 gnu_cico_list
4100                   = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4101               }
4102           }
4103
4104         /* Do not compute record for out parameters if subprogram is
4105            stubbed since structures are incomplete for the back-end.  */
4106         if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
4107           finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4108                               0, debug_info_p);
4109
4110         /* If we have a CICO list but it has only one entry, we convert
4111            this function into a function that simply returns that one
4112            object.  */
4113         if (list_length (gnu_cico_list) == 1)
4114           gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4115
4116         if (Has_Stdcall_Convention (gnat_entity))
4117           prepend_one_attribute_to
4118             (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4119              get_identifier ("stdcall"), NULL_TREE,
4120              gnat_entity);
4121
4122         /* If we are on a target where stack realignment is needed for 'main'
4123            to honor GCC's implicit expectations (stack alignment greater than
4124            what the base ABI guarantees), ensure we do the same for foreign
4125            convention subprograms as they might be used as callbacks from code
4126            breaking such expectations.  Note that this applies to task entry
4127            points in particular.  */
4128         if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4129             && Has_Foreign_Convention (gnat_entity))
4130           prepend_one_attribute_to
4131             (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4132              get_identifier ("force_align_arg_pointer"), NULL_TREE,
4133              gnat_entity);
4134
4135         /* The lists have been built in reverse.  */
4136         gnu_param_list = nreverse (gnu_param_list);
4137         if (has_stub)
4138           gnu_stub_param_list = nreverse (gnu_stub_param_list);
4139         gnu_cico_list = nreverse (gnu_cico_list);
4140
4141         if (Ekind (gnat_entity) == E_Function)
4142           Set_Mechanism (gnat_entity, return_unconstrained_p
4143                                       || return_by_direct_ref_p
4144                                       || return_by_invisi_ref_p
4145                                       ? By_Reference : By_Copy);
4146         gnu_type
4147           = create_subprog_type (gnu_return_type, gnu_param_list,
4148                                  gnu_cico_list, return_unconstrained_p,
4149                                  return_by_direct_ref_p,
4150                                  return_by_invisi_ref_p);
4151
4152         if (has_stub)
4153           gnu_stub_type
4154             = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4155                                    gnu_cico_list, return_unconstrained_p,
4156                                    return_by_direct_ref_p,
4157                                    return_by_invisi_ref_p);
4158
4159         /* A subprogram (something that doesn't return anything) shouldn't
4160            be considered const since there would be no reason for such a
4161            subprogram.  Note that procedures with Out (or In Out) parameters
4162            have already been converted into a function with a return type.  */
4163         if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4164           const_flag = false;
4165
4166         gnu_type
4167           = build_qualified_type (gnu_type,
4168                                   TYPE_QUALS (gnu_type)
4169                                   | (TYPE_QUAL_CONST * const_flag)
4170                                   | (TYPE_QUAL_VOLATILE * volatile_flag));
4171
4172         if (has_stub)
4173           gnu_stub_type
4174             = build_qualified_type (gnu_stub_type,
4175                                     TYPE_QUALS (gnu_stub_type)
4176                                     | (TYPE_QUAL_CONST * const_flag)
4177                                     | (TYPE_QUAL_VOLATILE * volatile_flag));
4178
4179         /* If we have a builtin decl for that function, check the signatures
4180            compatibilities.  If the signatures are compatible, use the builtin
4181            decl.  If they are not, we expect the checker predicate to have
4182            posted the appropriate errors, and just continue with what we have
4183            so far.  */
4184         if (gnu_builtin_decl)
4185           {
4186             tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4187
4188             if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4189               {
4190                 gnu_decl = gnu_builtin_decl;
4191                 gnu_type = gnu_builtin_type;
4192                 break;
4193               }
4194           }
4195
4196         /* If there was no specified Interface_Name and the external and
4197            internal names of the subprogram are the same, only use the
4198            internal name to allow disambiguation of nested subprograms.  */
4199         if (No (Interface_Name (gnat_entity))
4200             && gnu_ext_name == gnu_entity_name)
4201           gnu_ext_name = NULL_TREE;
4202
4203         /* If we are defining the subprogram and it has an Address clause
4204            we must get the address expression from the saved GCC tree for the
4205            subprogram if it has a Freeze_Node.  Otherwise, we elaborate
4206            the address expression here since the front-end has guaranteed
4207            in that case that the elaboration has no effects.  If there is
4208            an Address clause and we are not defining the object, just
4209            make it a constant.  */
4210         if (Present (Address_Clause (gnat_entity)))
4211           {
4212             tree gnu_address = NULL_TREE;
4213
4214             if (definition)
4215               gnu_address
4216                 = (present_gnu_tree (gnat_entity)
4217                    ? get_gnu_tree (gnat_entity)
4218                    : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4219
4220             save_gnu_tree (gnat_entity, NULL_TREE, false);
4221
4222             /* Convert the type of the object to a reference type that can
4223                alias everything as per 13.3(19).  */
4224             gnu_type
4225               = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4226             if (gnu_address)
4227               gnu_address = convert (gnu_type, gnu_address);
4228
4229             gnu_decl
4230               = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4231                                  gnu_address, false, Is_Public (gnat_entity),
4232                                  extern_flag, false, NULL, gnat_entity);
4233             DECL_BY_REF_P (gnu_decl) = 1;
4234           }
4235
4236         else if (kind == E_Subprogram_Type)
4237           gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4238                                        !Comes_From_Source (gnat_entity),
4239                                        debug_info_p, gnat_entity);
4240         else
4241           {
4242             if (has_stub)
4243               {
4244                 gnu_stub_name = gnu_ext_name;
4245                 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4246                 public_flag = false;
4247               }
4248
4249             gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4250                                             gnu_type, gnu_param_list,
4251                                             inline_flag, public_flag,
4252                                             extern_flag, attr_list,
4253                                             gnat_entity);
4254             if (has_stub)
4255               {
4256                 tree gnu_stub_decl
4257                   = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4258                                          gnu_stub_type, gnu_stub_param_list,
4259                                          inline_flag, true,
4260                                          extern_flag, attr_list,
4261                                          gnat_entity);
4262                 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4263               }
4264
4265             /* This is unrelated to the stub built right above.  */
4266             DECL_STUBBED_P (gnu_decl)
4267               = Convention (gnat_entity) == Convention_Stubbed;
4268           }
4269       }
4270       break;
4271
4272     case E_Incomplete_Type:
4273     case E_Incomplete_Subtype:
4274     case E_Private_Type:
4275     case E_Private_Subtype:
4276     case E_Limited_Private_Type:
4277     case E_Limited_Private_Subtype:
4278     case E_Record_Type_With_Private:
4279     case E_Record_Subtype_With_Private:
4280       {
4281         /* Get the "full view" of this entity.  If this is an incomplete
4282            entity from a limited with, treat its non-limited view as the
4283            full view.  Otherwise, use either the full view or the underlying
4284            full view, whichever is present.  This is used in all the tests
4285            below.  */
4286         Entity_Id full_view
4287           = (IN (Ekind (gnat_entity), Incomplete_Kind)
4288              && From_With_Type (gnat_entity))
4289             ? Non_Limited_View (gnat_entity)
4290             : Present (Full_View (gnat_entity))
4291               ? Full_View (gnat_entity)
4292               : Underlying_Full_View (gnat_entity);
4293
4294         /* If this is an incomplete type with no full view, it must be a Taft
4295            Amendment type, in which case we return a dummy type.  Otherwise,
4296            just get the type from its Etype.  */
4297         if (No (full_view))
4298           {
4299             if (kind == E_Incomplete_Type)
4300               {
4301                 gnu_type = make_dummy_type (gnat_entity);
4302                 gnu_decl = TYPE_STUB_DECL (gnu_type);
4303               }
4304             else
4305               {
4306                 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4307                                                NULL_TREE, 0);
4308                 maybe_present = true;
4309               }
4310             break;
4311           }
4312
4313         /* If we already made a type for the full view, reuse it.  */
4314         else if (present_gnu_tree (full_view))
4315           {
4316             gnu_decl = get_gnu_tree (full_view);
4317             break;
4318           }
4319
4320         /* Otherwise, if we are not defining the type now, get the type
4321            from the full view.  But always get the type from the full view
4322            for define on use types, since otherwise we won't see them!  */
4323         else if (!definition
4324                  || (Is_Itype (full_view)
4325                    && No (Freeze_Node (gnat_entity)))
4326                  || (Is_Itype (gnat_entity)
4327                    && No (Freeze_Node (full_view))))
4328           {
4329             gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4330             maybe_present = true;
4331             break;
4332           }
4333
4334         /* For incomplete types, make a dummy type entry which will be
4335            replaced later.  Save it as the full declaration's type so
4336            we can do any needed updates when we see it.  */
4337         gnu_type = make_dummy_type (gnat_entity);
4338         gnu_decl = TYPE_STUB_DECL (gnu_type);
4339         save_gnu_tree (full_view, gnu_decl, 0);
4340         break;
4341       }
4342
4343     case E_Class_Wide_Type:
4344       /* Class-wide types are always transformed into their root type.  */
4345       gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4346       maybe_present = true;
4347       break;
4348
4349     case E_Task_Type:
4350     case E_Task_Subtype:
4351     case E_Protected_Type:
4352     case E_Protected_Subtype:
4353       if (type_annotate_only && No (gnat_equiv_type))
4354         gnu_type = void_type_node;
4355       else
4356         gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4357
4358       maybe_present = true;
4359       break;
4360
4361     case E_Label:
4362       gnu_decl = create_label_decl (gnu_entity_name);
4363       break;
4364
4365     case E_Block:
4366     case E_Loop:
4367       /* Nothing at all to do here, so just return an ERROR_MARK and claim
4368          we've already saved it, so we don't try to.  */
4369       gnu_decl = error_mark_node;
4370       saved = true;
4371       break;
4372
4373     default:
4374       gcc_unreachable ();
4375     }
4376
4377   /* If we had a case where we evaluated another type and it might have
4378      defined this one, handle it here.  */
4379   if (maybe_present && present_gnu_tree (gnat_entity))
4380     {
4381       gnu_decl = get_gnu_tree (gnat_entity);
4382       saved = true;
4383     }
4384
4385   /* If we are processing a type and there is either no decl for it or
4386      we just made one, do some common processing for the type, such as
4387      handling alignment and possible padding.  */
4388   if (is_type && (!gnu_decl || this_made_decl))
4389     {
4390       /* Tell the middle-end that objects of tagged types are guaranteed to
4391          be properly aligned.  This is necessary because conversions to the
4392          class-wide type are translated into conversions to the root type,
4393          which can be less aligned than some of its derived types.  */
4394       if (Is_Tagged_Type (gnat_entity)
4395           || Is_Class_Wide_Equivalent_Type (gnat_entity))
4396         TYPE_ALIGN_OK (gnu_type) = 1;
4397
4398       /* If the type is passed by reference, objects of this type must be
4399          fully addressable and cannot be copied.  */
4400       if (Is_By_Reference_Type (gnat_entity))
4401         TREE_ADDRESSABLE (gnu_type) = 1;
4402
4403       /* ??? Don't set the size for a String_Literal since it is either
4404          confirming or we don't handle it properly (if the low bound is
4405          non-constant).  */
4406       if (!gnu_size && kind != E_String_Literal_Subtype)
4407         gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4408                                   TYPE_DECL, false,
4409                                   Has_Size_Clause (gnat_entity));
4410
4411       /* If a size was specified, see if we can make a new type of that size
4412          by rearranging the type, for example from a fat to a thin pointer.  */
4413       if (gnu_size)
4414         {
4415           gnu_type
4416             = make_type_from_size (gnu_type, gnu_size,
4417                                    Has_Biased_Representation (gnat_entity));
4418
4419           if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4420               && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4421             gnu_size = 0;
4422         }
4423
4424       /* If the alignment hasn't already been processed and this is
4425          not an unconstrained array, see if an alignment is specified.
4426          If not, we pick a default alignment for atomic objects.  */
4427       if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4428         ;
4429       else if (Known_Alignment (gnat_entity))
4430         {
4431           align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4432                                       TYPE_ALIGN (gnu_type));
4433
4434           /* Warn on suspiciously large alignments.  This should catch
4435              errors about the (alignment,byte)/(size,bit) discrepancy.  */
4436           if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4437             {
4438               tree size;
4439
4440               /* If a size was specified, take it into account.  Otherwise
4441                  use the RM size for records as the type size has already
4442                  been adjusted to the alignment.  */
4443               if (gnu_size)
4444                 size = gnu_size;
4445               else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4446                         || TREE_CODE (gnu_type) == UNION_TYPE
4447                         || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4448                        && !TYPE_FAT_POINTER_P (gnu_type))
4449                 size = rm_size (gnu_type);
4450               else
4451                 size = TYPE_SIZE (gnu_type);
4452
4453               /* Consider an alignment as suspicious if the alignment/size
4454                  ratio is greater or equal to the byte/bit ratio.  */
4455               if (host_integerp (size, 1)
4456                   && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4457                 post_error_ne ("?suspiciously large alignment specified for&",
4458                                Expression (Alignment_Clause (gnat_entity)),
4459                                gnat_entity);
4460             }
4461         }
4462       else if (Is_Atomic (gnat_entity) && !gnu_size
4463                && host_integerp (TYPE_SIZE (gnu_type), 1)
4464                && integer_pow2p (TYPE_SIZE (gnu_type)))
4465         align = MIN (BIGGEST_ALIGNMENT,
4466                      tree_low_cst (TYPE_SIZE (gnu_type), 1));
4467       else if (Is_Atomic (gnat_entity) && gnu_size
4468                && host_integerp (gnu_size, 1)
4469                && integer_pow2p (gnu_size))
4470         align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4471
4472       /* See if we need to pad the type.  If we did, and made a record,
4473          the name of the new type may be changed.  So get it back for
4474          us when we make the new TYPE_DECL below.  */
4475       if (gnu_size || align > 0)
4476         gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4477                                    false, !gnu_decl, definition, false);
4478
4479       if (TYPE_IS_PADDING_P (gnu_type))
4480         {
4481           gnu_entity_name = TYPE_NAME (gnu_type);
4482           if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4483             gnu_entity_name = DECL_NAME (gnu_entity_name);
4484         }
4485
4486       set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4487
4488       /* If we are at global level, GCC will have applied variable_size to
4489          the type, but that won't have done anything.  So, if it's not
4490          a constant or self-referential, call elaborate_expression_1 to
4491          make a variable for the size rather than calculating it each time.
4492          Handle both the RM size and the actual size.  */
4493       if (global_bindings_p ()
4494           && TYPE_SIZE (gnu_type)
4495           && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4496           && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4497         {
4498           if (TREE_CODE (gnu_type) == RECORD_TYPE
4499               && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4500                                   TYPE_SIZE (gnu_type), 0))
4501             {
4502               TYPE_SIZE (gnu_type)
4503                 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4504                                           gnat_entity, get_identifier ("SIZE"),
4505                                           definition, false);
4506               SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4507             }
4508           else
4509             {
4510               TYPE_SIZE (gnu_type)
4511                 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4512                                           gnat_entity, get_identifier ("SIZE"),
4513                                           definition, false);
4514
4515               /* ??? For now, store the size as a multiple of the alignment
4516                  in bytes so that we can see the alignment from the tree.  */
4517               TYPE_SIZE_UNIT (gnu_type)
4518                 = build_binary_op
4519                   (MULT_EXPR, sizetype,
4520                    elaborate_expression_1
4521                    (build_binary_op (EXACT_DIV_EXPR, sizetype,
4522                                      TYPE_SIZE_UNIT (gnu_type),
4523                                      size_int (TYPE_ALIGN (gnu_type)
4524                                                / BITS_PER_UNIT)),
4525                     gnat_entity, get_identifier ("SIZE_A_UNIT"),
4526                     definition, false),
4527                    size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4528
4529               if (TREE_CODE (gnu_type) == RECORD_TYPE)
4530                 SET_TYPE_ADA_SIZE
4531                   (gnu_type,
4532                    elaborate_expression_1 (TYPE_ADA_SIZE (gnu_type),
4533                                            gnat_entity,
4534                                            get_identifier ("RM_SIZE"),
4535                                            definition, false));
4536                  }
4537         }
4538
4539       /* If this is a record type or subtype, call elaborate_expression_1 on
4540          any field position.  Do this for both global and local types.
4541          Skip any fields that we haven't made trees for to avoid problems with
4542          class wide types.  */
4543       if (IN (kind, Record_Kind))
4544         for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4545              gnat_temp = Next_Entity (gnat_temp))
4546           if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4547             {
4548               tree gnu_field = get_gnu_tree (gnat_temp);
4549
4550               /* ??? Unfortunately, GCC needs to be able to prove the
4551                  alignment of this offset and if it's a variable, it can't.
4552                  In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4553                  right now, we have to put in an explicit multiply and
4554                  divide by that value.  */
4555               if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4556                 {
4557                 DECL_FIELD_OFFSET (gnu_field)
4558                   = build_binary_op
4559                     (MULT_EXPR, sizetype,
4560                      elaborate_expression_1
4561                      (build_binary_op (EXACT_DIV_EXPR, sizetype,
4562                                        DECL_FIELD_OFFSET (gnu_field),
4563                                        size_int (DECL_OFFSET_ALIGN (gnu_field)
4564                                                  / BITS_PER_UNIT)),
4565                       gnat_temp, get_identifier ("OFFSET"),
4566                       definition, false),
4567                      size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4568
4569                 /* ??? The context of gnu_field is not necessarily gnu_type so
4570                    the MULT_EXPR node built above may not be marked by the call
4571                    to create_type_decl below.  */
4572                 if (global_bindings_p ())
4573                   MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4574                 }
4575             }
4576
4577       if (Treat_As_Volatile (gnat_entity))
4578         gnu_type
4579           = build_qualified_type (gnu_type,
4580                                   TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4581
4582       if (Is_Atomic (gnat_entity))
4583         check_ok_for_atomic (gnu_type, gnat_entity, false);
4584
4585       if (Present (Alignment_Clause (gnat_entity)))
4586         TYPE_USER_ALIGN (gnu_type) = 1;
4587
4588       if (Universal_Aliasing (gnat_entity))
4589         TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4590
4591       if (!gnu_decl)
4592         gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4593                                      !Comes_From_Source (gnat_entity),
4594                                      debug_info_p, gnat_entity);
4595       else
4596         {
4597           TREE_TYPE (gnu_decl) = gnu_type;
4598           TYPE_STUB_DECL (gnu_type) = gnu_decl;
4599         }
4600     }
4601
4602   if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4603     {
4604       gnu_type = TREE_TYPE (gnu_decl);
4605
4606       /* If this is a derived type, relate its alias set to that of its parent
4607          to avoid troubles when a call to an inherited primitive is inlined in
4608          a context where a derived object is accessed.  The inlined code works
4609          on the parent view so the resulting code may access the same object
4610          using both the parent and the derived alias sets, which thus have to
4611          conflict.  As the same issue arises with component references, the
4612          parent alias set also has to conflict with composite types enclosing
4613          derived components.  For instance, if we have:
4614
4615             type D is new T;
4616             type R is record
4617                Component : D;
4618             end record;
4619
4620          we want T to conflict with both D and R, in addition to R being a
4621          superset of D by record/component construction.
4622
4623          One way to achieve this is to perform an alias set copy from the
4624          parent to the derived type.  This is not quite appropriate, though,
4625          as we don't want separate derived types to conflict with each other:
4626
4627             type I1 is new Integer;
4628             type I2 is new Integer;
4629
4630          We want I1 and I2 to both conflict with Integer but we do not want
4631          I1 to conflict with I2, and an alias set copy on derivation would
4632          have that effect.
4633
4634          The option chosen is to make the alias set of the derived type a
4635          superset of that of its parent type.  It trivially fulfills the
4636          simple requirement for the Integer derivation example above, and
4637          the component case as well by superset transitivity:
4638
4639                    superset      superset
4640                 R ----------> D ----------> T
4641
4642          However, for composite types, conversions between derived types are
4643          translated into VIEW_CONVERT_EXPRs so a sequence like:
4644
4645             type Comp1 is new Comp;
4646             type Comp2 is new Comp;
4647             procedure Proc (C : Comp1);
4648
4649             C : Comp2;
4650             Proc (Comp1 (C));
4651
4652          is translated into:
4653
4654             C : Comp2;
4655             Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4656
4657          and gimplified into:
4658
4659             C : Comp2;
4660             Comp1 *C.0;
4661             C.0 = (Comp1 *) &C;
4662             Proc (C.0);
4663
4664          i.e. generates code involving type punning.  Therefore, Comp1 needs
4665          to conflict with Comp2 and an alias set copy is required.
4666
4667          The language rules ensure the parent type is already frozen here.  */
4668       if (Is_Derived_Type (gnat_entity))
4669         {
4670           tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4671           relate_alias_sets (gnu_type, gnu_parent_type,
4672                              Is_Composite_Type (gnat_entity)
4673                              ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4674         }
4675
4676       /* Back-annotate the Alignment of the type if not already in the
4677          tree.  Likewise for sizes.  */
4678       if (Unknown_Alignment (gnat_entity))
4679         {
4680           unsigned int double_align, align;
4681           bool is_capped_double, align_clause;
4682
4683           /* If the default alignment of "double" or larger scalar types is
4684              specifically capped and this is not an array with an alignment
4685              clause on the component type, return the cap.  */
4686           if ((double_align = double_float_alignment) > 0)
4687             is_capped_double
4688               = is_double_float_or_array (gnat_entity, &align_clause);
4689           else if ((double_align = double_scalar_alignment) > 0)
4690             is_capped_double
4691               = is_double_scalar_or_array (gnat_entity, &align_clause);
4692           else
4693             is_capped_double = align_clause = false;
4694
4695           if (is_capped_double && !align_clause)
4696             align = double_align;
4697           else
4698             align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4699
4700           Set_Alignment (gnat_entity, UI_From_Int (align));
4701         }
4702
4703       if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4704         {
4705           tree gnu_size = TYPE_SIZE (gnu_type);
4706
4707           /* If the size is self-referential, annotate the maximum value.  */
4708           if (CONTAINS_PLACEHOLDER_P (gnu_size))
4709             gnu_size = max_size (gnu_size, true);
4710
4711           if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4712             {
4713               /* In this mode, the tag and the parent components are not
4714                  generated by the front-end so the sizes must be adjusted.  */
4715               tree pointer_size = bitsize_int (POINTER_SIZE), offset;
4716               Uint uint_size;
4717
4718               if (Is_Derived_Type (gnat_entity))
4719                 {
4720                   offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
4721                                       bitsizetype);
4722                   Set_Alignment (gnat_entity,
4723                                  Alignment (Etype (Base_Type (gnat_entity))));
4724                 }
4725               else
4726                 offset = pointer_size;
4727
4728               gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4729               gnu_size = size_binop (MULT_EXPR, pointer_size,
4730                                                 size_binop (CEIL_DIV_EXPR,
4731                                                             gnu_size,
4732                                                             pointer_size));
4733               uint_size = annotate_value (gnu_size);
4734               Set_Esize (gnat_entity, uint_size);
4735               Set_RM_Size (gnat_entity, uint_size);
4736             }
4737           else
4738             Set_Esize (gnat_entity, annotate_value (gnu_size));
4739         }
4740
4741       if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4742         Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4743     }
4744
4745   if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4746     DECL_ARTIFICIAL (gnu_decl) = 1;
4747
4748   if (!debug_info_p && DECL_P (gnu_decl)
4749       && TREE_CODE (gnu_decl) != FUNCTION_DECL
4750       && No (Renamed_Object (gnat_entity)))
4751     DECL_IGNORED_P (gnu_decl) = 1;
4752
4753   /* If we haven't already, associate the ..._DECL node that we just made with
4754      the input GNAT entity node.  */
4755   if (!saved)
4756     save_gnu_tree (gnat_entity, gnu_decl, false);
4757
4758   /* If this is an enumeration or floating-point type, we were not able to set
4759      the bounds since they refer to the type.  These are always static.  */
4760   if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4761       || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4762     {
4763       tree gnu_scalar_type = gnu_type;
4764       tree gnu_low_bound, gnu_high_bound;
4765
4766       /* If this is a padded type, we need to use the underlying type.  */
4767       if (TYPE_IS_PADDING_P (gnu_scalar_type))
4768         gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4769
4770       /* If this is a floating point type and we haven't set a floating
4771          point type yet, use this in the evaluation of the bounds.  */
4772       if (!longest_float_type_node && kind == E_Floating_Point_Type)
4773         longest_float_type_node = gnu_scalar_type;
4774
4775       gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4776       gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4777
4778       if (kind == E_Enumeration_Type)
4779         {
4780           /* Enumeration types have specific RM bounds.  */
4781           SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4782           SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4783
4784           /* Write full debugging information.  Since this has both a
4785              typedef and a tag, avoid outputting the name twice.  */
4786           DECL_ARTIFICIAL (gnu_decl) = 1;
4787           rest_of_type_decl_compilation (gnu_decl);
4788         }
4789
4790       else
4791         {
4792           /* Floating-point types don't have specific RM bounds.  */
4793           TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4794           TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4795         }
4796     }
4797
4798   /* If we deferred processing of incomplete types, re-enable it.  If there
4799      were no other disables and we have some to process, do so.  */
4800   if (this_deferred && --defer_incomplete_level == 0)
4801     {
4802       if (defer_incomplete_list)
4803         {
4804           struct incomplete *incp, *next;
4805
4806           /* We are back to level 0 for the deferring of incomplete types.
4807              But processing these incomplete types below may itself require
4808              deferring, so preserve what we have and restart from scratch.  */
4809           incp = defer_incomplete_list;
4810           defer_incomplete_list = NULL;
4811
4812           /* For finalization, however, all types must be complete so we
4813              cannot do the same because deferred incomplete types may end up
4814              referencing each other.  Process them all recursively first.  */
4815           defer_finalize_level++;
4816
4817           for (; incp; incp = next)
4818             {
4819               next = incp->next;
4820
4821               if (incp->old_type)
4822                 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4823                                    gnat_to_gnu_type (incp->full_type));
4824               free (incp);
4825             }
4826
4827           defer_finalize_level--;
4828         }
4829
4830       /* All the deferred incomplete types have been processed so we can
4831          now proceed with the finalization of the deferred types.  */
4832       if (defer_finalize_level == 0 && defer_finalize_list)
4833         {
4834           unsigned int i;
4835           tree t;
4836
4837           for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4838             rest_of_type_decl_compilation_no_defer (t);
4839
4840           VEC_free (tree, heap, defer_finalize_list);
4841         }
4842     }
4843
4844   /* If we are not defining this type, see if it's in the incomplete list.
4845      If so, handle that list entry now.  */
4846   else if (!definition)
4847     {
4848       struct incomplete *incp;
4849
4850       for (incp = defer_incomplete_list; incp; incp = incp->next)
4851         if (incp->old_type && incp->full_type == gnat_entity)
4852           {
4853             update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4854                                TREE_TYPE (gnu_decl));
4855             incp->old_type = NULL_TREE;
4856           }
4857     }
4858
4859   if (this_global)
4860     force_global--;
4861
4862   /* If this is a packed array type whose original array type is itself
4863      an Itype without freeze node, make sure the latter is processed.  */
4864   if (Is_Packed_Array_Type (gnat_entity)
4865       && Is_Itype (Original_Array_Type (gnat_entity))
4866       && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4867       && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4868     gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
4869
4870   return gnu_decl;
4871 }
4872
4873 /* Similar, but if the returned value is a COMPONENT_REF, return the
4874    FIELD_DECL.  */
4875
4876 tree
4877 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4878 {
4879   tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4880
4881   if (TREE_CODE (gnu_field) == COMPONENT_REF)
4882     gnu_field = TREE_OPERAND (gnu_field, 1);
4883
4884   return gnu_field;
4885 }
4886
4887 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type.  Return
4888    the GCC type corresponding to that entity.  */
4889
4890 tree
4891 gnat_to_gnu_type (Entity_Id gnat_entity)
4892 {
4893   tree gnu_decl;
4894
4895   /* The back end never attempts to annotate generic types.  */
4896   if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4897      return void_type_node;
4898
4899   gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4900   gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4901
4902   return TREE_TYPE (gnu_decl);
4903 }
4904
4905 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type.  Return
4906    the unpadded version of the GCC type corresponding to that entity.  */
4907
4908 tree
4909 get_unpadded_type (Entity_Id gnat_entity)
4910 {
4911   tree type = gnat_to_gnu_type (gnat_entity);
4912
4913   if (TYPE_IS_PADDING_P (type))
4914     type = TREE_TYPE (TYPE_FIELDS (type));
4915
4916   return type;
4917 }
4918 \f
4919 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4920    Every TYPE_DECL generated for a type definition must be passed
4921    to this function once everything else has been done for it.  */
4922
4923 void
4924 rest_of_type_decl_compilation (tree decl)
4925 {
4926   /* We need to defer finalizing the type if incomplete types
4927      are being deferred or if they are being processed.  */
4928   if (defer_incomplete_level || defer_finalize_level)
4929     VEC_safe_push (tree, heap, defer_finalize_list, decl);
4930   else
4931     rest_of_type_decl_compilation_no_defer (decl);
4932 }
4933
4934 /* Same as above but without deferring the compilation.  This
4935    function should not be invoked directly on a TYPE_DECL.  */
4936
4937 static void
4938 rest_of_type_decl_compilation_no_defer (tree decl)
4939 {
4940   const int toplev = global_bindings_p ();
4941   tree t = TREE_TYPE (decl);
4942
4943   rest_of_decl_compilation (decl, toplev, 0);
4944
4945   /* Now process all the variants.  This is needed for STABS.  */
4946   for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4947     {
4948       if (t == TREE_TYPE (decl))
4949         continue;
4950
4951       if (!TYPE_STUB_DECL (t))
4952         TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
4953
4954       rest_of_type_compilation (t, toplev);
4955     }
4956 }
4957
4958 /* Finalize any From_With_Type incomplete types.  We do this after processing
4959    our compilation unit and after processing its spec, if this is a body.  */
4960
4961 void
4962 finalize_from_with_types (void)
4963 {
4964   struct incomplete *incp = defer_limited_with;
4965   struct incomplete *next;
4966
4967   defer_limited_with = 0;
4968   for (; incp; incp = next)
4969     {
4970       next = incp->next;
4971
4972       if (incp->old_type != 0)
4973         update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4974                            gnat_to_gnu_type (incp->full_type));
4975       free (incp);
4976     }
4977 }
4978
4979 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4980    kind of type (such E_Task_Type) that has a different type which Gigi
4981    uses for its representation.  If the type does not have a special type
4982    for its representation, return GNAT_ENTITY.  If a type is supposed to
4983    exist, but does not, abort unless annotating types, in which case
4984    return Empty.  If GNAT_ENTITY is Empty, return Empty.  */
4985
4986 Entity_Id
4987 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4988 {
4989   Entity_Id gnat_equiv = gnat_entity;
4990
4991   if (No (gnat_entity))
4992     return gnat_entity;
4993
4994   switch (Ekind (gnat_entity))
4995     {
4996     case E_Class_Wide_Subtype:
4997       if (Present (Equivalent_Type (gnat_entity)))
4998         gnat_equiv = Equivalent_Type (gnat_entity);
4999       break;
5000
5001     case E_Access_Protected_Subprogram_Type:
5002     case E_Anonymous_Access_Protected_Subprogram_Type:
5003       gnat_equiv = Equivalent_Type (gnat_entity);
5004       break;
5005
5006     case E_Class_Wide_Type:
5007       gnat_equiv = Root_Type (gnat_entity);
5008       break;
5009
5010     case E_Task_Type:
5011     case E_Task_Subtype:
5012     case E_Protected_Type:
5013     case E_Protected_Subtype:
5014       gnat_equiv = Corresponding_Record_Type (gnat_entity);
5015       break;
5016
5017     default:
5018       break;
5019     }
5020
5021   gcc_assert (Present (gnat_equiv) || type_annotate_only);
5022   return gnat_equiv;
5023 }
5024
5025 /* Return a GCC tree for a type corresponding to the component type of the
5026    array type or subtype GNAT_ARRAY.  DEFINITION is true if this component
5027    is for an array being defined.  DEBUG_INFO_P is true if we need to write
5028    debug information for other types that we may create in the process.  */
5029
5030 static tree
5031 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5032                             bool debug_info_p)
5033 {
5034   tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
5035   tree gnu_comp_size;
5036
5037   /* Try to get a smaller form of the component if needed.  */
5038   if ((Is_Packed (gnat_array)
5039        || Has_Component_Size_Clause (gnat_array))
5040       && !Is_Bit_Packed_Array (gnat_array)
5041       && !Has_Aliased_Components (gnat_array)
5042       && !Strict_Alignment (Component_Type (gnat_array))
5043       && TREE_CODE (gnu_type) == RECORD_TYPE
5044       && !TYPE_FAT_POINTER_P (gnu_type)
5045       && host_integerp (TYPE_SIZE (gnu_type), 1))
5046     gnu_type = make_packable_type (gnu_type, false);
5047
5048   if (Has_Atomic_Components (gnat_array))
5049     check_ok_for_atomic (gnu_type, gnat_array, true);
5050
5051   /* Get and validate any specified Component_Size.  */
5052   gnu_comp_size
5053     = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5054                      Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5055                      true, Has_Component_Size_Clause (gnat_array));
5056
5057   /* If the array has aliased components and the component size can be zero,
5058      force at least unit size to ensure that the components have distinct
5059      addresses.  */
5060   if (!gnu_comp_size
5061       && Has_Aliased_Components (gnat_array)
5062       && (integer_zerop (TYPE_SIZE (gnu_type))
5063           || (TREE_CODE (gnu_type) == ARRAY_TYPE
5064               && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5065     gnu_comp_size
5066       = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5067
5068   /* If the component type is a RECORD_TYPE that has a self-referential size,
5069      then use the maximum size for the component size.  */
5070   if (!gnu_comp_size
5071       && TREE_CODE (gnu_type) == RECORD_TYPE
5072       && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5073     gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5074
5075   /* Honor the component size.  This is not needed for bit-packed arrays.  */
5076   if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5077     {
5078       tree orig_type = gnu_type;
5079       unsigned int max_align;
5080
5081       /* If an alignment is specified, use it as a cap on the component type
5082          so that it can be honored for the whole type.  But ignore it for the
5083          original type of packed array types.  */
5084       if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5085         max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5086       else
5087         max_align = 0;
5088
5089       gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5090       if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5091         gnu_type = orig_type;
5092       else
5093         orig_type = gnu_type;
5094
5095       gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5096                                  true, false, definition, true);
5097
5098       /* If a padding record was made, declare it now since it will never be
5099          declared otherwise.  This is necessary to ensure that its subtrees
5100          are properly marked.  */
5101       if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5102         create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5103                           debug_info_p, gnat_array);
5104     }
5105
5106   if (Has_Volatile_Components (Base_Type (gnat_array)))
5107     gnu_type
5108       = build_qualified_type (gnu_type,
5109                               TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5110
5111   return gnu_type;
5112 }
5113
5114 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5115    using MECH as its passing mechanism, to be placed in the parameter
5116    list built for GNAT_SUBPROG.  Assume a foreign convention for the
5117    latter if FOREIGN is true.  Also set CICO to true if the parameter
5118    must use the copy-in copy-out implementation mechanism.
5119
5120    The returned tree is a PARM_DECL, except for those cases where no
5121    parameter needs to be actually passed to the subprogram; the type
5122    of this "shadow" parameter is then returned instead.  */
5123
5124 static tree
5125 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5126                    Entity_Id gnat_subprog, bool foreign, bool *cico)
5127 {
5128   tree gnu_param_name = get_entity_name (gnat_param);
5129   tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5130   tree gnu_param_type_alt = NULL_TREE;
5131   bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5132   /* The parameter can be indirectly modified if its address is taken.  */
5133   bool ro_param = in_param && !Address_Taken (gnat_param);
5134   bool by_return = false, by_component_ptr = false, by_ref = false;
5135   tree gnu_param;
5136
5137   /* Copy-return is used only for the first parameter of a valued procedure.
5138      It's a copy mechanism for which a parameter is never allocated.  */
5139   if (mech == By_Copy_Return)
5140     {
5141       gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5142       mech = By_Copy;
5143       by_return = true;
5144     }
5145
5146   /* If this is either a foreign function or if the underlying type won't
5147      be passed by reference, strip off possible padding type.  */
5148   if (TYPE_IS_PADDING_P (gnu_param_type))
5149     {
5150       tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5151
5152       if (mech == By_Reference
5153           || foreign
5154           || (!must_pass_by_ref (unpadded_type)
5155               && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5156         gnu_param_type = unpadded_type;
5157     }
5158
5159   /* If this is a read-only parameter, make a variant of the type that is
5160      read-only.  ??? However, if this is an unconstrained array, that type
5161      can be very complex, so skip it for now.  Likewise for any other
5162      self-referential type.  */
5163   if (ro_param
5164       && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5165       && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5166     gnu_param_type = build_qualified_type (gnu_param_type,
5167                                            (TYPE_QUALS (gnu_param_type)
5168                                             | TYPE_QUAL_CONST));
5169
5170   /* For foreign conventions, pass arrays as pointers to the element type.
5171      First check for unconstrained array and get the underlying array.  */
5172   if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5173     gnu_param_type
5174       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5175
5176   /* VMS descriptors are themselves passed by reference.  */
5177   if (mech == By_Short_Descriptor ||
5178       (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5179     gnu_param_type
5180       = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5181                                                     Mechanism (gnat_param),
5182                                                     gnat_subprog));
5183   else if (mech == By_Descriptor)
5184     {
5185       /* Build both a 32-bit and 64-bit descriptor, one of which will be
5186          chosen in fill_vms_descriptor.  */
5187       gnu_param_type_alt
5188         = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5189                                                       Mechanism (gnat_param),
5190                                                       gnat_subprog));
5191       gnu_param_type
5192         = build_pointer_type (build_vms_descriptor (gnu_param_type,
5193                                                     Mechanism (gnat_param),
5194                                                     gnat_subprog));
5195     }
5196
5197   /* Arrays are passed as pointers to element type for foreign conventions.  */
5198   else if (foreign
5199            && mech != By_Copy
5200            && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5201     {
5202       /* Strip off any multi-dimensional entries, then strip
5203          off the last array to get the component type.  */
5204       while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5205              && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5206         gnu_param_type = TREE_TYPE (gnu_param_type);
5207
5208       by_component_ptr = true;
5209       gnu_param_type = TREE_TYPE (gnu_param_type);
5210
5211       if (ro_param)
5212         gnu_param_type = build_qualified_type (gnu_param_type,
5213                                                (TYPE_QUALS (gnu_param_type)
5214                                                 | TYPE_QUAL_CONST));
5215
5216       gnu_param_type = build_pointer_type (gnu_param_type);
5217     }
5218
5219   /* Fat pointers are passed as thin pointers for foreign conventions.  */
5220   else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5221     gnu_param_type
5222       = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5223
5224   /* If we must pass or were requested to pass by reference, do so.
5225      If we were requested to pass by copy, do so.
5226      Otherwise, for foreign conventions, pass In Out or Out parameters
5227      or aggregates by reference.  For COBOL and Fortran, pass all
5228      integer and FP types that way too.  For Convention Ada, use
5229      the standard Ada default.  */
5230   else if (must_pass_by_ref (gnu_param_type)
5231            || mech == By_Reference
5232            || (mech != By_Copy
5233                && ((foreign
5234                     && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5235                    || (foreign
5236                        && (Convention (gnat_subprog) == Convention_Fortran
5237                            || Convention (gnat_subprog) == Convention_COBOL)
5238                        && (INTEGRAL_TYPE_P (gnu_param_type)
5239                            || FLOAT_TYPE_P (gnu_param_type)))
5240                    || (!foreign
5241                        && default_pass_by_ref (gnu_param_type)))))
5242     {
5243       gnu_param_type = build_reference_type (gnu_param_type);
5244       by_ref = true;
5245     }
5246
5247   /* Pass In Out or Out parameters using copy-in copy-out mechanism.  */
5248   else if (!in_param)
5249     *cico = true;
5250
5251   if (mech == By_Copy && (by_ref || by_component_ptr))
5252     post_error ("?cannot pass & by copy", gnat_param);
5253
5254   /* If this is an Out parameter that isn't passed by reference and isn't
5255      a pointer or aggregate, we don't make a PARM_DECL for it.  Instead,
5256      it will be a VAR_DECL created when we process the procedure, so just
5257      return its type.  For the special parameter of a valued procedure,
5258      never pass it in.
5259
5260      An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5261      Out parameters with discriminants or implicit initial values to be
5262      handled like In Out parameters.  These type are normally built as
5263      aggregates, hence passed by reference, except for some packed arrays
5264      which end up encoded in special integer types.
5265
5266      The exception we need to make is then for packed arrays of records
5267      with discriminants or implicit initial values.  We have no light/easy
5268      way to check for the latter case, so we merely check for packed arrays
5269      of records.  This may lead to useless copy-in operations, but in very
5270      rare cases only, as these would be exceptions in a set of already
5271      exceptional situations.  */
5272   if (Ekind (gnat_param) == E_Out_Parameter
5273       && !by_ref
5274       && (by_return
5275           || (mech != By_Descriptor
5276               && mech != By_Short_Descriptor
5277               && !POINTER_TYPE_P (gnu_param_type)
5278               && !AGGREGATE_TYPE_P (gnu_param_type)))
5279       && !(Is_Array_Type (Etype (gnat_param))
5280            && Is_Packed (Etype (gnat_param))
5281            && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5282     return gnu_param_type;
5283
5284   gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5285                                  ro_param || by_ref || by_component_ptr);
5286   DECL_BY_REF_P (gnu_param) = by_ref;
5287   DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5288   DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5289                                       mech == By_Short_Descriptor);
5290   DECL_POINTS_TO_READONLY_P (gnu_param)
5291     = (ro_param && (by_ref || by_component_ptr));
5292
5293   /* Save the alternate descriptor type, if any.  */
5294   if (gnu_param_type_alt)
5295     SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5296
5297   /* If no Mechanism was specified, indicate what we're using, then
5298      back-annotate it.  */
5299   if (mech == Default)
5300     mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5301
5302   Set_Mechanism (gnat_param, mech);
5303   return gnu_param;
5304 }
5305
5306 /* Return true if DISCR1 and DISCR2 represent the same discriminant.  */
5307
5308 static bool
5309 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5310 {
5311   while (Present (Corresponding_Discriminant (discr1)))
5312     discr1 = Corresponding_Discriminant (discr1);
5313
5314   while (Present (Corresponding_Discriminant (discr2)))
5315     discr2 = Corresponding_Discriminant (discr2);
5316
5317   return
5318     Original_Record_Component (discr1) == Original_Record_Component (discr2);
5319 }
5320
5321 /* Return true if the array type GNU_TYPE, which represents a dimension of
5322    GNAT_TYPE, has a non-aliased component in the back-end sense.  */
5323
5324 static bool
5325 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5326 {
5327   /* If the array type is not the innermost dimension of the GNAT type,
5328      then it has a non-aliased component.  */
5329   if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5330       && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5331     return true;
5332
5333   /* If the array type has an aliased component in the front-end sense,
5334      then it also has an aliased component in the back-end sense.  */
5335   if (Has_Aliased_Components (gnat_type))
5336     return false;
5337
5338   /* If this is a derived type, then it has a non-aliased component if
5339      and only if its parent type also has one.  */
5340   if (Is_Derived_Type (gnat_type))
5341     {
5342       tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5343       int index;
5344       if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5345         gnu_parent_type
5346           = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5347       for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5348         gnu_parent_type = TREE_TYPE (gnu_parent_type);
5349       return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5350     }
5351
5352   /* Otherwise, rely exclusively on properties of the element type.  */
5353   return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5354 }
5355
5356 /* Return true if GNAT_ADDRESS is a value known at compile-time.  */
5357
5358 static bool
5359 compile_time_known_address_p (Node_Id gnat_address)
5360 {
5361   /* Catch System'To_Address.  */
5362   if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5363     gnat_address = Expression (gnat_address);
5364
5365   return Compile_Time_Known_Value (gnat_address);
5366 }
5367
5368 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5369    inequality HB >= LB-1 is true.  LB and HB are the low and high bounds.  */
5370
5371 static bool
5372 cannot_be_superflat_p (Node_Id gnat_range)
5373 {
5374   Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5375   Node_Id scalar_range;
5376   tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5377
5378   /* If the low bound is not constant, try to find an upper bound.  */
5379   while (Nkind (gnat_lb) != N_Integer_Literal
5380          && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5381              || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5382          && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5383          && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5384              || Nkind (scalar_range) == N_Range))
5385     gnat_lb = High_Bound (scalar_range);
5386
5387   /* If the high bound is not constant, try to find a lower bound.  */
5388   while (Nkind (gnat_hb) != N_Integer_Literal
5389          && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5390              || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5391          && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5392          && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5393              || Nkind (scalar_range) == N_Range))
5394     gnat_hb = Low_Bound (scalar_range);
5395
5396   /* If we have failed to find constant bounds, punt.  */
5397   if (Nkind (gnat_lb) != N_Integer_Literal
5398       || Nkind (gnat_hb) != N_Integer_Literal)
5399     return false;
5400
5401   /* We need at least a signed 64-bit type to catch most cases.  */
5402   gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5403   gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5404   if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5405     return false;
5406
5407   /* If the low bound is the smallest integer, nothing can be smaller.  */
5408   gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5409   if (TREE_OVERFLOW (gnu_lb_minus_one))
5410     return true;
5411
5412   return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5413 }
5414
5415 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR.  */
5416
5417 static bool
5418 constructor_address_p (tree gnu_expr)
5419 {
5420   while (TREE_CODE (gnu_expr) == NOP_EXPR
5421          || TREE_CODE (gnu_expr) == CONVERT_EXPR
5422          || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5423     gnu_expr = TREE_OPERAND (gnu_expr, 0);
5424
5425   return (TREE_CODE (gnu_expr) == ADDR_EXPR
5426           && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5427 }
5428 \f
5429 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5430    be elaborated at the point of its definition, but do nothing else.  */
5431
5432 void
5433 elaborate_entity (Entity_Id gnat_entity)
5434 {
5435   switch (Ekind (gnat_entity))
5436     {
5437     case E_Signed_Integer_Subtype:
5438     case E_Modular_Integer_Subtype:
5439     case E_Enumeration_Subtype:
5440     case E_Ordinary_Fixed_Point_Subtype:
5441     case E_Decimal_Fixed_Point_Subtype:
5442     case E_Floating_Point_Subtype:
5443       {
5444         Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5445         Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5446
5447         /* ??? Tests to avoid Constraint_Error in static expressions
5448            are needed until after the front stops generating bogus
5449            conversions on bounds of real types.  */
5450         if (!Raises_Constraint_Error (gnat_lb))
5451           elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5452                                 true, false, Needs_Debug_Info (gnat_entity));
5453         if (!Raises_Constraint_Error (gnat_hb))
5454           elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5455                                 true, false, Needs_Debug_Info (gnat_entity));
5456       break;
5457       }
5458
5459     case E_Record_Type:
5460       {
5461         Node_Id full_definition = Declaration_Node (gnat_entity);
5462         Node_Id record_definition = Type_Definition (full_definition);
5463
5464         /* If this is a record extension, go a level further to find the
5465            record definition.  */
5466         if (Nkind (record_definition) == N_Derived_Type_Definition)
5467           record_definition = Record_Extension_Part (record_definition);
5468       }
5469       break;
5470
5471     case E_Record_Subtype:
5472     case E_Private_Subtype:
5473     case E_Limited_Private_Subtype:
5474     case E_Record_Subtype_With_Private:
5475       if (Is_Constrained (gnat_entity)
5476           && Has_Discriminants (gnat_entity)
5477           && Present (Discriminant_Constraint (gnat_entity)))
5478         {
5479           Node_Id gnat_discriminant_expr;
5480           Entity_Id gnat_field;
5481
5482           for (gnat_field
5483                = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5484                gnat_discriminant_expr
5485                = First_Elmt (Discriminant_Constraint (gnat_entity));
5486                Present (gnat_field);
5487                gnat_field = Next_Discriminant (gnat_field),
5488                gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5489             /* ??? For now, ignore access discriminants.  */
5490             if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5491               elaborate_expression (Node (gnat_discriminant_expr),
5492                                     gnat_entity, get_entity_name (gnat_field),
5493                                     true, false, false);
5494         }
5495       break;
5496
5497     }
5498 }
5499 \f
5500 /* Mark GNAT_ENTITY as going out of scope at this point.  Recursively mark
5501    any entities on its entity chain similarly.  */
5502
5503 void
5504 mark_out_of_scope (Entity_Id gnat_entity)
5505 {
5506   Entity_Id gnat_sub_entity;
5507   unsigned int kind = Ekind (gnat_entity);
5508
5509   /* If this has an entity list, process all in the list.  */
5510   if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5511       || IN (kind, Private_Kind)
5512       || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5513       || kind == E_Function || kind == E_Generic_Function
5514       || kind == E_Generic_Package || kind == E_Generic_Procedure
5515       || kind == E_Loop || kind == E_Operator || kind == E_Package
5516       || kind == E_Package_Body || kind == E_Procedure
5517       || kind == E_Record_Type || kind == E_Record_Subtype
5518       || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5519     for (gnat_sub_entity = First_Entity (gnat_entity);
5520          Present (gnat_sub_entity);
5521          gnat_sub_entity = Next_Entity (gnat_sub_entity))
5522       if (Scope (gnat_sub_entity) == gnat_entity
5523           && gnat_sub_entity != gnat_entity)
5524         mark_out_of_scope (gnat_sub_entity);
5525
5526   /* Now clear this if it has been defined, but only do so if it isn't
5527      a subprogram or parameter.  We could refine this, but it isn't
5528      worth it.  If this is statically allocated, it is supposed to
5529      hang around out of cope.  */
5530   if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5531       && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5532     {
5533       save_gnu_tree (gnat_entity, NULL_TREE, true);
5534       save_gnu_tree (gnat_entity, error_mark_node, true);
5535     }
5536 }
5537 \f
5538 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5539    If this is a multi-dimensional array type, do this recursively.
5540
5541    OP may be
5542    - ALIAS_SET_COPY:     the new set is made a copy of the old one.
5543    - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5544    - ALIAS_SET_SUBSET:   the new set is made a subset of the old one.  */
5545
5546 static void
5547 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5548 {
5549   /* Remove any padding from GNU_OLD_TYPE.  It doesn't matter in the case
5550      of a one-dimensional array, since the padding has the same alias set
5551      as the field type, but if it's a multi-dimensional array, we need to
5552      see the inner types.  */
5553   while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5554          && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5555              || TYPE_PADDING_P (gnu_old_type)))
5556     gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5557
5558   /* Unconstrained array types are deemed incomplete and would thus be given
5559      alias set 0.  Retrieve the underlying array type.  */
5560   if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5561     gnu_old_type
5562       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5563   if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5564     gnu_new_type
5565       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5566
5567   if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5568       && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5569       && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5570     relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5571
5572   switch (op)
5573     {
5574     case ALIAS_SET_COPY:
5575       /* The alias set shouldn't be copied between array types with different
5576          aliasing settings because this can break the aliasing relationship
5577          between the array type and its element type.  */
5578 #ifndef ENABLE_CHECKING
5579       if (flag_strict_aliasing)
5580 #endif
5581         gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5582                       && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5583                       && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5584                          != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5585
5586       TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5587       break;
5588
5589     case ALIAS_SET_SUBSET:
5590     case ALIAS_SET_SUPERSET:
5591       {
5592         alias_set_type old_set = get_alias_set (gnu_old_type);
5593         alias_set_type new_set = get_alias_set (gnu_new_type);
5594
5595         /* Do nothing if the alias sets conflict.  This ensures that we
5596            never call record_alias_subset several times for the same pair
5597            or at all for alias set 0.  */
5598         if (!alias_sets_conflict_p (old_set, new_set))
5599           {
5600             if (op == ALIAS_SET_SUBSET)
5601               record_alias_subset (old_set, new_set);
5602             else
5603               record_alias_subset (new_set, old_set);
5604           }
5605       }
5606       break;
5607
5608     default:
5609       gcc_unreachable ();
5610     }
5611
5612   record_component_aliases (gnu_new_type);
5613 }
5614 \f
5615 /* Return true if the size represented by GNU_SIZE can be handled by an
5616    allocation.  If STATIC_P is true, consider only what can be done with a
5617    static allocation.  */
5618
5619 static bool
5620 allocatable_size_p (tree gnu_size, bool static_p)
5621 {
5622   HOST_WIDE_INT our_size;
5623
5624   /* If this is not a static allocation, the only case we want to forbid
5625      is an overflowing size.  That will be converted into a raise a
5626      Storage_Error.  */
5627   if (!static_p)
5628     return !(TREE_CODE (gnu_size) == INTEGER_CST
5629              && TREE_OVERFLOW (gnu_size));
5630
5631   /* Otherwise, we need to deal with both variable sizes and constant
5632      sizes that won't fit in a host int.  We use int instead of HOST_WIDE_INT
5633      since assemblers may not like very large sizes.  */
5634   if (!host_integerp (gnu_size, 1))
5635     return false;
5636
5637   our_size = tree_low_cst (gnu_size, 1);
5638   return (int) our_size == our_size;
5639 }
5640 \f
5641 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5642    NAME, ARGS and ERROR_POINT.  */
5643
5644 static void
5645 prepend_one_attribute_to (struct attrib ** attr_list,
5646                           enum attr_type attr_type,
5647                           tree attr_name,
5648                           tree attr_args,
5649                           Node_Id attr_error_point)
5650 {
5651   struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5652
5653   attr->type = attr_type;
5654   attr->name = attr_name;
5655   attr->args = attr_args;
5656   attr->error_point = attr_error_point;
5657
5658   attr->next = *attr_list;
5659   *attr_list = attr;
5660 }
5661
5662 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any.  */
5663
5664 static void
5665 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5666 {
5667   Node_Id gnat_temp;
5668
5669   /* Attributes are stored as Representation Item pragmas.  */
5670
5671   for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5672        gnat_temp = Next_Rep_Item (gnat_temp))
5673     if (Nkind (gnat_temp) == N_Pragma)
5674       {
5675         tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5676         Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5677         enum attr_type etype;
5678
5679         /* Map the kind of pragma at hand.  Skip if this is not one
5680            we know how to handle.  */
5681
5682         switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5683           {
5684           case Pragma_Machine_Attribute:
5685             etype = ATTR_MACHINE_ATTRIBUTE;
5686             break;
5687
5688           case Pragma_Linker_Alias:
5689             etype = ATTR_LINK_ALIAS;
5690             break;
5691
5692           case Pragma_Linker_Section:
5693             etype = ATTR_LINK_SECTION;
5694             break;
5695
5696           case Pragma_Linker_Constructor:
5697             etype = ATTR_LINK_CONSTRUCTOR;
5698             break;
5699
5700           case Pragma_Linker_Destructor:
5701             etype = ATTR_LINK_DESTRUCTOR;
5702             break;
5703
5704           case Pragma_Weak_External:
5705             etype = ATTR_WEAK_EXTERNAL;
5706             break;
5707
5708           case Pragma_Thread_Local_Storage:
5709             etype = ATTR_THREAD_LOCAL_STORAGE;
5710             break;
5711
5712           default:
5713             continue;
5714           }
5715
5716         /* See what arguments we have and turn them into GCC trees for
5717            attribute handlers.  These expect identifier for strings.  We
5718            handle at most two arguments, static expressions only.  */
5719
5720         if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5721           {
5722             Node_Id gnat_arg0 = Next (First (gnat_assoc));
5723             Node_Id gnat_arg1 = Empty;
5724
5725             if (Present (gnat_arg0)
5726                 && Is_Static_Expression (Expression (gnat_arg0)))
5727               {
5728                 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5729
5730                 if (TREE_CODE (gnu_arg0) == STRING_CST)
5731                   gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5732
5733                 gnat_arg1 = Next (gnat_arg0);
5734               }
5735
5736             if (Present (gnat_arg1)
5737                 && Is_Static_Expression (Expression (gnat_arg1)))
5738               {
5739                 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5740
5741                 if (TREE_CODE (gnu_arg1) == STRING_CST)
5742                   gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
5743               }
5744           }
5745
5746         /* Prepend to the list now.  Make a list of the argument we might
5747            have, as GCC expects it.  */
5748         prepend_one_attribute_to
5749           (attr_list,
5750            etype, gnu_arg0,
5751            (gnu_arg1 != NULL_TREE)
5752            ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5753            Present (Next (First (gnat_assoc)))
5754            ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5755       }
5756 }
5757 \f
5758 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5759    type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5760    return the GCC tree to use for that expression.  GNU_NAME is the suffix
5761    to use if a variable needs to be created and DEFINITION is true if this
5762    is a definition of GNAT_ENTITY.  If NEED_VALUE is true, we need a result;
5763    otherwise, we are just elaborating the expression for side-effects.  If
5764    NEED_DEBUG is true, we need a variable for debugging purposes even if it
5765    isn't needed for code generation.  */
5766
5767 static tree
5768 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
5769                       bool definition, bool need_value, bool need_debug)
5770 {
5771   tree gnu_expr;
5772
5773   /* If we already elaborated this expression (e.g. it was involved
5774      in the definition of a private type), use the old value.  */
5775   if (present_gnu_tree (gnat_expr))
5776     return get_gnu_tree (gnat_expr);
5777
5778   /* If we don't need a value and this is static or a discriminant,
5779      we don't need to do anything.  */
5780   if (!need_value
5781       && (Is_OK_Static_Expression (gnat_expr)
5782           || (Nkind (gnat_expr) == N_Identifier
5783               && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5784     return NULL_TREE;
5785
5786   /* If it's a static expression, we don't need a variable for debugging.  */
5787   if (need_debug && Is_OK_Static_Expression (gnat_expr))
5788     need_debug = false;
5789
5790   /* Otherwise, convert this tree to its GCC equivalent and elaborate it.  */
5791   gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
5792                                      gnu_name, definition, need_debug);
5793
5794   /* Save the expression in case we try to elaborate this entity again.  Since
5795      it's not a DECL, don't check it.  Don't save if it's a discriminant.  */
5796   if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5797     save_gnu_tree (gnat_expr, gnu_expr, true);
5798
5799   return need_value ? gnu_expr : error_mark_node;
5800 }
5801
5802 /* Similar, but take a GNU expression and always return a result.  */
5803
5804 static tree
5805 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
5806                         bool definition, bool need_debug)
5807 {
5808   /* Skip any conversions and simple arithmetics to see if the expression
5809      is a read-only variable.
5810      ??? This really should remain read-only, but we have to think about
5811      the typing of the tree here.  */
5812   tree gnu_inner_expr
5813     = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5814   tree gnu_decl = NULL_TREE;
5815   bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5816   bool expr_variable;
5817
5818   /* In most cases, we won't see a naked FIELD_DECL because a discriminant
5819      reference will have been replaced with a COMPONENT_REF when the type
5820      is being elaborated.  However, there are some cases involving child
5821      types where we will.  So convert it to a COMPONENT_REF.  We hope it
5822      will be at the highest level of the expression in these cases.  */
5823   if (TREE_CODE (gnu_expr) == FIELD_DECL)
5824     gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5825                        build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5826                        gnu_expr, NULL_TREE);
5827
5828   /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5829      that is read-only, make a variable that is initialized to contain the
5830      bound when the package containing the definition is elaborated.  If
5831      this entity is defined at top level and a bound or discriminant value
5832      isn't a constant or a reference to a discriminant, replace the bound
5833      by the variable; otherwise use a SAVE_EXPR if needed.  Note that we
5834      rely here on the fact that an expression cannot contain both the
5835      discriminant and some other variable.  */
5836   expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5837                    && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5838                         && (TREE_READONLY (gnu_inner_expr)
5839                             || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5840                    && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5841
5842   /* If GNU_EXPR contains a discriminant, we can't elaborate a variable.  */
5843   if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
5844     need_debug = false;
5845
5846   /* Now create the variable if we need it.  */
5847   if (need_debug || (expr_variable && expr_global))
5848     gnu_decl
5849       = create_var_decl (create_concat_name (gnat_entity,
5850                                              IDENTIFIER_POINTER (gnu_name)),
5851                          NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5852                          !need_debug, Is_Public (gnat_entity),
5853                          !definition, false, NULL, gnat_entity);
5854
5855   /* We only need to use this variable if we are in global context since GCC
5856      can do the right thing in the local case.  */
5857   if (expr_global && expr_variable)
5858     return gnu_decl;
5859
5860   return expr_variable ? gnat_save_expr (gnu_expr) : gnu_expr;
5861 }
5862 \f
5863 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5864    starting bit position so that it is aligned to ALIGN bits, and leaving at
5865    least ROOM bytes free before the field.  BASE_ALIGN is the alignment the
5866    record is guaranteed to get.  */
5867
5868 tree
5869 make_aligning_type (tree type, unsigned int align, tree size,
5870                     unsigned int base_align, int room)
5871 {
5872   /* We will be crafting a record type with one field at a position set to be
5873      the next multiple of ALIGN past record'address + room bytes.  We use a
5874      record placeholder to express record'address.  */
5875   tree record_type = make_node (RECORD_TYPE);
5876   tree record = build0 (PLACEHOLDER_EXPR, record_type);
5877
5878   tree record_addr_st
5879     = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5880
5881   /* The diagram below summarizes the shape of what we manipulate:
5882
5883                     <--------- pos ---------->
5884                 {  +------------+-------------+-----------------+
5885       record  =>{  |############|     ...     | field (type)    |
5886                 {  +------------+-------------+-----------------+
5887                    |<-- room -->|<- voffset ->|<---- size ----->|
5888                    o            o
5889                    |            |
5890                    record_addr  vblock_addr
5891
5892      Every length is in sizetype bytes there, except "pos" which has to be
5893      set as a bit position in the GCC tree for the record.  */
5894   tree room_st = size_int (room);
5895   tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5896   tree voffset_st, pos, field;
5897
5898   tree name = TYPE_NAME (type);
5899
5900   if (TREE_CODE (name) == TYPE_DECL)
5901     name = DECL_NAME (name);
5902
5903   TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
5904
5905   /* Compute VOFFSET and then POS.  The next byte position multiple of some
5906      alignment after some address is obtained by "and"ing the alignment minus
5907      1 with the two's complement of the address.   */
5908   voffset_st = size_binop (BIT_AND_EXPR,
5909                            fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
5910                            size_int ((align / BITS_PER_UNIT) - 1));
5911
5912   /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype.  */
5913   pos = size_binop (MULT_EXPR,
5914                     convert (bitsizetype,
5915                              size_binop (PLUS_EXPR, room_st, voffset_st)),
5916                     bitsize_unit_node);
5917
5918   /* Craft the GCC record representation.  We exceptionally do everything
5919      manually here because 1) our generic circuitry is not quite ready to
5920      handle the complex position/size expressions we are setting up, 2) we
5921      have a strong simplifying factor at hand: we know the maximum possible
5922      value of voffset, and 3) we have to set/reset at least the sizes in
5923      accordance with this maximum value anyway, as we need them to convey
5924      what should be "alloc"ated for this type.
5925
5926      Use -1 as the 'addressable' indication for the field to prevent the
5927      creation of a bitfield.  We don't need one, it would have damaging
5928      consequences on the alignment computation, and create_field_decl would
5929      make one without this special argument, for instance because of the
5930      complex position expression.  */
5931   field = create_field_decl (get_identifier ("F"), type, record_type,
5932                              1, size, pos, -1);
5933   TYPE_FIELDS (record_type) = field;
5934
5935   TYPE_ALIGN (record_type) = base_align;
5936   TYPE_USER_ALIGN (record_type) = 1;
5937
5938   TYPE_SIZE (record_type)
5939     = size_binop (PLUS_EXPR,
5940                   size_binop (MULT_EXPR, convert (bitsizetype, size),
5941                               bitsize_unit_node),
5942                   bitsize_int (align + room * BITS_PER_UNIT));
5943   TYPE_SIZE_UNIT (record_type)
5944     = size_binop (PLUS_EXPR, size,
5945                   size_int (room + align / BITS_PER_UNIT));
5946
5947   SET_TYPE_MODE (record_type, BLKmode);
5948
5949   relate_alias_sets (record_type, type, ALIAS_SET_COPY);
5950   return record_type;
5951 }
5952 \f
5953 /* Return the result of rounding T up to ALIGN.  */
5954
5955 static inline unsigned HOST_WIDE_INT
5956 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5957 {
5958   t += align - 1;
5959   t /= align;
5960   t *= align;
5961   return t;
5962 }
5963
5964 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5965    as the field type of a packed record if IN_RECORD is true, or as the
5966    component type of a packed array if IN_RECORD is false.  See if we can
5967    rewrite it either as a type that has a non-BLKmode, which we can pack
5968    tighter in the packed record case, or as a smaller type.  If so, return
5969    the new type.  If not, return the original type.  */
5970
5971 static tree
5972 make_packable_type (tree type, bool in_record)
5973 {
5974   unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5975   unsigned HOST_WIDE_INT new_size;
5976   tree new_type, old_field, field_list = NULL_TREE;
5977
5978   /* No point in doing anything if the size is zero.  */
5979   if (size == 0)
5980     return type;
5981
5982   new_type = make_node (TREE_CODE (type));
5983
5984   /* Copy the name and flags from the old type to that of the new.
5985      Note that we rely on the pointer equality created here for
5986      TYPE_NAME to look through conversions in various places.  */
5987   TYPE_NAME (new_type) = TYPE_NAME (type);
5988   TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5989   TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5990   if (TREE_CODE (type) == RECORD_TYPE)
5991     TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
5992
5993   /* If we are in a record and have a small size, set the alignment to
5994      try for an integral mode.  Otherwise set it to try for a smaller
5995      type with BLKmode.  */
5996   if (in_record && size <= MAX_FIXED_MODE_SIZE)
5997     {
5998       TYPE_ALIGN (new_type) = ceil_alignment (size);
5999       new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
6000     }
6001   else
6002     {
6003       unsigned HOST_WIDE_INT align;
6004
6005       /* Do not try to shrink the size if the RM size is not constant.  */
6006       if (TYPE_CONTAINS_TEMPLATE_P (type)
6007           || !host_integerp (TYPE_ADA_SIZE (type), 1))
6008         return type;
6009
6010       /* Round the RM size up to a unit boundary to get the minimal size
6011          for a BLKmode record.  Give up if it's already the size.  */
6012       new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
6013       new_size = round_up_to_align (new_size, BITS_PER_UNIT);
6014       if (new_size == size)
6015         return type;
6016
6017       align = new_size & -new_size;
6018       TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
6019     }
6020
6021   TYPE_USER_ALIGN (new_type) = 1;
6022
6023   /* Now copy the fields, keeping the position and size as we don't want
6024      to change the layout by propagating the packedness downwards.  */
6025   for (old_field = TYPE_FIELDS (type); old_field;
6026        old_field = TREE_CHAIN (old_field))
6027     {
6028       tree new_field_type = TREE_TYPE (old_field);
6029       tree new_field, new_size;
6030
6031       if ((TREE_CODE (new_field_type) == RECORD_TYPE
6032            || TREE_CODE (new_field_type) == UNION_TYPE
6033            || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6034           && !TYPE_FAT_POINTER_P (new_field_type)
6035           && host_integerp (TYPE_SIZE (new_field_type), 1))
6036         new_field_type = make_packable_type (new_field_type, true);
6037
6038       /* However, for the last field in a not already packed record type
6039          that is of an aggregate type, we need to use the RM size in the
6040          packable version of the record type, see finish_record_type.  */
6041       if (!TREE_CHAIN (old_field)
6042           && !TYPE_PACKED (type)
6043           && (TREE_CODE (new_field_type) == RECORD_TYPE
6044               || TREE_CODE (new_field_type) == UNION_TYPE
6045               || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6046           && !TYPE_FAT_POINTER_P (new_field_type)
6047           && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6048           && TYPE_ADA_SIZE (new_field_type))
6049         new_size = TYPE_ADA_SIZE (new_field_type);
6050       else
6051         new_size = DECL_SIZE (old_field);
6052
6053       new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
6054                                      new_type, TYPE_PACKED (type), new_size,
6055                                      bit_position (old_field),
6056                                      !DECL_NONADDRESSABLE_P (old_field));
6057
6058       DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6059       SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
6060       if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6061         DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6062
6063       TREE_CHAIN (new_field) = field_list;
6064       field_list = new_field;
6065     }
6066
6067   finish_record_type (new_type, nreverse (field_list), 2, false);
6068   relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6069
6070   /* If this is a padding record, we never want to make the size smaller
6071      than what was specified.  For QUAL_UNION_TYPE, also copy the size.  */
6072   if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6073     {
6074       TYPE_SIZE (new_type) = TYPE_SIZE (type);
6075       TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6076       new_size = size;
6077     }
6078   else
6079     {
6080       TYPE_SIZE (new_type) = bitsize_int (new_size);
6081       TYPE_SIZE_UNIT (new_type)
6082         = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6083     }
6084
6085   if (!TYPE_CONTAINS_TEMPLATE_P (type))
6086     SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6087
6088   compute_record_mode (new_type);
6089
6090   /* Try harder to get a packable type if necessary, for example
6091      in case the record itself contains a BLKmode field.  */
6092   if (in_record && TYPE_MODE (new_type) == BLKmode)
6093     SET_TYPE_MODE (new_type,
6094                    mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6095
6096   /* If neither the mode nor the size has shrunk, return the old type.  */
6097   if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6098     return type;
6099
6100   return new_type;
6101 }
6102 \f
6103 /* Ensure that TYPE has SIZE and ALIGN.  Make and return a new padded type
6104    if needed.  We have already verified that SIZE and TYPE are large enough.
6105    GNAT_ENTITY is used to name the resulting record and to issue a warning.
6106    IS_COMPONENT_TYPE is true if this is being done for the component type
6107    of an array.  IS_USER_TYPE is true if we must complete the original type.
6108    DEFINITION is true if this type is being defined.  SAME_RM_SIZE is true
6109    if the RM size of the resulting type is to be set to SIZE too; otherwise,
6110    it's set to the RM size of the original type.  */
6111
6112 tree
6113 maybe_pad_type (tree type, tree size, unsigned int align,
6114                 Entity_Id gnat_entity, bool is_component_type,
6115                 bool is_user_type, bool definition, bool same_rm_size)
6116 {
6117   tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6118   tree orig_size = TYPE_SIZE (type);
6119   tree record, field;
6120
6121   /* If TYPE is a padded type, see if it agrees with any size and alignment
6122      we were given.  If so, return the original type.  Otherwise, strip
6123      off the padding, since we will either be returning the inner type
6124      or repadding it.  If no size or alignment is specified, use that of
6125      the original padded type.  */
6126   if (TYPE_IS_PADDING_P (type))
6127     {
6128       if ((!size
6129            || operand_equal_p (round_up (size,
6130                                          MAX (align, TYPE_ALIGN (type))),
6131                                round_up (TYPE_SIZE (type),
6132                                          MAX (align, TYPE_ALIGN (type))),
6133                                0))
6134           && (align == 0 || align == TYPE_ALIGN (type)))
6135         return type;
6136
6137       if (!size)
6138         size = TYPE_SIZE (type);
6139       if (align == 0)
6140         align = TYPE_ALIGN (type);
6141
6142       type = TREE_TYPE (TYPE_FIELDS (type));
6143       orig_size = TYPE_SIZE (type);
6144     }
6145
6146   /* If the size is either not being changed or is being made smaller (which
6147      is not done here and is only valid for bitfields anyway), show the size
6148      isn't changing.  Likewise, clear the alignment if it isn't being
6149      changed.  Then return if we aren't doing anything.  */
6150   if (size
6151       && (operand_equal_p (size, orig_size, 0)
6152           || (TREE_CODE (orig_size) == INTEGER_CST
6153               && tree_int_cst_lt (size, orig_size))))
6154     size = NULL_TREE;
6155
6156   if (align == TYPE_ALIGN (type))
6157     align = 0;
6158
6159   if (align == 0 && !size)
6160     return type;
6161
6162   /* If requested, complete the original type and give it a name.  */
6163   if (is_user_type)
6164     create_type_decl (get_entity_name (gnat_entity), type,
6165                       NULL, !Comes_From_Source (gnat_entity),
6166                       !(TYPE_NAME (type)
6167                         && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6168                         && DECL_IGNORED_P (TYPE_NAME (type))),
6169                       gnat_entity);
6170
6171   /* We used to modify the record in place in some cases, but that could
6172      generate incorrect debugging information.  So make a new record
6173      type and name.  */
6174   record = make_node (RECORD_TYPE);
6175   TYPE_PADDING_P (record) = 1;
6176
6177   if (Present (gnat_entity))
6178     TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6179
6180   TYPE_VOLATILE (record)
6181     = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6182
6183   TYPE_ALIGN (record) = align;
6184   TYPE_SIZE (record) = size ? size : orig_size;
6185   TYPE_SIZE_UNIT (record)
6186     = convert (sizetype,
6187                size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6188                            bitsize_unit_node));
6189
6190   /* If we are changing the alignment and the input type is a record with
6191      BLKmode and a small constant size, try to make a form that has an
6192      integral mode.  This might allow the padding record to also have an
6193      integral mode, which will be much more efficient.  There is no point
6194      in doing so if a size is specified unless it is also a small constant
6195      size and it is incorrect to do so if we cannot guarantee that the mode
6196      will be naturally aligned since the field must always be addressable.
6197
6198      ??? This might not always be a win when done for a stand-alone object:
6199      since the nominal and the effective type of the object will now have
6200      different modes, a VIEW_CONVERT_EXPR will be required for converting
6201      between them and it might be hard to overcome afterwards, including
6202      at the RTL level when the stand-alone object is accessed as a whole.  */
6203   if (align != 0
6204       && TREE_CODE (type) == RECORD_TYPE
6205       && TYPE_MODE (type) == BLKmode
6206       && TREE_CODE (orig_size) == INTEGER_CST
6207       && !TREE_OVERFLOW (orig_size)
6208       && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6209       && (!size
6210           || (TREE_CODE (size) == INTEGER_CST
6211               && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6212     {
6213       tree packable_type = make_packable_type (type, true);
6214       if (TYPE_MODE (packable_type) != BLKmode
6215           && align >= TYPE_ALIGN (packable_type))
6216         type = packable_type;
6217     }
6218
6219   /* Now create the field with the original size.  */
6220   field  = create_field_decl (get_identifier ("F"), type, record, 0,
6221                               orig_size, bitsize_zero_node, 1);
6222   DECL_INTERNAL_P (field) = 1;
6223
6224   /* Do not emit debug info until after the auxiliary record is built.  */
6225   finish_record_type (record, field, 1, false);
6226
6227   /* Set the same size for its RM size if requested; otherwise reuse
6228      the RM size of the original type.  */
6229   SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6230
6231   /* Unless debugging information isn't being written for the input type,
6232      write a record that shows what we are a subtype of and also make a
6233      variable that indicates our size, if still variable.  */
6234   if (TREE_CODE (orig_size) != INTEGER_CST
6235       && TYPE_NAME (record)
6236       && TYPE_NAME (type)
6237       && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6238            && DECL_IGNORED_P (TYPE_NAME (type))))
6239     {
6240       tree marker = make_node (RECORD_TYPE);
6241       tree name = TYPE_NAME (record);
6242       tree orig_name = TYPE_NAME (type);
6243
6244       if (TREE_CODE (name) == TYPE_DECL)
6245         name = DECL_NAME (name);
6246
6247       if (TREE_CODE (orig_name) == TYPE_DECL)
6248         orig_name = DECL_NAME (orig_name);
6249
6250       TYPE_NAME (marker) = concat_name (name, "XVS");
6251       finish_record_type (marker,
6252                           create_field_decl (orig_name,
6253                                              build_reference_type (type),
6254                                              marker, 0, NULL_TREE, NULL_TREE,
6255                                              0),
6256                           0, true);
6257
6258       add_parallel_type (TYPE_STUB_DECL (record), marker);
6259
6260       if (definition && size && TREE_CODE (size) != INTEGER_CST)
6261         TYPE_SIZE_UNIT (marker)
6262           = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6263                              TYPE_SIZE_UNIT (record), false, false, false,
6264                              false, NULL, gnat_entity);
6265     }
6266
6267   rest_of_record_type_compilation (record);
6268
6269   /* If the size was widened explicitly, maybe give a warning.  Take the
6270      original size as the maximum size of the input if there was an
6271      unconstrained record involved and round it up to the specified alignment,
6272      if one was specified.  */
6273   if (CONTAINS_PLACEHOLDER_P (orig_size))
6274     orig_size = max_size (orig_size, true);
6275
6276   if (align)
6277     orig_size = round_up (orig_size, align);
6278
6279   if (Present (gnat_entity)
6280       && size
6281       && TREE_CODE (size) != MAX_EXPR
6282       && TREE_CODE (size) != COND_EXPR
6283       && !operand_equal_p (size, orig_size, 0)
6284       && !(TREE_CODE (size) == INTEGER_CST
6285            && TREE_CODE (orig_size) == INTEGER_CST
6286            && (TREE_OVERFLOW (size)
6287                || TREE_OVERFLOW (orig_size)
6288                || tree_int_cst_lt (size, orig_size))))
6289     {
6290       Node_Id gnat_error_node = Empty;
6291
6292       if (Is_Packed_Array_Type (gnat_entity))
6293         gnat_entity = Original_Array_Type (gnat_entity);
6294
6295       if ((Ekind (gnat_entity) == E_Component
6296            || Ekind (gnat_entity) == E_Discriminant)
6297           && Present (Component_Clause (gnat_entity)))
6298         gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6299       else if (Present (Size_Clause (gnat_entity)))
6300         gnat_error_node = Expression (Size_Clause (gnat_entity));
6301
6302       /* Generate message only for entities that come from source, since
6303          if we have an entity created by expansion, the message will be
6304          generated for some other corresponding source entity.  */
6305       if (Comes_From_Source (gnat_entity))
6306         {
6307           if (Present (gnat_error_node))
6308             post_error_ne_tree ("{^ }bits of & unused?",
6309                                 gnat_error_node, gnat_entity,
6310                                 size_diffop (size, orig_size));
6311           else if (is_component_type)
6312             post_error_ne_tree ("component of& padded{ by ^ bits}?",
6313                                 gnat_entity, gnat_entity,
6314                                 size_diffop (size, orig_size));
6315         }
6316     }
6317
6318   return record;
6319 }
6320 \f
6321 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6322    the value passed against the list of choices.  */
6323
6324 tree
6325 choices_to_gnu (tree operand, Node_Id choices)
6326 {
6327   Node_Id choice;
6328   Node_Id gnat_temp;
6329   tree result = integer_zero_node;
6330   tree this_test, low = 0, high = 0, single = 0;
6331
6332   for (choice = First (choices); Present (choice); choice = Next (choice))
6333     {
6334       switch (Nkind (choice))
6335         {
6336         case N_Range:
6337           low = gnat_to_gnu (Low_Bound (choice));
6338           high = gnat_to_gnu (High_Bound (choice));
6339
6340           this_test
6341             = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6342                                build_binary_op (GE_EXPR, boolean_type_node,
6343                                                 operand, low),
6344                                build_binary_op (LE_EXPR, boolean_type_node,
6345                                                 operand, high));
6346
6347           break;
6348
6349         case N_Subtype_Indication:
6350           gnat_temp = Range_Expression (Constraint (choice));
6351           low = gnat_to_gnu (Low_Bound (gnat_temp));
6352           high = gnat_to_gnu (High_Bound (gnat_temp));
6353
6354           this_test
6355             = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6356                                build_binary_op (GE_EXPR, boolean_type_node,
6357                                                 operand, low),
6358                                build_binary_op (LE_EXPR, boolean_type_node,
6359                                                 operand, high));
6360           break;
6361
6362         case N_Identifier:
6363         case N_Expanded_Name:
6364           /* This represents either a subtype range, an enumeration
6365              literal, or a constant  Ekind says which.  If an enumeration
6366              literal or constant, fall through to the next case.  */
6367           if (Ekind (Entity (choice)) != E_Enumeration_Literal
6368               && Ekind (Entity (choice)) != E_Constant)
6369             {
6370               tree type = gnat_to_gnu_type (Entity (choice));
6371
6372               low = TYPE_MIN_VALUE (type);
6373               high = TYPE_MAX_VALUE (type);
6374
6375               this_test
6376                 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6377                                    build_binary_op (GE_EXPR, boolean_type_node,
6378                                                     operand, low),
6379                                    build_binary_op (LE_EXPR, boolean_type_node,
6380                                                     operand, high));
6381               break;
6382             }
6383
6384           /* ... fall through ... */
6385
6386         case N_Character_Literal:
6387         case N_Integer_Literal:
6388           single = gnat_to_gnu (choice);
6389           this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6390                                        single);
6391           break;
6392
6393         case N_Others_Choice:
6394           this_test = integer_one_node;
6395           break;
6396
6397         default:
6398           gcc_unreachable ();
6399         }
6400
6401       result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6402                                 this_test);
6403     }
6404
6405   return result;
6406 }
6407 \f
6408 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6409    type FIELD_TYPE to be placed in RECORD_TYPE.  Return the result.  */
6410
6411 static int
6412 adjust_packed (tree field_type, tree record_type, int packed)
6413 {
6414   /* If the field contains an item of variable size, we cannot pack it
6415      because we cannot create temporaries of non-fixed size in case
6416      we need to take the address of the field.  See addressable_p and
6417      the notes on the addressability issues for further details.  */
6418   if (is_variable_size (field_type))
6419     return 0;
6420
6421   /* If the alignment of the record is specified and the field type
6422      is over-aligned, request Storage_Unit alignment for the field.  */
6423   if (packed == -2)
6424     {
6425       if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6426         return -1;
6427       else
6428         return 0;
6429     }
6430
6431   return packed;
6432 }
6433
6434 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6435    placed in GNU_RECORD_TYPE.
6436
6437    PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6438    record has Component_Alignment of Storage_Unit, -2 if the enclosing
6439    record has a specified alignment.
6440
6441    DEFINITION is true if this field is for a record being defined.
6442
6443    DEBUG_INFO_P is true if we need to write debug information for types
6444    that we may create in the process.  */
6445
6446 static tree
6447 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6448                    bool definition, bool debug_info_p)
6449 {
6450   tree gnu_field_id = get_entity_name (gnat_field);
6451   tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6452   tree gnu_field, gnu_size, gnu_pos;
6453   bool needs_strict_alignment
6454     = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6455        || Treat_As_Volatile (gnat_field));
6456
6457   /* If this field requires strict alignment, we cannot pack it because
6458      it would very likely be under-aligned in the record.  */
6459   if (needs_strict_alignment)
6460     packed = 0;
6461   else
6462     packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6463
6464   /* If a size is specified, use it.  Otherwise, if the record type is packed,
6465      use the official RM size.  See "Handling of Type'Size Values" in Einfo
6466      for further details.  */
6467   if (Known_Static_Esize (gnat_field))
6468     gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6469                               gnat_field, FIELD_DECL, false, true);
6470   else if (packed == 1)
6471     gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6472                               gnat_field, FIELD_DECL, false, true);
6473   else
6474     gnu_size = NULL_TREE;
6475
6476   /* If we have a specified size that is smaller than that of the field's type,
6477      or a position is specified, and the field's type is a record that doesn't
6478      require strict alignment, see if we can get either an integral mode form
6479      of the type or a smaller form.  If we can, show a size was specified for
6480      the field if there wasn't one already, so we know to make this a bitfield
6481      and avoid making things wider.
6482
6483      Changing to an integral mode form is useful when the record is packed as
6484      we can then place the field at a non-byte-aligned position and so achieve
6485      tighter packing.  This is in addition required if the field shares a byte
6486      with another field and the front-end lets the back-end handle the access
6487      to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6488
6489      Changing to a smaller form is required if the specified size is smaller
6490      than that of the field's type and the type contains sub-fields that are
6491      padded, in order to avoid generating accesses to these sub-fields that
6492      are wider than the field.
6493
6494      We avoid the transformation if it is not required or potentially useful,
6495      as it might entail an increase of the field's alignment and have ripple
6496      effects on the outer record type.  A typical case is a field known to be
6497      byte-aligned and not to share a byte with another field.  */
6498   if (!needs_strict_alignment
6499       && TREE_CODE (gnu_field_type) == RECORD_TYPE
6500       && !TYPE_FAT_POINTER_P (gnu_field_type)
6501       && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6502       && (packed == 1
6503           || (gnu_size
6504               && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6505                   || (Present (Component_Clause (gnat_field))
6506                       && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6507                            % BITS_PER_UNIT == 0
6508                            && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6509     {
6510       tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6511       if (gnu_packable_type != gnu_field_type)
6512         {
6513           gnu_field_type = gnu_packable_type;
6514           if (!gnu_size)
6515             gnu_size = rm_size (gnu_field_type);
6516         }
6517     }
6518
6519   /* If we are packing the record and the field is BLKmode, round the
6520      size up to a byte boundary.  */
6521   if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6522     gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6523
6524   if (Present (Component_Clause (gnat_field)))
6525     {
6526       Entity_Id gnat_parent
6527         = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6528
6529       gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6530       gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6531                                 gnat_field, FIELD_DECL, false, true);
6532
6533       /* Ensure the position does not overlap with the parent subtype, if there
6534          is one.  This test is omitted if the parent of the tagged type has a
6535          full rep clause since, in this case, component clauses are allowed to
6536          overlay the space allocated for the parent type and the front-end has
6537          checked that there are no overlapping components.  */
6538       if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6539         {
6540           tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6541
6542           if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6543               && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6544             {
6545               post_error_ne_tree
6546                 ("offset of& must be beyond parent{, minimum allowed is ^}",
6547                  First_Bit (Component_Clause (gnat_field)), gnat_field,
6548                  TYPE_SIZE_UNIT (gnu_parent));
6549             }
6550         }
6551
6552       /* If this field needs strict alignment, ensure the record is
6553          sufficiently aligned and that that position and size are
6554          consistent with the alignment.  */
6555       if (needs_strict_alignment)
6556         {
6557           TYPE_ALIGN (gnu_record_type)
6558             = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6559
6560           if (gnu_size
6561               && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6562             {
6563               if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6564                 post_error_ne_tree
6565                   ("atomic field& must be natural size of type{ (^)}",
6566                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6567                    TYPE_SIZE (gnu_field_type));
6568
6569               else if (Is_Aliased (gnat_field))
6570                 post_error_ne_tree
6571                   ("size of aliased field& must be ^ bits",
6572                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6573                    TYPE_SIZE (gnu_field_type));
6574
6575               else if (Strict_Alignment (Etype (gnat_field)))
6576                 post_error_ne_tree
6577                   ("size of & with aliased or tagged components not ^ bits",
6578                    Last_Bit (Component_Clause (gnat_field)), gnat_field,
6579                    TYPE_SIZE (gnu_field_type));
6580
6581               gnu_size = NULL_TREE;
6582             }
6583
6584           if (!integer_zerop (size_binop
6585                               (TRUNC_MOD_EXPR, gnu_pos,
6586                                bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6587             {
6588               if (Is_Aliased (gnat_field))
6589                 post_error_ne_num
6590                   ("position of aliased field& must be multiple of ^ bits",
6591                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6592                    TYPE_ALIGN (gnu_field_type));
6593
6594               else if (Treat_As_Volatile (gnat_field))
6595                 post_error_ne_num
6596                   ("position of volatile field& must be multiple of ^ bits",
6597                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6598                    TYPE_ALIGN (gnu_field_type));
6599
6600               else if (Strict_Alignment (Etype (gnat_field)))
6601                 post_error_ne_num
6602   ("position of & with aliased or tagged components not multiple of ^ bits",
6603                    First_Bit (Component_Clause (gnat_field)), gnat_field,
6604                    TYPE_ALIGN (gnu_field_type));
6605
6606               else
6607                 gcc_unreachable ();
6608
6609               gnu_pos = NULL_TREE;
6610             }
6611         }
6612
6613       if (Is_Atomic (gnat_field))
6614         check_ok_for_atomic (gnu_field_type, gnat_field, false);
6615     }
6616
6617   /* If the record has rep clauses and this is the tag field, make a rep
6618      clause for it as well.  */
6619   else if (Has_Specified_Layout (Scope (gnat_field))
6620            && Chars (gnat_field) == Name_uTag)
6621     {
6622       gnu_pos = bitsize_zero_node;
6623       gnu_size = TYPE_SIZE (gnu_field_type);
6624     }
6625
6626   else
6627     gnu_pos = NULL_TREE;
6628
6629   /* We need to make the size the maximum for the type if it is
6630      self-referential and an unconstrained type.  In that case, we can't
6631      pack the field since we can't make a copy to align it.  */
6632   if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6633       && !gnu_size
6634       && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6635       && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6636     {
6637       gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6638       packed = 0;
6639     }
6640
6641   /* If a size is specified, adjust the field's type to it.  */
6642   if (gnu_size)
6643     {
6644       tree orig_field_type;
6645
6646       /* If the field's type is justified modular, we would need to remove
6647          the wrapper to (better) meet the layout requirements.  However we
6648          can do so only if the field is not aliased to preserve the unique
6649          layout and if the prescribed size is not greater than that of the
6650          packed array to preserve the justification.  */
6651       if (!needs_strict_alignment
6652           && TREE_CODE (gnu_field_type) == RECORD_TYPE
6653           && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6654           && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6655                <= 0)
6656         gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6657
6658       gnu_field_type
6659         = make_type_from_size (gnu_field_type, gnu_size,
6660                                Has_Biased_Representation (gnat_field));
6661
6662       orig_field_type = gnu_field_type;
6663       gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6664                                        false, false, definition, true);
6665
6666       /* If a padding record was made, declare it now since it will never be
6667          declared otherwise.  This is necessary to ensure that its subtrees
6668          are properly marked.  */
6669       if (gnu_field_type != orig_field_type
6670           && !DECL_P (TYPE_NAME (gnu_field_type)))
6671         create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6672                           true, debug_info_p, gnat_field);
6673     }
6674
6675   /* Otherwise (or if there was an error), don't specify a position.  */
6676   else
6677     gnu_pos = NULL_TREE;
6678
6679   gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6680               || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6681
6682   /* Now create the decl for the field.  */
6683   gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6684                                  packed, gnu_size, gnu_pos,
6685                                  Is_Aliased (gnat_field));
6686   Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6687   TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6688
6689   if (Ekind (gnat_field) == E_Discriminant)
6690     DECL_DISCRIMINANT_NUMBER (gnu_field)
6691       = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6692
6693   return gnu_field;
6694 }
6695 \f
6696 /* Return true if TYPE is a type with variable size, a padding type with a
6697    field of variable size or is a record that has a field such a field.  */
6698
6699 static bool
6700 is_variable_size (tree type)
6701 {
6702   tree field;
6703
6704   if (!TREE_CONSTANT (TYPE_SIZE (type)))
6705     return true;
6706
6707   if (TYPE_IS_PADDING_P (type)
6708       && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6709     return true;
6710
6711   if (TREE_CODE (type) != RECORD_TYPE
6712       && TREE_CODE (type) != UNION_TYPE
6713       && TREE_CODE (type) != QUAL_UNION_TYPE)
6714     return false;
6715
6716   for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6717     if (is_variable_size (TREE_TYPE (field)))
6718       return true;
6719
6720   return false;
6721 }
6722 \f
6723 /* qsort comparer for the bit positions of two record components.  */
6724
6725 static int
6726 compare_field_bitpos (const PTR rt1, const PTR rt2)
6727 {
6728   const_tree const field1 = * (const_tree const *) rt1;
6729   const_tree const field2 = * (const_tree const *) rt2;
6730   const int ret
6731     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6732
6733   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6734 }
6735
6736 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
6737    the result as the field list of GNU_RECORD_TYPE and finish it up.  When
6738    called from gnat_to_gnu_entity during the processing of a record type
6739    definition, the GCC node for the parent, if any, will be the single field
6740    of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6741    GNU_FIELD_LIST.  The other calls to this function are recursive calls for
6742    the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6743
6744    PACKED is 1 if this is for a packed record, -1 if this is for a record
6745    with Component_Alignment of Storage_Unit, -2 if this is for a record
6746    with a specified alignment.
6747
6748    DEFINITION is true if we are defining this record type.
6749
6750    P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6751    with a rep clause is to be added; in this case, that is all that should
6752    be done with such fields.
6753
6754    CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
6755    out the record.  This means the alignment only serves to force fields to
6756    be bitfields, but not to require the record to be that aligned.  This is
6757    used for variants.
6758
6759    ALL_REP is true if a rep clause is present for all the fields.
6760
6761    UNCHECKED_UNION is true if we are building this type for a record with a
6762    Pragma Unchecked_Union.
6763
6764    DEBUG_INFO_P is true if we need to write debug information about the type.
6765
6766    MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
6767    mean that its contents may be unused as well, but only the container.  */
6768
6769
6770 static void
6771 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
6772                       tree gnu_field_list, int packed, bool definition,
6773                       tree *p_gnu_rep_list, bool cancel_alignment,
6774                       bool all_rep, bool unchecked_union, bool debug_info_p,
6775                       bool maybe_unused)
6776 {
6777   bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6778   bool layout_with_rep = false;
6779   Node_Id component_decl, variant_part;
6780   tree gnu_our_rep_list = NULL_TREE;
6781   tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
6782
6783   /* For each component referenced in a component declaration create a GCC
6784      field and add it to the list, skipping pragmas in the GNAT list.  */
6785   if (Present (Component_Items (gnat_component_list)))
6786     for (component_decl
6787            = First_Non_Pragma (Component_Items (gnat_component_list));
6788          Present (component_decl);
6789          component_decl = Next_Non_Pragma (component_decl))
6790       {
6791         Entity_Id gnat_field = Defining_Entity (component_decl);
6792         Name_Id gnat_name = Chars (gnat_field);
6793
6794         /* If present, the _Parent field must have been created as the single
6795            field of the record type.  Put it before any other fields.  */
6796         if (gnat_name == Name_uParent)
6797           {
6798             gnu_field = TYPE_FIELDS (gnu_record_type);
6799             gnu_field_list = chainon (gnu_field_list, gnu_field);
6800           }
6801         else
6802           {
6803             gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
6804                                            definition, debug_info_p);
6805
6806             /* If this is the _Tag field, put it before any other fields.  */
6807             if (gnat_name == Name_uTag)
6808               gnu_field_list = chainon (gnu_field_list, gnu_field);
6809
6810             /* If this is the _Controller field, put it before the other
6811                fields except for the _Tag or _Parent field.  */
6812             else if (gnat_name == Name_uController && gnu_last)
6813               {
6814                 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
6815                 TREE_CHAIN (gnu_last) = gnu_field;
6816               }
6817
6818             /* If this is a regular field, put it after the other fields.  */
6819             else
6820               {
6821                 TREE_CHAIN (gnu_field) = gnu_field_list;
6822                 gnu_field_list = gnu_field;
6823                 if (!gnu_last)
6824                   gnu_last = gnu_field;
6825               }
6826           }
6827
6828         save_gnu_tree (gnat_field, gnu_field, false);
6829       }
6830
6831   /* At the end of the component list there may be a variant part.  */
6832   variant_part = Variant_Part (gnat_component_list);
6833
6834   /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6835      mutually exclusive and should go in the same memory.  To do this we need
6836      to treat each variant as a record whose elements are created from the
6837      component list for the variant.  So here we create the records from the
6838      lists for the variants and put them all into the QUAL_UNION_TYPE.
6839      If this is an Unchecked_Union, we make a UNION_TYPE instead or
6840      use GNU_RECORD_TYPE if there are no fields so far.  */
6841   if (Present (variant_part))
6842     {
6843       Node_Id gnat_discr = Name (variant_part), variant;
6844       tree gnu_discr = gnat_to_gnu (gnat_discr);
6845       tree gnu_name = TYPE_NAME (gnu_record_type);
6846       tree gnu_var_name
6847         = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
6848                        "XVN");
6849       tree gnu_union_type, gnu_union_name, gnu_union_field;
6850       tree gnu_variant_list = NULL_TREE;
6851
6852       if (TREE_CODE (gnu_name) == TYPE_DECL)
6853         gnu_name = DECL_NAME (gnu_name);
6854
6855       gnu_union_name
6856         = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
6857
6858       /* Reuse an enclosing union if all fields are in the variant part
6859          and there is no representation clause on the record, to match
6860          the layout of C unions.  There is an associated check below.  */
6861       if (!gnu_field_list
6862           && TREE_CODE (gnu_record_type) == UNION_TYPE
6863           && !TYPE_PACKED (gnu_record_type))
6864         gnu_union_type = gnu_record_type;
6865       else
6866         {
6867           gnu_union_type
6868             = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6869
6870           TYPE_NAME (gnu_union_type) = gnu_union_name;
6871           TYPE_ALIGN (gnu_union_type) = 0;
6872           TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6873         }
6874
6875       for (variant = First_Non_Pragma (Variants (variant_part));
6876            Present (variant);
6877            variant = Next_Non_Pragma (variant))
6878         {
6879           tree gnu_variant_type = make_node (RECORD_TYPE);
6880           tree gnu_inner_name;
6881           tree gnu_qual;
6882
6883           Get_Variant_Encoding (variant);
6884           gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
6885           TYPE_NAME (gnu_variant_type)
6886             = concat_name (gnu_union_name,
6887                            IDENTIFIER_POINTER (gnu_inner_name));
6888
6889           /* Set the alignment of the inner type in case we need to make
6890              inner objects into bitfields, but then clear it out so the
6891              record actually gets only the alignment required.  */
6892           TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6893           TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6894
6895           /* Similarly, if the outer record has a size specified and all
6896              fields have record rep clauses, we can propagate the size
6897              into the variant part.  */
6898           if (all_rep_and_size)
6899             {
6900               TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6901               TYPE_SIZE_UNIT (gnu_variant_type)
6902                 = TYPE_SIZE_UNIT (gnu_record_type);
6903             }
6904
6905           /* Add the fields into the record type for the variant.  Note that
6906              we aren't sure to really use it at this point, see below.  */
6907           components_to_record (gnu_variant_type, Component_List (variant),
6908                                 NULL_TREE, packed, definition,
6909                                 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6910                                 unchecked_union, debug_info_p, true);
6911
6912           gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
6913
6914           Set_Present_Expr (variant, annotate_value (gnu_qual));
6915
6916           /* If this is an Unchecked_Union and we have exactly one field,
6917              use this field directly to match the layout of C unions.  */
6918           if (unchecked_union
6919               && TYPE_FIELDS (gnu_variant_type)
6920               && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6921             gnu_field = TYPE_FIELDS (gnu_variant_type);
6922           else
6923             {
6924               /* Deal with packedness like in gnat_to_gnu_field.  */
6925               int field_packed
6926                 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6927
6928               /* Finalize the record type now.  We used to throw away
6929                  empty records but we no longer do that because we need
6930                  them to generate complete debug info for the variant;
6931                  otherwise, the union type definition will be lacking
6932                  the fields associated with these empty variants.  */
6933               rest_of_record_type_compilation (gnu_variant_type);
6934               create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
6935                                 NULL, true, debug_info_p, gnat_component_list);
6936
6937               gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6938                                              gnu_union_type, field_packed,
6939                                              (all_rep_and_size
6940                                               ? TYPE_SIZE (gnu_variant_type)
6941                                               : 0),
6942                                              (all_rep_and_size
6943                                               ? bitsize_zero_node : 0),
6944                                              0);
6945
6946               DECL_INTERNAL_P (gnu_field) = 1;
6947
6948               if (!unchecked_union)
6949                 DECL_QUALIFIER (gnu_field) = gnu_qual;
6950             }
6951
6952           TREE_CHAIN (gnu_field) = gnu_variant_list;
6953           gnu_variant_list = gnu_field;
6954         }
6955
6956       /* Only make the QUAL_UNION_TYPE if there are non-empty variants.  */
6957       if (gnu_variant_list)
6958         {
6959           int union_field_packed;
6960
6961           if (all_rep_and_size)
6962             {
6963               TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6964               TYPE_SIZE_UNIT (gnu_union_type)
6965                 = TYPE_SIZE_UNIT (gnu_record_type);
6966             }
6967
6968           finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6969                               all_rep_and_size ? 1 : 0, debug_info_p);
6970
6971           /* If GNU_UNION_TYPE is our record type, it means we must have an
6972              Unchecked_Union with no fields.  Verify that and, if so, just
6973              return.  */
6974           if (gnu_union_type == gnu_record_type)
6975             {
6976               gcc_assert (unchecked_union
6977                           && !gnu_field_list
6978                           && !gnu_our_rep_list);
6979               return;
6980             }
6981
6982           create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
6983                             NULL, true, debug_info_p, gnat_component_list);
6984
6985           /* Deal with packedness like in gnat_to_gnu_field.  */
6986           union_field_packed
6987             = adjust_packed (gnu_union_type, gnu_record_type, packed);
6988
6989           gnu_union_field
6990             = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6991                                  union_field_packed,
6992                                  all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6993                                  all_rep ? bitsize_zero_node : 0, 0);
6994
6995           DECL_INTERNAL_P (gnu_union_field) = 1;
6996           TREE_CHAIN (gnu_union_field) = gnu_field_list;
6997           gnu_field_list = gnu_union_field;
6998         }
6999     }
7000
7001   /* Scan GNU_FIELD_LIST and see if any fields have rep clauses.  If they
7002      do, pull them out and put them into GNU_OUR_REP_LIST.  We have to do
7003      this in a separate pass since we want to handle the discriminants but
7004      can't play with them until we've used them in debugging data above.
7005
7006      ??? If we then reorder them, debugging information will be wrong but
7007      there's nothing that can be done about this at the moment.  */
7008   gnu_last = NULL_TREE;
7009   for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7010     {
7011       gnu_next = TREE_CHAIN (gnu_field);
7012
7013       if (DECL_FIELD_OFFSET (gnu_field))
7014         {
7015           if (!gnu_last)
7016             gnu_field_list = gnu_next;
7017           else
7018             TREE_CHAIN (gnu_last) = gnu_next;
7019
7020           TREE_CHAIN (gnu_field) = gnu_our_rep_list;
7021           gnu_our_rep_list = gnu_field;
7022         }
7023       else
7024         gnu_last = gnu_field;
7025     }
7026
7027   /* If we have any fields in our rep'ed field list and it is not the case that
7028      all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7029      set it and ignore these fields.  */
7030   if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
7031     *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
7032
7033   /* Otherwise, sort the fields by bit position and put them into their own
7034      record, before the others, if we also have fields without rep clauses.  */
7035   else if (gnu_our_rep_list)
7036     {
7037       tree gnu_rep_type
7038         = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7039       int i, len = list_length (gnu_our_rep_list);
7040       tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
7041
7042       for (gnu_field = gnu_our_rep_list, i = 0;
7043            gnu_field;
7044            gnu_field = TREE_CHAIN (gnu_field), i++)
7045         gnu_arr[i] = gnu_field;
7046
7047       qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7048
7049       /* Put the fields in the list in order of increasing position, which
7050          means we start from the end.  */
7051       gnu_our_rep_list = NULL_TREE;
7052       for (i = len - 1; i >= 0; i--)
7053         {
7054           TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
7055           gnu_our_rep_list = gnu_arr[i];
7056           DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7057         }
7058
7059       if (gnu_field_list)
7060         {
7061           finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, debug_info_p);
7062           gnu_field
7063             = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7064                                  gnu_record_type, 0, NULL_TREE, NULL_TREE, 1);
7065           DECL_INTERNAL_P (gnu_field) = 1;
7066           gnu_field_list = chainon (gnu_field_list, gnu_field);
7067         }
7068       else
7069         {
7070           layout_with_rep = true;
7071           gnu_field_list = nreverse (gnu_our_rep_list);
7072         }
7073     }
7074
7075   if (cancel_alignment)
7076     TYPE_ALIGN (gnu_record_type) = 0;
7077
7078   finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7079                       layout_with_rep ? 1 : 0, debug_info_p && !maybe_unused);
7080 }
7081 \f
7082 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7083    placed into an Esize, Component_Bit_Offset, or Component_Size value
7084    in the GNAT tree.  */
7085
7086 static Uint
7087 annotate_value (tree gnu_size)
7088 {
7089   TCode tcode;
7090   Node_Ref_Or_Val ops[3], ret;
7091   struct tree_int_map **h = NULL;
7092   int i;
7093
7094   /* See if we've already saved the value for this node.  */
7095   if (EXPR_P (gnu_size))
7096     {
7097       struct tree_int_map in;
7098       if (!annotate_value_cache)
7099         annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7100                                                 tree_int_map_eq, 0);
7101       in.base.from = gnu_size;
7102       h = (struct tree_int_map **)
7103             htab_find_slot (annotate_value_cache, &in, INSERT);
7104
7105       if (*h)
7106         return (Node_Ref_Or_Val) (*h)->to;
7107     }
7108
7109   /* If we do not return inside this switch, TCODE will be set to the
7110      code to use for a Create_Node operand and LEN (set above) will be
7111      the number of recursive calls for us to make.  */
7112
7113   switch (TREE_CODE (gnu_size))
7114     {
7115     case INTEGER_CST:
7116       if (TREE_OVERFLOW (gnu_size))
7117         return No_Uint;
7118
7119       /* This may come from a conversion from some smaller type, so ensure
7120          this is in bitsizetype.  */
7121       gnu_size = convert (bitsizetype, gnu_size);
7122
7123       /* For a negative value, build NEGATE_EXPR of the opposite.  Such values
7124          appear in expressions containing aligning patterns.  Note that, since
7125          sizetype is sign-extended but nonetheless unsigned, we don't directly
7126          use tree_int_cst_sgn.  */
7127       if (TREE_INT_CST_HIGH (gnu_size) < 0)
7128         {
7129           tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size);
7130           return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size));
7131         }
7132
7133       return UI_From_gnu (gnu_size);
7134
7135     case COMPONENT_REF:
7136       /* The only case we handle here is a simple discriminant reference.  */
7137       if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7138           && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7139           && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7140         return Create_Node (Discrim_Val,
7141                             annotate_value (DECL_DISCRIMINANT_NUMBER
7142                                             (TREE_OPERAND (gnu_size, 1))),
7143                             No_Uint, No_Uint);
7144       else
7145         return No_Uint;
7146
7147     CASE_CONVERT:   case NON_LVALUE_EXPR:
7148       return annotate_value (TREE_OPERAND (gnu_size, 0));
7149
7150       /* Now just list the operations we handle.  */
7151     case COND_EXPR:             tcode = Cond_Expr; break;
7152     case PLUS_EXPR:             tcode = Plus_Expr; break;
7153     case MINUS_EXPR:            tcode = Minus_Expr; break;
7154     case MULT_EXPR:             tcode = Mult_Expr; break;
7155     case TRUNC_DIV_EXPR:        tcode = Trunc_Div_Expr; break;
7156     case CEIL_DIV_EXPR:         tcode = Ceil_Div_Expr; break;
7157     case FLOOR_DIV_EXPR:        tcode = Floor_Div_Expr; break;
7158     case TRUNC_MOD_EXPR:        tcode = Trunc_Mod_Expr; break;
7159     case CEIL_MOD_EXPR:         tcode = Ceil_Mod_Expr; break;
7160     case FLOOR_MOD_EXPR:        tcode = Floor_Mod_Expr; break;
7161     case EXACT_DIV_EXPR:        tcode = Exact_Div_Expr; break;
7162     case NEGATE_EXPR:           tcode = Negate_Expr; break;
7163     case MIN_EXPR:              tcode = Min_Expr; break;
7164     case MAX_EXPR:              tcode = Max_Expr; break;
7165     case ABS_EXPR:              tcode = Abs_Expr; break;
7166     case TRUTH_ANDIF_EXPR:      tcode = Truth_Andif_Expr; break;
7167     case TRUTH_ORIF_EXPR:       tcode = Truth_Orif_Expr; break;
7168     case TRUTH_AND_EXPR:        tcode = Truth_And_Expr; break;
7169     case TRUTH_OR_EXPR:         tcode = Truth_Or_Expr; break;
7170     case TRUTH_XOR_EXPR:        tcode = Truth_Xor_Expr; break;
7171     case TRUTH_NOT_EXPR:        tcode = Truth_Not_Expr; break;
7172     case BIT_AND_EXPR:          tcode = Bit_And_Expr; break;
7173     case LT_EXPR:               tcode = Lt_Expr; break;
7174     case LE_EXPR:               tcode = Le_Expr; break;
7175     case GT_EXPR:               tcode = Gt_Expr; break;
7176     case GE_EXPR:               tcode = Ge_Expr; break;
7177     case EQ_EXPR:               tcode = Eq_Expr; break;
7178     case NE_EXPR:               tcode = Ne_Expr; break;
7179
7180     case CALL_EXPR:
7181       {
7182         tree t = maybe_inline_call_in_expr (gnu_size);
7183         if (t)
7184           return annotate_value (t);
7185       }
7186
7187       /* Fall through... */
7188
7189     default:
7190       return No_Uint;
7191     }
7192
7193   /* Now get each of the operands that's relevant for this code.  If any
7194      cannot be expressed as a repinfo node, say we can't.  */
7195   for (i = 0; i < 3; i++)
7196     ops[i] = No_Uint;
7197
7198   for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7199     {
7200       ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7201       if (ops[i] == No_Uint)
7202         return No_Uint;
7203     }
7204
7205   ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7206
7207   /* Save the result in the cache.  */
7208   if (h)
7209     {
7210       *h = GGC_NEW (struct tree_int_map);
7211       (*h)->base.from = gnu_size;
7212       (*h)->to = ret;
7213     }
7214
7215   return ret;
7216 }
7217
7218 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7219    and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7220    size and alignment used by Gigi.  Prefer SIZE over TYPE_SIZE if non-null.
7221    BY_REF is true if the object is used by reference.  */
7222
7223 void
7224 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7225 {
7226   if (by_ref)
7227     {
7228       if (TYPE_IS_FAT_POINTER_P (gnu_type))
7229         gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7230       else
7231         gnu_type = TREE_TYPE (gnu_type);
7232     }
7233
7234   if (Unknown_Esize (gnat_entity))
7235     {
7236       if (TREE_CODE (gnu_type) == RECORD_TYPE
7237           && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7238         size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
7239       else if (!size)
7240         size = TYPE_SIZE (gnu_type);
7241
7242       if (size)
7243         Set_Esize (gnat_entity, annotate_value (size));
7244     }
7245
7246   if (Unknown_Alignment (gnat_entity))
7247     Set_Alignment (gnat_entity,
7248                    UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7249 }
7250
7251 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7252    Return NULL_TREE if there is no such element in the list.  */
7253
7254 static tree
7255 purpose_member_field (const_tree elem, tree list)
7256 {
7257   while (list)
7258     {
7259       tree field = TREE_PURPOSE (list);
7260       if (SAME_FIELD_P (field, elem))
7261         return list;
7262       list = TREE_CHAIN (list);
7263     }
7264   return NULL_TREE;
7265 }
7266
7267 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7268    set Component_Bit_Offset and Esize of the components to the position and
7269    size used by Gigi.  */
7270
7271 static void
7272 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7273 {
7274   Entity_Id gnat_field;
7275   tree gnu_list;
7276
7277   /* We operate by first making a list of all fields and their position (we
7278      can get the size easily) and then update all the sizes in the tree.  */
7279   gnu_list
7280     = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7281                            BIGGEST_ALIGNMENT, NULL_TREE);
7282
7283   for (gnat_field = First_Entity (gnat_entity);
7284        Present (gnat_field);
7285        gnat_field = Next_Entity (gnat_field))
7286     if (Ekind (gnat_field) == E_Component
7287         || (Ekind (gnat_field) == E_Discriminant
7288             && !Is_Unchecked_Union (Scope (gnat_field))))
7289       {
7290         tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7291                                        gnu_list);
7292         if (t)
7293           {
7294             tree parent_offset;
7295
7296             if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7297               {
7298                 /* In this mode the tag and parent components are not
7299                    generated, so we add the appropriate offset to each
7300                    component.  For a component appearing in the current
7301                    extension, the offset is the size of the parent.  */
7302                 if (Is_Derived_Type (gnat_entity)
7303                     && Original_Record_Component (gnat_field) == gnat_field)
7304                   parent_offset
7305                     = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7306                                  bitsizetype);
7307                 else
7308                   parent_offset = bitsize_int (POINTER_SIZE);
7309               }
7310             else
7311               parent_offset = bitsize_zero_node;
7312
7313             Set_Component_Bit_Offset
7314               (gnat_field,
7315                annotate_value
7316                  (size_binop (PLUS_EXPR,
7317                               bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7318                                             TREE_VEC_ELT (TREE_VALUE (t), 2)),
7319                               parent_offset)));
7320
7321             Set_Esize (gnat_field,
7322                        annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7323           }
7324         else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7325           {
7326             /* If there is no entry, this is an inherited component whose
7327                position is the same as in the parent type.  */
7328             Set_Component_Bit_Offset
7329               (gnat_field,
7330                Component_Bit_Offset (Original_Record_Component (gnat_field)));
7331
7332             Set_Esize (gnat_field,
7333                        Esize (Original_Record_Component (gnat_field)));
7334           }
7335       }
7336 }
7337 \f
7338 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7339    the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7340    value to be placed into DECL_OFFSET_ALIGN and the bit position.  The list
7341    of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7342    is set to true.  GNU_POS is to be added to the position, GNU_BITPOS to the
7343    bit position, OFFSET_ALIGN is the present offset alignment.  GNU_LIST is a
7344    pre-existing list to be chained to the newly created entries.  */
7345
7346 static tree
7347 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7348                      tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7349 {
7350   tree gnu_field;
7351
7352   for (gnu_field = TYPE_FIELDS (gnu_type);
7353        gnu_field;
7354        gnu_field = TREE_CHAIN (gnu_field))
7355     {
7356       tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7357                                         DECL_FIELD_BIT_OFFSET (gnu_field));
7358       tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7359                                         DECL_FIELD_OFFSET (gnu_field));
7360       unsigned int our_offset_align
7361         = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7362       tree v = make_tree_vec (3);
7363
7364       TREE_VEC_ELT (v, 0) = gnu_our_offset;
7365       TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7366       TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7367       gnu_list = tree_cons (gnu_field, v, gnu_list);
7368
7369       /* Recurse on internal fields, flattening the nested fields except for
7370          those in the variant part, if requested.  */
7371       if (DECL_INTERNAL_P (gnu_field))
7372         {
7373           tree gnu_field_type = TREE_TYPE (gnu_field);
7374           if (do_not_flatten_variant
7375               && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7376             gnu_list
7377               = build_position_list (gnu_field_type, do_not_flatten_variant,
7378                                      size_zero_node, bitsize_zero_node,
7379                                      BIGGEST_ALIGNMENT, gnu_list);
7380           else
7381             gnu_list
7382               = build_position_list (gnu_field_type, do_not_flatten_variant,
7383                                      gnu_our_offset, gnu_our_bitpos,
7384                                      our_offset_align, gnu_list);
7385         }
7386     }
7387
7388   return gnu_list;
7389 }
7390
7391 /* Return a TREE_LIST describing the substitutions needed to reflect the
7392    discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE.  They can
7393    be in any order.  TREE_PURPOSE gives the tree for the discriminant and
7394    TREE_VALUE is the replacement value.  They are in the form of operands
7395    to SUBSTITUTE_IN_EXPR.  DEFINITION is true if this is for a definition
7396    of GNAT_SUBTYPE.  */
7397
7398 static tree
7399 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7400 {
7401   tree gnu_list = NULL_TREE;
7402   Entity_Id gnat_discrim;
7403   Node_Id gnat_value;
7404
7405   for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7406        gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7407        Present (gnat_discrim);
7408        gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7409        gnat_value = Next_Elmt (gnat_value))
7410     /* Ignore access discriminants.  */
7411     if (!Is_Access_Type (Etype (Node (gnat_value))))
7412       {
7413         tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7414         gnu_list = tree_cons (gnu_field,
7415                               convert (TREE_TYPE (gnu_field),
7416                                        elaborate_expression
7417                                        (Node (gnat_value), gnat_subtype,
7418                                         get_entity_name (gnat_discrim),
7419                                         definition, true, false)),
7420                               gnu_list);
7421       }
7422
7423   return gnu_list;
7424 }
7425
7426 /* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
7427    variants of QUAL_UNION_TYPE that are still relevant after applying the
7428    substitutions described in SUBST_LIST.  TREE_PURPOSE is the type of the
7429    variant and TREE_VALUE is a TREE_VEC containing the field, the new value
7430    of the qualifier and NULL_TREE respectively.  GNU_LIST is a pre-existing
7431    list to be chained to the newly created entries.  */
7432
7433 static tree
7434 build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
7435 {
7436   tree gnu_field;
7437
7438   for (gnu_field = TYPE_FIELDS (qual_union_type);
7439        gnu_field;
7440        gnu_field = TREE_CHAIN (gnu_field))
7441     {
7442       tree t, qual = DECL_QUALIFIER (gnu_field);
7443
7444       for (t = subst_list; t; t = TREE_CHAIN (t))
7445         qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
7446
7447       /* If the new qualifier is not unconditionally false, its variant may
7448          still be accessed.  */
7449       if (!integer_zerop (qual))
7450         {
7451           tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7452           tree v = make_tree_vec (3);
7453           TREE_VEC_ELT (v, 0) = gnu_field;
7454           TREE_VEC_ELT (v, 1) = qual;
7455           TREE_VEC_ELT (v, 2) = NULL_TREE;
7456           gnu_list = tree_cons (variant_type, v, gnu_list);
7457
7458           /* Recurse on the variant subpart of the variant, if any.  */
7459           variant_subpart = get_variant_part (variant_type);
7460           if (variant_subpart)
7461             gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
7462                                            subst_list, gnu_list);
7463
7464           /* If the new qualifier is unconditionally true, the subsequent
7465              variants cannot be accessed.  */
7466           if (integer_onep (qual))
7467             break;
7468         }
7469     }
7470
7471   return gnu_list;
7472 }
7473 \f
7474 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7475    corresponding to GNAT_OBJECT.  If size is valid, return a tree corresponding
7476    to its value.  Otherwise return 0.  KIND is VAR_DECL is we are specifying
7477    the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7478    for the size of a field.  COMPONENT_P is true if we are being called
7479    to process the Component_Size of GNAT_OBJECT.  This is used for error
7480    message handling and to indicate to use the object size of GNU_TYPE.
7481    ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7482    it means that a size of zero should be treated as an unspecified size.  */
7483
7484 static tree
7485 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7486                enum tree_code kind, bool component_p, bool zero_ok)
7487 {
7488   Node_Id gnat_error_node;
7489   tree type_size, size;
7490
7491   /* Return 0 if no size was specified.  */
7492   if (uint_size == No_Uint)
7493     return NULL_TREE;
7494
7495   /* Ignore a negative size since that corresponds to our back-annotation.  */
7496   if (UI_Lt (uint_size, Uint_0))
7497     return NULL_TREE;
7498
7499   /* Find the node to use for errors.  */
7500   if ((Ekind (gnat_object) == E_Component
7501        || Ekind (gnat_object) == E_Discriminant)
7502       && Present (Component_Clause (gnat_object)))
7503     gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7504   else if (Present (Size_Clause (gnat_object)))
7505     gnat_error_node = Expression (Size_Clause (gnat_object));
7506   else
7507     gnat_error_node = gnat_object;
7508
7509   /* Get the size as a tree.  Issue an error if a size was specified but
7510      cannot be represented in sizetype.  */
7511   size = UI_To_gnu (uint_size, bitsizetype);
7512   if (TREE_OVERFLOW (size))
7513     {
7514       if (component_p)
7515         post_error_ne ("component size of & is too large", gnat_error_node,
7516                        gnat_object);
7517       else
7518         post_error_ne ("size of & is too large", gnat_error_node,
7519                        gnat_object);
7520       return NULL_TREE;
7521     }
7522
7523   /* Ignore a zero size if it is not permitted.  */
7524   if (!zero_ok && integer_zerop (size))
7525     return NULL_TREE;
7526
7527   /* The size of objects is always a multiple of a byte.  */
7528   if (kind == VAR_DECL
7529       && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7530     {
7531       if (component_p)
7532         post_error_ne ("component size for& is not a multiple of Storage_Unit",
7533                        gnat_error_node, gnat_object);
7534       else
7535         post_error_ne ("size for& is not a multiple of Storage_Unit",
7536                        gnat_error_node, gnat_object);
7537       return NULL_TREE;
7538     }
7539
7540   /* If this is an integral type or a packed array type, the front-end has
7541      verified the size, so we need not do it here (which would entail
7542      checking against the bounds).  However, if this is an aliased object,
7543      it may not be smaller than the type of the object.  */
7544   if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7545       && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7546     return size;
7547
7548   /* If the object is a record that contains a template, add the size of
7549      the template to the specified size.  */
7550   if (TREE_CODE (gnu_type) == RECORD_TYPE
7551       && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7552     size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7553
7554   if (kind == VAR_DECL
7555       /* If a type needs strict alignment, a component of this type in
7556          a packed record cannot be packed and thus uses the type size.  */
7557       || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7558     type_size = TYPE_SIZE (gnu_type);
7559   else
7560     type_size = rm_size (gnu_type);
7561
7562   /* Modify the size of the type to be that of the maximum size if it has a
7563      discriminant.  */
7564   if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7565     type_size = max_size (type_size, true);
7566
7567   /* If this is an access type or a fat pointer, the minimum size is that given
7568      by the smallest integral mode that's valid for pointers.  */
7569   if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7570     {
7571       enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7572       while (!targetm.valid_pointer_mode (p_mode))
7573         p_mode = GET_MODE_WIDER_MODE (p_mode);
7574       type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7575     }
7576
7577   /* If the size of the object is a constant, the new size must not be
7578      smaller.  */
7579   if (TREE_CODE (type_size) != INTEGER_CST
7580       || TREE_OVERFLOW (type_size)
7581       || tree_int_cst_lt (size, type_size))
7582     {
7583       if (component_p)
7584         post_error_ne_tree
7585           ("component size for& too small{, minimum allowed is ^}",
7586            gnat_error_node, gnat_object, type_size);
7587       else
7588         post_error_ne_tree
7589           ("size for& too small{, minimum allowed is ^}",
7590            gnat_error_node, gnat_object, type_size);
7591
7592       size = NULL_TREE;
7593     }
7594
7595   return size;
7596 }
7597 \f
7598 /* Similarly, but both validate and process a value of RM size.  This
7599    routine is only called for types.  */
7600
7601 static void
7602 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7603 {
7604   Node_Id gnat_attr_node;
7605   tree old_size, size;
7606
7607   /* Do nothing if no size was specified.  */
7608   if (uint_size == No_Uint)
7609     return;
7610
7611   /* Ignore a negative size since that corresponds to our back-annotation.  */
7612   if (UI_Lt (uint_size, Uint_0))
7613     return;
7614
7615   /* Only issue an error if a Value_Size clause was explicitly given.
7616      Otherwise, we'd be duplicating an error on the Size clause.  */
7617   gnat_attr_node
7618     = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7619
7620   /* Get the size as a tree.  Issue an error if a size was specified but
7621      cannot be represented in sizetype.  */
7622   size = UI_To_gnu (uint_size, bitsizetype);
7623   if (TREE_OVERFLOW (size))
7624     {
7625       if (Present (gnat_attr_node))
7626         post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7627                        gnat_entity);
7628       return;
7629     }
7630
7631   /* Ignore a zero size unless a Value_Size clause exists, or a size clause
7632      exists, or this is an integer type, in which case the front-end will
7633      have always set it.  */
7634   if (No (gnat_attr_node)
7635       && integer_zerop (size)
7636       && !Has_Size_Clause (gnat_entity)
7637       && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7638     return;
7639
7640   old_size = rm_size (gnu_type);
7641
7642   /* If the old size is self-referential, get the maximum size.  */
7643   if (CONTAINS_PLACEHOLDER_P (old_size))
7644     old_size = max_size (old_size, true);
7645
7646   /* If the size of the object is a constant, the new size must not be smaller
7647      (the front-end has verified this for scalar and packed array types).  */
7648   if (TREE_CODE (old_size) != INTEGER_CST
7649       || TREE_OVERFLOW (old_size)
7650       || (AGGREGATE_TYPE_P (gnu_type)
7651           && !(TREE_CODE (gnu_type) == ARRAY_TYPE
7652                && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
7653           && !(TYPE_IS_PADDING_P (gnu_type)
7654                && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
7655                && TYPE_PACKED_ARRAY_TYPE_P
7656                   (TREE_TYPE (TYPE_FIELDS (gnu_type))))
7657           && tree_int_cst_lt (size, old_size)))
7658     {
7659       if (Present (gnat_attr_node))
7660         post_error_ne_tree
7661           ("Value_Size for& too small{, minimum allowed is ^}",
7662            gnat_attr_node, gnat_entity, old_size);
7663       return;
7664     }
7665
7666   /* Otherwise, set the RM size proper for integral types...  */
7667   if ((TREE_CODE (gnu_type) == INTEGER_TYPE
7668        && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7669       || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7670           || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
7671     SET_TYPE_RM_SIZE (gnu_type, size);
7672
7673   /* ...or the Ada size for record and union types.  */
7674   else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7675             || TREE_CODE (gnu_type) == UNION_TYPE
7676             || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7677            && !TYPE_FAT_POINTER_P (gnu_type))
7678     SET_TYPE_ADA_SIZE (gnu_type, size);
7679 }
7680 \f
7681 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7682    If TYPE is the best type, return it.  Otherwise, make a new type.  We
7683    only support new integral and pointer types.  FOR_BIASED is true if
7684    we are making a biased type.  */
7685
7686 static tree
7687 make_type_from_size (tree type, tree size_tree, bool for_biased)
7688 {
7689   unsigned HOST_WIDE_INT size;
7690   bool biased_p;
7691   tree new_type;
7692
7693   /* If size indicates an error, just return TYPE to avoid propagating
7694      the error.  Likewise if it's too large to represent.  */
7695   if (!size_tree || !host_integerp (size_tree, 1))
7696     return type;
7697
7698   size = tree_low_cst (size_tree, 1);
7699
7700   switch (TREE_CODE (type))
7701     {
7702     case INTEGER_TYPE:
7703     case ENUMERAL_TYPE:
7704     case BOOLEAN_TYPE:
7705       biased_p = (TREE_CODE (type) == INTEGER_TYPE
7706                   && TYPE_BIASED_REPRESENTATION_P (type));
7707
7708       /* Integer types with precision 0 are forbidden.  */
7709       if (size == 0)
7710         size = 1;
7711
7712       /* Only do something if the type is not a packed array type and
7713          doesn't already have the proper size.  */
7714       if (TYPE_PACKED_ARRAY_TYPE_P (type)
7715           || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7716         break;
7717
7718       biased_p |= for_biased;
7719       if (size > LONG_LONG_TYPE_SIZE)
7720         size = LONG_LONG_TYPE_SIZE;
7721
7722       if (TYPE_UNSIGNED (type) || biased_p)
7723         new_type = make_unsigned_type (size);
7724       else
7725         new_type = make_signed_type (size);
7726       TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7727       SET_TYPE_RM_MIN_VALUE (new_type,
7728                              convert (TREE_TYPE (new_type),
7729                                       TYPE_MIN_VALUE (type)));
7730       SET_TYPE_RM_MAX_VALUE (new_type,
7731                              convert (TREE_TYPE (new_type),
7732                                       TYPE_MAX_VALUE (type)));
7733       /* Copy the name to show that it's essentially the same type and
7734          not a subrange type.  */
7735       TYPE_NAME (new_type) = TYPE_NAME (type);
7736       TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7737       SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
7738       return new_type;
7739
7740     case RECORD_TYPE:
7741       /* Do something if this is a fat pointer, in which case we
7742          may need to return the thin pointer.  */
7743       if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7744         {
7745           enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7746           if (!targetm.valid_pointer_mode (p_mode))
7747             p_mode = ptr_mode;
7748           return
7749             build_pointer_type_for_mode
7750               (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7751                p_mode, 0);
7752         }
7753       break;
7754
7755     case POINTER_TYPE:
7756       /* Only do something if this is a thin pointer, in which case we
7757          may need to return the fat pointer.  */
7758       if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7759         return
7760           build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7761       break;
7762
7763     default:
7764       break;
7765     }
7766
7767   return type;
7768 }
7769 \f
7770 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7771    a type or object whose present alignment is ALIGN.  If this alignment is
7772    valid, return it.  Otherwise, give an error and return ALIGN.  */
7773
7774 static unsigned int
7775 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7776 {
7777   unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7778   unsigned int new_align;
7779   Node_Id gnat_error_node;
7780
7781   /* Don't worry about checking alignment if alignment was not specified
7782      by the source program and we already posted an error for this entity.  */
7783   if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7784     return align;
7785
7786   /* Post the error on the alignment clause if any.  Note, for the implicit
7787      base type of an array type, the alignment clause is on the first
7788      subtype.  */
7789   if (Present (Alignment_Clause (gnat_entity)))
7790     gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7791
7792   else if (Is_Itype (gnat_entity)
7793            && Is_Array_Type (gnat_entity)
7794            && Etype (gnat_entity) == gnat_entity
7795            && Present (Alignment_Clause (First_Subtype (gnat_entity))))
7796     gnat_error_node =
7797       Expression (Alignment_Clause (First_Subtype (gnat_entity)));
7798
7799   else
7800     gnat_error_node = gnat_entity;
7801
7802   /* Within GCC, an alignment is an integer, so we must make sure a value is
7803      specified that fits in that range.  Also, there is an upper bound to
7804      alignments we can support/allow.  */
7805   if (!UI_Is_In_Int_Range (alignment)
7806       || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7807     post_error_ne_num ("largest supported alignment for& is ^",
7808                        gnat_error_node, gnat_entity, max_allowed_alignment);
7809   else if (!(Present (Alignment_Clause (gnat_entity))
7810              && From_At_Mod (Alignment_Clause (gnat_entity)))
7811            && new_align * BITS_PER_UNIT < align)
7812     {
7813       unsigned int double_align;
7814       bool is_capped_double, align_clause;
7815
7816       /* If the default alignment of "double" or larger scalar types is
7817          specifically capped and the new alignment is above the cap, do
7818          not post an error and change the alignment only if there is an
7819          alignment clause; this makes it possible to have the associated
7820          GCC type overaligned by default for performance reasons.  */
7821       if ((double_align = double_float_alignment) > 0)
7822         {
7823           Entity_Id gnat_type
7824             = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7825           is_capped_double
7826             = is_double_float_or_array (gnat_type, &align_clause);
7827         }
7828       else if ((double_align = double_scalar_alignment) > 0)
7829         {
7830           Entity_Id gnat_type
7831             = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7832           is_capped_double
7833             = is_double_scalar_or_array (gnat_type, &align_clause);
7834         }
7835       else
7836         is_capped_double = align_clause = false;
7837
7838       if (is_capped_double && new_align >= double_align)
7839         {
7840           if (align_clause)
7841             align = new_align * BITS_PER_UNIT;
7842         }
7843       else
7844         {
7845           if (is_capped_double)
7846             align = double_align * BITS_PER_UNIT;
7847
7848           post_error_ne_num ("alignment for& must be at least ^",
7849                              gnat_error_node, gnat_entity,
7850                              align / BITS_PER_UNIT);
7851         }
7852     }
7853   else
7854     {
7855       new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7856       if (new_align > align)
7857         align = new_align;
7858     }
7859
7860   return align;
7861 }
7862
7863 /* Return the smallest alignment not less than SIZE.  */
7864
7865 static unsigned int
7866 ceil_alignment (unsigned HOST_WIDE_INT size)
7867 {
7868   return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7869 }
7870 \f
7871 /* Verify that OBJECT, a type or decl, is something we can implement
7872    atomically.  If not, give an error for GNAT_ENTITY.  COMP_P is true
7873    if we require atomic components.  */
7874
7875 static void
7876 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7877 {
7878   Node_Id gnat_error_point = gnat_entity;
7879   Node_Id gnat_node;
7880   enum machine_mode mode;
7881   unsigned int align;
7882   tree size;
7883
7884   /* There are three case of what OBJECT can be.  It can be a type, in which
7885      case we take the size, alignment and mode from the type.  It can be a
7886      declaration that was indirect, in which case the relevant values are
7887      that of the type being pointed to, or it can be a normal declaration,
7888      in which case the values are of the decl.  The code below assumes that
7889      OBJECT is either a type or a decl.  */
7890   if (TYPE_P (object))
7891     {
7892       /* If this is an anonymous base type, nothing to check.  Error will be
7893          reported on the source type.  */
7894       if (!Comes_From_Source (gnat_entity))
7895         return;
7896
7897       mode = TYPE_MODE (object);
7898       align = TYPE_ALIGN (object);
7899       size = TYPE_SIZE (object);
7900     }
7901   else if (DECL_BY_REF_P (object))
7902     {
7903       mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7904       align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7905       size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7906     }
7907   else
7908     {
7909       mode = DECL_MODE (object);
7910       align = DECL_ALIGN (object);
7911       size = DECL_SIZE (object);
7912     }
7913
7914   /* Consider all floating-point types atomic and any types that that are
7915      represented by integers no wider than a machine word.  */
7916   if (GET_MODE_CLASS (mode) == MODE_FLOAT
7917       || ((GET_MODE_CLASS (mode) == MODE_INT
7918            || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7919           && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7920     return;
7921
7922   /* For the moment, also allow anything that has an alignment equal
7923      to its size and which is smaller than a word.  */
7924   if (size && TREE_CODE (size) == INTEGER_CST
7925       && compare_tree_int (size, align) == 0
7926       && align <= BITS_PER_WORD)
7927     return;
7928
7929   for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7930        gnat_node = Next_Rep_Item (gnat_node))
7931     {
7932       if (!comp_p && Nkind (gnat_node) == N_Pragma
7933           && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7934               == Pragma_Atomic))
7935         gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7936       else if (comp_p && Nkind (gnat_node) == N_Pragma
7937                && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7938                    == Pragma_Atomic_Components))
7939         gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7940     }
7941
7942   if (comp_p)
7943     post_error_ne ("atomic access to component of & cannot be guaranteed",
7944                    gnat_error_point, gnat_entity);
7945   else
7946     post_error_ne ("atomic access to & cannot be guaranteed",
7947                    gnat_error_point, gnat_entity);
7948 }
7949 \f
7950 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7951    have compatible signatures so that a call using one type may be safely
7952    issued if the actual target function type is the other.  Return 1 if it is
7953    the case, 0 otherwise, and post errors on the incompatibilities.
7954
7955    This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7956    that calls to the subprogram will have arguments suitable for the later
7957    underlying builtin expansion.  */
7958
7959 static int
7960 compatible_signatures_p (tree ftype1, tree ftype2)
7961 {
7962   /* As of now, we only perform very trivial tests and consider it's the
7963      programmer's responsibility to ensure the type correctness in the Ada
7964      declaration, as in the regular Import cases.
7965
7966      Mismatches typically result in either error messages from the builtin
7967      expander, internal compiler errors, or in a real call sequence.  This
7968      should be refined to issue diagnostics helping error detection and
7969      correction.  */
7970
7971   /* Almost fake test, ensuring a use of each argument.  */
7972   if (ftype1 == ftype2)
7973     return 1;
7974
7975   return 1;
7976 }
7977 \f
7978 /* Return a FIELD_DECL node modeled on OLD_FIELD.  FIELD_TYPE is its type
7979    and RECORD_TYPE is the type of the parent.  If SIZE is nonzero, it is the
7980    specified size for this field.  POS_LIST is a position list describing
7981    the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
7982    to this layout.  */
7983
7984 static tree
7985 create_field_decl_from (tree old_field, tree field_type, tree record_type,
7986                         tree size, tree pos_list, tree subst_list)
7987 {
7988   tree t = TREE_VALUE (purpose_member (old_field, pos_list));
7989   tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
7990   unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
7991   tree new_pos, new_field;
7992
7993   if (CONTAINS_PLACEHOLDER_P (pos))
7994     for (t = subst_list; t; t = TREE_CHAIN (t))
7995       pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
7996
7997   /* If the position is now a constant, we can set it as the position of the
7998      field when we make it.  Otherwise, we need to deal with it specially.  */
7999   if (TREE_CONSTANT (pos))
8000     new_pos = bit_from_pos (pos, bitpos);
8001   else
8002     new_pos = NULL_TREE;
8003
8004   new_field
8005     = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8006                          DECL_PACKED (old_field), size, new_pos,
8007                          !DECL_NONADDRESSABLE_P (old_field));
8008
8009   if (!new_pos)
8010     {
8011       normalize_offset (&pos, &bitpos, offset_align);
8012       DECL_FIELD_OFFSET (new_field) = pos;
8013       DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8014       SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8015       DECL_SIZE (new_field) = size;
8016       DECL_SIZE_UNIT (new_field)
8017         = convert (sizetype,
8018                    size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8019       layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8020     }
8021
8022   DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8023   SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8024   DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8025   TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8026
8027   return new_field;
8028 }
8029
8030 /* Return the REP part of RECORD_TYPE, if any.  Otherwise return NULL.  */
8031
8032 static tree
8033 get_rep_part (tree record_type)
8034 {
8035   tree field = TYPE_FIELDS (record_type);
8036
8037   /* The REP part is the first field, internal, another record, and its name
8038      doesn't start with an underscore (i.e. is not generated by the FE).  */
8039   if (DECL_INTERNAL_P (field)
8040       && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8041       && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8042     return field;
8043
8044   return NULL_TREE;
8045 }
8046
8047 /* Return the variant part of RECORD_TYPE, if any.  Otherwise return NULL.  */
8048
8049 static tree
8050 get_variant_part (tree record_type)
8051 {
8052   tree field;
8053
8054   /* The variant part is the only internal field that is a qualified union.  */
8055   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
8056     if (DECL_INTERNAL_P (field)
8057         && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8058       return field;
8059
8060   return NULL_TREE;
8061 }
8062
8063 /* Return a new variant part modeled on OLD_VARIANT_PART.  VARIANT_LIST is
8064    the list of variants to be used and RECORD_TYPE is the type of the parent.
8065    POS_LIST is a position list describing the layout of fields present in
8066    OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8067    layout.  */
8068
8069 static tree
8070 create_variant_part_from (tree old_variant_part, tree variant_list,
8071                           tree record_type, tree pos_list, tree subst_list)
8072 {
8073   tree offset = DECL_FIELD_OFFSET (old_variant_part);
8074   tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8075   tree old_union_type = TREE_TYPE (old_variant_part);
8076   tree new_union_type, new_variant_part, t;
8077   tree union_field_list = NULL_TREE;
8078
8079   /* First create the type of the variant part from that of the old one.  */
8080   new_union_type = make_node (QUAL_UNION_TYPE);
8081   TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8082
8083   /* If the position of the variant part is constant, subtract it from the
8084      size of the type of the parent to get the new size.  This manual CSE
8085      reduces the code size when not optimizing.  */
8086   if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
8087     {
8088       tree first_bit = bit_from_pos (offset, bitpos);
8089       TYPE_SIZE (new_union_type)
8090         = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8091       TYPE_SIZE_UNIT (new_union_type)
8092         = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8093                       byte_from_pos (offset, bitpos));
8094       SET_TYPE_ADA_SIZE (new_union_type,
8095                          size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8096                                      first_bit));
8097       TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8098       relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8099     }
8100   else
8101     copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8102
8103   /* Now finish up the new variants and populate the union type.  */
8104   for (t = variant_list; t; t = TREE_CHAIN (t))
8105     {
8106       tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
8107       tree old_variant, old_variant_subpart, new_variant, field_list;
8108
8109       /* Skip variants that don't belong to this nesting level.  */
8110       if (DECL_CONTEXT (old_field) != old_union_type)
8111         continue;
8112
8113       /* Retrieve the list of fields already added to the new variant.  */
8114       new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
8115       field_list = TYPE_FIELDS (new_variant);
8116
8117       /* If the old variant had a variant subpart, we need to create a new
8118          variant subpart and add it to the field list.  */
8119       old_variant = TREE_PURPOSE (t);
8120       old_variant_subpart = get_variant_part (old_variant);
8121       if (old_variant_subpart)
8122         {
8123           tree new_variant_subpart
8124             = create_variant_part_from (old_variant_subpart, variant_list,
8125                                         new_variant, pos_list, subst_list);
8126           TREE_CHAIN (new_variant_subpart) = field_list;
8127           field_list = new_variant_subpart;
8128         }
8129
8130       /* Finish up the new variant and create the field.  No need for debug
8131          info thanks to the XVS type.  */
8132       finish_record_type (new_variant, nreverse (field_list), 2, false);
8133       compute_record_mode (new_variant);
8134       create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8135                         true, false, Empty);
8136
8137       new_field
8138         = create_field_decl_from (old_field, new_variant, new_union_type,
8139                                   TYPE_SIZE (new_variant),
8140                                   pos_list, subst_list);
8141       DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
8142       DECL_INTERNAL_P (new_field) = 1;
8143       TREE_CHAIN (new_field) = union_field_list;
8144       union_field_list = new_field;
8145     }
8146
8147   /* Finish up the union type and create the variant part.  No need for debug
8148      info thanks to the XVS type.  */
8149   finish_record_type (new_union_type, union_field_list, 2, false);
8150   compute_record_mode (new_union_type);
8151   create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8152                     true, false, Empty);
8153
8154   new_variant_part
8155     = create_field_decl_from (old_variant_part, new_union_type, record_type,
8156                               TYPE_SIZE (new_union_type),
8157                               pos_list, subst_list);
8158   DECL_INTERNAL_P (new_variant_part) = 1;
8159
8160   /* With multiple discriminants it is possible for an inner variant to be
8161      statically selected while outer ones are not; in this case, the list
8162      of fields of the inner variant is not flattened and we end up with a
8163      qualified union with a single member.  Drop the useless container.  */
8164   if (!TREE_CHAIN (union_field_list))
8165     {
8166       DECL_CONTEXT (union_field_list) = record_type;
8167       DECL_FIELD_OFFSET (union_field_list)
8168         = DECL_FIELD_OFFSET (new_variant_part);
8169       DECL_FIELD_BIT_OFFSET (union_field_list)
8170         = DECL_FIELD_BIT_OFFSET (new_variant_part);
8171       SET_DECL_OFFSET_ALIGN (union_field_list,
8172                              DECL_OFFSET_ALIGN (new_variant_part));
8173       new_variant_part = union_field_list;
8174     }
8175
8176   return new_variant_part;
8177 }
8178
8179 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8180    which are both RECORD_TYPE, after applying the substitutions described
8181    in SUBST_LIST.  */
8182
8183 static void
8184 copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
8185 {
8186   tree t;
8187
8188   TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8189   TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8190   SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8191   TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8192   relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8193
8194   if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8195     for (t = subst_list; t; t = TREE_CHAIN (t))
8196       TYPE_SIZE (new_type)
8197         = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8198                               TREE_PURPOSE (t),
8199                               TREE_VALUE (t));
8200
8201   if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8202     for (t = subst_list; t; t = TREE_CHAIN (t))
8203       TYPE_SIZE_UNIT (new_type)
8204         = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8205                               TREE_PURPOSE (t),
8206                               TREE_VALUE (t));
8207
8208   if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8209     for (t = subst_list; t; t = TREE_CHAIN (t))
8210       SET_TYPE_ADA_SIZE
8211         (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8212                                        TREE_PURPOSE (t),
8213                                        TREE_VALUE (t)));
8214
8215   /* Finalize the size.  */
8216   TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8217   TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8218 }
8219 \f
8220 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8221    type with all size expressions that contain F in a PLACEHOLDER_EXPR
8222    updated by replacing F with R.
8223
8224    The function doesn't update the layout of the type, i.e. it assumes
8225    that the substitution is purely formal.  That's why the replacement
8226    value R must itself contain a PLACEHOLDER_EXPR.  */
8227
8228 tree
8229 substitute_in_type (tree t, tree f, tree r)
8230 {
8231   tree nt;
8232
8233   gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8234
8235   switch (TREE_CODE (t))
8236     {
8237     case INTEGER_TYPE:
8238     case ENUMERAL_TYPE:
8239     case BOOLEAN_TYPE:
8240     case REAL_TYPE:
8241
8242       /* First the domain types of arrays.  */
8243       if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8244           || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8245         {
8246           tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8247           tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8248
8249           if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8250             return t;
8251
8252           nt = copy_type (t);
8253           TYPE_GCC_MIN_VALUE (nt) = low;
8254           TYPE_GCC_MAX_VALUE (nt) = high;
8255
8256           if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8257             SET_TYPE_INDEX_TYPE
8258               (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8259
8260           return nt;
8261         }
8262
8263       /* Then the subtypes.  */
8264       if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8265           || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8266         {
8267           tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8268           tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8269
8270           if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8271             return t;
8272
8273           nt = copy_type (t);
8274           SET_TYPE_RM_MIN_VALUE (nt, low);
8275           SET_TYPE_RM_MAX_VALUE (nt, high);
8276
8277           return nt;
8278         }
8279
8280       return t;
8281
8282     case COMPLEX_TYPE:
8283       nt = substitute_in_type (TREE_TYPE (t), f, r);
8284       if (nt == TREE_TYPE (t))
8285         return t;
8286
8287       return build_complex_type (nt);
8288
8289     case OFFSET_TYPE:
8290     case METHOD_TYPE:
8291     case FUNCTION_TYPE:
8292     case LANG_TYPE:
8293       /* These should never show up here.  */
8294       gcc_unreachable ();
8295
8296     case ARRAY_TYPE:
8297       {
8298         tree component = substitute_in_type (TREE_TYPE (t), f, r);
8299         tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8300
8301         if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8302           return t;
8303
8304         nt = build_array_type (component, domain);
8305         TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8306         TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8307         SET_TYPE_MODE (nt, TYPE_MODE (t));
8308         TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8309         TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8310         TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8311         TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8312         TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8313         return nt;
8314       }
8315
8316     case RECORD_TYPE:
8317     case UNION_TYPE:
8318     case QUAL_UNION_TYPE:
8319       {
8320         bool changed_field = false;
8321         tree field;
8322
8323         /* Start out with no fields, make new fields, and chain them
8324            in.  If we haven't actually changed the type of any field,
8325            discard everything we've done and return the old type.  */
8326         nt = copy_type (t);
8327         TYPE_FIELDS (nt) = NULL_TREE;
8328
8329         for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
8330           {
8331             tree new_field = copy_node (field), new_n;
8332
8333             new_n = substitute_in_type (TREE_TYPE (field), f, r);
8334             if (new_n != TREE_TYPE (field))
8335               {
8336                 TREE_TYPE (new_field) = new_n;
8337                 changed_field = true;
8338               }
8339
8340             new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8341             if (new_n != DECL_FIELD_OFFSET (field))
8342               {
8343                 DECL_FIELD_OFFSET (new_field) = new_n;
8344                 changed_field = true;
8345               }
8346
8347             /* Do the substitution inside the qualifier, if any.  */
8348             if (TREE_CODE (t) == QUAL_UNION_TYPE)
8349               {
8350                 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8351                 if (new_n != DECL_QUALIFIER (field))
8352                   {
8353                     DECL_QUALIFIER (new_field) = new_n;
8354                     changed_field = true;
8355                   }
8356               }
8357
8358             DECL_CONTEXT (new_field) = nt;
8359             SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
8360
8361             TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
8362             TYPE_FIELDS (nt) = new_field;
8363           }
8364
8365         if (!changed_field)
8366           return t;
8367
8368         TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8369         TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8370         TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8371         SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8372         return nt;
8373       }
8374
8375     default:
8376       return t;
8377     }
8378 }
8379 \f
8380 /* Return the RM size of GNU_TYPE.  This is the actual number of bits
8381    needed to represent the object.  */
8382
8383 tree
8384 rm_size (tree gnu_type)
8385 {
8386   /* For integral types, we store the RM size explicitly.  */
8387   if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8388     return TYPE_RM_SIZE (gnu_type);
8389
8390   /* Return the RM size of the actual data plus the size of the template.  */
8391   if (TREE_CODE (gnu_type) == RECORD_TYPE
8392       && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8393     return
8394       size_binop (PLUS_EXPR,
8395                   rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
8396                   DECL_SIZE (TYPE_FIELDS (gnu_type)));
8397
8398   /* For record types, we store the size explicitly.  */
8399   if ((TREE_CODE (gnu_type) == RECORD_TYPE
8400        || TREE_CODE (gnu_type) == UNION_TYPE
8401        || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8402       && !TYPE_FAT_POINTER_P (gnu_type)
8403       && TYPE_ADA_SIZE (gnu_type))
8404     return TYPE_ADA_SIZE (gnu_type);
8405
8406   /* For other types, this is just the size.  */
8407   return TYPE_SIZE (gnu_type);
8408 }
8409 \f
8410 /* Return the name to be used for GNAT_ENTITY.  If a type, create a
8411    fully-qualified name, possibly with type information encoding.
8412    Otherwise, return the name.  */
8413
8414 tree
8415 get_entity_name (Entity_Id gnat_entity)
8416 {
8417   Get_Encoded_Name (gnat_entity);
8418   return get_identifier_with_length (Name_Buffer, Name_Len);
8419 }
8420
8421 /* Return an identifier representing the external name to be used for
8422    GNAT_ENTITY.  If SUFFIX is specified, the name is followed by "___"
8423    and the specified suffix.  */
8424
8425 tree
8426 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8427 {
8428   Entity_Kind kind = Ekind (gnat_entity);
8429
8430   if (suffix)
8431     {
8432       String_Template temp = {1, strlen (suffix)};
8433       Fat_Pointer fp = {suffix, &temp};
8434       Get_External_Name_With_Suffix (gnat_entity, fp);
8435     }
8436   else
8437     Get_External_Name (gnat_entity, 0);
8438
8439   /* A variable using the Stdcall convention lives in a DLL.  We adjust
8440      its name to use the jump table, the _imp__NAME contains the address
8441      for the NAME variable.  */
8442   if ((kind == E_Variable || kind == E_Constant)
8443       && Has_Stdcall_Convention (gnat_entity))
8444     {
8445       const int len = 6 + Name_Len;
8446       char *new_name = (char *) alloca (len + 1);
8447       strcpy (new_name, "_imp__");
8448       strcat (new_name, Name_Buffer);
8449       return get_identifier_with_length (new_name, len);
8450     }
8451
8452   return get_identifier_with_length (Name_Buffer, Name_Len);
8453 }
8454
8455 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8456    string, return a new IDENTIFIER_NODE that is the concatenation of
8457    the name followed by "___" and the specified suffix.  */
8458
8459 tree
8460 concat_name (tree gnu_name, const char *suffix)
8461 {
8462   const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8463   char *new_name = (char *) alloca (len + 1);
8464   strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8465   strcat (new_name, "___");
8466   strcat (new_name, suffix);
8467   return get_identifier_with_length (new_name, len);
8468 }
8469
8470 #include "gt-ada-decl.h"