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