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