gcc/ada/gcc-interface/decl.c

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