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