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