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