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